ks/0000755000176200001440000000000013620451512010666 5ustar liggesusersks/NAMESPACE0000644000176200001440000000453413620366105012116 0ustar liggesusers##importFrom(FNN, get.knnx) import(grDevices) import(graphics) import(KernSmooth) importFrom(Matrix, Diagonal, Matrix, norm) ##import(mclust) importFrom(mclust, mclustBIC) ##importFrom(mgcv, in.out) ##import(misc3d, contour3d) import(mvtnorm) ##import(multicool) ##importFrom(OceanView, quiver2D) ##import(rgl, axes3d, box3d, plot3d) import(stats) import(utils) useDynLib(ks, .registration=TRUE, .fixes="C_") export(amise.mixt, ise.mixt, mise.mixt) export(binning) export(compare, compare.kda.cv, compare.kda.diag.cv) export(contourLevels, contourSizes) export(dkde, pkde, qkde, rkde) export(dnorm.mixt, rnorm.mixt) export(dmvnorm.mixt, rmvnorm.mixt) export(dmvt.mixt, rmvt.mixt) export(Hamise.mixt, Hamise.mixt.diag, hamise.mixt) export(Hmise.mixt, Hmise.mixt.diag, hmise.mixt) export(Hnm, Hnm.diag, hnm) export(Hns, Hns.diag, hns, Hns.kcde, hns.kcde) export(Hbcv, Hbcv.diag) export(Hlscv, Hlscv.diag, hlscv, Hucv, Hucv.diag, hucv) export(Hkda, Hkda.diag, hkda) export(Hpi, Hpi.diag, hpi) export(Hpi.kcde, Hpi.diag.kcde, hpi.kcde) export(Hpi.kfe, Hpi.diag.kfe, hpi.kfe) export(histde) export(Hscv, Hscv.diag, hscv) export(kcde) export(kcopula, kcopula.de) export(kcurv) export(kda) export(kdcde, dckde, reg.ucv) export(kde) export(kde.balloon) export(kde.boundary) export(kde.local.test) export(kde.sp) export(kde.test) export(kde.truncate, kdde.truncate) export(kdde) export(kdr) export(kfe) export(kfs) export(kms, kms.part) export(kr) export(kroc) export(ksupp, dwsupp) export(Lpdiff) export(matrix.sqrt) export(mvnorm.mixt.mode, mvnorm.mixt.part) export(plotmixt) export(pre.scale, pre.sphere) export(rowKpow, getRow) export(Sdr, Sdrv, mur, nur, nurs, Qr) export(symconv.1d, symconv.nd) export(vec, vech, invvec, invvech) S3method(contourLevels, kcopula.de) S3method(contourLevels, kda) S3method(contourLevels, kde) S3method(contourLevels, kdde) S3method(plot, histde) S3method(plot, kcde) S3method(plot, kcopula) S3method(plot, kcopula.de) S3method(plot, kda) S3method(plot, kde) S3method(plot, kde.loctest) S3method(plot, kde.part) S3method(plot, kdde) S3method(plot, kfs) S3method(plot, kms) S3method(plot, kr) S3method(plot, kroc) S3method(predict, histde) S3method(predict, kda) S3method(predict, kde) S3method(predict, kcde) S3method(predict, kcopula) S3method(predict, kcopula.de) S3method(predict, kdde) S3method(predict, kroc) S3method(summary, kms) S3method(summary, kroc) ks/data/0000755000176200001440000000000013264647355011617 5ustar liggesusersks/data/hsct.RData0000644000176200001440000060716413265504400013473 0ustar liggesusers7zXZi"6!X9])TW"nRʟⅧ ""ȏe|á|Ewpd 6#r@!:U 9FK=[.V?4 7ŰI`COE׃f]ٯӺ(5#2<+|p_=΃Ly=Eg̃^{-Z\eTr^ՑX!걩\_xNs:n 7 ʓ, @~jxCT;ݏti_.N[weiEq q{+MFNم+a!flؖL!ZDžǖBסw6wpg=8їw?|4Eu9:K [bsWW' |'j2IrF D?uX,2& \{xXڐ.zr 7X́ 8T`oSӽDzyӢ;89P; ._d;/g.﹇m74חLF%{f<4\Yy[:5zZ܍ml1:Md~1}+Gv˩ppg5 qRv-eZI BSuBG#"|fHAAȥ%Ya—Y(`57J`%~Ne PS|Fv7"Owy!M 9G̿ճ1śm?<0VJ2ɺ\8A5A{ SO/0 %/ߵ(x[m0aizYdn 9d Tַ-ی6CܕB/nJ(v॑J5`exwSմC4 1uVjX,۲zDQQ-%zpj 0 @ } F+:M)0>: Jw2UXWJ9o"b/M2]~SP:!z^*}F7cRI{/q}LN`O`,1'pU2~Dw[ [rg$T|p*&'-OP*^ٙ3H4Li*eI}3 Ռ*t3FI569%eq΂%ҁAU:r]Ql9aW}|` BG{~Y|j AL@w߾ɑ]_%ATiOȽxܪOw9DVG[!H st*9b'y1RbVtLLܙܽA̧lh9b 2>i l2ՆҚ}=QjO]D _.80}8E ʓ~dk5n(\5-S`oT%|\SSyݦ#o>t8(YcsWFJ=qfx'VA:1_jêw,vg6h( 88& (or?*IS,cl | Hc-Ϲ" C"v4"*Q1s!]dA3Zpsx289Ӷ΍1q5mU<~Td !$x\Sh*6"-cJ3>}nKw{VXi/߿/zf`չ@몏n mHjVd**E?$W}7'+K)=mykVDx%Hvf[JCȫ=p,L]PPA1SB|oLCrOTc*|SrPjn)S}$Y˺0qh0ӕ|.N1MlॐPueU%ܕڗƒ1z4]~ xIPf||=}>my⾦ڑ;8 }s%\i4ʨgTNphxZ3R+%j -Ҫx(yO_ 1_i}gنILͭ8JNRJ?=IiB  H:fvY U3f[ _Ztct@d&d2|岆5A}\r@izГhݸfdߚAM|Pr!SfނF5~)0ʼnuVtZNą|1sNrhiشT(L5 9aL[.$,AqZQc0t*uS7 U)Bs=hEj._4J;I:ޣiW`9Y;:9ǂ:7ͺ~FV>Q!91Pؓu{ny3Ÿ5"TJ@ZD*4)aේJYHn+?LVui(xYvfp^g %X$E׭ g<7^7Wd.IyΎwek򪓾l*-5~ż2GF;sl7Q̽ȀsMb=6Uy( ̋ :Ҥ.') 1ޫ !q #g74NF}.%7Z1$jIx5912f0H?>U.񪁙/]mwb?3 R=<){p$S]2\{Mđ~U ȇm/Y҆`=ި;!܋MYGJ} 1?:odÅu2wJa,Kd[@6^3d|(SJV(^6>M3*s^8J;!nGĈV=&w)׿gN-.`]yz@L ܧQe#g` I> |3lS;}riV́<no:"̈kgFsT{D8 a9!~'xƜ# I貂Ѯ, tm;V.Q)<b䱞E*hVח3i`Dus)B74mgۭnbhN:}αc$e|jXxۦxSTS.Xe%IOU>}KgЧa|l2 l˩~$weo?('AVGTEmǮΊ1tȉ90?+Q^^/&0vY*|?]-Awc$2<.cQ\v;,@ v~>ܦ`˷bT&kƲ䣨nrB:UB1"FfͻO^7C`VB(%M4{9/XCD@}` ]e=]sAQvDwgFwll.*R.@pfK]ݺdDRa7r8j\RjH6B`%tL/WĕA'K,m х(Yu>{)YY+&eamXpa"xcfa Mf9 nhHs=.w .1bBƂXISn59_Ny"y^3Xqo߭0I?QQ]Fz221 ;%|f~)_f:#@Z5}Tr|C/⺘.ťUk<A'GȌv5ФmN>S '$Np!miʞ5`ZjIɘI7aqe'Ļi?],R{߼EX{2E`Q,P2Mei, PQPE'D]X[wGnQ mGӟ,"Q!TޗSL{V 8,YSy-"%!uJчI'NaEq<13SUxK6$y5[]]/qýTCs̉#-=! aPLVɸZUWx0 އ&dwKֱkaVk#V$n=Ӟ7vbwD >:o0Vdr^-9gq0-%n+_dW08BZ~{`+e=h {I8PI6$3s)W,oS)/emCC&GP=pl 7ΚS_˖$ B Vs9}6%]#8yWܱvP A̢@@pSJe 7ܒ!qL!X}iC'^(~ls]jR(v*[^C;hUw|lͅڱj D2-4|Gp=UHɠ,5M=.h?zOxliIRXa2* L:`̏`K0g%THΜX(S#lZ4~_ 73~ ,—/<.JC|uHI q`iTkW/]iQvCyԗP3a3 ddw9~ڃhlpց۳rK-sjOz.="Ѡn)U6N>y"꧵ڈ s:ڰʈay6ax~ܢLeۈ!@|nssdX7[O#s3.;¨Z^҆]?C1b{fqhć0s|/{DTV-ǬvR5i S%ϟ2Ez0gcA\=\U3U>o|5Yq$N%20:3[JoAf0IJ _67ƻj@]"ސ~(1{6lT"7iQ{msBm؟m憈X BJFuvn]bh#򣗬!棔2<(]az*|?(lW댯.ח.;ãGϋ3?u'&QH@d{y 5;ҲN7CI [kxHIQ0'0P+X/zQ-kN%35b͠ƾd񋗸rq}OHfE W~ /7b| D2όf76teӱ:/!up6wד< $ |:oX!jI nQm/I0RJG EƵT"jP1M/,5۸G:ŀu!Viz(l1KߍQ>;7^L(&Ͽ:Ev\ 꺺4%~m& dɮ#ĝ܁Q}2u,T=ivKAvH0͒Q'+TI.ď%VoxPN9jMQ%['vN$oצ6" I 1{lCׁY9kM#n 9#& JBz96gqVm gtbr3cٰ'ȼXr9~)CEEM<huVAh)z<7Q{oc +’z1jˑX s3[Tgx!1 >݄qa$!&%>doTU'9/(;쀸]N NudzFKj(ݕ%@YJeCthS;Ŕ65],p K%9䚜dywt%#shQaL!%y_rӮ%{8ZDf7$[gzikT. Ld~n:.lp}N;֙M2w Uߨ!ĥŦLP#ZhG) .r6?^fj 8F64>iY](м7qwG)j*~L@~?]$r^۲9,nnEɪ6 cRMtMދJ6WLV"D)HwbE#}]qVvfïFzWݰ:< FTzѨc;]\;(r}y.&r7dMڠ=f?kvl}n 1'0kJ 5yl4mMU|[,$]*\FXYxn"5׏[k|}[d_`H>v]Mm7k{OӠSkfy7Q_U+$iP}J| n`69v^Pݚw2r+kAs 3>R}}~.o uD\D+w06:6 u_383#0aOᓭu=^f:x ?PYh#>zwݲ }FZ;g~?㿈 U1 - BAuAnSӆMfɂG%Ay xIYM;¥rn {Q`2bPs Ü̋ƍSX!Z1OwKJ(\T7y!pĔYw5ϧ8!$Z@H eӔu\J!!2[ ,&\n*putaN7Z7簀f8\w隡#z-:w Nd-[*3cG8}`Dhܯ-_"+ cTdXH{{ vyR',A6Xʌls=FT,4]^.?E>k3eu2Ve;v}7Yت~&GXlǠ>IRL\ѐNs ۰w 8I0nw؆a_ݍ@kMf?r3Lƭ Bc%d yvds;1X)[vY!Nd?U`eO CK]qNCkO FFaV6q6=C@؜ $)H}қ3Qun C~+>**pzD ]DŽ#+ґGy`aA+~ebq)#) 9NR%+0T3v{6/gZ4Gf 'UI{izQFrN<"r$wGj#52kW :'֥J;nq`:Ar5ȶ։B8 ug=k |ԝ+VK 1ff']y'7onV:@bKAZV9 ̟$]ju ;Ke\y+j9lyd&<֊P#TG9_#꿦kP g:oکrƛe'^bKn`?Ҝ_Z|4~%dDdTƴJɤ6q}-P2ˣa' \>IX};m1Ȥ-E7)A;6=j {VU%*oʵCz»VM$`v#jC?e/*7;{UІ,}"Z/XK%*jXYIk(qs\viCޱ%x@V!b}y"&1_ZC$}ϥeu?@\в0YDp{~d)\@h4IJ.g/'kCA9)!aοM"IkВƖ,sznT{,ca}|{hU`pWao[q׿ qpY#>UM/5)<=X+Jhu06^Zw_ >3]kx…iɊO}ON2 O?rDܻ͝Y,W7-wSƮQs%,! [_.M)F '5pzB —@Ja} XՑxDdqߤ**O{ h eIu!g| q}1H\D|-dQ(i )4c*fT+2&W3M@"`W'PZ|PBqўƚ8ҊDR( "H1IԈAOd`w˓ 3]T|5b ?J+Ŵa:V_'dN>p6,E J)fu-w:Z(yѯ`'J؜a]V/ ?+A$&߭3G}0WG\@.KQM4{7wo{I$?[<I'ڸ*;$o6&"Ɍ {BhβV8~$ N=deg%Lϭz)x]>Ż]&".vHif M^9Qt&?XX95:kT,`9{%:.\–7%~J>Ejk)!m> q$ifAqkp#d;ZP F (0IZwYD$dSdq f:J ڠbmW(R=vW]L:NG0}&K`wc|9H{# ;>ZM Y+9+ PܟN~/#=lfs&f4XȥԊ+=)H"ݡއp@0hxK/?Q4`$*`}֍@zg3㕢/R/-f|GRp\@۩ސUƂKJB(jx(3ۻ^mV\|=~iNթhEdrzAN(]SbKW9M%;Em *<ɻ)dP2~v&t1i g\|Dk/<~BGBiMfh~P؋PB=7BL>%:b {#=޾PNnzL[* lNO`ߔ* HΛ,'J$^|b;okƇU%oGJ澇<=9 8Ia=o!R\݌` $4 g ixq+|3t$k>a.1m7v*sw7?hJ+x.M-¿ ZL7x˔4n'iNvjas]rbiΠ; _+Y" 4wOV(aRx yC׶.W8ւ{Z>ͪP;Z b`ڠzN3RsYB/8yTI2Mxܼ0I;z ٹL1Q0zRFUMTjܶK`ȔW|ެx0OxOC-IRR KQo3cc3X6 . 疬ft4ߩ'wËs%b=Orw]'RRgEUr)יGΣh}j+ P`|$ w/bA%50fC[:'  5bȳ g?˨l@g/ʚ#",wkAۉKvb~7̹%}W}S;"^s?҄T br5q`1<^et(WKvR.4;3yJCAsB: "x#:^9sE T.Q YOD^B ZBv=Jb/`+'g}*Jj}}TH"9o`|ĂY +[~dBctTEѸ2{ĩDT٤#ԅÀt Q"!1|%*SN`@6d4ls"W6.יdbOnpTS6yҦCƅ+EJr)ӷsFY藮:F@5ؾȈE&Tjg$6cNM!toIw!dfϛ$Uf{dAeB0hztL|q5{y$/GY;B%-ټ,C,/nE@%*mcnѕ~>Ǝpr֝kAuj"H5{7eFߙx8MzC>d1 as{<3PZryŠhMttyZ=)ߩ^ERV*/1M(t0i nSco{;@&7փK8drj]vꞯf쩜^U I1代]f-C=:bubr("jg^6F$%NY=GiT(/Mű 1qy)`smMDgDuGʹBu)٠&p9W5f/dyQ)3k[矓¼m'جvšc+Ȑf."+ܓ#v:, >h,hl(¶&KHEb7-sP kbmOZ/ׁמ"rM6#obogo\y-fϺBhXgE79cDw;rM~+SxB4JRq.ͥK( @ /eEvR&kMx㋦S;{4k2/GDsLP.(3+V$2ܥ>xk{_]OWu űF~NMysGDG_O `ɢ\ujXC?Y*:]\㎿"=}$js7iuڸWg/7jc- fYvѐ8`H'Cl-yRz:8'KF,]d3=(IQz xrJ V^#P1x G C%PpD~燼\a@C"+o8GA6K&ӵ:uFf6}R=ѽD nְB", 1{y?# mﻚkKDmE+gB@aYvotE2j`P0p DN JܚΥ(]LU1'/T" '!]=7qrT=n3i,|SvѽL|`gZղM^6m8=^f5)8 ;14c6f~laebqDNL7 oX].[8;-S滛È6|0K;ǣ}撀S &7b`}`$ sچԌ1YmCZr_BC`O%'-iB Ԛ(UGS-a($#|P-Nê<}TH蟔2^$}hKfؗKV_ ;&r 3m/ZSG| YF*ȧ@O+O`A2wNa;dt f)m= kk X1ml~j6-禮FJ]Ձ`H>}8'|Sc)9f}o4YKP̧S^Y@K U'p!,h$Æ͍y'y]P4e.$I_:Yy}sSZoq|"?_" k aEѰ눑E4b՗z_f #T5ti܍#>Nճ@0x1L%fOU\r垡'ƛ_%CгGJI%1hγ&EȀY+ z.<_9`\&8jiquGa3W^Qƕs]j)F8Zyt݌Z;p8y-.g}xƥϤ;C3؍ٳl@a-4 Ȗ*z@$]Xr<Ӆaivj_Q!kMfIWWF9:bltjp:sUtLsa|mҳUR`!/-(ا4-Pܚm v;:{̷ҺF|KZŹ2 dyZC PkI˖N=בd=k)*8`$g\I9TF\']wŃu.QXUbH]JJ}*] ׾f[7yFH8ѓbPY #!_tQRNBJϜcS.7en :DG*dQ e=Y_LP۰z*T_N &F9  v琬TlKd4ogS&4k"$ k幵-p$0*2Xxk+eܟOu6DpHbR3b|WT*Ӫ[X6,6w:L~>唟ۦ h(]!j#>+d2վ\&ڶliIEm4\gt=9{>/u=*5=]:3W[5Jw䍇Z3-c;4FX۠!̛ŭ]0ͨ25h~(-M%ח\wf~GUu7b[ 5BkPJs7uCӑV4IE_.h~9o5I,EO;Q@vJbcMi͇cn3=8 Kɕ+YgOҾ^<P9( bēN-t_.1kydi.>L$`;b3wყAxE!!#A1ˆ_yײ@#LW/ ǫj)hܺ!msy^;́A L}=A4td3ZCe/n`CC SgSi:?| ~N^ȞxMdz_0}oO@xTo4⨉\fANso$U$r3f-d`D\j2.ʜ*ہJg:&̋J|,+|!~2en9rƿU`/&DM :xߨv&U .%g'Vu)'A6`Xd4y5)II1L~>GF+`nnMg@ZF @r`y~0 uϥHpy/1 m x9NfH!:8LMGo{qL䌓i\p@:NN2K`zAEB A8`r}LvD{-鿢#ԓf4̺ж7 ܪOhD&gl KIЧ'Cum$Nx|P=層 FZl$!$IL_Z҂q 2v<7T^w5cԌw!!hBx%%e[ a \-،pY?12Oq41닁rLϜ$D DV,H@G]^Citbt'BJl['?j`F> {@M }]b{-¥3=u$,vQ;{.f:yI Gi*f/ЙxCx܅N0IkңoZ <΂_*b`.[b R-O´DC(oe/2Z )-12!o65gABѽ^^3heq|#^;VfH˷r_*L*Y|&f;فTݣ a7V-v8u{l[94$u7NLAahG0lnm^\kR8| )x*k/&j-lȁ&t[Dr,-㴔 Ӹ ay4-a }o8c')h8nFzbѿnB[lxi([ڃ\糵\RcRi;Kq‚iWB}17\*8h euF\v[[.Ydj ]HPJ]Z@̂ ^mdɹ~uG]𬼼3!;3j¥ .+(BZ-ߎ`wDNzW˥ɞܧyjMw)X`Idz}0z#Z֔$EI 0 eo]7ѓX =|?+J$7$.65Ng8 h /j<{d맋/ `=psodC5=|t̰[=tYa\.b@uӚu QEA pAEh4΃RII9|%G:&Vo>+f*ALp*3q]Iw5=j~ Y |ʉZ13!m"BC)'{F:ǝuHjk !0;a _ѡˉ18{Tjr(*U:g &%Zo$* ./YoF̈́v/Wy#k!]sD GlMHe2SX2бM>yl],zmFODV n~י1y$2Meߺe%jtI {%7o;DX/e:,DVC Q [/.RRz q7X጑\ 7KR=k~qIە:Ϭ$un+(S9K6iR8-p2ƫU|FeRMA&<˘:y,Ȥtu/8DRzTB8mN!(8R s'*}st5 [5* x醵ĎKgɵ تxR e˹7еԕ Z|G*È2d$uLj_"NH κŮ]XRMAKB ?qF3KUI˭ަ+0h#5H F?W/?G>` ^ J]H%hK*On-R| 9.iIo얜pR9(1]?&Ñ[sSwKOH?1Lk[Ӕ}Li뾰tN)Vn ʒM9w ʃ5{ cѴ4^~YK)xf-zOZ?Q~EJ?)d0KH>* dJ-ͥd&irCzE}}AOzka|M}T'ZX8trKCme,"jqьko%OvORGE_j$;>؇tJ.qGVC7zE\Mr>ߘeST:ɮ͍߲O}?NϡŒ/#-';!¿G\(Z dQ6+Ҏ"ncGofK v_ĨD4oIX7.!~"tv5$`kݘfR)pKw\?|;-gXyS1P~<)##شWy F'Ks^{vgvl].lY9!nCJjv st }nV/&{Ėɟ~T$*G$r\x;_5j>JltxcSR*df:9*h y= &] ϽnXk`0 Ϸ-<hڣ3QY H]z cчm9F%QE8k@+=Q.{,xLg)QzF?> T(֌ esc(g$Nfߎ,o#1&PܻƼFŷl@2s6c<`45N1YZ1$n1#(' '1H??i/7wPM0}vpZVN)5k 'p؏i{Ռ;)7u6;\J>rquR@Cp-1h,l9`1,j\ѮE 4A8Dh/{.9tGbx`j.tsx7N‹N Az_rb'cBRdY0}bfuQ6".'-kV{ Vې*A #nr2ać6&VVYa"^aJq~i ,"QL2*-hS;q@[ Va3aQMъvn+a{\- Zj*7nk~pEVa|`e-Ӱ- Nc_$w5s^O&$GE9OXol=gB45]}AG7v3OnvӚԧ&OnJݭȅ6U{rôT4G2m \ iBg1p:q[PNތЅ8]x6Y & }kRB Y,eYǷ羻-Řdy< ^h8>%sKavhVh`c;iρ%U?F}qӇEp">@`h^/z\q< ճT(ӑ}LmP\:>" @aؓ}jc=nFYm)])lB3D:bhO=n{ѶCRyX)Jᘣb@]m 1ZO,Ό%ePkmۚ {7`SwXj_dn5Zu(yZ?66ed4VB*i]izf%|_gMA=n-?{!ƨ ݹ1"% avQdD*1Cz}UoIÎ䱣BkJqԣiH`րdlluFIwl RTvr߼-@H9NDsLpZ_lXZ}ix^8Tz6'D8…LWlW 2c-J"x<5ɋB=Կ!srVlK~(@?NMS[o~Sg;0m pvY{KAD5nK iY۲*iq!'=x=fMRy R[8bdU("Z~d/KMqxY$%aa]|eC5bRjJAfx-r1e"> $pW3hVFmYLDky] [uR *?8z vCstGnDp K`NJ[p3HN|?ܵ_wr)@tRRʕ 04}?3R9@,;9򹍽 Ddbہ[x{LTJK]3z :\vu:ã'6`F;cE0,=T7{c0 }%rF4\)01@ Z$>ŧ-3`r;2Ll9qRkNYe\(cXJ| Nȹza\$$+7c<~(zlx%w;t/[\iedh!ٿ⿽-rl 't/O_M|Dۼ>QCΔ9 +ӲNqk{m|M.IIsG >m+(?`A͖0zDǜQp.Sp]9KqgǪAڨi)m =B0 Ţ)Pz6Vأl埧\ aݐm)1/R ΀~.TAc]9@6ȍ##9!@ t KPQ-Q|<t (5g.QG<b#&gFQo{R#XN4lNkywF4 S dՐWjUY޷ hJ͑X0ij=ܘ pHX>Gƭjk@>>tǷIbҬ]ļ0G.A|hx0VM"UU|hb4mb22.FFY1U< \ RQy x:y^"U>ACݒYUrK|qPb/.r"6+ !03EȤKKXL${[0v`>{FS*ETim6mgm~\@>\.\gViQ*s W,doF I?0᳇Z֩xaad{mO [jgq!isu^~Qa~]7Iëa c;-/\v?eg88v{4 <=l[kD\=oPaߜŻ!z!N 2䚪Y[oހYfdTt9#wzTaw"`¥yi!:)̛6[q kS@KgvSGk ,QulP˞aB,}?Z‚9_y;ڗGjh=$VGGfsEy2b'C| u4@vn:$!7gGsK; s jHdbY|L 9 |VYxlv;<tA+odrʡt'-+Xf4v %6A=4e3\ʂ#"4l_>2ŸXڏ96ͅwDFr4HݵF&@,t+D d#;aKG}+2G{~*БNd'?Wv9qcSh1.p rVv/ϙNQ!.f goYlI PbXҴHoyBWdɂ7~TyKaqyب`9}0xN] Q,X [epVװXsRBLj`*R…G3pz⌦4UjV͈Bc1j|)Pb2r]*UD8wNV@Kth|0xt Di&eէ![6{\IٖSȵ謑5χNi0hg{8dc#COMbtLY`CEœ S?"GI(|{$H+0^GTOJՍ`$ieCtD|ǚ\MIDT,4ސ/mۧ^@LO`TJ:eEzCX(VͤP&On˙<6.,ELH}D%|p#QC?3")a1]&DOF GX ʼ">~2/mޓu(TĖ SZ03m)MFf] (P&{Iyؓ3G$rBZAue`\램X 9#+sKSm?AvNq&VF-keBbA T*N4@tw0w$z>*%ZlNCv.ݎdaR^;DȢ٣tpCoLIC! 8ZGf{pzL.FvP8*W3!ոU}g8YNR3V2J'.`d_W=A惆1HB/bVbqz7FH{m4ux/ *45fq0&hmb3v=0tLj꩚ep%=W0*1 LBSW|9 ˇVDzU^℅+0ŬQ5Q|:vq[˽ɝ"H>ֳBa@Ky\dž$ƜE3j"%v9E[<.?:YB9 0 ddіLRw@TYW{ߐh1"ZJɑjogkڀ_/PKR Y6Em | zM25DWF]G17~|(W|(O?Mԝ!oDZn_{XCn<%G~g&t've<ڊM">\6+N2x K;Ո6BpnoR-٣7THK~,Y7$*1o42% nHNo#F&)8.|D+4b¼f|"f {^Ͻ-3X ߌ*  S&t@d1p>iJtz5vvTWB1DP;,OA YRϡ~۴is %FjtOFTmaQrkXaSUA}Xyp1c8Q~I;[\dn(Ƥ 6uQxKՋDdōn֪IȵCN2U^ Mr笏21Vpfg%"[m9ͺ6 '6Bu?UP%FlLDBʹ*>&gVJ r/nDeڶ:ӗ&R)<=Vj_eڟ2H毝?"6V oV\Ʒ癦hu HXjTTI5/*ϊRSn4N#>U뀚 U؀Z$4zU*PV4s%UŒlE q}HT9Ղ`*h b ^=qS"H&/RGMJG Id70 * 'ƵvoGεCBj8/!]JX9ț?Oʍ : Ǎ.~Mtt~ HU=Z UpJsQ. oÚ4~PJ3 _} >QREo 6#yz.>ϓXJ/;LB[4x0wņkǪ(Knv)3V2&vS/xLnP d1Ԇ=h]⡟@?d0Rݬh=!DPȧSS`]3։YoDg 7/"ҹ5aOO!")CFUU5$6<)!N>@+ "HXEàN,@ony c_[N\WweX#Jpr zB7EMe]5'q*Ok{Fb<Œ) a4z %KDϥ3_d]ߺ &XX b^!n72hp2HtLOg24?¶j+]QLuW cY-6TYwѝc3et y&$SIN*}lGEb@&2Ჴ"ģY7.#xY,?|NrsaƒP@WP(nקsL}Ͼi2"뮣8_ W dH$yNLZ^ XRtet$&ψln6ՂJDR│8&{g:>-`T7鴤5Hj#$-LP:>aP'cIICGW8x^ˈ<flu%y  }4+IeAZVx.x=,|w2L=ɼ[Nՠ^vXXF+YXH/ [MV$B+Rcplk]!P}ux8]!p0[&n/ψFuHn8w j¸bGԽ[0«d*YLZx-8TV4)0NF3y !&uN8KXcv~YƟ^ңJ:XmDﻖ1],)[RYѰuRN7З(!tܦ/nB%P+21Y g avϵNa6Lƻ^mck:p/jx'sfsi/hk1"OaPY:XŶ"BdgLF%T^ @ҁk֝aZ:9P?Ǘm(\"v9K/P: ٚ7aSū 7 PB0p5G)XU]+ y L/3GA=sSkyɼg:?c)'$m쩢}o}g+:[H,;LV2Į?P҇? "\ s&ٺb{mjOZmyiI zMF4f8XJ N} YrDZQs4|FMzħP9XEhO}N&'y qk %=IIrHsm>xX6d[iP|wfZtڍ*Yd"g.׮~N܄ڧ+9c%pNb6>+ .u<̲I=8.̩tjÉi$Pȑ6_%I'W1 xjOb-)4DؤLZ1@%`Q>]/+wvobU-!15B~賗OلOkkߓ73~D b%k qW1#v>K<Η6Su*Ro.ȶb.(W2Z'z^dSH ĻE3%u ո0' #73d񉎦)T9I($uO?=D?}^* %,KQ={$aSk7} NeːՀPI&-K&3 ʛwˈ2 )!k*PI,ً^:hu^Uf@Rb>Gkp GL +=Nk5#auJ^3RP'<ĵ˜Qr·mveQq$c"r H4Yj̫Z0tЩ.ss,Ȝ˝6>8hꚶ{uGi4"P:-,fo5@%3Շ .Mn&Pb<3V\M.u'&WfՀJʇŀ@Vՠ2@ƘuaelcHNL Ք,{jVLFWحT Av̺6 Fg'2^,*U"O Ax*K4fͷx^1J FQϧ[E6:Iq{[?eY/5#czcvQxFG"#wD#ayt! P~RD`.G렛?2ftI}`B.K#EmqH=go♒BBVn~8Yu՘a>X+|\ه9XyC+[B^r|""R'kB]EWXM$Ƈ0PѸyzLehU'bs췉H$lBΤ$뿤93ŒI`a PK ≢Ç7i 믑~e7QZ5tyX3EOG/9|o r{UvSil/v$yQao(v癕XeCSVޙQ2 f[S|) H>uefl5Eb_M08uXw'Ij?BYdhwy,*gL=IVs _!Jy?D*`{j:s47~{;.Σ7L; DTSi\dP4lݢ( Qm5j9"JNyeTlBVIeϗ~MK6|:[.xȋCů`t_3tKPAЅo~9%! A9 dp _ "tI! jNV(8 ;6a5{ À 3B=$nK$2lVcw1oK)F浶+` oCN)2.gP?j 匜X>NWp0LJVh:2|N%KC[ju&Th+ﯚKB7:-(-.p%_дm˒/kB dV( V$YaA1#>`{ʿ egNCD<< {s}RèG f}v ̥/~r"w(̜F꓍(O6&zbn1ǢkZ_+\s Iپ3XMOt!kK箥F>{6}2IWƋt3qcVcDJ'w;`_[nV&ԛ.‹EG.&R jM!LD=!|)H'rBl݋9Kz/yK]x ,,^ FO+O n oo3V~)~0Vv 8G)_NyuuYh(OWDͨ6ނN@wRJX4Nj#fa)l YPZ=濁N_JunKp aY f% UV)7oR٦U.z Y $C(us >;xx"a>\7,ޓύn<wAr?C3㒹 \()@ZcV:!䏣"x' )ԋTLge>sxF wD$zR̘lR\^wefdܳ*gL P8 ²>GvWql"}%ԃf1ke;"jr*krz5~DKF "&y(G,\ '=W|2f2&wQ`@)X=ƴ8i(5_qBJU.[ gBt׵:k 8@աx^ŚF?A9HE@&Y8 =+=9 c=j<`giYk`s+,>ĊabӉ5%(oiwμoCB8Cog ;R(Ne  gu:9(`P;W7 2U|8I_% C[ "V:䗛9y()TGFͨĦ:IIeb}Z[iobWx+!jȺSqN2&AHÍ ڄ+e=#_RnFͪd*h/]0rLExvC0F^։^ty֓mELGUyC".#$'T~B=Ih1]r$A:MU|~X @&ity`P9X!}I칕$]jS0ǔJ_:Z@;3r-.jZ 5w[?> iM4̽W㓥_3?`f̢YH&N7?*n:N r`na. sr b 7(Ndtf%wu("4Nm+b41hSδ9@QsD5 -؝\`[6rUo;Jݶ97!R`ԥ RhS1yeoII+ho({4(Vypdt4&s厤5Li)Ǭ跤U D.UŻe4u'z;iJ.mƋn{e cG rH(MU1pHoA5ӴNya4@?dБUCygu}6'm~O&25_ Wa^ 5k 31aZ@^7|eW7.P#%WBU1o2vF$z|`Dv:n+,?wX@N܍JEe ˉABG #Q{. ! Y<}֡݋kڨ 8R/*e~Y!/p% ta ;ʰ, c_"8͡ #/sPzD-:nk9"m4[MJ)SR(6w:2i|-Y3 3۠jr٪[( N9Jg=T Rʻ=7u,p?a<gz>J'7`{)ANnU;C}r-.܉'Px6)-D=Z9$t  54'lUN`+2C9q;Z& \իUHUBsW=k GpݓTPNrw>1eE79do=E\ ݣ(KQ3-3'}d0+į2]UYލ ov$C~٨.&Rb[kh4Y#SXc7{G٢pvoutx;_!Ԫz92K`)`TҲ+P; {9`ZI6ugY @`X|dJ^%&2vh]\8fnWܶ0))ܔ}is^>F9+6=C_΁jnMSlN&V7BaHv"Nia6~I&Um[%KOE(͍ 6kfJQ6&n̓N Mc6@MєPϲ|~ u=? ڨ3C<uRZH4 (  kSx&氦Tic2F}98\Z8t-$~Jn`|+^d[fb{tv m:&9܀ Z/Q(Y_6SyvJ7=k ȯ3: w'6쥇uzuha}o(sIfl?`[hښW22>j~Ztf,7xΗ3 p9Inoܱ.42ބR" E9>6a_b3s>|E}R9k.a r řJLOg$=@sDApMDu((U' Xd>%Jd}X3KE7*U0"|@xK](\`x}NHF*:%lolPu0zZ1_-~=,Vrc;za#.UP ThB?ec.THed~\78HRLjH×HWǽ VIC[R:p z=7ڸE0G{I`Кu(8Pm0KX:]EoT'KxѭBU |EoɵAGE\w%8o>B `ԼƇj\]tN~4fX0[T֍f?5 2b#1^NxDoؘ+nZIt)^ ,`K.yvbY}E> }-Hv{.DHLW&)q0ōAL=9ț{VvIVHr`y} Ggqmm6wY-dG"֦I|.g;a6]sP7J$=qyMq8S|'!V {0*9ɬs鷀Ք*8(,=>Y:I/ YX ,`4GjۭGik}+3'.tFAs 9"L{Zs4 w? JƂvfU "/0.o5i%lN6(\؆9p鵣W̸ZAB"}ns[CX_t'dؙZX!F]6CwCH+ lh[gHXGowV(!OZ&7;h; wC8RVC(F C~mk}o*m$Yы/e7`ǼVzu}1{pE/prGI = Id׌jX*unw3 d:bW:u/- fi 9'cȥ|pt %j*+;QrQ{rHE;},L*MwS,aؽb4Juɐ..MKOBB;A)Y3L)/' T\w73pV?~j!٤^X.7+X0   8+pPt߂uMk* ԅNt]Ҟ>lmөIrke_}{b|CC\Q_ЮC4A9U9Y%AIsf"nB1JDwPէ'~Э=l@/`'[ Z@W+l]rHӼ/!8F:i&kU]5ZOb75src`Hm_M{JH0 ̙U%npV=I7H-sKùVWjf0:XymnoػBMJTs&+4]\شAVUkc`bC"Kjk.E~P@;f٫[0s,]4-noiʢ:pЇiyNP9c,r{񆷥p4z=lK'lfh;~OM8̽ޭ \HD|G| (&1ϣ1*I2, 1uҽ #~6Y/ >Ω^V83p!Ǩ IA1Cqy\v{x+!mqVr)Ν@l|7 g5! ,ŪfPbu΢?nr՞iJQ19 JjH*6#h[@ {u: f DZ\)|:ZO/ zs|;^CD,v?qoz-u[ ghvqٍf|#as *"IE5ܨmzL^>&fFuM-ibد52I1+`sWhsn`쇥k +܂erl=|e=ѯ41HC5+҉~3.rmqqRx<`1@¸#;;R( =T0+U#ӗzTsd,.dž>ฤe@I"ذucׇ<e'EwPsGjkj 01ت"J` ] 6#UQ(ܭ(,̶Ga&vPզt&o3tR6 @<24kT|ʙwL:&ƒJ`=Ph3[0U]qJfvx8 g,3,!MN 6Tٚʍꋐ&RɡG ݑAe&79)bj_.h,wڤމLh.GiW=#OXVlN#p/ YF *r2f ѫio2VJ*>_Gd>k/bZ$\&%X-1+b:$~ol)3yĊqW{y$ ,KD̀Q IPIO:ʱȂ)bjqw{`E~Sm&jC$VQ+RN[sa6D= *Bv2a1ZA&MHMz4/k+ՙN2ڷ>ܴV%лv]^'*@孞 ZaLuSLx݄?Lq\pZ'R!' Hrɶ{EMH8IuTH) x`a91IlETtkN3>,AU f77NZrW&]"NxfѤu5&1w?PTҭE<"E&G ꆅ–NNu{4rߝ%tN󚋚v]~L)GW贈Yj3[X5]2~JL>FL{paO0juDD'ڔ[}]C\8wKTC͓GI3tdWс;a1{Z٫l(B20wj\.8Oi`aI"(/0a0D-ɯ{'/DД !vecE]~0>РYdã@3IiZ$f;2 Һ 6q,"8.YT&>W|62gњ&tdPM{2?JR2&e(%a6%7\&;/|+b7I0/3U,z#$l`T.U97KKcF8{%\bӃAiH~vÕYne"QK'[s&#@wgeR9Q8i,(b28$6ַ?Nq$㏖m޴(N 9f)ȉbnhW&D/:I3חo\I_ɥb'{%_GKv.guNJZ%|3HR4s !zx;z+RTtn /gµIPcbt'@VҎS1%|RÃC-! 9dO*] xWH Wj~bxN\U%=#X]n*O:aڟJq7̷Mp]Kpe&E ~?1-RDCVF~H '˘ѸQ })hӥ/'S$ݷQ"eiy<^dnEZF"d)߈o[p֧NR[(v˔DvP^3sF5rLOzxshʹ:y* 6]w{9zB~)$^0Q% R| a[8/f (M4]4*i:t՟aGДLBX~Z֛$o23\Kx !1SH bPL !/5QYgED% I{,*DoUj:aL}\/酴V gq`u qxsŧ%iJ*]K~9 R>=1ñvev`xCE.V[jgwze j-1_3]K>8LS;@!/|.lW`PūW?NZHZU zCE|^U:"oxz S9AǢY(o^"Q.檼Y0~)V.r4f+`[eo@}`\+3Vi)3 R@Lp.VXcucsP`) u,uLl80oWEv4P`G8pOE0L l %&;Y* A+=Bͤ&!O(]23 s'Dt0&ڀ2V7ey%K>D $g+a`Rdo25N-RIX6^!8MVT|մ%=AHyNrz 5ʶƞp*HŽ:샃)PSVRwMO`ֶJ9|.'7."Q P+HV; tSfޮmTdoN7z2{ & #Y)nB-@nixeQlJdBT.CjVV&5uYv;dAŀ ˖s_3ftν.E'pB]ĴGvc!~C3n4"8%,w_۸GzZ?',($^u*[tN0Sc|nP1w1v2 h'9Kl!nU4iJ>Mo%)N-aeZ}8rc>EEX;܁oKWf ϑz;53V- };JblZ7?Jpm]`۵tg.ZiY@ۏ+˭xӝ6<,c ",IF?oE< >lKwG:QW7״bPy/ϒ!']T /1Aug-~LNi "nf`X8s +~@7uyj=_aN6!Vv<' ErGۀE??7vNǐ3yHcW7Jz{Ii푑+H ky De|o >N(,cOn{U]6p\H4UAy-Hct~ # 78M=c-͜pR@Ԯ2UuGg~xݳ Zz&6+oءU@LYĪm[:rޣJ}c!Hl1O\r;O-UuWp;_d 왾ŬWL&H*:6/ʜW0YFR,qrE[?AE9Pϊ*9wU[ѤnB(Z`Yv:#Cy_l1bAOSzu)NOFlOpgnt {.pqwF6r{c[3O¨WֶyAECx?>.%<d8O|U]rt~CT[:|AȮ|pRꔚ Q ՒZ\/@faѿ̅_d8*?[L/ܴm5B߯䉭)z"-1G$t[bN[~)Zr$7՚?ph!=9},/ Q8;nޤdF>KHf0mT͓Ck$Y}@*B;I"' ((6Eݬ#Yٞt ]aE%՛҆<@%oA0hUY+({{R "-=q׼?88M!s$$ySœzfA P 3,6H![[C1Q(Sи yIP.^Ie?) 8̀7$]$d t"ץXFoRXz*-"m'YhOP̀Z3AgvQ5ɰ1zhv?Jj+.w-)?w*^ @ɧ@]hԿyv>Q>mBЛRU8I9@W 00xM.0~nj(`|yMyz yƨvI Z遑e{"Y75 y.K`Y2@t7Dsj2ik_-wvKHZE&V{;Zs[୘/UտSA';B̀5a n)ߧꬩ!l nחy;pIU!nH.*o6т5t(&գ[qaE@K?+@6]? 0'[.J.T} CXXWX6d6JAsjEUχx؝ h1F" hIÔ+?8_7ARCmC5y4+3NNX͝! "mnl*u= 2 1߯薑-.^R`[q UudOu;0@+.$qY!i5 J&r%6Q+/xnxEp8M@UE(<QgVt'H]c$o3?^*!qϞv⽑Xl?TH Lx ?fg6-M .]WX ~/&"DTF}c&y]nƯ95jg@$]v#loY<og]2aANn/SV(@TEޭ+1h7 3g_!4~$^O x x]g倠A/- (*uIGŇ&ou$ōH<,C>Ixl{l)bQN~A$[p9G1]. R$"͐Ӵ܍?!!'? |ouZYF@JW0qD9gn̾ppbxv^\T]HУ64_EY g2wc:9V! ѓ?8um"aБ4ݚ*U -Vp 嚝L1 P7Bnr3|3mԣAZTcv $+_ш,ǛN2(D6˜*8OrtWK ?ʼc ^u{Lb݆'jsD}*$?r@HB97$b4r TeܫP *ar`_;+֩?SU5T$-GGR!%H=}ݨ?E#荮\SϗR>:+Juб/=V7c">XSx Lu5uc,e;.Y֧3I"oVif r;Dzva`'sJŌSSahjN#'AL Kx.g_٬ h/;쑆|lx?xj cxIQ2>o'h{k]zCErZ?`|9_ i'fjoK҇ cv'+>Kk\ɸl*CQ<6<`#v?m+EF6@J%^B7o5J{& t*Zɢg%=hgQ#/t] }>n'(.;I4Ui5 &VvbvBht[aqd[muXUh[ЭZ24F?qKǥ /9Oa* UsTkHB*1PL'1u;&;uG _x;w_2Ê/Úw fkgN 5< /'-tdžɴ_@X:QT1TW3~%` O%S@e|%"859ՠ*JbX 7FN"~  5&o"y|R`B=[o^~H-,!FJZlM^SyL`SZ@lJ3n=QH9-C0`O 3 :.mC[{C9뫉{Tlhk6>H:5jakWheږ l}M{`zQO5s*^s؇5'lĈλ>[j,[Ĥva0E̸*m}F>zBK9{;,4NMC)leQ:*鋲U&5׮=ԂUjn))Tyo%ԙ]2CqW8x>3!7U .͠&ǘ:[ #oHRa<`!q1S:=j0;ti2/Clr <FX]n: ~G ٩є6.sRZ]0¿W}^Bާ~*P$9זo>{dD]!j~i^0'':ى 45} #գ/nQ 9_⟨w~VT僦i!b_ 0aܮ’˷wN#meG~)~Yp!b.+[FJ8zLx#nIbʓR23J+Wu¡<xLߢ'\)0𩕴=A-iWLzRF z{">JJB߆ۮìk%?8/TB1 "dJ۳9 q4̾ MR@CQ/Хލ74<duaGR7Yz,t@rtkk7%ЖNxzwQF'TbL K f1O^7NoQ7&J$Ji\ALvdUYqjd%9}V}?=oDaƅnoj+羔'fdggaL*A"\F+{p[Ϯ tqAZgv9 NY^ZW~"e{ 32а,cV T DŽ+):-UUf2-$EtY\Pa'2n(_ t݈&GJym-VyAt zfJ2H8;/q\P￵5{ƙ7 80YLc0Gѯy7ErmKq2jKCXySyf;`dzbt32i-7 ]niC: ]*ca'-xyk~~հ9c΄0}d?f "+ DL1~%,_@yba`쑉gQwlm;HGA(R| mG`:jcu&'Ɡ<;nljT6SҌ:0̾TrБCCyw=90|c$N/MO\?ĊMkbA_&7ןsө2-ixqxŁ$ulҥ} SHH)@EqQLrHӓh&6zxЂK:.<> v5.LOPs\5iQδ{,fk+8t\Umm΄ |![#C KZ$Zk ;&E'Ƙ n>|H>j^[Sƈ5;;:jml0h!R=,yhTC J#]׭wzLGo=?3cRl6'@R-`6x :]rէS?r^M[TB=YpAX+,Tc5)Ոo[ަSBY(`>rt8e^},z)yaX)@H.MmXpI,nYpz S]r;\5z#f@zU_pL˨x-7svW8![ _iz JAӺ1jWCp8afx;* .e؛(XF乆mYd4g 3ʐO lmS*TtɆ'xCa?fН ӯwR%e0,I-c풴![`ie{i-} Ox7?o-:ũiE}UfVQ7=2i~c43P~$ϧ[aENʘ&h?| F 5qrp (4NӭU?&a4YM{R];ɺ0U5ly݃C)\Hbu!yԲg;ҶbCuxrXrEpv/jMH$HLc۷DES@z-bξloz:=ZUD!IȉU {fA1a4&PHv%_'UP]_y/ٔ)1Q[lv =\o_S QhZўsP~!%LڲAZso0'Ë PiiVsŎ:M7d\gK Ca1!m>!&a^_]s mcAgkS"@'mm(`'vW7]>Yg a<)Uݛj,('4 l)-_G}E尐k: "|34r)rK|1)* ';lxPcb Zj2%* wbE=28_v__-G z 9 "@2y/ z*%d-]vya (rьy.$gW^c WiLUE F@9w{eR*]Dٌذ _ _ +?hV΄T; $7 RUzg~+D=mH49^㲐Jʢl|d0-E(G O*2,jζ7Int4:}v1ݑ01Nc+䓏;IEI˽P;ӭՌMn(IhfW=l}ev!Lln"7VRA#gÊ1Bmn[~HX iX75umdMqgWnzvMЁDZw[ y%_.^v7$T#5"e@CqdgYâ|$'ILإ!+ a&|KՎmf"u3g碞!jIk|c7,Ԏ'6DG/eVY%'h~(!D|ZZ |[ĂvM]!A7Ze#(?U̷ͯuEil*ѹHw͎F1.ΜIoW] X|X?FcGR:ZbXмݸxg*6uv–D-'e*tƻ,r>8Kd@/ >MM[?07TZՏ|̨"7^v<@C-Ȃ?sBd ^J;8փp&2kMOk]]``^u\Iރz}<` !mSʤ R! k ϵQpee!Q6 D'Js޿s"!4ILM݄0a_G|;vxEhQ];c$6ATjREx/2o}>["f?+90B~KBI$tohBZbU|(詛wWC [,fJv+=A%Ո_`6$eڜA'#15 d҅1e)`|Zt*zWkrm5dz,a$ތV47*3'{S*p7s|]U `$H&:el7k,չ^` |`_/̜2`uF  F|EЮ#A|/{I л!t^a-|!G3J+ ,HjWW|4ε2̳Blӣ/wv5%!(_>\CwQ $Yd]dD 4iHZ}=2F؈[5wK7ro^v<%-@󸰂|*usCY T5a[Pt> p}S$fjS+K-ywǧs} BP6uRTEa#ߙ:Jԁb/+GUu5җ7WsVlP7n)ʻ X.2 Y%bROoйcYĢͪ6? XGutiiƠ#=s6~jۚg^ɜt0/@z5@/(Xn:_b=jzrUi13|vm0Zp!t BwF=s9ܲ9>χ%;ŗ>Qb̋_}RePD Fc+G@9p봥{|n_mI̮8T" IV`gr;U ߰t`Ԑe0U`g ͅ F6Aj}OUs]ߢ_bPV*ׁRx6ZG27w"{;)y^@/-:Ä14WHY{YSyK^$ 7}I_Q`xQ qZ;R\l%[02egW[Z$k9D+g7G3 6`N_W]ɓ#1f B-T'Jxѐ,lh/]G)Ԉ+1.0J)9R1LcvcwJς̚B~ťFW0t[5쟔WL{d{Rr$-_&_4@1ߡ!P`F+'`% `p0iR99:3rCfb*򩑿 X b #N Mc{1a79B08sfH+SuBJ#*.@KrwKӖcrsDd;J`1EKc:Ħ-7pJ{nܯ'6}v6 H].WT{]|6^RfZ_pdǀ&u?+I]!" "Knun<ó hPR?Pz"tR;F?AŌ\-Z D|h!5K?zYEBįeua*L4'AC֮`*\ ঔa@̟lO=yqkb!*?iU9qM")/ ZB4&xI/&vmGd"obӖ!(g^ w߼Ý'|-dlm;UEOooW*jXY(ٖ72{ ;^k3ikUtLE/<W,VL. l Ӓ_Vч 4g\۵( tSH_ c~c{flӶ.#ql%OJ:;4KАBNuI?|PZV>x׽&Dhxon@O6!ش':L3L#D^{G(ɍH {Πp*b R݉Hۍ3q|x%|!2?DV: .iX<՝e=2GzVuyħb+5B;gWDΝ ry2F199caꖧiY:kċ\E\)ӭTintray}_4EDn'@rGÛЊ$3LIHj[&mF"/"n1yϷN9iZ긾1f_[暓0⩭g1-֫h^= vvfGU.[40Y~hKqkqFeA~`٩Np #g!*3%aojZ r<a[>>r7k^5]h&~U!g0ݧ0;)sjZ*n6wTO AvCXpq@ YO.'+UB}{ȟ,ś(+da+-3MUo/R7b@p6FqTnӠ(.j?G/:yFxRDXCx0?#,Yc1Df`hy2{ Zj(Z 3xh$Z!k~Z35jx^i)?ia*XqDGw9 \CCH⩵P-_v*01ƂpgjtRR`15י澲YU\Â@JJ-Uy CBkw"lq#@n`vB+ UfFq#9GXhl~8izKALE-y\x쩗A{ n ަn];55-://E3gKJh'[-NeHH^}]FjTkA;$z׆ Iq޶:ժˮc* fRXB9 #s[/ _19s[с1K>p;u6B4כBLii6⤏ [Yq%[b gQ,qA_ш75D=q MVw@iJN;NI3TT-} " 5HKg߹`9"?dek҈m[+gVchFaݢHIJncvf19!z~*`99T;~;/dGS< TY""z V!i$h4{OA% d%vWg5k9xe?G'jxzx !*kuÈS"D$EnKaXئL 5.ȍ_@qU4 A6@ԯ1+N&>cj=~p~uAQD!Oq"yuY! #p_>۷!D\DKАB G/ ^ OE`fj$JO%+R'0&W=^6/ k#yF.v|JKH10<)^6c6U֟XJu1\$8bN О/eID Rܔe-T$ʽ BKdz ;!t5g0}M9#öy dxfouWN9RQ& =(ػ)uC Q7ZPeB̆.u>1?ا{bĖߔԌ?.-Qc~␬Vz=@`KIOcn3-ITZH=؀Ij8HgGS[ȍAnd;bp& jNVOiK>tt֣qJʾ-]^S9A:)Si;:QU`v`SB%g]W/bFM`,;s$'E_^ͬH8(LvQ&]0e1(q Nүw,{>6fWKQM5*5n0Fħ7Y'akٌvG[tj` Jpv vn-_y|=%$>vG*_\\ͱ$Hivd|=●>F)䄼6#Q 4_*njpk껭*Mgb$G4GeLzAL<7=z-̚λi5|pd^[ Nb 42ӳ7Ewn+Ŭ>KlZ| >vY? 5PBT/·1/@|iI1DOA so?bI;n6k5\ZpSn M/`54V+T$JTN-)SnCwJv '0 QG"3o.j\|A^{nN#d\BfЎ>VR+z$-{;׈1ϽE A 1Ëf2) R}|,[b{"x(seuSH>V,8k ̓IƸvߡ!J/AmBnLt$ 4'`_r]m\^?.4Zśs|Fquap4?086Qt@DkjYjf̷kqSp{Fpj¾wF^n;h~.Nbb\Y0 IV @HŒ$҃H9a!ڧ8_ѫ/(0i hYlJܥȔBZm-C S ԙ&:M s8- ݜV bu|.#{59U38,T}qGg^` o{"d[]o[@iE2@K ̷LnwWũ-P2^ScpB ox4wk b^!,: k:9WuX2/Sҿ$5G;!>P:hyw [UϹm g7/+buk̓Ntԙi>  q5p? kɈ%aIƅ@&fZl9f-r@xa|Jh[ohLe)OBquKFibIt2~1Xn'|k=PyR-#g kZ<|r̻ ^L!܏~t 焘w o\1rP%3(Dˣx&!eϾ0|oJmg_ыTFJBTi@O]f6pI;ySw{W"R`3`lJ4 ʙI|h`HgmfZ32Qz~Y X6x,;} 9],)P}l[ϭ*X]c#/UtgH8/r=8w{gna yذb{+\:V(hlbtR_21-1XE'e+1O*)p1]l%yk&Q"3#8QK em*7IšՎ}^x]/gy\9I"IA@˧%_"_jXWgU#rU1a 1>Ggho`2W8usи`vցpT+ʭAOIEt&4`}x\ I8s µJv|o*jE|2G7{Dby*e~ PR 18_jEqjWl',~n^]lCЀ|J֝,[qPKme^#Laug$ zT H)8ȫ"Kou_sJj< #eeVs%@{4l&).YP" 1BYuaj!p b.R}ś1zࡧIGEw>t"b]7=<4)1F_bg l(ר^9d !5ܿYu\.6p9oFqÎDC_bbE=]ZHԈȣ "5Br" tnT^P dQ$h`E`XdSyH2!wDl)Gp>%K7YS[!Rᩦ& NB5|13Yj\'$V*Q aKM!ዒI=wk0:63\{?8ݽbR`ѕ6g !O[eY20{Yæ*0bxn4 dUQiH1.l`M"84 &tlVўu]"ʮZ!ztzʩ_O X`w}qʳtAhܩ$x.{(c,+mx9I' &? D*+:̌p\z5UZe&(qS>u} ETMV]$4<{8(cgQuo.w}0|}]bOe*W9dy^, !ML*ĩ4{遜-ǬʆߡtMuq`}k< ]S^֥3 |K0`T<ȲyD~*6"G|~ Dy002hPN){V?9R4iWGWl&KNj1Ǟ6ĤBj1.Mɉ",t<)i*!oMBqWMX) R9jȸaSX)Fr% T/b#^SDϸ{&ܻؓJަ}3AO}cZܿ䌗JHB 鎂.+(r`"άku't^AzIq8ueꢵ5XhG W]-A+yk jWo>'4`M&,] XiTba7{c Vq,gM#1/Td)6bذ *5UʟM :,(h\Kq6JeGH+R+`v}m:aϞ6&{F7#jTw|[W w*L9ݮAy&ڨͳ99__;XĿ{"wkAaWt!"_=ʦ+м :+k,ɻ\;>urܞ't}%C ~3#qڋV31r4$DI#]sy@s Yv( xWi'βi#"`'=M j%sX_e{l]vX7uMx⣰}z$0ZznGXQ<`&}U47FۊuTtb(ٛ>|w q sP #onpU/qp2Cyw*尐`}Vr- ?^KcDۭb4ÒZ*m qN~XF{z^k՛WJo96m>g_o uw$mQtK+{r5V#Ax-JhR PZ7D,)TGَJ,Y GYlz89 MF໤-p02ܱ-D9RAK2MC[ ڄy"OeԞ (!^7*l+U;WkrpX]nCh^]6srV\'h Ӧ#"><߼! T"ꊒE&|xߙƛ I >\ɢ\?;lǥA݀߸ /8@7t]rW$Vr~﹍[vCq{RD4ed/T7ġ$tqVYKm1H|c"osV_|S{p 4 aBzʉ%(5{kms^ew˨΁uRX%r:7IFC4IW& .Fi,G6*`v~8tc /;KRB+T4N}4jH&ܘbl0Jf lZ#ӗҵ_$-V>l}w&mMADZvgX<ާYx[3}^HWF=={|.3?ٓ8hxR r^ L(/hpPX) #ܓ+ Q=2삲z_Sf/G(j r[)d@s- +,4U&~]1 mo =U6\N'*cty!īK@l?|_"6;ypg: aHw*(lBP) ۆ?W=V0K|=E*}O1w w#I-h|8\PyuAG!9 <.VflkGsyDTY >v.[ba)(U["glcS?+2N$оk@ֽ#r.ÐF2XTpn{;Uaރ vg֚p\}U6]~, &J.k 38DmSb U9e>:e\Nٓ ~=m[/<-ޅr3Ejzʻȳ l:N5: 9K0. gj\H"埪r) C1uk߉K8IONtRRY]PE~^I;]-tR&ψ'Z R CZD*gD ${s*P%^_}Qx^`$sfJ%(m%&C4| ,j "ӉpˢGNjgo>NlVHYXx {%c3f4 5p͵Zs>hhY,ظz֞/`T^z&JT?N A#4/s%ޖUD!(+`Iu"G`=]ƶ|Skt~|6+)hOgv$שM"? qsMP?;"eRgJq^ Q&?frROَXjv inu}#dؤDMNs$N[: |^ HoIz=6ҒC,v:ukz;AtrFs3ڨ;J$!ie&=c l"y9 _Ր$|zF]2RϼF|wXRFwW)aPVՠ0ژޟŖƥWTW4cD^>*[c%DӹcKӔI'E':eY. Dk\mc|KFY]0/& q{8 -؛wJ\ed/9LAz ;p2Pc#@$~Ӏ˳TxwمZ!󺀪}DpW[󠢉i BxKRO]GR B[ՏD?=:{Z3lQU;/nhkym6KιXۜk7I{bk&;  { Kae*I Pv^X |g'aGksMΑjPZLr"s 2H\X9X -vWA\1ps<}i ):l/N#ķ:+)ϥm_~7C/fEcTzOAzbh[MAZ8T"?:JSI=;>r =4GS2(甙En[\4]moه MeaPC ᢡy*,iPR:>80|RȚٌ[PobXZ(7\7عF,s؅ #aCTCp6./f)FTgHJy벖0Z%Кɐm|`E`/[L>^Hc4nEy)rIqT:Ǎ#DdX:]{.>I9 פ?`@Lpa/,qO7Ҹ <$gTGo@D*SYm#Dx9I-ۓJ~LK Fˉ]`$"֟{>jQ/ 1yp@j]sh;@8mIRT<*h[N>H\I8$Ks!2^]\f}ZWZB.< cGNӰ9[_ܠfdOVk _VKs6ND(7ch4E4^Ns|xB:;"FNJqُ6)"-vxs21XovAE JmjLz'WXw*)oI80b? Rd-2X=C:3>>ļZA_zړ u D^ĭ]JFᢆCD%#O:fDe!~,YM0<4=0)Ⱥ*hvy/32a}TGY%za9 PبkH n, Rޅ!K`Ң$bYm=_چ }X`5 ~nmC^> ST[0TW#3}:TQQ{y#{u+FeH&lSpQ_?4M&AO `[ލg.^#:Z`No}c>*v=lra'7_繱*i;Lܶc .M{J~V?24Ho|:@ZyZzknŤ$2F?ߤf)K׌.AVBw[u"EQIo֏ԓ,`HRꂜ$__M;IK\܉bSSIK[W}KjqLS~m-7_yn"vo|?KdKXH,!5CNI e&@L 9 SPwNh()#i߂J`6Ï2e/] E񹅌ר fO]  J7EuYϹR&Xe]E'w + Rk0j\ DOLKyF!MLV|[fyA4C4% Y^k:S)ԭi鯝[ e ;OdY a4#uF]\Z ?ƶ5/>(ƈETT]y*K EӼE;Tmއ fPe`'ArJ̳)Aɓͧ"n$T"Z~=W Xg ǜ?1=)VPe(㢀="%P`.%:H3\$ yZPRt _P û'НdJ gd4sڔX"ՙWN*h&r+?lK+t#Ǚ׀mU)OJp14m mNMFε#S7GӢivqO5N\ӨZORh,, o9 E)/mTNG|g P:bkG?[@8qYQROܺ9~9(MWTdsG b Fў!. F{$DcVI)vǨ4arp9$٘5xjgȁ !=_qFK!4n;Esz$~*fXmŚIҭ H.jeɭxoDF&|GuB, 2ZQ|h/Gn<V;/7a†*IWEd:@)%zfd=Du7|LӍcʆۚveb[ [}QܾR8%>H>DZ+>apyP[V6 ޿pZ]ZX"jL$I$1&?5FꢳFr)]AeV%\P6D 1KAwBW\R&~ڣQ0k;n G▼5Đ'ש.bG>pFBqsp.{wYhC" H=(-ij k@ƴ7Fh[įyfLc\60kK?ckneg$Hv%.t'*R֮A|<6-xou,c0hm!rkcTJ!joeQޭv/_(FS/u93?[ ?>4utggN  |_~\0̚ ow^ǯd5NetZ$vѳʫ{[ZgڮcE9I33P45cdzg-3EN?@.%ppEw-[V!.]zdjr9h,AEZ39D~YzkH[T p(|˜ts_ЛA|Cp \pt-9k<1aظ9 -L{=;_n^!m4?˪i#$ǠW%x^l$>IH};]b^[Gޣ j}0횚9οfE_ 5k6qtzx qom\[3+9Wct7ܿI)9jOO.F~u/?V<걳1~%h<Sʔ,ʍ#Nk?,-%{8Z;X_$3\I޶&"i#{r3_eܩ֙: M>6ɀ+tΉ\_-'|Ӓ 3H] rgYȴځ<>91Vޮ@LiijF L̗/H/E.wZK8؞xw}C S#IJ/vm{JTBTjv'rT;W<\euWη/lIR?ԞPL$?(rcϲFjfg v-8MK`7sy2ϿD\6B MPׂ n Ud~Ak۴ %-Qw nSc ľ?c&W]l,ކ65<QFžRlCJ]+3n*ZCSn}O :)EӢ}ż#~Y$be=^E4ˬMUĜw;O,MIIvK˨$md(ihIM=AHFcWJҨ܁ gNfYlCA\o Q' V9;X8#&BhL΄ܻf7h %>ZWFW ~'kg_tyB*e"аQ4(4Ɗ+:A^W6DmП~o!S2uD@u^ex=m"'E-&m3m]$-uU@k~i܍DCsbYfsTxj sGOHhLo yyK# ض8"Gp+1kTٰ<@.+vƟhV k %WE㛔sv%uZ \"-HKӵ32i5BC ƺu~cHhp"2eG,0F6*،.N|0?l}9d_+w6hu DB n0rIocKQbиdu [`AnӮ#&k\\,,3~鴝UIJbK;y@ӓ]ʇ퟼2?(b,y B㓤}iuSi&2mZ̷'q O៼ o[ZlW)}dW$kg/*GveV,g5Fv#G^~o9#F'5"!;PP J.z"(߆o "s\ *&#[`%UcJ4eIn6<[1BtW"m4$?*؍y|Aқ>2yyՕUobu 6GCd šj9s忮 iΌn.7[Jŋ%KMh- "UWHEZG;XKkX]Lj:3I_^LdLOSI*\BL!!O>F}H-;BkFoq]dwX]`b*!&fc>Ȣgѧ_M^O[*2` %Ӕh٠t~.KTX !:-WDQ ӗf'+ѱ?D2=Ek! PJA mLǾݰsqUYݠ^>;)i%0pZFI> Zʻb\+wpsIM ]莁_yGF7;V]O#Sq*?qA؏8}{**)tK&Dn╜Ox?vcyoTߧydc[-Ƌ)z@=[$}aľ7Xu1 aS#e)n#5Ӫ +ħiH"UҺ]g` Iwe4.q[|Yը+MہfL<`% ۬qVٻkĈ>{jko ǟW}5ڎrSZ{VL3$tO,pIo󔮤AM1ws 3pD}zA[aq/}Hd] t1%C|{>;}xMz ns'SwaLRi 2O567">!gg[y6*b7ǔ]8BjK$͵F,ڴG23▃4:Jjcs]>iH5ko EYJ56,9oBX'-Կ ?63j@>3PB@a9UJȅ%fNqqtrTwIj'ިOLl8ii7y5CmF~8]XP -@p)~5*Ϋ T5Gj.B]Gⶓ66[y11`(d^%fzS^T#J&5ΈaBd5) G9 1~ػгU؃'B(lEv|kqrJN"_hPHO[ /έp|5v袏 `ͥ#~htY ! 3|f@Ṇ=hdL CiK t3s4Np>G؆  qp D'^DiM4(N5U!%@,& pCOqGKB[7dzKQUm+H¿$U82WC2TfĉӤ'kmL^lkbA9@n=Y7b.{N&3"^f~my"8S.`|y_HȯwB.֔q-;(>LiU*.|Cj"dc@H, 'nesHԙl>Z%3~RbϹ.iu#@φ_'u h;mnT)E؞z&,-Blbq*|ωǥN iߏ!yzNSܝQ3\@GX iƄU.>UǬ{G nŜS"'4.5Y`PߢMd`CbQ&lP$'7eƍ0A\[T}`hқ#q`"s~B̩[VtЇ:=RvyC@QjG&ݯY|tas7$ h?}-AZ! ;yb_ܞ'+u=Aە-i0.e 1za: |J7,&as,q#o GM2O^t1H::ID4` v;oݽ'IF&2>afiÎ"a0Y(k%`7+Fp0 LdjY6XNhFA% iGìm/}.afnޯՌ:T'8!Z \kJ7yhqUp2 km8 S1,x7O)Ffy|h'yUFG,"UۻZP۟7l4?Ju3S2S¢͡Jzm?7=lur6M!&Xד2zGReA"Gј$NcaG((c.Ӆλ}{~oyMyɶb?mߎ,4GiK}nGxN1\?|uC%o7s^8Xth˞ogǁJ1^tTPⳤٓsw[҈>$4PK+ZAop O}dĉ{:7W/8mɎ$Hl,p'#!QިI˫NKK/ >uL)mưT[1|ꍤ _x- BqCѠez7Tzk1a VR 5s..nC4?w辈(Uuњ( CuY  [ 1]3Mm- 9W6CtXUZnQT $B!G5$K/f'20$vA0vRjHxjG|>A1ă͒z+&9 X_`(@H/āAn6F0C<MOtS (=!opIKhN-2ǡ@TniH3S,g9;qȉž ԡ o0·>NȹC= <4JY6v0ۙMAq9?ZuϷ& BϊHw{\DUAPS1Ǧ^|X*;\C}:eΆ{.\VK{N3C*MvP{!n-pߐӄPq=b Marc-[@SQ ьılHC\eC㨔1Ȍ.7SnZ&*zM7Pʰ^`(T،dk56% Bk0AG8Bh|IQ |a;]mqyіTrK7>TW,jҸzHDoL&NF*QM9["뛋z|uD@#sG ҭ"l\gb^Q SNevLF[o5%M H҇2j r-a&F@ސW9xS|\'{_P҅n}V(b9;ҳ '@/#ZQh"{ JksZ_NNy pEw4g8ԭD1$7eѠt_A7m&zTv0vY4J١g4i fΎ";&Orm''Ab L,ȶ0W;euo, :Z&^ F-7R%Ev6{dQy' ;dɱrvrCbČ>1ճi9y>^IQgy‹uUHf+PV,b$=xXkyvʹbw3I68>aD&+1;y?On' w:Ѵ; 2h0c),3r6H9AC@g :i h/z>wa W5Z[0 o.i-\K]`/>✦#']iXg1 %™`2T/.NW!"dQ{-T.8?mF+9׉A~4 mN:N1[Xn09҇-$;K-q!2L[Vs=(ŢһyfXK͑(Cr=㺕0cXokqfidPer~emnH o+!~Φ R.~'V] 䵄FjuiYH*;{:"䕣T%|c73N l ;$C R*$j?%l%KL#Cg!yaNЗ;[&4WP#,DڢA+'iRtЃ퀴ipB`X-e@N:K &S|3fpooP|Jϱ`H_!ss#hME͕&W !ޡҐHlhxiv'dr_DLvdf6Xc, !=4X0;JlIJnU㌓Y!anE6 @zcN[EaܞkRJxJ -!&Xzwl2 gU?NPA'+ w)༇Q2[R7,3KZM2@N?nFQ8to7i RJ z+ mpCm?_cGI=DJ$-z+Ϛ҆ZƐt;~0Pw?ͶӠP`$j. u? :o>g4RۊskPdT9|4A,gJ2@~NXs(IN*i6-*#4/ F3YD8Cԧ 6H&b54m'+{a{(2L(KReNX^L;]'\iv'™Ӷ{ꖁM!sA@*3Ȕ.k?"L*)Í i71sHo m6yJ&VmETԟnUd-2%Vj8w-2a{Ҿl!.ϓ@xG+ ?r>|U/DBq^NG'A ;J%D|{ n ,˟*cA8/L@>tOTxsuRFa;H֒zyY"8UN_bvl\fVPO7%[}ZP6"Y/rfr/xsI("H |uHcNqd{'W~.h] F=B w":tyR{ coh3/~gg^bV3] Gzcլ_Nʿ<\⊂g^*Nl ^k f_/׬^H*a^Iꠅn/ 2^EϸR1 <)j}4'bٵd9ëQF׏$Lcqblld9Vy0/oD-H#pwT&P1{|@6YJV1] G&&x3Obž ;PO5hH9%~>k@|J!ۧz23xX^\y.e!W Ipd f?GCIpF_2`cf #.i "N95?zZ•>Nls<~sa{2WF*i=V G-SQJaP\%ݏxi:  V]#.޲h#8OJ#F*|j9t"qƐmGr~~ {0Jt_~uv#1W8R$e -(faB0qُʖ18w7W~Y=ZNV7ffCZAv x jlN5)eN'&(\ t4dLdJGt61x1H9)Aümv̋{g0r_fQbu-tPK #%$pVRƚogqgab&ߞ>R5ńʼntdйGFO63%:UiIW )% 6Gq bdˑsy*6 s=ߐ9\(qAS&Ҥx/,oO(1e)x >9± =& qWRxBh^ze\,#قk8 U ~{}v&OS.n{k4z:y=>^3(;ʹ,F+L61·ȱ,Xj)uv"R|iXBawD/B9[{țI`GZ_lh-Q3>+Y@_-6ϭaɮQ-Ѝ9Y& K#hN>Eo]c2 (b I﷍a{3f:Bk$7$!}Mw>K ׯD=JfhUG'io>$Yuׄ'kP$dDLK5@{̒"8K6%m?RRx r:6(ă:mI֭Ac([jO=ʻq`=P!pNS74q۔Ҝ؜d|b05rPA. _GjߛS1q ^ ; =FOڕۏ}ccì6~f;)5X,iZt^+v o (Vϝit!@??ŵc0e܍2f6DPMcN2GbVZ_`xk^ QU +,4Ʊp'bd+R-f J1Z۫wD C MfYf=S l30UsRD(_IʢmtEẔ=k.p"ky4 MHUM`&B82oGֲ_ss ]X776"$¡pKX}PVv"x(EN؋;rn \yXЎ'T9.G ,->J䖩㺰ѧ4`q֫"{L(JhMjDs1 ۱Ϥ8L+޻T:oI:p\ z:i5ځ`PbGdGx?$uRlϋ$T,vpPk5\Y@x dvE8KǕʼnegOMDcx5Y?ќ!|qس4n$fCAKPf͵V4i%v@z"G8nJr5!~pdw F B =`JoN/O.gv`h81 ¯.o<<8NКz/"#L/"~2i %ќ^R? ZC:be > tMi]- ^&+gрt&##NukQܨA ߑb 9aFngV^ҠFe 8SIpXQ?=\=2hLi=r؏28_ m恎yr 1K"? $YD7Ō"J ƥG,n8(. =PboڀoB!T<=؇[e"HV1Ȏ.cAzF< |]jŔ sݲPBMcZI3J H#8 [s؛nX0[r7`^]:(7ڐ}Qv'!D=fyQat4!zKA"4$G[j#)ʙ97cu&1"1nn ?7auCPvxWby1wdh<]E8kagu]8@y` jz6QG7H8؝ S[.xMVgXk͙DَUoqEt{Cc[& Й"5lZlb39%@kXHZVeCH}۲C^p_-' V>5,MpvicO`瞫&`њo`ſ$lՍJzG)~v3ky\$ռ4t ǃ,{_]ZH9}VӨD4]K&hd-IcW g#vaރ׆z$(t ] pѺ5agtzB5̱ ۮq8xLKS @;Ť'm9)Zm~5tpk%TbF+j(oa٤Đ.-H0~N)ޞͷea;n .`^X~sm^&2n=ITosDV{ggJћp C_I %Z¹,ס&l/ J8GA  d`Om, !'PsL-*|A n&P+okYqh袲KyD3Uybn,jI>#T?=3-)/m*W-smtryid_gr:2oZM[GԖ0D/dDO܃kg}[@L=go 'Q|O?AǵP]i('_aG r \-UD6/?O8'& ur;6m bur][#: ! Ƽ1[P KM2Ma a1ji\ZKg\~1=͎")B,y/N<9䉅:"W&r+9y*(<A( R4Bh =BC9 3,7 ύ6uuyߗDG]N9VȄT'yHzMxGB|Y 3WuqݎmPdL:-GSTdjhăF\Jt'݁M@}uӆ bl2L$:MzjDSʭȪOw0g_dE@ب"TI>,aDnO:?F*j 47 }v(,w"5!0\F}kÿ;*2`#/kHR|$:yt VWwT{g#J,rLe! H :LT誝U]dHJejÔO z<:.]&pk(TԵ5JՖ/.>ւdʢ`nfn[3 sV4Sq\O i=Tw{c߬#[잂b:k1=M0g_3;GSgl^ō m$AgHUĩԟ3˭9#4b aT4!a0Dy-߲HT}  dn-ԃJ9>$~/=p~t2 Wot@MJ~+S>5aDNupQx),|Bܛ)8td%gQ =nz_)oyF715 *x$_q6ïp9h9f@z*>A{f~.?9eI6ԂJ å۷1Җ?I9@{ABwY&'@z$ԭʐ řA+ˌ=,eJ9R_ !j`7<˄=}Z[ >1q1i ~' O_hZg;[YBEZJuM#ecN= $R\Xj*~sJC*NeEu8l[ʟ)QcW^g7v`ơ6*%ZDr\{=^D8Sp%S&C]%R韏Fq4v'|ZԹLcԌ*uު(UO4pbI= m@}㰈 Q\+;! ͬ8a{Z{ tz_QOPƝ[O.Uhm2ȿ{_,- 7/I(, 6_kkLNf,gss/ YJ'5D_{Y7fs Şf~vܫb: pZƛh.?&@|GzƑ{D~#~q^}U(πSgbHVm*jO56Qz߯1hFi{{gU ^@Gʯ0mؚ ܫ\%_ڀSkK7ϭ[FU[WgVc;>[w嬥uR͐Er fLfMcה I*"ԕ|]#4r%_Ddkrxp%zG@|9,=>,o?Ps1c~R%Sx$YWzz m_ "D1v'NaǍ  "Hw!% t+LVb/=pedyrwi>?*Y/Fvs8%tڙrgYqɦL;i.g M*g|[ > 6 tû'F6P8iN'Lƿd5ˮ#Ԫ9:W$WC 4 4*FEΖ.Ag lF,JxT|; c3ď<xd0CpTk"ǍQ6[^n6q4kFA~s>ES I4JTTD+?MsgjmϲWJ{& q.C60Ym$/K@j+B} =`9VWٻBid )HG0bHcK7YX7(w!D?6;M=٨epVGuK6ox Ciǡ8bՠ%?lzY;4soV6(Wqe,EO݌ێp>y jWOfɌ`SAPˆsv<)%;xuF<'5c]z̙!ZBl;*sE0`ݪo4nj_|u2q8Pg?gtWl{˴Q a( $ Qy8YFA?r3Js \4mR;q2OBjB^e# \%]Jߙ9_g'J%peߗ~ϑ SV  Wa9yo^ r񦉷:K(P&o0wdۂbP8MCc 6w{归~4m Niu=[ך#OaCӒDj:+F76$]5 |ѹ#_Hq+Nzq~c}^"m/`vy9ȏJ&,~"7mk!YE#jEXVxNz"'q`_'}Q[^r } z&04]5% &iXDIRH;]!Zxݵ~SǨ31TFXwJG c%ZE &?XL1M*#SC64R_.8_v)D|=͜xJl/J=hMJ`!Tx@Ւ?6}EOubnT9qt/Nl#vvjs忊R@䌷4}@'n~9BVAB#[Eop0ΊJ?$1B7;n&ԏҐH K#)[Q3\S/~2pCP5krΌZ*фؼŎx(^`` ! S3Qmq,u _$I]i\/wpq5jO:1X2KtNA $V |2-w7Uw(ba" _ϣ|UFT_Ih٦LDDžrWށP4eW[%[t.Lqƪl^ŐF;OdP9]GE X:Ci}W)b{db7uO}7ʬz PTbW^J݈1s1܀4ԃejJWT*??yf4"a6*8meGX1,r}G^4ېryMN,[reAByTRN :گzA;f(Dņk2 eeM QF>mvL Xx ?JHMoH=H!1Y((oG赀B#Nv\.<''J[frלȴ:hp =K!2P_ㆁ I\"<}njM>9cpGGӅ7<-onz7n䔢ㆦ-ױ~`0K=ؑr"A2{:3hޏ 'm6Pzr98L<@`"9,m .JV2P'|E_7%y^J9n&XNC[901ZPW740c$&L<3vڍim%\V/`0i=Ԟ̽b e}nYh gEP" WL6X+X*fjR0;GʙacnC9vvP>Gݿrs0RH)8Q^LB 7śLήa8.WvL Q"uu2Ћ9 ,lkhAGa:,YhauGjdj^,A EA JXhU]QĎ;%(b'鍻3 uwH9Q};_~̾؈J"i7Huj6j%㨖O95m=&==1Hڿ&_̇[ڗx:b;ر=t5׌R"h=ɍIm-xNDŽr S| ^:nGd@-t=id,ʓY k暗}֍LG#Mz!>ۉP#k,m0eN-ւA ށ" O>ҿ"p=lݾ&BY%7#a J"eigBc gTvc-;my\̵Hk[cAYlE֚hVF /)y*u/'ݗeO T/3dnrgЯA'Gk4.Vc I@f7h f6emDY2z]^ b8rHAPÑu$=B`ja0Z9e.^qw{/۞s?Ëd oֹ}R41cBxehP:!7hYua9w; _)̴A^=k G9y,O!0n, ?_cgp} aOq'۱ $\AyRt 66Ʌ%tO]kt XF#woƃuIOgC'q`Ļ1KGHl w>)wmNWbvX-mR.HN r)OtḓuɌv*O`*N[s2h˹ab]Gz{m(d:]kdGC&% nk!O5yE?TyfshHLG?_Z F %T0uRCEHc!a[_isƉ;4\w t :y'CG'-O}؝xCo$!.9kk \4p @_pæ!w B7/(*81fhbq ;%:6*ޕ }bG }iHv~T?O0RA 6s9:8H(ӥU'YJz72j<ѺڋR@wȆ>a`+kζ!V5gɣre | n<@=52{~%2-=$FAD^WբUVs8c'k֒AY*Ip0m@&l0,edgm7. ~z0? ;֋rS ON2؀1nSBGh>xk&ri}?+P}2|~ 5*mG` z0:Ejz9(:}04>RymipB3F| yڧC@]req4xT~88H tu䕔Pq cgU)߮xD [9VLj[pB 6Sm 7YNQW5} +.?t'*<60 cS̨i?K  &P?b 1ޔxiH< غ<ćh-cYǣ>+^k{1~?l8629O4bR\UP|{A`gAR&rmiU#{=EDG:ZH?b]z"ǹB;UTZWaEDNLwASSFɫ$TGCZ4n47Q+?DZ7f@R7u~-O_C]LF?O=p)c]s͍Z_L9[:$jӗ/N_KO?C[iQcPiX351Zͬ5wBe'ueJGzDn dd/ǎ om0k{[T̪)XӳqGvHX؋/R9_'֕wU>vb0 ګr% cXbh&Hs'=<,Ѹix2l_:"fJDNU.5^#NtDluUe}Zq0XS~DFy""ZizC߿6˒ZJ[Qx5eH ;1 `!/m3 Pƣ3G"4߽.!3Pviaa HźQ\(I \OMbzrɀ瞈ַ1AT [d{v1(gTVڰT2Uڮi'9:ZD hAKUA{NܲP9njO".)-V&X}ޛ9"h~(.BC~DiMw}D$7 Jl'-_ .1 ;oؾ V$V~# ׊A_g먰I}9O{,*9JITR ԝuh\\b0 9e R { ~V ">lÞ$)@^IlqsTh&(]a|a8ğW'ͩlpZT2(MZ[6g Ơ*Zff!|ZtbΡ^ʐ^.:2[+gONu(ny5}l@N>&BMBx?Z勥BXzMF@?7XD#ak[{xETCwJq{a4#VZN|nNi`l[F[Etk>`1e!UBAFN. o,ye5KEhQq95!Pܒ>:&Qwh&Y)~eF!vv25&}~f@`P'%[on=%aLH@U-覭_~Q. -LFZBA驣Y /`6@v\$4e%qS;UE>,TF>2hI12@ڄ/i^Y&Y6{4 Gà묂cxjy-u*5:ԭin)<hYu.7M{345^"HOɸb l!:ZdhGϼ*B)ѥ$Q}-7?Z$ApGuӳ/Ʀj)ʹmkXa@Z* Y̿rf6UFmZW RNo$ك<8hk1,H^7}T3Dq/~U.irNʨ%UY[h &>]*h^@hÅfQSȚ}7Dn1|qaUǷxUPX~}=Z9~wW?s.H0)-m*zSd'ʻU!dv;-VZU׍2M{t'?<+r Kg0 zF+XC:bk iA,/pSyWHa;쏪Ik'Ko`~Ylo0ԃ\v鎁\8Vﹳ! ч%>tC#,#S]]S(&*5r HP ܨ>oZpA=${@*vN_F_j|F#7?_""}qWUl0þFѲ@AY1EzVBx4z$K$6 U$2@й/H|a՘5izkܙN҃Η(91]@z 5ƲwiS; <ƒf,Ng;x3۾魙?c=[dlOs;6 ѐ3S>gv4tK*9f,y<sD ("kA#r=և1"i`eNPXbjMw _&4f椷huTfl>'韌=_(ݠ({[d!1 DU1(J,ETkQ*< l؍.h:z;ehW zyU}"&`H{*΋ֳV$Mu'L3g( ҉E[‡g5֐|LO=~*#ѵiH')dbIpvgyr7'>fMwukfl~tVF闷ެ`dIoF2_^AW7T;_miwtԓ7r E˿n X|O[n ^^%Q7E! Nߐ1x8!lJ+,J&GT"Kce5\ F~d2h씬Y5QRDatg[2[mCOi>ih6gxȞ}-k^McCOgv{?7N6~/TSiT yN#} Qwe@gR zx|QCvBLyRʿQzJibd-kjx8c 渴K*C d)qtFV~ S;RM~8ʍLC9Ҕ^aW;*Cxjwkf<$Eـ";5cQMI$PDla+ܵHhN0njT.q/hǦzĀlV[B 2T.[8jʁyY٥y=kwTZ$3-gg؟Q(,2!`xZRh}ũHRmwn^YoX0=XkHr$Uuf<TdjFh#y,ONh6A"_G0:5xw7|D"g[ԖH'̦_6V qN!.BG@5 bǵ.\?ןllhkɉ̷<|V]dJ ɴ%@*P|ص ~{S5<d?Cm_H5vdԅ P:loTpd .1_ȭX^0(\>@%\߉5\ hbuB]@>ИB\C[Z[d\ I!_Ý'P [rJiqC0B(G+NSDT Nv1~}iǑ}&>iFvWIl$H9O\3-rk=lK!% !t %7wBB&aPR RTp0 hJqX \/r8GD/=YSenm=eZWd/ vihA7N7t 54 aqR撦Z.l ^,8'pG ]濶E X?nYzφNMa6B ߙak*OTZ߆:ufT3QFO<ÈސH1D۫/c7}HuRGby{7A4fS?J:p<觶^oxjm$$1 -qHÜ'E34>]HH+ǮTXۈ":v)2mKf5 yvfѽOϿ^r+0lb= Bךt}w99 Sz2lE:u˗Oy ophv"1 2J€cĨJm`iڻlgr,wH aqkC2>.wާ7͌3&o'J^{mݥC?VYnmj0:)nSyHI/YNu/#< %z6CU< bEd_ Sx*q]_d!kv4I[i65yHsy JupDc/!tqpsh!^„ .KBskc_‰;Fw=ACjۂbo6^9W YKCa =rΦI6kpo 5hzV1S`hՌǠ(< ;㘃o*XꢌY*#1wD`5:9qs АweO/DJK./;uCO1<=K $` АΟK6\=7.8I‚ C,}PWʦk MQSұX,zP]s/NxON\"ۇ;DYi1*tǒZ[1a~h&xVOEWt1ΐrb9MJ1?/2@sYꔏJ7&m(WT*'8P[(kXguzv;,B$X**{JW(]>Ÿ6bّ7H 4}bmVl^hX$QCڡiZ_AHWJE_`.}A9Po[4yΣ8j,C5RgA*QJãW9/go'1%UuRZˇgB^eY3uGn /j<DafpQ‹vu|Jhs@&e&} FАjBkԲq,ж T hTX❍xh39)1t ={-Zf\|ʘVĶ.{U&t(eFV B suTOAx.>RaP"ru$s ,nȽt!9ϟĝ& مûبG}ŤNyf h>Bդ@܃LC&'uE) |}~kS6p[GdYC].RQ} ̳UJ9Cm*SVv,DO G2#v% d\.MQKELa<3\ #hz|3mHUx;XbA?k&g)6,čҰ8{*q-lHy+37'q9ZU~s mWvFBs:jhr(z 'Q`G8Z"NmQK%xϱN{tU2.b=Yz98JD$Nrnj 4=1v.p2 71i՟SUcn jg>I95tQ+f e] m1HR9`J5?\,gJ$ -6I4r&"^"s`eڝ23AHk>ۮEKxiE{p 50ɻsMy*EWd} h<0tN 59 2 itXqڊ߯ߎ|@ݖ:bimc/;s2P3½y_9,jiGW:L \V=d'; X%ąrq`06ްK"i- Dau]ih\ݓ3")8RAseiuT˙KF%QUE/-𾛄OTl)cy)aMYc&܋_Pp }j7+f.H/[%z#.nePsI@2jA'wOj|z-r )BEya{۳+ϐe;CvI 37([LEs&ȵ 2xQpzl~D5'ޛ~ 2pyi OnnۜW6j5WԈwKGPs4^҄lC{>#fZDt !cQZlD@7T{}'cjW@FeNLQ/ X``<[Uů%qM"+DgRQÔ9oޠij[NKk0*ͅD=x/億u9><(Ö=RsX(lﺎ_o􏅕6aPij]pW>4C] ".T5mJXr˞8WHOP$C"0 (!3CR D 9qe{$e Ig*&N_@~ g\M vfĆ.{Ba -VyY)[kf\[ox(^[H.$E;~HP=Ę'o rhQ1$;z):{1l#ˇY6ýhJw&F{0mHi=TW Ch{{/Ej}rt n@|O<H.j&Ip\+X٬Ms=D[ R齩_~O F=L ΈaT<"9;+B4O3O\96)1.Z wF7j,\gp{([V&QY˛3vh6>ۼھM_i,/8=:6(,_8dObChpd($0S}Lj&xW8<࣠R٨墡Z`0rS%8d_. G;DK ;F{4 krO>}ZB_Q[* PnxɵঽP j޳K2甪մ/҉Mf[Q:#q( DzPp=f2h0A+lqkj&.=FɈ.k*C].;; ը,YBrS JG-z!Ć"*Х'u}=.[>/RqH+ 5w~:5J/g83仐< #xcݬ9 :་卾 RJ,& ~ˤ/:bFBxῘ(uqwtRޜnk-~쒖ψ]3R;}9=aL 5yox@N=*e(֛A^OɖIetNV/eqٯ u<&,Dn߇.Eȼn@r;*͘WAҥ2s1$jZ4CK eįQObԫlTj+EG`va_![XD!;AE't~ÇPNzp(lNqx?gi\Rpň5p'59ymɦ~%'QT\#rj<5&3g*0{;ΠEZAX,HQ,m=zeZM3Yf_ kMۛTTH%&ȗ ?=:^Sj-g!~X^+! 8;?i[Na @B4S R Yn4=#NPסwi)?z A,1+'pf:G:]pv6>$6ǸWى>FwlLdu)'"@=C@NXO o%-K:u^WcpY/eQ zI\.wf%>Sx}U1Q˘^rp+AnkjoF*=v.%h'Fpl|; N'ţ*+ $6/?gX@"q׳"bKhz!c6GFEvpnظ pY;)7㶴No삆mGP?x'<'I">"R-:B$AfXeNq 5RO4Llet#%:=l_.<=SQj,1F(˅ٱ BV*dKqWhIe{H8T~ lpRtVqahaYoaP . b–\s;vs֑毆[6]{QpT2f1p^u$ϧs''t?&A\M4<%{]*zsXN QHC)z>/z-fc97DV];6Лh@#YBi6]2y)C;+н`%: _EM(Izuc42pTckDJei(鼇p4sEFaBhۀ_Ԡito`W?A7:J80/*-t΀9٨|\X0tXjRu,T4:pS4i."΁{10έJ H>57;,􀨈nlSk9kN!attzrU)) L'Ƣ5LhbqA&V2ЇuCVŧJt+a<;pD\_\]Ȋ­#H!Y\e~EFU:yu:om8Vrg O{A[OՄ#@(,\Q' 6__05S(AJIj!u8Aʐ%Ϙ֦nhwL@|}ǶTHC; 5ѶPoq2JJ$:z*΂758ZҳlCQJRxFo=U'] +&RNX@> l渨^D">}vHM9/[ɣ;O[T:;*4-G:QUd`tȔ5G6I)&o҂%nGZ?"dl 40qSDŽ:+wc.[9DU^ߺa ck᷇}=Wߌ Y GcNu%J~@f=$ḯM".ob8f02QC#nb#'p` ӝ Ҹ-ĹYHM d249tMߊY;!%},?`Ԭffobn.*s[D8br3M&udƀd{24W܂&鲡t^Yh(QSAv3ӧWcA37B\,:|CAJjk̽YWS%_  :i\xc!-I @4 4Ovoc%3r\ <2!ݯB]EDOTW Yf\-Վ) ]<A-Zj^,b8 Tz::C*'z ߒ_&EJe oN: cqp%~I}qmfpmgy0(Q|m9ύ!pq[ţB{}Fw8Z2aԱ"pV(jw5ym7'αŰu8QizĢ׵ٷ{)SDE[64cG*<ϋOޤONՂjs !vK<~U>d:8"Yjd:9&K֭jwlVn/=cTxc&^M#x (~%Ѯ _X P2ؚyG51["7rtxa[Yq![ԗ7@m˘)V67<Wը!a JD]Z*UM=\tN Y3=~^Y{ JCrq$a xb2`(96H⭼O~("-fDUpn( Yًʥʃ! zWN i$2K!؀LLvA`|QvbgvfjTs_39159v4+똵kP+p/RR|2,h脊ݨ8dR<=eٻ7K9]n/4}̓|^fI˝ɁmM,1 7> ,_3q4-*c,~wuHh+!6b!6$BXoظ㾣jӒêh t`ZP < #C_'2nA@GwYҴ?CGq'xB;b\ o5R\ؙW.z[;=yP)lÓTH.q{Fi,M=]!Cx,! _,W{w ]HaPaAmUd2-SMkǖ|5۸Xzq2`O]fE 0f<㢠/dKAnFI\EU>{eI;DCa5)[6x{s`qy=27;GZú #y4_~(&|}s}Jؒ% $()Zn{DmrDfr m iuab}NMcp@:(`5ۈD - cJ,#q/x/p'۸Kpip"6HNM K[i*AL0N1zg&O6:߂?o6˰.cjȽ>e9Ud]H2@aUHJ'gz.gG'ǜjci3~,YP(r,[ѱR.|LݴN]&3y1`# HkVu7{89O(Nqwc:?7Cx_#3d 8L8x Xf쌪''Nmsۚ|[lɖDi8rR(O t[\r +1M1†mvO'R0WDJorT/9?rumVa i#CzRiO7BH~卋K,OIM-k`EĴrW 9T|wЂӴM@LQ$݀BXi.~*+O0TW:ZBl:^ 2y=HoV/c7LBV8_HJ)~̏&x--I(@/2X$a`(Ĉ߰XGr Ԟ$hu(*`1(aŰ֖iGM3~ W{w8-lѻITVT,"POʩ`iXJl*mVbIcȠ}#a=G/d>"<Ex͛~mQެ({ѓ&l<" 8c TZ+j[HWYeOrA#{pFw̉D9xk\l zyz*NsD0Y3}=,ʶ~sxd ݓ| )mxr)4ק]= X"+DXcH40rL/Ld PՍGm"V5D>:tl|̃ 3B9.>e/jMɂBqWh|nl1?+O}G&Trs25[CŜ3C*cU(ÌLuXWm-rOxڌ磻Ѿ[W aKĺӹyuIb|f_ Ħ\z74'4l۵MW-W;*{E:,4BffQqS w6PUr 5'I\~u< dA훍^^cxa1/N6Auo5-Ӕ®XLQ+߬_z-S趨ȫk.?8twK~w¤hhMpUI~CSqtap%RWIB,ocX1ri}ǻw37P20b]"|@e_be/_V6GDz-`ƠxQ΁;=ltﲤ*+㔴X@)vymFx\To=Xύ&bq3E䲱A/5<=iG0\fÅ*1fa'=9K*ٯ]n+8$~.xl LDIDMuO)sY3*h#0qb[LHO2f>b?9)J'#~;7@@T2h@'_@.n*>SI/7ަLm "WU@}Hrc,$_Ԑ;ߔ&%jJWarU'>&'GtL_Km@n˂gxk3lրEgLV3V{&s|~ sB <6&R(vkY.S߇ɌfSyɆmz:3 ȕ>ŒjCHʝIHbU|H~d<UCE<g6V~NM,VPGNjnWdcմJ 3_Pe+ vp}=_e5o{AI7 k i)nep:9"ډ˧{q'k7yBL>}"A#cdE:. !4lp7ts^oTe6$G..Hj3ҫe aLr$LR9^ 7!ANJxK ,K^ S=򲘬ekksY+31&mkxu!#$F>!t]xz#7B)eQ\LOQb/?UhBH^[(BՅUk繬|.ykJh'R~zu<׷I8^yb{ifc颹7L}͙&Bչ-g_qJk֧>EuEז#Zꂑʂwk ɎNuEbl[A vU6{>9JgqO#p1Zaϯz<~?sBӘiI{=n[ʗpLo}^qːB[2^JTQŇ{ُv6txdN5Cu.B9*\޸ }vczFRܚEʲq$y"JV%8J!'Zy?77G -.ھ-թbaȊHI8p{ׯH{i35b&̻{RJm7%ȇAO4 z(Q68 z4 cu^\%},?},< lv,"*[6Ko[ɸ{ '\qqDk %?;Df4-!z E. >[WHuG  S˱7$ 0cbX* J1|Xi׆l i}OԿdm-T ,l5>^=a}ߎbAl5L(o1p"}:O,8*E98S39nmOLLϐ~oEI:uwZ:љ6!*c}LZ  9hfI/|KoXނl"zP M 0< w1f+ذN,~<1SW}Qqt>-(Yby-OٰTX1B7Ӄd7Y^f/8ILJ_VJviol/7gr?+~Džkr41!=FtHee:G#报VĴv=VT{Z p I)iYZ+ZN:aKWR-̈́ %ÕH yޑջ#!*Zn_t1c ~}(N8mGa IWz3ˆ;X& ߞRZމ^N xk2Fg0-]" D:m EUm|_E2=_^2$^O`ޫ%B3bgL.× LSYORw>"5M#׸8r4i. #0opW.jM}>˞Uź(~ ;ٙ52 EQ֙$ h57R:0ִX,AŘQ#–IZY㇕R3T}-p`XBf5urfI`C,y3Nw;1v Q*;_:VQn#%rykƨ.3j5̪EC`c [Đ0ZH&qKvs`ކiavnV0OVʁxI$J9ߏd31Q *1hAG u f(Bc<V%:ݤ5n p#%];.D*X(+򯎛G)']Hs4lܩBm{tH9Η Vx(CgE @D4 %ϕ-1"dToZ&GJww!MXaOB&W1[|ojxIX.h bBxB?T}iaGP.i}?p)v{`Sn2N\#0ƮOc 56o3cpVAץ>0"5Tc(#]#)fh95m`'gNB.*]3*O|Z8^$Y_,oܨ?Pm_[Pvpo =AWXoKYoSm(Pd4>=+ѐϙH?2<=سA|6͞瞷D3(9G8. ֞>ăoφjfҍkzo;V4l҅|)tBkdKA(&>GkQ]ixS6]5(ykD >D3BCN16hPQnYGnDFEZ-_ il!Z#\8&=<%%v=uHЗ~Sr*@L.^O YV2NXsu^Smeu(92F<7*{1an;}nc7W)k.h^h`EK,%_[*>!@G̴BFe=HM+zaHDž1Fzm&!:^hleYat4OF=ɛleX7!-bGe6̈.9xMoo f꼨6JGR; 8~X1N«8 Nׇv2a<^9@FRn|2,|j lw[:ԕxśW^mJ`'wڵ-/σd9H#^пaiM_ Ͼ}hUKg|I WN Za_O L9xIe]l!aЖ}$3LdU q"ڠ&HF޽%'.|pX<2vB TXڹ.mVv~?:;e 6L %8)H؀B bM^YE(e,'+97dꅧ-s]lB&tZs h!|e.jXBĿ#)B`Hvݾr$DYɰhudOR#vQz(ڠ(Y~M~tQm[E?k`w6,<X:iAǽOTwPZ?TGa=@nh T1U`n EGa\v1kdpq:1Qq?`hEH.?T <~L*'.[V zSvtHf:7՛),ZܡɆZoEs^MB٭eWmX "(y gKBpӱ[N?>[vG9i(y-T-9M ̉!H`-Ťe~Ą@KPʊجuֻ$i&CuABIgP'%3Sjw,!v"on5L tD签1MB YZAiFzL%&5ZQogO0c`IY0gջ8_;Qa+ъT( Fe*qU.'NQ~6L(ڿdV=&@ԞAϖbV_tj5D[GҹP4JL.T lmt ?sODt#O `$\\ 3BOGҷXw8̯ ^r@|oƾI0_('gtf>jTa%FBmk\w>Q,M ͓l 3gQ2 vr?CeZ̮xg\R(?SG~x2}.D£VKҁC^Y>sg[Wpp94b*8*?i9!Cw_Lզ\[,> F= T(:FQɹ[d[|oCkts9>-/$Qr.UFۉXqst|VIIm9.eZ?5qeRWb(*dje`/82H+ɱm*hE;4._t&ϲ̾nEZbT8Z%}qRLƐ%GGHN,7,\Mߺ,M4y)虗m7&嫧ϱ;G$Iyx#iRoͤ7E0BL([{ԴaD$}@\E #bp7 SҒ<%HRgkyy"BSÕvΧgrxF Ө^) NT^kQ*v滆{L51kjAJqDBfpݟ30T_Hnǀ.q}ZaZ14ǟ2|H{W}tϺϼW&ejpeKheڳU0B$)'[.b#C'FBJW/T Sw-fh( w-s0`,jr<׮2X#sēU7~7R{ VZJ6yXv:$}x\9P,$ ~3kx"ծ+v晚$h'dT9c?6y}zBYZHSԼ\\CPϕ؄S }piCabd )6l+0r-3d0uiZK>(p5FPU sy<C t H'^:$ l23gkBϤw4mKP2-QVчht"rƚkrpsvyC,1čQ81(ݲ\tR'qlb}2Qwp[GЭKsV9\ 6Eg+q?oui_-Nkqn'dwlJJyoKmD:U|Wj:Kiɻ\e2)i@&gǛ*2&dl0/ ;nuQkF78jK\{vv% I(Sƅr\VSwGYЂ!={rOPZjq.J\ &"gĨu7ݻ.6;3HnV s']kPBUrH~^/r߹ІM*BS,2Wף!{1nBa)mEEf :mï3..x]iO<)/Pzr5?053z}l>P4xE# VPy saKQ45!6<h2'=" 1'(R&1S8"paX9\8Ѳ3e&oz{M&i}Az}*t<3i 2/m~6!-_χ5E+rE C@@$ͤEK{ rQ7yQ :bo]ʡw~5JQ #G:X[h;z)fĐz3)KbX̢K9C~bfpFE 屹)_;HL&|2mhվpPJ4]tBO^Y&6V@&*l3ۊuSte=.+Zg+y+e,FQvzEf=^P(J+o0QCTLG̍!` &F۵ TCԩ.)d:ZWgQ8K[?6/݀FTidVkulG%ێh"%ȭ9kSbr[4HJ.l$$96o/ /V7vv<,d4ȝ 4DtkIbjeƽ̮ ?I[I-vY9+d. ?$-k Ah-0FI8c MS=G~O3vBgWֵ,Z~'I*Hԟ\W%~Z: 3f]PkKy&:|(Pvc>p@wnQwpZaHQ#ƥwvlNpbVo'x47p;-'}?o\| rlHse`g`B/.gׂ,ac"AH1foLbfM 95/86ADбR_y3'/:Nr G3F&xCuňlT"]op|`AwӚ:^딲_?kh`!qV/>z,=̫l庬Uo p^ٸuv=#uN6|W:X@5 Eic*{s$t)1q)&PXbEyy>R7Rd(JHi(ۿ<:H}z1f.F6 'HO`ZU".˘y? v[t`$9i4K}lXzPDbg2clkAy07Fԭj Uoz>рr{z/^ Og,M!EP?S7L2EɤzC1Kɛ1p CҒiFұ '-vL\eu~\aebE5BjQv#lfX%ƃ\u1>{ rZҴ3ɛ;cx@N2`/+9mً /+DGHZ5tI_gKLO(:,yjN݆<J }]0MY _\UBk#es<+* Di5@[jHHj|>:nN[{Q&g {Z  &-+)EWerݵQVW3; ̬nYD9a'{lIJJ -) `;'x}6ԣbµ$*x4jMs=#5uz7;#7@}7vD#"B6]^8*AUR8<37ѥ.w~NQEס,\l*ULb{G/|l^ lͩXPoSH= VqCڌ7~P$^0V==y~}jwF9 l Jt w`3FK-鿎J#nb(G#L,U#A3na`V %3\NLֈYI1{R]XrmnYU謁jEh' vwnӃK 0g@sZw`.^s2V CjpŽ,oQ.u%tMˈ\1ߍqs̢W8/\˥M!mD'#ݬ`D ϟcj8:a4aBbCgeV} w/ t0*#1;)U}_/27ڜu=,E]ʽ*e;/[IZК/˓o4E0Գ-c|1ȀTF|,S`n@ uO 9>dPACĆҞvZץG>u< & qI8[]E|pi c"l{ |2sCB8dSq&/w $NjՐd{h) )=7z_xBhc#YG^-ƛS[ %5i4S%"F Rdv}ϴUWH+?jŌKrM5a7= N\V?E&MԮ(~M?M8_@i|=mj5*zR0^Ñ+1AlSi2nT٨6JZj9PmRcQR[0~>6[t?eHϹ:ҢFtjKA :朸jFJt8On[؍>f0>5v]vP kW*PA٩%5:챎+P O=z b "KW&m y 7lHTy#4 N]a$f ͺ16 0if!@vhX3BFfjL|3NfukHB=ZQ+aKS?n!cBPn]C1!m\௛ͣ{ a( gJ])sc7Mz).mͰ>54. z]R)pb<6Uc8 #41czQHl{CS1~pʜ/ЅS*$ϰ.Tt\1.[ajhw"}F+dMRʨ:; P>y"XJ/ռ9Sp gϡH֩餥5m!RQ:yDZvaq6d3L<es(Ҁ(8dNׅfϥqjޕ!C͢@xÛ.%9iRRxiŒ <=Vc1.Vvbat)k_3:bIVD.-yXlE`zIP3 w@xbXUX}xrxV\Íԩ܂R]/[Y$(/q%gx{8?-#DTǞ-B'@y?~A\~%B%BI)l٢` jKUeĵLpwJFFD@lp""x@/I,f[n(mm ݷ줲h{c_- TH'B,_sC*^;MJڇnWq  OUdA1?w^ɍ7G\3]y(W-ͳlbL#q]Sh=k[&i"7O&@_YGZfH\xڒ(v &;4 [YZuR+%{WSzģ3ZɳPޭ) JȗxS0)/i+4>h Sg_r N!h֛pd?Ls`SՒۛNVϣ\c?~a[ bfKtb-W(=h_nGc`@2ROD73쭣3Ȭu%VvcԼC;Aiyn D0y( (c,Z@iV^6OqyUR0%/+uZpu: "23 fr Y.7Z My"4=(v3'aD%!YȌ@7aJ0K\*GKn )(A*{L.)z-8)Ϡ'2%!k܏.P5SN;팙ڼ7=xWu_,J െ瞎LaLgd PHҴodH7)->[uë[vzn` U,ٙ&/Øs7!Xkܵ6Bȇʎ 3?49c4y(}-v­R5೷L"@èb~U}~eEi&&NNT%ı[~YcCSФ͹Y3obB/䷨`e8@YI6VF/>L.UfAIm?HT\k]?yZDXr9\? @X> 0Gmq߿nu,?M&wۿz׼ѶKZ`½-05VBp'A*-ěOȱ8[d˳T _*66ٮ7 }Whׁͺb 4M審Dg> K]ZW>q֏GDM T!Q ԩC8BVk)rDIv項Ԉ_ ?u/95 )[G!|@Y]XPMiܦX_1ʩJbok'0VUnB-,%M7/K:!w 8ZwjK3%t\~/oE_clPV: *\%;XV|g̤k6flʴS럶-^m܆Hn6"JLͦ1^"@Ҕw ~PTA:AF'Rh>ŰM2p򗧮9B`h\JUN s+nQrcºȎ R uDb`͛Su ]]k9VLܵөd BNK;ULx)9k2?cҺo$D^h-0 у,f_~֟Ʊ>kuO0*#?HTT6B`H.YHG7%58,:҅܊+r?7q_dS`*?&[~SEsn$ن._}K&3rLoK s(q_+6# #'ŶsF%%5 s/kWG[YsUʖ_&z#ӌ a =8:θ{Wzr(Y.No'zm?1TC(;$u߼r P<^=Oֲ[ pS V2D*|s:2yg*l1j;ƍSx? RK3=NBj/YDz4-~qc¶\x;y 篻7Wukg! `U0s[)k<jX; F(ݩ)&̝)0K;wy8z: (O^Q;1nƻ!IrxZ|%ޙ c~7}:nūѨ%mt {aLGV&[n:kRbΆz`QUhδ̎jj*OƘ4*uaT`R}}Ќ?KtH/Xf@}^#4w8~d&՛xڍ禙pב/cul˦4=Ocբ\. 8 o7JpJ /+)OY3`C`6l//)M؞#9i{}L^)J)X #Z! Q1݌8 ?|豫^S3UAN{dtΆD GÃ-|CQE?w*m7MMܗ{5Чw6h$NҜb]Y>5[cxeA( 'Dw7t~ow9u%rÜoLyZF'(!1#h B#8.W4GCɊ -i8-o 6ˢ2Γd%Ʊ`a08TR,M"l୍-N{Kt<5^W3bVL0sӁx!"XIGfXDpCCG2W/b`exH,]fC  6O%ujh68%7Y%Zͺco#5MS 4DBw@g3鄡m"L`c mIk+{ٰ$1ʫ`8 0Xg9WM˕H1P[yJSN iof?r6"YtWU<??i;[!x#p{'ՖT(񏹻.bTr ܔcm`tٝ!{.+7Jsp6|N2*f'mY!X e3F³#|[@Kz%1WVFV+L=LAϤ\I (o Yۨy +}ÿ\*XahB,&(rQ|g~pr R[ٖ܅:'(C{-59یɠ%wnq?N0;jEldYղ ߇7 5aw(g{Umދ P䱰M }՞]J$ɢ):l Off^U?cYL/4E|м"Xl`WQ!I7TכA.89 #;:0HFWM_&'|a: CT7.$΀] 1ZlH dI;մI>yO^) )UtA mԑ^& )Kubڽ2 vZMzkִsU*-tɶc+Nm_ JHMpΩgBt؅&影ʶ5i!AٟRᐖ:xю6 VHL}(]Hَ8e ڲZIi2Ҿ~Ic}ϳm:Oi*77 II-N55(uk5OhJ2+1ܹŖ%\.΅8>t6=q+z%}-m+*b jqyg.mWO (TVȚ}|. ? $j!?%x_iSDHѡ/Hjϭ;«cwLAz?=]G;"c'SjP/NѝmOثRN$&$ʐ^y.ف"0[!;4ζeKΒsyqBWJ49%jͣŽڅ4_NmMda Ce/[iZ璪A4S'|څ4톅"Z=-p(MKGzWj0`a)]&Įq7 -`TjcUPZƗz:]i==}~D0[^.RtŴg $;oI^ŕ VJ8PVTIO; 3,?ƨ"تY5ǯgӆAWSu [1={ 9}qˢĔެ)O>yHz)؂~sa>Mu?>Qb bR3Fʔ+ZSm-ÿyԆA\4/ Pm$"Wcu  ]Z2{jKI9 ID.N.#[1@IE)V$[bm1:Er H.$7׏K@t䊽 <{H2óo`f}\l6:O6YC3T1ݛ$. 7& $⹞PPK'A"٠YNLM+vTv3y}V2JgN}1^auX[j^^X1tЭN$8v,[s WAAx"M H5}dGTIOЀYo]F7Tr@MSU ]8|A(9>(]t 7%A]+3.*]:ws![dHLt3q;nZ`pе+2&UAvé CMDի[;ᖥm`(&VN4$ %!|9$%QV^pN3|QD\Ր;7es3ꮠRйճ I9 &VuLt:gh)!jn}bq_B9 QHY[*d@^&OHYy LMmVIߨ6wR7nkKTgQ j5P j NMiU7S58ZKRf2x?ߖKm)[+LÒ^՘L7m؛x= ֐fB2R5p'<ܺ8(%aypZy>ȫң[1\Ak]RvN6}NQ80,r`1C.Irnm?Jfc Zvc\ d[Of@--UCC+;/P]B1Ly(s%)¥v.CvFcCWCMDSnUvG=fCJoPv M~0u_*'Oewތ pfEdgTQrct@MA<]u佖Wx[B/x}|$;'2|$C0ys1Tx?&[ t]k'+oM/)ЀO#БX:P*WpW< eHtș3֗/͌q$&bg jkc5C7cMջ_VXYivT9.FZޒw`5kQMygsw 5 ߉@'V|Jo+n0IK<>҆|3% |MW)(6[fM_ehFS|sY;t \Zo:w?ࣾ.rZ Wv-R@WY[(JahG⠥,qܿp6v5„Zd^~(3TܼЭ 3 #c2jAl)?\+Zda>dQ+WȚnoce(0ߨkù)v漃#"Dpdged5ͽ (0)<3REH5xd+S-l )՝i[+TalΞS=|DHIR?^1ra]q0? mN}>e+o7jPx({t@XaU0G#aX}7,+J0RǵӂDoJAЧ"?^3>6I>#ѵzE"IZ ſ.ЙYщҏ>T  g2*/ؓ`ovTB\-cpEkp3)_up`f\h7de*N=dPJ&JG'/u59 òLZWE =c-,&_+#cݨ9\kj~4OnR9<9K$Yi=8Wv4УA56=p viFO_n p'j 2`ȸy,k-SVF1 Qg%'떘k/M?1ްXWB̗\Ϥ d4܏߷{׼ձuS$["` 4|\:aVr8$BMu?!_&@o;(X/Xv)nC9$ŽNr!ejmҧy܎A24qCXA\nFN+Ho P'7*4[ =N 0G{k$^h/[ /&mx.:.ȁL ,gF-Nloi¹`(' B5;boDҗ3`Z>zW@u ->lqEu<'Lm:OTEZM=K߀G&g|Ef1y{y6]aoqIDم=goSLI);By?6+j[A1_l̶e*Uց¥L_d9:+Gy;((:mtG7It"Ӣ[4ӯo-3XKa, Q+xGX3yUG R)8֣B+> s,)CJBI=Ǥe늾Jz{>prU d!X@K?'Sô 6>B'f63X1z8@ccv=hcc eI5@+2h %B14 H:PkkO9/jx$z"ȡ 6cG ϒ6Y~gdtj*%6\ǩ:'`V٦Ж!b.[dS]H+d$]1*߳a}q^ۯh:Pϭ5T/Bե Pi$eehm9BFJ-#J~g!gV{a;1:  &/NnFLXzhiF' GtH筰H*KΜ.P|o@S_Zz_Gcۭut3'­n8Niբ %C?Zk zڅP Pm w7kOP3wfIc !@eq5E./r틖+`^à8n{1˄kWFɖodg#"YmCl>Μ 2/&$IBRM~A,:b y|BB%vym?(Rs6I}7s. hӣvV{׹MRd9zƃwa0|1jU3r`--#W}GQ˽O QpZ"f/K GC5#ܾƸy٣\Z9Bg$E0j/c._Iʍ3}R+Ö^]#G0k= j\! ?򃒝Xjg NLJғ-'Ho ~M8"]j=pşSx}'aMc 7k`w_xZ%]h(Uܒ2ޑ&"RlBcezQ.}剛~W]ltWVqT>tiJ kY +D5 c{Uɮe“-=I>{^#5#hRt4+%&8RyP2@;>ya\ lȶ`"7\hu0fP:i$C +sdSz)T=prcUMڋSeՌhc#Yl!aLJ=ڵ1xS:Ȧ<{0 ?ݒ.9M}W{O=acE Ǐ,y;@lj>CSj}Xa `0HE&~A-BRg{挆DewǹՍ9v S9d;ٔ+4Y *K"#8e?Sj$' 3y~S&޺@U"ٵzZ-5=t|辬dz 0SKrp1eT- mwՓ_eJ$~ȞLаW3ȋѐ BsC%O]'@@2&hN|t唘$fGf쥠(5dMoS8A˄Q{t|;F;1-b@!ƖC[d?"0k$hG)że,\˂k#UVISFS<% V𠱈ݡ7^A<}97Zc4k߽ Px5~`B<ziC-@3 [5;۪b Q]}뱀 /&[EL\!̘`3*]noii X2 L[Ծ~0 d=& ӭEBkvи e$DzZ֤RHtc煞wcEƄit\Z7n RxS"rƴ 8{-`A =F}"yˎ R\g3XAHUV(/AlBGJ7z.u,1 yQ. tbeo{ 5+Ouw1).45 tJUAfdfP] 0@<,)]Z/Сn  $fN .ku=O>=b=J؆NNRAL$@a~5}ǒa*Zpb׀*OSzSjϵ+H֦k088jS?)@{l~G.<#g¦t7r;d}nO8 ?6sĸ>"|b(yKk3Fb{gy\uWqQlC;duBqȓ] d)ˌ|0|7_Kʭ3]:녖 ^&> v\V"kBJ~?g,"_XJ*Q D8qEc&Wt^Rb3"=tt8WEBA8&Ph "ZC$ b]n_@xGdFUA>7# Ӑz fhTAGs7O6MεE6 9Q"нlD+U}(XI>A=bf4A:D@44157'~h*B }ԋǣPpPT&-\zG-GNADՃ"{+JvBIE~|ʞ_$*ru;xmĿnk>OܮQ?ϪN N^<(5dT"xB;5}l~'גoZ>h0[PCFpݚ7M/& Y'R)$!4* xwyǠzBRWdRZOAAQBOYNkkVK, 6 ١L0-Z:Bw#pI?~#L_fŷ|n'ں͕MPb(GCr:勊F$FvIda.G+VDs3G:t( R5H%DL1R;oAU}g+:;%B5psAg4C %3̪~)Lv-ZwNϞW}.fͱH#zxJ?OJ.ޕjyvlSݫ\̞nsAI}gMc\G0 5>:p?u7~GvBMEg0⫩QHbxHlDjDIjuoW`:9qcq΍Pb51$3=SU؝K0 @1֌P~_]&/{EC^ %pC\ExkpI]M1~@_bu2<A%\3бKޗ[4uū-|-1PUiubLE4?Rm\d'cuM$MnƊ)GYWekƥ kanq҈֊a mN0S'l[O6=Nո]bGċoLwI!OcS~a6~V(WQ8Bu:-@|w N*'1[pg?IooE]ӳxoWa.ME3zcˁ9cb*pUU+3ie3o=+cu/&g+̫Nz~'W@낼`V !c#EXc?Qu\GA`5N'¸1b6lS[[7iv<,Im/&B|e ǒϮh8YK:,&g-~H[pU"EYuy43; )w _{bV;g5o˂q-5vt޽pѨZi%.%1 [d5>-ĭ;NgW.gLhP!ΠVbf}]|j:z1VayĤQMZQ`WHCW!.z it *1.;x*]5ǁ(H[< ]fA6(o_oMnFlT]BMCRw ZZk8j9vW` -DrVI ^>**bw?L=X v'AOmq`S~똆E&0wO 2[&.)9![|2sHK0irqzf("T?YD\k5&d9"?qˮ8FHua(*ߘd[rD?szӗ,n/Jzd𡊤`قpJSjWTKz-+.sxn pL>Nwr|ۀv,$}?,]*mTd &1}^wg&]{;&pVoqhzhtTʬSִL}?F/K>xH{Pj>-I(!Fa]zc15ꋊSZevcaD _$a2 ۀiWYmˍ{_'@;[Q vEޤ"G&ƋմISZZ6\5V.#WT˞GH ' 'vGՏmAŗTVKLDs `_fTn2No47 BN3+7&nQb*;-NEH(Ex `1Q|q݇پpCLPr7p`Xltմ/DxæM7-)I 0f/{\3RĞu'r>mDȎ2.dJ \^⎱| `?J-T j*C b0Vۑp͔#y6Pi-tp m j=uI0Q_][+g!{XӪ'*{r_WX^~Ce/cJ샧Ts](?zO`X9hv=`SEװ$d ? %^jpa8>Pӈ``䆤V| 7(.0ϥ(n (ӈ k ˙+!nͥ8Ŋ8kZ^sCeKԣM hVK; t,V/ x먵ܶm91ֳ<5 7ݝ![OjR/VAr&@~'Yi{VH:s I\\J.5zkmѶ 7%bIė`CI!,;D#8(]G LaYj@iM'dOY1i*oĆ9<(qƃCv'}*r`ɏv T7FE$GWOhb)in 0hMH>GwJ|͘-X(MKAiP3)U}rM*d#BRN>rR:xCw9ovè `_Ygܐh1baoT 8_MŔXpUd<ş @8@R^9jΆT8 :# >C6aJnjѷu:F# yuNWxa.̺] dDkZqJ z$6鍯&Ef01ф (|g1rcG7ؼ@me?SD%vòŸsJoxf@"9s: :74 flrS!94h_.i5 L#c,1A*GGC`|וD1u>Z|"a< xZױ&a9s2W`}}Vh֙eu^ǛݢrW͕(9ĘeojNb\0]w|^Q~`Ya5 b,߆ӎd0Ą}*LkY4W50B!!_}+U\ @ Cڀ}f&S*k؅< TZtfc+F|A(Z^Fbri! M;W*<8gNcf]_BFBkZHPWZ-+ZkՈl˪_9Zw|jCQO t&xHuj$,EK"AE[BNJ,}pbk率!=#qCmuG% r˻@ +m+aJ36PQ΁ *0/iT03WR/udd#5P Υ̐up£:K.з'kYTĞ[;&? 0m2֏}11BGbuR}KCB!ʝJ%}v}%bVTd`t\⯩}<]rBxio%e׉, ͒_B\»@ -ڒQNr#״;uCKAGs f:`bEv!;<ŦauD(졹:idP japeXqJ`ϲ6}jl${-]%;"/xp;9Ћt>Џ~n{arc"QHW tmg]ɃX xskqI9[$1]GwP~i<`C x^}q`̅ znEWN9zveYш쏿*L&{;>L7?m⨶Q1HRFWpRkeR+9f Pj˨'hI u])jǞw_HHrhSo9RyѕBjЯ|:4 DM?j)5FGn&Uq@r;}d_f'8)G_X,v?$I!3sv E%g8"O*>-g%X<fA;7aERnG]L1|w3Nd}q \pes(UkDŽlty̓c0O?>5ؚ4I%6K$ 5&60DmPK%Z4qgxO=K'y/:bA6:t~j -KvyߩĦ7#B"6's W]{{G۲+ny#Zjx2Et7T~<9s~V;yjh/);xUb;AD/mF&ήQK`iЗ~as_ \.9C%? {$Ѫ8cxf%wg`|UP.E6j$k")*}pztͷI=y9"mYmrjB|Qm O6d=kAl,:jdfi"@ȯkX'Ru&9. v%4_nF3sFKD(YV}m;ҿ1K! C |%-tZc/w*< QMvs('$4:a}TJ a.{&$ XBi賓ORL ~8-}nP{8Ce،Z`O{&TP^z{0o#n*J'X!aMiS7<D ͎ܢ#AB4+ĠyB(b`*9I7%j7*xꄷazMG/c,eSβqH)D&(] H;h+Nv$WUʵհzST~vE k~S[ a(- Dȗ*J4Ͼn̛Mo L,nscKӹemospewrxH?pݸi估Hx2PNb5CL"g P7 vMV}ơjI$< vܝ,}P/::p-YMж|:e.T#L{/$-"!p[Pn~!>ƣ]B<lipj, V1AN±PJAR`5{772-ělDQ-@FŸw:ޅ9l1(׊#j`)e ٟd~ %CMe(OX&H <@ňIQSk ˱)-Y6"@o](Zwњ$p~}ѐ򿼨)"H mWMߦT.t 5/mR#D܃3,RhmwG=g c-/V5uy5t7bi Zū($|QA#w*9P&uZsz{TC,F`J5}v/ˣYc rv I(uY6]1zJ2Նa+VĶ\@L$oB{DvYfi?Dh>;>sO`ܗhg4K.cBi0LVW_e1 zE#-vK,_= i<Z }?|]9흡jl! MNݱ'ÐD*v2ҥkzCOـODwѡBS3OdEPF90jD}gx>%VU}ȊX;TT$&z}zu6RK(mm\Is{զհ1Co |d0Ih9d q|;lw5hR־>N|는iw%(_MDyE=45I;,tI ҧz`D;~9Lgf;zxF97`ȩPd@/=GwΪ&?+!_y!^(@[66ޞԋYlmz"*r`;SZ}kCCr\ԬύZeRAe0<~h8:1y{vPa\;P[<TR+S F\S/Kp(B w5x3ǭeީ|Uƴvks-N(-G˱_G_Y|]aք39 fplX WV,nwfH f zVol=zP8!UJw8E<.Ț?P?SLnތDZF.z]V:ň'z¨*ݥ8N#@_sAJoxT8?>ȷ b[Wߣ~bʕÌgYwhet .эOISjx9[+Cp2A&ޞUjinRj}vcKm("?K$PXaz{CQEekdan2 ˭#?iK@aМxdgz͑wb>I3Ƞ Zg!+X/V3.ÀNQ5Ⱥ$V/_#C؈lxEuN$Ӷ!ʛjo_)٥m%(E^MD [A=B95wo6e2Z(`ew( q}ԂE kշQE0l)u2q#͉jMd 洉qH=TgRՆcu= tV fht/$6,H G)wYܸWC{ӕ.D:]QpqX4-nEqRh%msC=K-jPA Ξah[N4%s$tJxHq激 ^J0U‐_YLOSQ,u.cFo}OƮ.Y@ӡɳn-G8?imœ{I[XG܌`8*/L\Yd nCҢA”LX[bI  fkW)3WufqB*ַɫmo:W|`I=D{}~iz@M``7td \kӧ#m+ܓtK.k(¯B}+l G͂z !*;e߱m3hb;q?z0мy#)yu3Zo^T$t'2yia* #`i|+67@xBNbrw`5{{C9؊ yе.CtQzBfL}/FK}ĔTg(I O؉,SUA߉FIe (G~YQ=K~+y6 ڢ%KjKg q/UB:,jPvUvc29}*~Y5tOSUuaCj0DEd Pi|d8ag.rGpp̜qA[KJ8ލ"}̳.ه(%sBܴZ(x勩̭C>i$p 4ܱeOŝKSZz,JwB?'+Cz†̆H/l{WXL0:3rBt%17[|WktYԍJaYu;kh__niMjJ3ޗM)N"vZ$ Ic$3zBZk~#4 F>$i=]g8gP/εaKw8YfRdY#fÏd7N#sN˶l}H(ہ}Lr $ j}BZЁCiT%P@ IsrK%m.6#p1<2؄l'[?6O:4=6oroRk7y ]cj.48g^3*T89Fƚ0VF&}@~o\xu86LLR65` aD[pqh?h([qE\'2IJS3SB0nj@& ^9@z*"x/Hsy&SE}>Tiq h5xo7ϵo5nZDvNm aD1cJ!(џײ4C&qO|v=<Р0wn`NIvHδV\b$v ?Q 22o:X #n*{T{Ԛ ~ `tJ)_+7]9$;V^J|=L}㞸#,rAӜ/L6J,Ru/]lI(7z=9>N@2mu<48'הgBuuuċҵ#M^9FLE˗D،_ JŌ9# Imibn[D95?g/C fkecT(8TMyK);;#նާVnlqmf_Kty7_9x*6/1_S}S?vҴb/db͹ZVLN rK=(\|V$NKƖ-"baZ)vh ԉ`~#\\Jʸsu c+RpLuxO"7c#c$ѷ1ϡw ̰˛* wg!f<)!-f8Y Lk}qR&2/ $LF3,$*>caHx:|'NbJ9g[ĝ_zU{}1`IA'(JvVsz'f85Xfw(ㅱuCfwI-$O ccrd[,Xpeuӏ~{|FTL])B&1C!;l蘙cH=et jX t`2 [HgslZq\ )~t/68֓- ¿=Lu7țxf,i41->uV$uubޒ+sqA\{}GB/#2hBGb58B+8 sDGrjf4@B$ d?yš4aꜺʎ%f}qK'RV}Ɏ  5)uu95PPXE.Ǯlr G:RvNXk.MwQMͶ ~{9ʂ8FMEO&~hs8eF!j/1 xMsېL.mNF>BY:~'ؠ,̀Ac>"0QZ~ۣ*lSh惘V(UƉѩ)mc+K>də㓡^]h;qPL&gbxKǃ b;\`ݏꪔQI{ Adi~|A1g_(Hf l\;r}_竸g'zҖŧ.n"go`9:x4wبƓs~ΊKDfF.ғb7}UMF A&bܗO:V3kD2p h7 Ɍl"k^n\y@"2*pQ9"ז̳pKH%n܄sjL5|$u5 W66 b5U)/x/ZOgɵ˹{f bmvK '/GY U:;=r(6$}y"!t^ΒP@S `~Tw |e9ēQxaơ> N%(X.)}= Ҹo̫e:]PR F Ea[؃ޠ׏|ҏG7ۮ07VꇢtZKNR%J=<Ы1b|d0eeX;yTGHA\#n$ؖfVPҝh幷C~%z{O;g};d2SBe꣣SQXXIjNV `" F/c~Xҫc4Ϲ>AmgnTu#{r: (5ЫH*?^J}3Px`}Z)AP`҆^Syaٷfҹ~㺌c]i$Hm3!v+8 /DMhL7X L37iSNlONU\&{@R8= m?>9U.O*M"2߻<@ KH RnX0bj-i]ڑM.uGn1A xɜC7xH7쓩p8bkFA$"[d4/~2|D4e07N B&y]+AySLGgy\O 'fszȾf~3SÆ?Wlz& OJ)4m#$ܴ lŅ Z95D&b3훀poO Jho pVCvq_ƚ4TmPl"~. 3nS_lh_ Ho;Bxoi'Zyﯿ[160yU_@nԞ6~g:aV +{EA>{2Ɩh+5#jt3;-,hɉUf+vBȲO/6ށ^F~y=`:^lN>]ǯ=#ग<PԓZsŜLȷ DAѢדa"NGlnJaiH`wJK[QaRc[FlnnVnnoTTp'㺙aAb|9;H("dӪfӖr7D $Lq/jG C/5"~n27ԇ' 2ŧ819̈Uy"]vˏ<쥳lueSt&{_a {G]'(NTfYMTqvb0 8hlhHy&+vxkW[b!%3Oyr9ę7SgC(!+D\&e9)€ڕ /vDEKr+ ٱ\ \,}q|ǻkSw㗸e;ƍ̣uj0iOqy<Qu^AudE@_|H>\$/ 69D)j K/QN~v k<-MY=4ETnPdJM?B՞u~wydEW"CD;쩴/&.[ PJ<IJM$C ;1,ŚHGN3sݪ &6IV˔0~(5{V' tIjnڞ ϛS8._Dɍ 砼8n_!| 44 x,/Syc5-@$Js;HaAvL.B)^4YLzaBϥkT⨀}/tmak+͍‚R}7 rӟDBbXéV{a`ކKzAc0F%$%tEY<U4q+l -> 6 *̐RECd;B3{V@d:ɏ#XAD5~)=qMtR+V~Vnw\uW{SD{AKȌ;t;K41a|p _/yԙ5_k杻:\> t=4(*pCE&M 䌚2`/V;(T 1xƧ@t Ѝخ8H"s2R__8wJ~*NS-,lxx u 4P y6()QV u<"=}" ٖ(hf(\!WJxؽ4 ɢ]dD9=s}{k,5@ߎZ4C׹ ?aK\Ex*A93"cDpi`ۙ{nILݽ,).`[1G|%5:!ٓĶuŪ j6!rek%gDH2@E 2n rU/9I4FuF\LoQB̬WWC:K.gj%@!i "zU ?8g 1ܼDfΰJU{VLO׎rYw]r&ñ-vǦjl_,H™eϫF>$xa{Dؕo0?F*yik}g]4/ۉS'7*'틃7G~.Q@4yUw:ԯ36i 2 |)Wf^7LiWQ' Trphf>P]gpcEAssӉ{h~|j{lmAqE_)П]*)Om&K g0RJ餅S#vo_VMicP0읦TŽ%GC,EO&Uec!󲤜-K<>6AS/PRs26oq}OC,.*qfd޺RX-ЅщA ?x9ՀFe029mVs Tr\vC9ex(9ϧko" q#e60P ޷|]*6yJ1E)52Yju7v0Lȃ׈?Q%9gIlKT]ڧe)KWY}W{i|2p}or4"딟:䂐K\aö5)Zݛs5T1\&>O־5H 6r,dnAM`,y r[g~\!ŵV=tn/!& gdcd?(^)a9u,RkE4ًsPЗB1VIW0ZYr u0{,pƯbcO1})߭" ӬG ;? Ȏ^N1fN]]N8AUN& Y#꛶wsavJfj7ev:Jذ}9set)s}j7Uܸk2yl)| czy^i@zBl\ޑm2g!#h~ub\:`M2V<= d ;U_,+Bu\W96H}V ejC7Ӿ"୷"B>0S}} A_eLgL-@\l4yo\(1?;JHM7ҙU bgzW<?2^&9PW?$mL8]wD{ɒy}Z10;QȖ^Ъ%ݛ{uq>ɿ )N?~@۴o'e{Ij+UWYdQz: A"z]Szgdu@=mA+r7lhznNr .2)Du+~N)H?ݤL(N1CVxSʢ#i[;+ֽi VѸ"jk 1bԫvc4VMHQ;lI貗2}l{WᖍEԛ"2jvtkT,`q'N.c]"Ҥ#h~N,RU]aS5H3*FL0eRG:Sy6RC[B2]Cz;wbpb_6hr?bo2$U@$jMSʫ|l Ž,?R0aZz}H4ݦM &&Ci93c&PzXz#2H 8G|ո>:q6^cJr*~cbh]+rXA47ki]OY k+cf70]oӘ5 4U Rɀ#1FjɸhhgwA,4<*x_H @wCc{uURaçҤJWKP(e K@$xCsz^ ހnY2%4&]*3MBpo#2XBE9RٳPڞ1\bc'a,^J?R: 5q0ThxdT}73K+ۊ +nNqՑ$A 5AʆN(BOln5ƳuqUx!l m0_`Ǵ#%?BLJlboEJ ,pO|ېTW|$*7npe}oHͫd<7S%'sHO}_E*K&ȪI>bQXropܒp3NfL O^b-H(+C&tgxMlP8X,*/SXÁ6u! @wt֍UKz۩ŹPH&co9q44T޹6QmѱE~ 1N B%Tə#U@")־Aˀ}%4\J~AJN7Q)Orx񆇇|m,8H{MٿBL#@W] &%>Y OF=챚ںQ+չv u+Md&P:ڧRa715לCv3R} [K7U),AA&'S'ўLɉss,*w@M-~Yjg{?mH 89 TZ(ɤϬF@ȯ& AF+"~WMl2; X 2쿌\R +-t`Xi=4+ .TBŏ;xKZ$u][w#ůaaߥӋO8(^񃗙5,&[ v[] Ͽw]`Eu4$\%+(.8I2W }uQO0Qiz҇a&]<Ϟ?2ȻU$gU !W!lVLvfǃ<Bm9n%SbXĠRk9WakR[ǣ]s&J_^fu\A,В! ϧܺ96ЩD(-F}iӎ4yTS-B+Q$VIE e1\b2MRgw܆.[z)OZl\]%;5, a4 zߑ`T;;F/<ú7}K8\QH6; hKjbrM[( 0Da9ý"ÐEy1=ko7#skת(M*V`.eEI{Y&CD '^O%xjvDgeg^CJ5sQVw;'k^iJ}a oN* 3o%뒊4"!) J-)#Zb2@ӜU|X tr֩ d R܀}dI;~R[KmiVCNjHNdY@OB50y]̄I(\_LWb׊=?!A@FBf+2->~se I=uƊ#:VAYF7RjX64Wb%g:LY TޚxL^|TMaORӜg},ͥ*~u]s~ (} Jek +Lh4z6]a.JwR%B6zp Px m;:QOطGG"-SHrG֋O[a hkb" !43u( [;Ƹ2ͷOqP ;A^uV$_kwwϤtC҃}\(iD(A9-SyQ#wF]GMZ9/8Œ$VHjo??7z! zrF-\Q{7`ɐ,斳t,/Bi8Rng6V\~5``$_ZOE4Nq4-o0\ !|%/ ^jUMQ,I)WkgB⍋(8h=ܾcy8$GIB;F 4wa@nwn%A s.́bC s+So$4bBt{H%VQ iEb]CkܗiЁt 3i1bALHq~M(?#FHa3>A~[0}8; Ya1^^J4vԱ7rYKј9q{ë1S]38%%l$ȟ@,3 =~ǍtĞġu63!Õ*;6gۈ}ލN pt2i*P9rf*ˬr4cb"bرMO[xM oŏʁ.w]?=Mq $ ឥbĉ};i"UkA(M\N|.aIbZsXZrWA5HA9-oCgX%ʿJdfMc6!ܼyйȖ4 1j߮oo#ɍP~.Z|]g M>/\||ދŎ8֕ܫl{TN8,BB1liJL}@RTS?>8 B7b58# (BB>MSFC>&*vFvTH}_`9=ꑳ􍳰sJ148p$қ1>TAN?;:<h n(j,N#:2ak8`O%GuiEg/Aq01Eղ>@"`@] m^Hiy 曋fp-(nH! 1[5[ϚMҋuEjM`+B~z]d%5.P(p[hs((fX.qUcFFmQ54I}s'D+MEſ!YZKIQiYgu?0ǎk&%Aykc%$ Q`M9Q@L9&BrcH(gA,TO7j& !b}q/cv0Q]m @BQ#UAqҪLI~ybz@$ԡ.Tw qoP>Nxޝ]^Ӧt`5y9Zgt&3{!;zZlAڽ$y{ @yz~Vb.ԏ VZo=qWhe{L.YډyQ]i~վ_C{|q+K?][%dS#[k-["֥O4vE&\gGϔTwySA/,SQC𣞜mBb.o&?,gZ+P]kn.N!+% 0] jRFV].,;~a[4f[HMalVaԦ$ן B5so.%92.GLR,W{Et-dPD? YqZW 0)=eozIgg㳻cV~vϙ>q*xx &?'DԖl^_zr7Ԇ,CW:WCoUKo: ԜD(d@u^1"-A=Y(tm!Oy'B&PV%'+4aEҰmOvۚP۷@'iK#1Vd0:<_ GD5ꍧ;`IU,qM,O)3d kK1v>kw~o^]f|6L57GL;˴yEGILoG:%=:; gG=яB<X*mYfwHu WЀb+LrnS] dn4j&r4' R2PT%}Q:#Aj g(0ʭoZ)^g)ٍ:bm/vk[J};2I|H( .qO<w7QBZ/9W\p"g@a9OLoF?h4J1GqOuӕ|.XUl7)Ծ(K7'`Ծ"\bUIKlFD@njLm&{ލ/ΙL g]LA~Cs'i 'FzH+{ zF?gP qç"p<]Iy`;#.&1;n~815%RB w0( U'6k}& u0*\P3 o4:X ½TQ%Aw}l+lF,kC8 P.V`}l ,vaY4K#-:{)q<_t^}`p#|-LБAؖRL5:fRA/c狒9]mn̈mB 6sv1~mGE L:ԈYABo^zm9̋bLGi2սTlZH Jb dYpeϹۇ0j yx0wahNHq;6}u϶Z` /2΍M9?̖ۙ1z+⡹fk =AެI#"ΐOuRixc'MsTG Lv13hn :~Ã'8e) 7zP)LvTQv#*;7 IOt.>prbcĀݫRWev>&Ml: |U [/cvŚ]M1K8!Q(fKY)%1 { ƪk;`jHɋ>*WYr"é)JI}'g`a|ȗb=﷑¼TEJ[?*!3mkVsSc%h_RhX>)iW7R_DJ49:vx}ٿ}o/Zߥ$JaSON9 !bmfް4onxүUr6CmB؈#ONi233ũiU]i'$SBG1^t8oXcZ?0l TEճ/GGPLb"FFjn;:tbSChLԨš*;Eq6R?__ ]-ZD` 2ۚ׋GKȕ ౒[q#eȠKɨ` &rY_b>n?lZx6(0xBiXE rÁdR`'&Bzb hK"Λ5d@Z3y?k `R ?J{Ђǡ #n9i b->UcڭMLGa<5q-Y2tgjgZ'b/s! \R4Kf^ 6֬O}sϿŘuюLY] t,KzX".T) w>t`R;A"qj ^J:F?uirȎrf;˷J (fx"v_.$%YSԀZ񋙖I *y +-c.WT?^)CkzMY[nhgyXcGB՞#xbmfEHALryc8BY J=V~B0@sIN b} 'pxzl@6ZsT'Ʃ'/6Ў\6z.W:94yAAaS@\ ߹끻}C @t@Sʦ8Q+ʃ5H b >0H7ˌ#+N-&gaNnx}'˯/n !sEzHc$Ļӓ檅#Rh7Te8"!ox:,OrChg^h1&IVՏXKańg^R'ks1E7$~DܚI9Z泎Fsd>=:$ŭ6#4EhM LI2] -Y[t.MX*ZæR.%ɠp;qyDdM"Tb% 6('Ijg,6& FUx`UlPieCczg(~r# LC,E.}I)Es%pu5*90rk$|R](`lV N 2/QJ( doD"3SG&&}^Q6 |DdθN5n y?>UקР|p)YC5f:*: GTk3V-cr鉦H/ 'd%SqP39~o?bJ4K<QM@ z!6Ž\EɄa?5TEo`ma<i`hx*RӒ6MPS, 8/ED3! &, MsP A>HN`-Qh%ӬyD4&]&v.j96#KXgY_3;~r-.!w#)@@y{GoJ(dI+{)'<5⣘ʡ7DIk$,҅ @vRp2kfo{0CbCZ- Un+"vda3 |?d4&tʽmNk"uH%b3`n{ݯGW'dݫnfw&Іv&g0<,c@`vu|Fm>Q)y>p\8m1 r)ko=*+MY] qZHN%/}l;褪Ґ3zwwCdE]$޲13" )OМEn7GO̭ۗǴvsZjA'80?%E^{젡vԳ4lN6lL‚7 ! =]3e.8؈b'b)wt D+esw53R?pDlR7|#jP\ex)9 cZTivmb%rL=z' & g떈UwN2ۼ|o]+%vreN)(4S8ODǓE?BPW\<7,j]`&2ߜe[2,cI<^ު>Mh]zcPy7;TҁS"LIl|CQ[{bRm" d2sJѐ r2y~vϢ;$kh|ieAyT_kqZNʨX'M *66 ZJ3X6'1Ê7=,m#}oX$ qBU"iǧetZnﶙ'WE|%3yvIE1.5T NcުTNijr=zvOc4E3DG/2+~t͔Y i1Liu],`S26]K'~(Zї8\j7` 'I|)nlcd[#2SO2̸ -N]Pb3nEOpqa¬j`GxP-im⼊L iyQwr|V[JvJ=Q=~e滑'[ Cd%\C[FD!(n1|Wk8`nѲobSZ#ɚH{}3[ P LXW>ִsg!* ck"/LV9`BvT+PA-b5{Wۖn .!^hޚY淀*ĿU2ĈGF+5ͨzREܗ>$"5J}&$߰N!h}n@n3 {BqI=j]zS~$\?F_޲[ )!RN/[UK/c e,#xj:{C;at:*Xrt+ "9{.k!WL9R%*x7$Dʣ)3Fde?g&a:B|0èxď9zN1WpO(hmwUz:k!T_-}Mjȳ \ຑȷqiֲ(p!!%H,'l㑺EkqhNJ/Őyp;ޛEu~"4TА)9mx67 SDv GiP!S JϕbC>1DV/>k(Yuq\`bS' {^IXrgjX}ܽ=C݅*;Gd(\1%~1luͯ.l1Q媞gJ颣5fǦy&:–tνp2VCkE[ڰzo21 fЍw]jg+˭̼T +_[b CKHȝw]&@?x >u߅UWYF*ǁ$58*"&vU'ё%.FɖlJ)p٢*\ tlyDZT0ggymKP JJt(V6]ôOJrfo5Uw9N*ۜrMicL1.6)7)3dZ R sz‡#|U(Vl g>* 49,=w`;ާuN tnsB[tzǎjA/-tsdGkzgB4BBzљg#U-c Y-q: r{ͽU+mB7ZNw5z!p T `$뚖̔iFi*HĒ@vd4 ")<ap U %ey:_?TQ.I:IjX|%_v=cS^yO 5bYVUE`cP:ʕ;m *B`6_?}ڵh5+~BLR^mە[6&: a|mN ++ލ+鹃 n4iHI~[¯Pċ_:v'WvpwTiorw1XVd3pI&PiԑU zrG~b68E5 `KjӸINR,]7982#L6 j~&_?))T_hky'$vJ+'4x{9HUoaߣ}b>~/HVRFÄȄe䭶Pd?H82iRm`'OdƆPQ hiZT1<5ͻNz?ܚ`鲹x1uT -j&s6K +1|7 9N1KNQ]|h il LSj͋3v3 U:K7~ts Mra bgõ:r,^m+>8q F0Qa_,l-z vxQdx7,;孛`v[ &:~0TB8q teScE.>a^=͞,{!~h @˙"c=vmbhcbZ;>Ȣ;Oj_Ϡ0=Liܚ'>WЋx h|hu]fRBAy0~j:;hKZ;,uڃۛ3Pz1'!Sj*G)ĵLF:c9SZ-4CFzɳk+ G]@`'bC.Gb=`:7ݩ*3զZ h;1$IO'e[ђ訅E t`~힙SEg_[ bH,MFլcMnWo,5 j؟W;7$@k0ĄzaX2,Wl5SaU@?:)s(by}gm *S!;QdžY 1ߺN"=&|tV \^\'Y]yjvQ^cq L"kHC[< m?] Aբ&?Ϋ#M { zT8D&L(AlnIr#T*?bc*w(}`P:{f>30QUS3K-^Dmc]GƷrUB;񍡚!D!bݢizmuga.mjlޘF~T%aP n8 vKs# 'ȩl)k@mkO'x2 >^<ɵku^&I+W^~g8gv iEfGH"(_M>Sa"tKc:65{\Wtc]낰)Ӽ蟅nEom#d%O G$h&:QQ}ٔ%)v^״Kز޾ ނ?]5a9BjǨ+S ƌsncP8g%}n(i&q|E^ƨwrt%TEn`^/|'9oxXN2.c#Ϥ_J!L'Vh@@8">-W=<_rЩ`V2 *nnDEo/iʗQ<G`6ܚv [_rW@XEz{K(w=T(r)GuiBG*vbb$N,J`HOT+;cTJ3 m>E(he^|ʘQ~`:4#X&ƫ i'zm8 %J-\8 KF:t*2Ͼ}q0kҚ^x|`7'Z#찃q"m"fre l/3Ͷ@иm4ۧ)pי66:/z::yɥBI4_٩˕VUg yNlބ3 9@^D=WJc\G| D:J1|n٥饰R7nf֯Go~=ί HWrO>\#^M oĚZ%܊2]OyqkqPUKPvd fz*IV֋;Á>W,oyΌs܉R\C%WH9P :N[M,!QokPE_HO/]XW<, 875ew$Py>>p!`-9+DԵDYkY ь]_>c^w .wE:zcgTӣ|.{=]ٺPa2[*>` QG4Ȉzũ(Ѧ#\t[u E"A"e^eW\v.`cEg;U1ՆeO<"}Әצ&Pc %.W!4NS+Ыv =x議x>aE{X †D¦w1+EGߺ3WÚzt#kh/E}U"~m왛R0(FTH]"<@yFna&ۆ' +b訳pN9) XcX)P' `iFcx^[سl Cz$yrTM~AqSxdͰq{ C@Ru[,/퇆\JrpD3]#qe ףfƳfXWV %Hqb~$Rg(Ģ3 PNH6(+'teVW,esNUa@!PUMs#&!T#f0 %Ewz &a}^xFh Bj}R6$+S8iA]{+e.8Ev_YǢ"+ҡB>kvc!OUӍKN(HY3XR <|؝.wG%qyP;!m {."}K9,q}{w@kn_#KGvMn :Ln h;?Ϩ́ 1V?^Ըov ]|" >G(&VQI=p^@1%;Ah$-9*_7u Wu:1 E@_^y 뻼y_FTeFO Nu*$)NMH"ӻ`^%t#%*~iNQG ?"wM\.7rN`[9:[FL\ sTM.9/&oU`(/s5N}Ar@8lz.i(K+#Nh-aBH$SU[([T!Ȧ=&{˅Mފ פesȅ ƥ H~>5XbBs.x 2,wY-:ƚ4GG [W׾; -c7sB3|9Fz`1]cV_Lx[®혔%:7e$i_2?! ɹp^ʩ*Q+d9p :0 _kȧ?^d_7myg ,{ \ 4db@,&[dndiu06=~))Rvk@lXջ}j+p_!MfߡF3roJ+t1h[x@.8PjE>2s\ Ӄ[O1խ;"Q-" k]C'^2aʱ=$E-u۟=r ,<F1Aa~8[(EYf+U}Yqe!$W3Y*?WWSͧiƢf;e^QGt-xN~jxN 54ܳ^j-l'}9kݴ#(規4Ф涗^WOXf e{U(7J*7w/FԵN<"(j9J]ۉ(ƹ -RK>d$Rt%( Q`sSd;q4J{=Y&Y:U}ZedY}JˌX%y=/uY{W 4Cc `#flH'珺0rPV&'cHnZr3w~AW6jl [?@ZI>*o \h?k uPElfmeBrr!B!QޙԠ0P$Co ]м c>_Z5#u %ryq9*HHvH6bg@APpqt ~!J bO]U)"_pz,ԗ}؉^H1, ptdB`ɠvϪK %0pwA3jZ-mͣ!;w^il)lso"Y'0 U@?xn&t^wIe0\Ykx?\lJwföI2; r!kGdv󀵉y U*p+Fp/:#5l7rǁ4zQ9?ѳ>-)  '͌4n%GAߑǩm?h ʫ)?l&v"y3'n&kX&i1InP;RX2G/֙, SdD83m+WZUyf4װzj|A#T2X7W>AʎRJdnv&f"f Tj]eADNA|#_*qft /z[u݃.&`+HL֢c kH2.yvvP"E-8/=CI^7_`F"ZXM_!58N^ҳ|U2BִILX^H;qˇ}Ȋ?+z5=H!6i3h;;yǵ i,Rj07:jrn /g۪-r6j'/ܳ_ݢ+wļ:| mL Y;r7 Tʹ}_>W/K@]V'R!f^)X3OSTj])3τuh?;,6pe/@qv?1^#haFMS/q3_H8EžD.R©3IN.S=ݟSTдz;AyIp42 rMs>x664N(u[Dw_>eB׎U9"7:uVu{Kx]vt^ Rd|Sg~X|cNJ8T/Ѧ~]Xdw$!pX7TW$w^8`eԾZx1Uä+FSnc7fgQu2] aC;jItcU+j:CthXmR{άoS #J"{lb>G.R atKqaB 'a=dş$)R®<@7i#'@s9w >t7AN^P1kP#fP3&uR1un ] 4w٫a\͉] h~{4J]zBߺD:B@imLz(3SC֦A! 3%O=pB@>Eg@__K* T}k'tqoA\3R%$d\ǺܥH$CՁ Ǔp{Hr\I) /`%[do%5Ρ -pO nX)#~;H/4z ?½"4>O7Aųrjg\pU26m_O韺!AsGTN!c6s$1UZ?/&鶆2u7nq Ɋx#>nIq%ƧGDđW)/yOrVnb((X-?sA/c3 уl#D?uE+ oe s(r '[-U[ >V7xdt˙v+9K;21 lԬuS oVM%CW6u-P,m0AB7ʥ iGM3LmHJB2`[#3бpْlihI3jVcSROֿ3Z w[=c]Bc~ ₸i# ER$e߬;<ހƐѡ S(b$Q5z9XSS7vf-R_YWz7G4/IO)}p^5gݫ|K>o!޸d+~Bvev{Aly߲T{hIR#XSF|bM>o|LOwiH3,ZeǖErzmRo^wQd1uUޗ8>w,F5dj~ퟵC[botB(]QP/]Ы\_0؁%b `\iutWEя`rd zQY[PonuMpt"'N v9tsiuVʶpQ0|L8pa:M&M04`~%ԁ>X炨x#/ϭT]U7 x(+%Sg%8LGg~ F;7\ %:y)mY{[栲".GQD^ FocF"NH.8=\VY^`e~ ~/ , !cf>13(w*nuAr=z_kq[ 1v`3:Z}^r-_MȓcL[ KR<؊qƎlT>/$:ͫ@a,fi^e[BUF'"n% AxXԣB5㮹i3Ἲl ORA8Ji4N[eߥzT̕]R=ˆ@5kJَKxDJd\.ŴM% :'"NHDԵDY9b8R؇vU|Li޳Zkr-_P#T0I'Euޓ6Z(9گWK4X5l\X`i5@p14eti f8]Udʯk~ N @2@/ Y%D{h$ rP+BIC17d]EN[NRN&E:>R^C: n%G\v'}cb.qX4~%%'R;_nh-Gd7ᠭ\I.$k6)v w-c:Qy5ՍT8UXpMݩUrb8~|Q}#RQ RO! 8V=y?f&ߢh㠙ICC\ӟvA.V\&rЩ*sTm #3aNs.˟̖eI=}'[[6 ⵏRmΚ`Wy9PCyÏ fo?t_:0 mfWkI=uDJ]#GDžďJ-jT`+/cs+0B޼d>*P*םMVr.L;vW鞅S9~It9-PA:pa2SO JN&S n5ZK2s#~&ULGalv, 6 s!HZs UqbXKۙbJ[D .^yLA~zù!#]5XKf-.0aLF<j^Eq7* &9 ] P鮍Br WNR}M9v=$N9xi%tzn'wpLܭ%@¶wHKm\l>~v~ۣkv+#jEux)&~R8<,70a"֏BC]S*.-e粡d,nƃ;*දF99.&26Y9'xMT59&b&ZH@[- A{(N>73]D֖_u|GoffV7R;rEn!/soʔ~ fX޻keR8)m:=M6^# 0>P$7;7&)7o⹍Fcr⟥2‹CӦEꜦҦ~`mRCNux Qv8Vk/$(tj˓)|_Oc]2v]y;IN򂻪KG=G & !tZd[V;) cЂ 7=n}6q  AeC`\3SXa7mt?ɋ8 :LQq mQ{S#im)[_ Bwovĥ(F FmQApm4^֕C챖0_ٝ+ 9-ilߐG~JByC"{S$wvKOlmyTUn^ |1 K/ S/=tr".Q$8͓~%t0y>-ё¨3b50DtGCVv;dj13b8mN=1F"<"j$TS wx3J>Ɯy[ʡ*0Wpy_JzuLEF8hG:$+<ÅCoZKh1P* B!z^$?[Y"㷣n JS%57KN6g#⹴i2bh> -kqY}۳OdaBէxV0=&hN>] 9ĎWgSkuȚzZT8/2VB֣M9*GDu ('~BhrGUFRjD[~^|/a[N'ՠ.{q8']\[ܯvjXPъf-NO>H3o֥5!u7QF=(ٚXn$1/#i!12YxnM[#e6]bq~@ NLcd*hyZY&QTht@I /_SwSt8.S,8]TQr:|7 Lys:auO&]:t;1O"p:+ffÒ=o1-ì4e>>BǠB:, RX @qҖ PՋŧHDWܳQI)s!IijR'Q|}^D'헨 1du/IPoVu}X2815W`U?ƫAi^h kĔoQ;ʅo}Vg5$rSr?Q rHdFtFW!-U[V> {]V>ZҎhu~٘T ͺ%l#=ZET2pCfݍrM[n\˜V:~f $=Z0Ԕ:+!Kt{Ī8IZWlhZ 8wO2"CaR!>C49L⽠:N%3f~$^t`|ŞSOO.Of4cq*9T8;YF 7náQYVTx~kU+Ci2_5KbAxsAȝ*ou'# CG׈G*2N :qWV`muo1vfqܜly:d7ւZxwѕae'jNiLr3~&VE`dXK\xYvn{\npK|B~sqLT?H/`E!{ޝH2OJoiI(Ywi-d4@u;%E}%bS?v@.,W4"fTo$ٺ{ qСDևK˘# <0@AZ+pUy?OMČ?6ᇩ/t%iw^:N!lJb!pgy@ *!h71`~}az[)rR 2\SZEo`̚Z/'ZzZ$5ݻfOmS/;)-v8!.7.i)3>J/zw wRgva~W'f V FxDbN3ϧU{J<ՙ]«"TKd^;/Ig=Ek.Ykaא2q)rJdenQ<XGau^wjYGTN-xڇMr1^!@?^$qzqYKwd>Z鯮Z#$1LWzδbtx+!&uӆ_SSqK$+Nw,hy"!7֑?xRx)sWP`k6eLz]lޕ0%zf%[vB$.wP6d FcXQI3xf<$apl?cbE+˧Y MTo9cVr(뛏A(u}^ _ѯ(S=[*%s!OD %ьJRI?Vjd =2@ɍf%P]D~T-} JtK*]MP*=_?-9A9{ToJ^ClPUreA.{dc̫PC[\3鹌Zߟ<ާ` |.[4ϸ14}C'fF*1}5,!'ߣǿڛ[4[WKŗM^#߂2X{k%̊-[JtNhZ,F})=3qPBfpus !r׀A~ ݐv"9UBR$œX znmoj-%&d15p;l}uxC;r_M/qiq#vS0ۜ>BMa&Z))I̚ǚD^߷k.2"Ny $]tx *L^wx Cы smh hD0 Dpdv]ywEksDhVMڼPP7ٻcȄ8WJ ;G6 BlBG"_>-.OyOtz]wP˫ ㇊lp@8Oa܁6恋{B|CY_`^9!`fƈixF˱iPC~yRhal*=8inko0v*6EN;\veZkb+(Dy=1,r kDonDͶ>1偒bC~ vi`ɴ+h7M#(%j'ncDU. /' +hԕ7~sc՗)VߴmܜJV}6`2><-8N>}!ynjūQ٫5ɳYqd߀EK؀M85b >Î{Ġ"82%#TGUP$jwAFp"7^l$tttx#n7v@RE(xNueE7c"[z]ڏ޷ W:+wHCE"Fk=I#bY3T{aQBL3aĞv"Gv!.JXyO-5ˡΠtLZe^#E-ylKj]iݛ[3NܒLzm0"&; "z쮰* Iy{&qjOFq#^$2}I, %1,Oߩ֝FE'M̙{b#αA-Ν8|o\\G70S ?V g? B8<'׹ g0,gS6#Xqi]@Ʌ12,s̥‘p@C TO\n7#}=\Xu\ eOjbcpɮ,=]\'/Ϻ?$@ɑ8wN,̉S_H@\l>܋~o?Gt;'ㄋ=J?1nݐ'w ZoEG#N' %PJT;Yh,R-Z.ou +_> d5718~l#/xZ49s~K;\Ê^5$4-;:)G6N}jmp5:t64q'&nvC$Anǭ&hܚ%FFWgZ;nĮ@z`U 4 0H!eݷY@MJ_{6̔!ǖ@gҧu_J?#]ߍ"9eڜ;M\FLz8DCRp^ٰĻ8> VLH`y5ǿgxZ$smM 'C#}t+ԅkP~Vb6ssy/z;y$k yɳ&-BÌ}<.ТqGE9Ȧ1H~4œOg6+oM":bsEccs ߁@R;rdЇT &6NCg3lYŇKhCkБ㉘ *Don y_yZPf|y(FDdA/)bAl-H>/hoOr["` ߊ]JGwU"ay n/id N)%iMxğqG "{w|#`+J927Ycl3.x`s6z%l] N'!$PlF#Rz{SJjq=]^='I}FB .˺kCD3%ީA^Dz4JG=CH Uqݻ v8[-[p+I|M]LkZ=Uwm`9`ܺN|犫m\UѸTцt\ERSf]Z΂r͵dȝ"02{ mx 1h(E\%Y?BloE􃎂PAĚc6= ]44f QlF?lLBN>Gg jo8JZH\f(E;[":I6hK{Mi%y= R^T<(r(&|qaU@]|ͭ~^_$qҗkZz,OdHj UL&7%(=#_.'ɻFUSYۛeYSBӀ _ lb$jkǦ&yJ';%a^ma4:7CVC-|-r(4 ܂1qy-OO!"H^=8D-0LmT}`o4_cߚBF HR-C_4=mXx _%yz>Mk#h&v)`n6Ll%S]n?BJb¸iҺ'Ja!&[ܺ=kY3"T3̡SizȐrlKl$e5mipg$ ':bhɣ)&SɬD0yq3`d=mvWGYzNÇZ3x@ΪSo뚩,l ܗ"B{ux؎9; }yMi`ZzcF,s?A'IQD~%n<3≈2QGTޥ ,9dȽ- 6d13S:*L y4 o]Nz%o0~k㒝GTlLMQyEŀ@Zn!q G IV YxȪ֩čp&|LQ:yr8>w:sIi4A8ԞKuʬ@ξwC@V4gmٞdZM4wG=b4,|-'e&G?tN:I/`y Z#cѪHlgz(*vi̐f7Ba//mL̺2a"CJMq=/]g-WQwp8^=At3CAI0:ƢBi8̍Uid { gaRh4D|8{<&o&E L `dz$% FR$11ҧTO_u΍ᑏwB1_{,ؤY= Pe _mLpn[a_,n 4 b5l*c%4UKC*jÅ\l2hqN>ZD0"U}+m.V8`S~vGྭy9L{=]>5kTr 0]C4m'D>}F$>`w&٠75 ͠ o K,}<-n5Z䦅ߟs嬑?&gz3?٫uXW vA_TF>{ 7(S@9u٠ԣ1 7M8<M};=jW3\6:kv^'4DH8'q1oZɖ8EM$ xLnH޳Bvus3.y;R{xd-'`6r&` e=ɶws$&jfJ8ȔL[ HR\[lT8Kvq]}JŠ)˽ x 2FP@QHݶq42B(؈e/υ;`QyvK1* :KZh6 RּAE?*Ds[fX_Sp[p,{X8}U~=#ū@9A0i:BɱVo&R)@1/żԲL8mʡ: !\ ye9fifrUQ>uV(${q;A(T=,Ot535󻟋b(Ʉ硵}rWi:?֧;żTr(sY˳\r#錌O/uv@Y6JSXhi7$sOy4z4J~=@a`oߍ媛*)/u-@mmw 9fWOQi 0tBte苨yW)[/ϣث5 r2oQ*6u+aKn3Oh;j jx#AQ `9?+dTu 0D]OQvv/G#p2 dn6l!0p%GPol)e)l<# ,՛]|2WЃ.Q\đI ah; #!x{gV׼92&nj\q\O7g |((Ok8 +gztI*cO%Sn,)t".g f`2JLi3iXSZKQբC/4qR2 5? ص²tbI-gD(85\ '/w*/9 'g&6sG[JscDNsGDQ2!0͋;'!32_t{2K8+6|{E:^)7 x '͌R k/Fr=6.co ;7yaHI`*m2OOhSM[u>w&OaUެy \j?/[yG +{ UYr٧Ѻ3v)wSMNG7>;OR*hG/6H.- 00 r10Hwq ۂ9;\5,hV%df7^}bǹÞ|ߐJݩK3]J%8k(.~'|檠#w+j!' S\lݹj_9O^= ǀ=]bviG;V^2kkG)*8d(HQR81Anǡi&T:{c5]12:O*Nm$yD#r;r .ԣZ<҆kLuj[3^u* oJ;flgU=]fyZ/7XWEX}+DT%rWpal$*&` 0N3 2POBk.miO46O$px9k7VGG0p]&,Mz6b%Y5?C<+7I.t{C;iةDga_*t5'?924 ZUG =>ʫpedgN-&j*"Mw?^=Ww=bjr1dRL4l2Ry6M$rpb5-t`ܝKLcPB76/y a`o9/{Ea ;rT_uG; 0[ӸK(XQt /[ݖyvɰ]upB(<'gtTF6G%+A;R~#j #G? Qm<(М Bʗ>0 YZks/data/plate.RData0000644000176200001440000011672013265504435013640 0ustar liggesusers7zXZi"6!X~])TW"nRʟⅧ ""ȏdׂtgH=@BQCC@lki,x4$YQ+XnqS}@%yQ.?y[9./6kUIup 7cA#@uX2jD % Xy^b(KD]W+MIz"U탧eWq+8ͱ/6D+6yAMD٪ Ie!/hzB1n_+΃? ktq3%Qa.}w\p*G4k{cC(Lv "oz?nl7D5Z/[ G BSĦ =,r=N[ޏ*r$!ITV7W2dr vAAh5_*O](: @K#&nk=]0!ϥ*r,΃yS5Ϗ?Z\ X<3UYG{<;z;A|WnC H$dJ9h$p_b}O?09RNdyjXPn>`8~cv>( _ zo0 w8v(^$s#lȶR; (Y7s t:=F'$R0{,%4$cfےoZac|uz(5C \:QϮFlsNHdɊA}VU}#g#[@,}o?J$jV£DJ}XעgŽ7Gdt=/esxn՗B#@?v-dU- <ͥw qD{ڊZJ\$*!-rp5H"CY9O>RRoyB|v;\g3,+u=z4ު\_pTܝhy BW~b`~zj}n+~pO/2gl?[s록+7u7CF^B~=qedV7N;b]=M'[psl_B0iKxssn:]ghIbHSVC LR{⋆b2J>9/TB A/oWS ڠ'3`k*Qrd_|B}tW7'd)i~9_ͷC?km]ɛ8nk/*F%&e3qNo誯_A(tQW%wRL7},)m͂a,u2hs JҶpߑtRGcvTξ Լ1J\n8-&3<-W]-4{Ԩ5fq5>px8foX ,&{RD>&8ߵփ}BB GL& 24&k9ȚnjzfumU. Rkʣ3<)N;:U`NnSUvX)50Id=0)\c#G'tpz~>s2 ߃jU(lWb>ư7S{Q2OWY`mU2o*ÀSݠ~E]FFPГlYRhsfp| L {w'K*4f埩 K5Ӎ &D|GҐ8<C;YO9mN'"KyX؍xZd+b@u}KV}|eddEW,R$a̓)w{峏saIC 5D E9kD0L"z[E-iO}D*qcCiRZs{EQV 'NοI`Cad15~.%j|éLD8sa/OA7lmhU$:Z. Hʧ'1Eth:]USNьy"Crk:w'raj@hŮ+}R9KMKW97?q?h7:`ɴṙV=NUb%OZ/nU!J#X g^ŷR,Wq/'p3a[|)1X<CݝW21.O-HK8X3`)_Op7Z] 4 iav]1:4HzT7&Aڳ%!;2p,KEٷtHu:63[g`br:V$a@K&I=9&~џҝ}+IKy@ dL=HQ|84p{ 0N$>ڊx;(:la P%꿢REzy]g#2Yo=|tPquMɋVIvNi|՝61`:Q:򀖟@2UO7ؐW"p.U},[aUd%J@ko&>KA pIٹ:,0$i^&tnRT^nAB/AFY)v` Y?GA3HD5UsHneI]szON"CjhlE |&e6c.k:Bi Ԝ`"knOR7==1mT}tKƠg|nS(W\mRC@BD9؃"|p?lv6H;P1K^bM_;V*5dw_;]Z+r4;k0% +OLZ m0QM"ʮ-`j4& Rki^mf\Xxu\ LʏDg@k m |B-0muW e B0*#Q"=&hCqH,<v gyݔPe",`W-BR*zL*қ!w;,7Z? );& յYn棔 s~uv4wp=N|3 wAKۂBź!B$~L $Rl{lu=-Use=aY4$bsƤm:ɍסC/D'o d(.ntbM=vEP/B^0{O_:YPInAe/, vկ: t0fN7.t Q# jr:E:w#{PahxوPjCX'dljQ@+OǻۧFMQStᓜ&sLH*|w1 y`.?@A픻ky6{S'~Cߺm+.)Vs׾o N5i?et,p8Rr 2AsJ0agucJq H30^$+k2*vaf=Izv͢󺽕]L. p!JW;! ̤*gB=Q6 pQ~4?̈K$)܉_b/"8WI+H][GvX9qʟ_FݱZr3)RF_YhɅfvJy\Jg^-*8L;EyFRJTk5D!53Rk܁?ɺI҂HG_BtbIZE [ؼTRF#aWl<A 6Ӈw&T!}=7HJ&k7& A~m VȻ#<|&CI:6 %GC]qi+Y )BIpit]p(7CN[xM-ˈ0Be0̓GZc"p4Fjb4ɻ۫JV`YM* K-k]ݦj rZo͛b.l߭i(Ueq͠y?^q]bҷqr ̉aU8&F0Q*%lAğ `9*Z ɍS4 ~DsREˡ9-GAHG3V_'őGXb5Z- *p8l,B #?~YXTVF;>1Y*ԝΘ].Й CzNDz܈fJF^FR)%ӟy_'ؘa{sֵ)g(%W nƮ6.}.B*WQ,P2),3m~!!ΆAޤӋ4+3 pk G^T,x#r{<8@LN1#TY4kb%@)D/UV{Ypt}NJO:RYd!~Nyti/r$r3NΞ[!ZhNS[$q@(N"~ l|>p{ j@9'C<+s<}y._|0IX }Օ~ N cX?=$VY1zI8*ؾїXA=j RltS0^VFx! Oj}Lm.4S%™[O43& cC8 H8p僷K! I!X 6}[[rWb5ʩ'?^-į'5{s?DFlhq-ȴ$VF$^S>p.f%\pJ<ť iLk~4?p9yeجXa[? F8c4}ߙz~0M3g8D%]+/eNr.S92T|4r%QT WG9pÞܙ=Q M7*GzoIu?xz'wLLokILF 5Ibv F.7T:xZC S^ @5Msropo?Ccp/ I":yJ%EMp9J B8 ,3Hz kwx;XJEdʐO08|h8<ޱo5'D.V ,єCzE4*Cp ۋ:9F<%DsInpQ31t-j;}A0hϣ-Uiۧ[Eȁ9Kr@뢵+agmpB>h͐o6.TC;n6&}>8$.n1ӑ?6Z.C}#="/‚9 ~"ƣt=ɏ͌AB&okL{}LS"ʱ\6g$"x- b2P>]=YKplmkRt &;ZnN_I9DRo1b)1_+T)I7Q3(!wM>6i `2'?#a}<>s3 KEE q+*NaSto Jd&&Bz,JP-4//S@x{Qv@e9TE 7 ڢLy5u5,b=ip ylk U|͋aQIsPL I0l1K ǬO0%xSI$`*f1K%nQX#'@߬b2QE垅DYKGǠm|T.TKBpdpg:sʿ!̽-v>rpPgd4ya=\$8GaG1+8oYiK3j.7b< Y4}˝&.ʆC&,cH;&NsSo Ӯm^+zжkY+teOsVK!r J0f\e'W ,F)ta%n~R0p 0Wf_ f=fMܾGܕVSs.#rي~t | AzպImlڴ^]9fS,GPZʕ& ;CM[NKZÅ~<,"(&Y غ&t_V{?fŝ*u8aK&.G^l:ÄUv3ӻ ]*irmf6& QH躵iW<&>a3Ka4-B_tb'%9qf-2~QP6RCN ,_h6xR}5[*o<̳h*#{l{NdJ~ovbr:O7du45{_lHf Vn jfMPJ<9(msMR‚~ %K?-0YK\ ҔTi5Wi-9'ytjׯf fB,$AG4d(Dјy )nqq<"hQZVTJoe +@H>rmxMUbDնШ車.J]zɬ;m^nAt,H']#yD0ԅ-3>RۋP6F($p>gc?kb=Koʖ%u ䷋<*PE&ަxU5 rz.*)zj!5"M`'TxVfF ) L"Di!vi)zI;(gGo(EIfrTS%퀳6҅9h&OBA&&jSJ+F0bM%7QI6x-=2"H^7V,=b^P2b u}q#f@k?^ߍ0@W*VDsܑb7.@-WBKk4lҝGrsgI@j_3duZC&Eڻ?}8 ׵n[)ܱVkif# ߙb* L}׻RWj9u~[4+hnBså?qR|7e{H%p<:BAkzW+C2>{Չhܹl,\]AD, }&J5[#y-Ԝ|/czKX6D}>Vqy6E:Ґ%((+Ie;uI>=p^i iA jޚ+ mӤ>E1)poC]^33@7?9SJo#CI?pERq{f2}PqqL]]4*B$T҄}rcN yO+8˟ne2$DǦbeQ= p^ߕquh&q>`>%"#QivAf= Ԫ4Ve"sUq\yj}$?B7_6f~&AGsHBn9de_ bREJެx΢ I:CiHfMfˬACApǒ]ܪĕ q+=.Bi%hiխd>ӵ.r>(Uw,x.`SVr7&Bܵ!rs vП4xb Ȕ7M\Ħ2FNڥy nWP=++O 8"Iµ aai#8 ޵"ćf=wM D #rųʟ!Q|\Ft!ᐨ$hC{KKFaYUx8oYˡ9FT +IHQftqrCE?3aBۚT֓?5 *L;cc3Ac%?c0s)ry7BB7Wi9hrڤ(lX#2wMe_] wwEሼG!͝.Y=UG4mq!97Di(th)1/UtLGSC2 TR$Na}jV=H [Ij|=p$lTCZ:x&@cTF2x"9uV.{R㽂*G"ԂMk E|Kl8- Vyr-tP 3,{BԘ5-;eXu#X6F4m!}kXx\u7+*4Ji29r+~Х2^{YSI\0X,ˎp>Ĉw[7|1dN+.oR9߿Ys9$s@Y`WkX.XxĊ#BNg?1?/W\`\P9hоrzy lJ :r^5@ W9h@HOd!uʪ3gSF`$1,z=|h/YSא#=~>U'aԔa\i1K[?2te~]}؁oK`Zg R2i;n l o`JIaJ;IuQi` w:r~4!'OkIx8T+|\Z߇N }A~}%d1~(@}u\Ƃ\,[QB :70poEGE">r?+ (EFvN`Zp Os{09H߫|vLy&e&j9AR[}^;؞8bLC|T0,/'?4CxMM"aD-|dyϢӍZKF!H;k"S>]G<1o84)Ҹd? }jq= H5kҢaȭ2>0G 1zrků FMoc)aZc% RK-RL^O S +FQ]fҤK&WjUӗߊrP^jn!z#,U.߉q:gujj? F#*V(rei2C%CSPӮEfa"qZP=/zO+2~bn9D}l:bQcrI%r7h@d!& Sx'qJC#̊Fʈ$TrZGZma}ɚzkYؐ3p`EI톛eF-Rե9[0LOXշkD,.(V֦K&ph>&#J=^5,a0.pu0^h=_6U6L6FyU,> 30HjRݪI!/t=i>@n"J>T?8,PMe̐ZV#ۦN[V\} bR")%)&a&>Ն@$i,\+w2o@QcH=*DY_\ ͎K: NSM:LVkҝ4찙42?ԍ*g 6o] N$V^7$ rnN&\j>f-.+1ȨymDZN8F]Qp'9CpW.I%!8~T J UEĆZ6K zODMR2tlEZ6 ۔A1X]e4 !2:E RY$ {m"c;VڷR7xRGywɠ\% m.]7v9dqۛP{[5K/rut[![\,*!mCΚX9Xix$rHlx=.6 :9`c N;4rG)h$>,5#Sr//ȵ뛒?eX'Q6l[3&RY)}cs0}\ΚԵ-a+~1в/{mP/>*PhؾhC"lqh ѢfXi G&!5 3YnDh2v;.f?QL`%6}(T5hD7sZ1,NJ "vfGjטϻZlXF} deho8F ofqv7  "CZBZ^%q%ak$TŰ.fሟ+ȡ gio\}>EeSe3]j!N ׾Gc+ i-iBگKgGXOh )T^76fBU\$m9@iD':`4WVKL[ :ҖЍ>,MlR؞ؓj.ڛ7.WS>%ߞ}s%?%q'q֖P0U:ZX.u9tF:YAb$̡^tJ`3u:uggŐU&bOK5NblC^#է?cE…6Yy1i= &w-uo\BdWSCn%LLSJ]Jl;>#)T&AzA[`x7R{?n%jJ|aP{P׌Ec9:p:Ӣ2`yc*ZAqjNH!yU%R&мT։ Ŋm]X [~YA4 #wO_/9 ŸME =V z ˃vM;R*`D7Ō[GcAIFփu%ի”o~KzBH5mKJCK-c. 'bzT%`m2$p؂9!$9-JqW,5f_XIo!𡭋؃ۻ,*m8IrʴrkIXؽ(,!W;q5V~on &s*Fj%eV_yB2Z Ja`$7-5R*ts[Sͅ"Hmgi2D%$L .AMo6߃dB zq@@=6up%RyI4}kY/QEZ}kt C&CPzŎoHx^ey0L2kpD1,k}`Vi{=PT[]/_Md&%o@M*eeXL]o{Ƕj!N8rshh= w!m&SQ)=2?&k"\pݐHl9ĚV{VUME,KDѫb@Wjj&WB6jX ƻؽ#IRP#OoubI^ܢ978F\ uZf h:}˵@f܍Ҽ6ULWU+!`j}[&J3#ОQ׭X0GwqIF;/ZUmȒ,!z{NHc 0xXV%_Q5 #֌$\sWԺk*¯Qi[((<6~wIuqQ -6=>{s8-سNMVơm2Ϩ7#}Y,}{=d/;(FgV?dt,8ڏs6!߽RXOvvA%WpP֙5ġd,VPS 12<~׾H{?wzpC,͉u a}!7ʟ8ΙW!^J}aw'ٯCBq;NNٚrvp˜h\ŀ>PtRL~'$s+Ia ard.MQ|;攎H \T6e%>c$Emƣ`FsZȾ8\It?YsnCO*BQ6uY^4DFxm,w.MrWkZ,Qn3qH%0꣢/v6r֩ ("ǒ䉥!#-kuȮq F\D/Zj~K\B]6Dx[Mbnwg)vZ!L!\ z:8v 0Yn.%iĤ5* n&{ ȡe.ӜBl]+2C³1Xq#E4 Y; ЯkwU@nJ—HV\$Z:ps |D]VDh~TR lLblE#+.k˯A*ȉi  ޛ#3ԘdYl]N[sܴ~F$n`Rf#xa'\N#|l O/2mG5E /fD->~9;û DFdeNc>74lkW 2xBB$8TG ѧ{p콼 γg0cpG)~W?ykj6[7chFVMmbkL n%SʼvȦ4%7'GʌGb_ 1 D,݆Fy"::; a8\׃!gVļ#͋rٌ7O:n}g0Q ϝGޣ"W1}yO#e%0R'_#dٔ39q-޲.jN<ج1ǔv+ԏBZj=h$EApC$a6|JT߹ `I2wD&FH䚾ńkWV3Oxt7!ɷ3˅a}id.YV@t*v׳"q"C !M mwwf_(_JWjn?_Ju`9#RWmqDQ;*4T>lLZV*Np=ͩD5sy:WH J$d5Bސ)"<1Zd@z3n@fUm . Ȥp-G=֌$ϖP{W;Qo)qQ oD}9EJU;!Qw~wu6ҺbQKF4X0!<~7kRЬhXa 4)vqȑUCZ2a[CQO`++POAY0M0!Fx2.; y5R*҂TBٲ\RcgEuVpBUG-V1{v.> Fק'`VAOkV ı )' o:ŷTG:4=MwL̈e5E.S.VOk_[*j/ZC8BŃs &RY»O$@+^`a1Ϧ#,D| .akѕ&K1!qk9g]B7.Feҧ-u,A֭QچQ٩׷_Q=nsM$e1ɪ yE#Ne ]}v hngчW&QUgdo/h麅˜p}sfT^9Y@tvh9wV\Ҁ/<= @ ʎ"L*oC!ݗ;<gehǮ`z$;`ЂVq pH\fk1Tw=SKu_DU |][J8(\ԘTWHZp6y#֚pC<ꔰH |?c`N| i%N&zy%̱+Lgb_bc1!#kY 3/NP -ZK0S>l֒0J..ޭtxl1*#NSY"5j-in ^il=EGrC'e.ჶ4m~HB Y]Ff4BQm\}G 6 CZcYk7?(k*q7 bP%NG>j<^,roPA(C;PlF/l!(ӕ ̣Cf?J*Ot;_fi5 t^o,~%`&Poo>>,N0`m=<.|Eb[EDG4V2.Vo[i){:Fa˺if^DOsGEc]o<ú?hFjNТg064oRJF t|]7'Pre }qz qoKHlyuq!(95Z[X!ƛ׊8 sq@BɱA.4$OCԝs{܉>2II˃nzmWyT{4rZߣh(cQҝ)IVg'm52]ive#*UiUeRʰD~7&{L^Oo/%)XE!QA;BKUah^::x:k` ~:ڄfast" t92e$JńTdw? 4ꛡDmȨⲌ%@V:RI"#|EjB\#"ǪW >ug),R_7:K!4&N.{VN_Q 0U,]}-s?90Le6iuCzӣvm$d~= G+$RZ/Wן̋Ue2d[ _%TJ⹲+ i_3=8Q-.q8< =\9~͝$!r;P'2(5<('xrEX H5h:Cw;< P=M%Pm]#QMvxx*,%]c2; o-,[ʕ~g-WhJ Eu _.>aRD29kbK}eWU ұz,L^w{lW 99(3<]P[:Kz$j\ۗ@ ]e'We8}xxW>5/思#;hv@@wޗkɠTHrFVExd6E:{P[5疫!$1]c="fM=wdBmSу:Y.%Ac%#|g"s o]g=AXO7۰A+_y]큶/:>ayU$;%,@%ީz̈+ 6%c1vo<J =:6O'hOM`ֹ8\؜ll~DVk[-rBqrt+^._(&fP*1 ۽Iu1e v'8E8-xvǾ>T30~&&E# NbW7sQ 4g',H3و12j_Ougy%}ܳhꮣl6>~yʲ̑08_;8: n+ڱq[o,G~xImxY׍dL-X*GR[65G 鐼ۢ躨%YFhz,2&]#"( ։D3QyRIt7%fNx8K<3W\ZCrg`h=<7[#y0֢(Xeld*Dzk~PU1X= g&p܋ ΁ C 7&{CY]Ѓyl\P 1 5IQT/s+5:!$WEJ}$apy|,g*є:Vvaȋfe {TqE2 lJ>pCB=# 5k$UHClvXiQϩV{+S\q?~BF" Cv,}p~im' y1.HʲImU]e *x*]ܤ',78Jo/oVcwyNGe  ]L"o?3m~HYX׀+La 1 ݐq\x/ ۉ3<jۻT;GnE2j64'~|޸ r`J"2t6! YLܓ{D:.w=MP< p\jkh@w: 7bn/D=mxpU哩ƁS]`a^-of,w`DDhŖ rgyzSu†{doX@ j{v?&CUf*G2 %'}߇1Jۗ֡L|)kVmP5/ԓ~ 9/df)R5zIγra bct(ǁ#ӷ˟.䢻PRj0Z @5X)(07 3FLM]W|60oG QJJ6~yq9kmQn\ io/CBvSfdF]{eoƳ,>rpa+.PΫ}&Ջ΄fGo+ea57_m^LґH -/Va绞k\} mJMZ(ltO5MԍH-֡F?Z0fW]%=,d+p &O7}fx{ @6սzL;]p)cm0_Xvu 1-. + ,XRI +@Ev=ӗ﬑Y@yK+O9}J9ڲуP$pt;~蕝e?)E_JBG5fc]'}.ۜ CBF׶.`oܮҬ}"2M*ӀbBG/oh O56X$ m"fw"N]- p"!:Sϥ$uq?؟_R\K[nh-5JsҊ߸;S1U\k [􀢚"ܕj :LG@8%nrzBJkLupr#Zn} N2l)Y\V_<8BSsbcS1Zפ pjz *n[3{~ nASHԭda1 BomG8BlP ~'(fغiX<OEe6u Uzd.@_w]#=T"cwڟR~a*YeߜVwߌÚuYծ$L>&V32L!63+uEwJЖSOdIbv3gr4t]zIkUBl>ZqVJMw/D F@X8@NƬ/?YmgwIw4sak $CrUT_Ѝ"L 1rڕI/ao{UP0$褂5<J5A !."¹- u;3B>Q}WKGۮO]rsށWnJEiw3H96LJ8䓃[SY{SIq8X[Kxݞä,b'u*GȇxUN+}|^7PqfԍΡעMxK_Drhz]s}%8baD^04ζ[f YgQg>wXZFniB>~7Zc5yO)YLu,h @73_p >Ӛ*B0_N/Bl+ig^Om"oq[4t!ne>wFGIhh:; ) 3K| ח h-Z{ ɈޟCe߇EeliP_qQ 3/݃Nq $Q& [FW@)\I;5@1~Q${{e.|WK?!Np6(/rF}ChG^Z, yS<$s|6"x@J:bv W,HGPҏOi}V+z7索}7%Q\ 0)̸hV@dTA^M3Y>F?4u7tCپUX$ ]YjEM@PU4ӎ9)(O_y UCs^[xQ0)j2ňE^FArMb./ߌlyq+kT>@M RjY1\VR]yCǃS_ Ҿ*L5_UJlV 4̕B%w|Y*!:\q4 L *e`65َ|  Y}ӈWծضcPeFH3FA" Xō>U?Bty84sU:`CytsUw[vQI|bؚ)go9 p 9>ъֲ=.>+R1xLaKE̜ƒ=nrşp 22wyPT, 8婄㝤ah5'tMd.bmFsGe1J Ծq>Fm@ ڊtbr/n1?s#)ǯG8|kx7\a]ܜF_1s"Fɓ6P,87{tYi?I{GޒuRKSq! n]TrVk@ Odɝ] LOj )1Y06ͩY9rG:\h0NBUӱm"{%Q.ceYkXJx(Ify7 m43r#-bS?k.qҰpLs^` .3j؏!Cj󩕆`|w:4@d<7ab-[+Qp*k6SuV@3#HKE؆΍Oz׷4byՂyq(na$4-kKxm> =;?s&ȆۇE9,=A_n "4߽0;H$ڳyE~Q囩.z@c]lFWiZ=_$QϠ?U)[8oTvę}øen)H%yOf׊b](LL/V}zDG碹+[ at/&xu#G^aYN@Y"Jh⡞O3f?!hJL̛67Ưʏ6@(zs:[Z~gPpHmr;m)͑xynY]ov7Һ*qbVI^k% 7M[}$6 r0"MY~+ >Cɟ#+; ſ_&_ UGc s5V3v\XiM0Y:Qn.oCГyЯi?W$61>#ifhXh/eA[|QU@ Zc~*Jص&pz*J.uoA -D_wyI8ۢ!O- /!؉_d\B*O ـ3:r;qүЂLk-Y$CHa۬]I^wjX8\NWvc]kв T?7o45# 1?O8hzkQt+\3@$&UZn*S00VqӜ8uG`Gtkr62St| h*Ȃ&!p@wޒd|j;6}nf?nVN\ڊ[`5 $@exeWkmTG7yKm:U, 9(\$LP(܄8:znB#UFc$agz{ѿ^ /A|lshu``+Fk M`7 Y4*܋5ax`H,kUo~coʚ j$BC[3KĸfJ)|&lUK0%[㸁Ok ( :`}NyCYQDޮek*q\٢eBGcwHe#5XzD=vyTEbs?U#!IփZp8r&S"G(R򋀎951cq뫦XNFsyp7I( ݑl?W鹨h!IL⑐)S|I)/ p_Kթ$38#rH*Iῳ&uSVvJv:\ r2r^HB6]6qfV| ~9&vKA\tc:"O):'JXMω'0U;wgڜsz`!qjKLӷ^`Lp=1 ؃K.B(TM>v7$rLA  =5q<^6;esR~ֆ®Ț}[eOsL[ni3Y0>M @P*oglbIO *t^ bBa`M| !g^3><)8'T^)%8p?0 m"#l_ړߴ lLсЫENI`R!2Pci^9H+Fpq̽{DFfB{_LܺJI%dΛJњc婍88 IǴ %MQGz)yDPR<>'>6\埣9E^>Č(ҮDȧ?nv[69:OQh;$wʊDn#dӨ.G(.d%R rl 5(k`y,&ڱ Yy?ro@J [JEf`<@ 僿0_hmi:0D! tRс8T oEj t*(0=b>~i 7=]8<¾{^Z͚i:ZgIOjD!Y͇>ќw`27~_ e!:ՐnjMˢp)iKy7?Ͱ`lSj0ũ v$̺ .)ӛ{tx79vcK,㍰d:&f}Ppmw皤aiS=JKUr}\rkZ2o r y"˴ ^Dɱ!@Ġ<d8BU\JDQ&%A^剬YƢƉڠK^f̒BQ@7_3 2VD^ Vn~|'vUxM\SlA'^FRf<+y\cU8)0SEƈ%mVBGb@ _o"FE{[^6Vמ@ln{b{"$ϡ;UV̡LS42a Ӆ@4u[#q|%DZt d7PT`/ BϒX,%y ϜlQcYGK !7w^DkeVZ(hyLJ|@ ,U,@L0RVb3; DlESOItmSI.ODK IļTaF:@GZ+S֎W;si.IvQ]\)QI_{y*! =18{rO~PL"΄.qj>_S \U4{մ6ncϾx:X.h$EɄ;{OiThL~yP7mAWd(u9N%\3^ka6 3~Pl\1Pv}5Ω B=0׸ GPq6'Pa+FsDNK)\܎i[Y(9#M㳽QԄ$|0P^/.ӄh_`^AJlL!:Vyun{N_hXLZU*ZȖt'B %/aಹ.L){c*bݹ TG)Dհ\14m8 ITSE܎ƭ6Zpfp@W/r?E>j.xܬma҈KsZzhёdh\S? UBk%:1Tozm~2Nbd^h$Esb"ʸ5G7^IȲ1g5ʀj(z0gɴ LZ7aQYmn؄˜n:_+f#yVFy{8;g{z ODs6+BO$xW|/-m ~ȡaePx/G N( Bm8BHcJc(c9җ#ց+UhZedS.Vn PN{qOտC8`T"$V#e̙r'PmshvצQ^(h+te(F}CN24AqG0;[IVMp5Bܫ QicC&ϼ~[|tʭ?Ӆ 4,=t6=z=A!)Oĭp-e Z)zu :.W[nDؾ>Y ^ೖ2: ވ(#;|w13?4[KWc;.+3NM34 vXm=.\@+l0A22Fwfzehɺ6~yJ# `}1+,ulVY'[ᑻA!A<N{r8G}%yL6r %5*U:m`ݐʣ}r|Ír8YY0--4q|pd+,@/YR+$TO8NO[H:MSzjuh\Y\ 8FyX7uâ3rz&xq'NaY<>Dg?7xg\_5ۉhhdP[8 K̺=`uy%\ZJv@I986tPՍO`rۤCP#e^QNiZ~mwLLaL!TVt :$sbR.ǂ0th75vm!! âS?Ȧ 텶DxV;57oߘy5 t8R&$K^OFIU֩n}GZSADgقdg芍BW\Ycңirk eo¹Jj+y\xV2 ^ @5K\[]y &T(6MYb"*;֣VQ攐:>T!ujǻk[HsZLc ϔjud#M>hXסSM(r:1֡&뽑% 1E>8U/dg@&.˳T*]a˰ 󐈚GY)Tp5L-u WBؘB"rj\r9twko嶗CKEYV.K5<"q2&^Ͻ+ U/Hv!E4zN:%["MDT#H)ӟdhSA ҵ qux]hK x;x-PX 0Kl_4#UbM-&$*d.Kq5nYzW1Sh))kI\әĩU lww=7]m`2!sg5V&G'X=UcRN?e]dtb[ٞ [UQu@!2 Ҕ-WҰ6!b/ڸVK>qɁU^GeNɍ&g6GpD7v8J[$Yњ F` &%nB[Gɱlc( *G([vX&ngyΚM OLr ?f(֘T ~iAI;_Ή=ybU 69&ƓtAܑ*ɿ$mi範Bwc5ZU;(͵gUÚW\|/)|0 ׋P0t^;%0V#o#x E-w #Q8|}GS!4g6n<yZXMVt k]VُI->kL}.-ѸՒQyw7akEyɿgWw@Xۋ2/ THs[G6M Y=QjN/wij =GJ Ik7b'E 5϶mUSU .*C9+{7өۥ'EfU6aZ0~@FGrNxxu,xSQC.u2YN!ku?H%FS=Exϗ@r0Iz,6/,c?"jybHCȔ +Y$ > -F2C.0zoiV۹Gc`>L4]|jO%l)_,Gl;還|К9LqKR_$(/dG$p6N&Di[J#,?( O֥Ox(OX_{cۻ\p({rc! B&!$;}Jb_a{Q;y怶?FЫC bYZmiKӱ[9ɫ15,H!+VbDwLz{- N+Bإ36Ov2Ok^F71LPh]_WT\FƸ]"-LbQX3i1dZSP1neW2 18;DXk xfшIN>=W+$D+Zީ3YfxYJ0H LzBR"3AjA0] Gíb3&2pUW1< lF f6*3r@|} ƠH58/,yYRzM7=٘ww\}kY{lCH^Qb2>0 YZks/data/worldbank.RData0000644000176200001440000002570413216563676014527 0ustar liggesusersu 8TǾoc_bU׾ˮ1ØR*Z(RJJ)Q iRIҷ((#3w= Q>%rLH Ҋ s&'F,l4T*ӑ$ (ͭ+<11dڿ0ISȡ⻜%Ց59aHpJ)].-N[ϼ^>)L97@w65 u#⋼wNR\b(s$ȴ %(I"̟IF1ELᓔ/Ɋ!q('¤#CUօQy2qҾ )FNLFQ)\)~%G !ym /9EfkGC]wPA? ۃ::.!ڵyCaGǦ0Y񃕻XBdoaqLq{0ю5PoB#P@"G bQU~$5 @2;py{yR hg~Ԉ Y2JA!/ɛk TY3XAe\d&]3x2nK4nKٓa o`%4@9p,\<. 1BX,I%y;w<d,VURx]T͎;W@bzH<_("2|;ɞ& 'vd<%'Gdd)xLeM2| L+<i r_"DMGѠ$(4E+`#7 q BS#ɑ'D E8I&ɥ27Ne$M4σ'HpMW^`:EPKy{iN2H7&U f'miᔿT)Bȉ+T466бסRXtdkw&o~ju?a|FY1iI)@xP_DliG3A~Eoa]+;׽? [Aʴ](|8,~w{|W[zL>=|-@'x/QgA=iv&̓Xr1ַgӰ_E r{_0O& |GOȰ_ֹA!Z;ϮwޯGauJb/vhyZe30qw > N vnӴqfAs1lh(dm.żeJv슫EA?5e؈[~7X%3Ė%ޱU^$U\4~{Ժԏ7ʇ[la_.Q>y. B ՞n۱c?c{إ顱gDu6ajWKL0Lp<:lnz:- BC v #=6xB3?@X&9u?M!oavj3 c-K0N][M[Ɲ_(<'k]\oRs kl:2f_^H ;~n~K}p Ў傰qmC*w!` h͠d>g5VV'6>ߔ˾N @xIJr4Pe_ZC'Lw]X`OWMLiFZ +4کkb_-21syZ'_%b~ß5vb.] W#@4`_{>5s=޲XGmsk/fhX-̪9"ع!Ƭy?06Lo ߆̭1As13@߹oa+&y_+>c&ۑwFc#w2FXCç ʮ/:|9ׇE_z`רG+:`Ka0hS0h1قUyR=ZlI?+3E7`~6sY|\+3,𴵵%s7I\{~!¶9؛3wCsűlj]/;u@|jx4 x/R01u;˵.MP4^_3$'%1G;6Rݘ9neuPS]M2O+9'Qw㩦,6z48ϫluvJMХt 6,t w<oT$gW]ߪ-~㇏z|+&-+>RVB7 'bG;AإP9v.ML/bأg밫m}b@o}ݕqh%֖pasj{wqGo `3*9 sFK6LGxdV{M\o" +AUoZfȌ$V&m`!4'7_/#- d>^/4T.(?"m$ o=f;7/>;}_1g5[.\։؟-q5X(m &i Unq^9um /ۢkNʆ&#bUl! jFfvAD[Y cv2V7Jkh翰6{4h.Vl&v>;@w9pC.1L}d*8shΑ[ {m+ LH~Q ϖ@-Wipٯ(eNP*>#U.+ytc4tf;Z&؜:>OT>. oi4 c|O2W]-6.ه緬P|knTݘ޻j\VqmfV잠P83o\|,1Cc+%ZA*T5:܋ۭlXF\fv`)j?}HրBp撵 R{VùeGP7 ?-_Xrq2ʨZX}x)dK[f}. /XaZ !7".ύ,tD0쾢HK6E`WU%=yzWze_V8t˅旬ܛ;·9^-2ZW?'p6} ;cw^-;o_ρn%ϭTB9hj;vԪHzo_cX<5?+2`jyb3:mט4|O7nhmhҰ EFh=WmK/ڰ5!m78LY_rTN_}9U)lm\19oA;h(֬Xc-'^-RW+]^yzDrdY~{aO 4p#P]y $ݖ|^KVC]K|=(1M~ E[sC![0q}MW\SaQ_uH`TTX.rkџdx,#!ԏy-$~(QR%{_@,6E np;op/UqU@h5 dy 5EԎLP2i\YGF;Y?p?Ή7 r<:jxYtwp)4Qv_b$/qv$O0$cáwyŁC {6~i;2 nŶ@vy%+@L{Vܺn|ģL#aU3ѴU .!9ȕ@m> liyRZ lrr3H,WO5"D2A.'g}N3Ի2Ay2t-mK{\G ÔorkIu7^V3(] j|};ڋk/ff 0XqmW$Q?w=mP&|u5m Mj])SOD9GҲ!P)|3x_xp4腃9ʦ|?< Oc/ZInp"J8< oփl(o4\ǡ Lbrm:uh\zx(?-T$&@I~Yu En$UN)*Ȝ}aX:MtWt,_4֚ 3NN_ydר25 ı.5V\%(cR;<4^`B?;jη, Wz2+׀i%)E DomPGedrXxƇ'nI_n.oHN.),x:X&]tṣK^l˅kGCk<𯬏 تoa|&]ZMuZׁ6TP&̚&{/v{* !W%%Ay+b/Gӳ7jEkn^72ufrLmPJϽ)D\sŃV Tu~P2zQ_ʋCnؾ#6jI[E0 Z9Bgakt0_o/\]빹hzt-w§\ΪNUJO7V7|S'Qζ #U؈E2/k[?NQ҂_c+UEWi~컝J?AȯjʞhwGS͆4@k߬9GʱwF,*g/gwpjy7Uq|8ZJFEE|ԧF*41P@D mힼƶ 43 l|dʄ-FhS} vħlA ]#8`f\PJZ\c n/=?5|m {ޞCOǀ$wgi q#- t>%h~t@|amuN?͟ ZQ9Bj}5OgY.R Ce4't8iCtʕtz6V\:U^ һՕc@ Z-m} iĨr*@U 44"R+qvW]MArMw '⡪G@Wn~7l44smi0+^z>Cd/ִ+ _+6U=5=q~$묨a[|ne@uї3 %h, ߃\91 s1ᠰN0XZ}/|@ⳊwoǧǾKw %k+:_!J0of? Ӌ5\~½d }s0mw ~0o~/u΍xaƂ=B]0}}M e7o|u|AkLPJuZ2ɼFK:@zxP+,O\i}֧eAvgC$~;l ѕz^@L>&vWL$D ?";OY"듳W}Q=M{ǁ[6$9J]m5:u+g7zt$u^A$ܜd>{ۍH7_2߻볈3@>vO':N t#iViT_OzFR$T 'A9?:S׀DQρ=ǵMwᑢ;8\&.يfMcq-oޏܥ'h@DTM|61OşwSWލzr On5wNȌa%u wP% E7Aq#@,xW(DRc OZA٠bdB:m_msS7Ye;9!gB $l6- #y#c J^(jjS&r3ltHT SѪ`^$?-[tS˘#,AlhPڼPy/cw68;Ug7 rѲ Ck-n8>|ʼnR`O`LѠ|Dj,ceŠB@U+P4W,|a&2m@5.psUz+Ӈg L1 ~S0[Ypm$X3tGHO\Ym6xbg[Ld@&N\SWpϘA0o;{Ndxr{p'ϩ=3>V, r?n96) Dn~題@<794@g8lKB|]Q38rn/.2~HY5-OD'@D}ܢ-u\Ay?̜ |;׋WO>8s"(qj5!D;pcl/Ss?l޽r`.7-m|.#v 1BHcǨ+Qҵ=_'-~c({4r;rx?ę?^Y{+A`'4~KfҺq{Ur}!" CIJ g};&3GB6 ɉ? y ~ٽX>mЏwjqie>X=8LCդ]y) 8qGA;ix~ 6,B`1:Od_[ f4ǿ xaw77I@H[ U#^zAew(n/g<N?DzrnΕ/ԉrǂmE7`&G\ eepu;&uҌlWu/+39yyh>w i :yz ]z6W7#)3s}}X^%c"?/-W;G^kch)a"_gUuoU6Ԃ=2?3NS7X]q׌Sog\91o V&A|?ԞpK,Yayϋ`&gSe&:15|~l9W/N=rl;up}gν`Ww$r h9 t Yqu8v118prd\w%۲<8LhOk6of5w{@{h+~v0n7  }*fޫ:R{ p*=p6|ciS6P]ooʠʵ !Fs-_iX{cϳŲA*#뱍oSTAڒ2xwz G=cŽ3Ja.  "c=j;e],z'ihY@h-lچ0+>{ǜH3ɞL٫QҼKo63p=HyIЕSju; e \KUz- ![2@.բ0tgf哝@<ƭ1DŽԼ=ǝzXI3Ć6 T,kMj.W*unrH`*Z'=_ :?qk͚|.u|<_nj:Gea|󞿽L;lq+X?+T}` n ]fSj->0[A+ fy$_vKܼ%;IaGttokzT8Ȯ~a7כ E[\a[Ɇmg@ѻnfLuۖ`uCpo}vJI]]/]&Y LVNUnz﹈]a'*Yc?}{$ffعp")oEMg%>B!6$9 .}S&=?.f _ԜT.AHE71u7{В vo VWnu +aoTj׉i0%raNTmR0,Ju3t^ LnF2!CKOuk Y@v0P] 9L~>Z5Vz6"qz!<ks/data/grevillea.RData0000644000176200001440000000441313216675765014513 0ustar liggesuserseW XG(($(%v?Ctր* d?1jk1)q1(Def;fuU'{2?o>㩕"~.},>|qyi6@+oV;t<}ڑ!{dQ :U1/~_)O/_*.M-̗31xj S>.WODy;Iռ?!>%}rUx\99SpW7f9~`VflhPCq\ UJ_ȍȤ!w ;u3fʷocFmt 2?f!1b_S:>Xt6f;J u9377sXִ^:tnفP@!ő侺{"ÂڳOfc}~ w o~\?13Bf4x K/ mJcO)ꪜ"sf01!N<#q h;p7ض͉d =hKZYt):̴e%% !+OvNsyG}d3eS2>˶}g&a }a 1'UX~c!dٞ`WK %~ͽr#~̜)"YX>r$\C[kj~#|+'xi!}E186coD'?Q1 * 1+ɻ'C~\bRe\*?%Rks/data/unicef.RData0000644000176200001440000000164611541700632013774 0ustar liggesusers]oU7ApR$$ Mb;Ʊb*NP[8~n !!$$.Hܸ!!$N8@|7}᳻vfwfqVW[eq˸"%q/{S1 貦 e~}л6ρ@\<~_cx첮)ZW^z;#οwk& nMf[` gks4yuc9y X1;|o{}nerxa/sif"ús1tbHԶ٬Ć/bC|rD|f6Gބ BRT+OlR73dbVKaF$O{AW lI.6/lj#2ShںD&RdԤH6$:Xm (kNM4' 3mt`ijpн9$K'r0QtQD6a;J؝ZFƚV8VQh*kBϚ6HMva2(J]i@~Wʍ ي;*meV"H7jWڄN/Xff%%bW:ؕ#aKd=i(oQ:vŞ]}fًIqC(В+'u%TٺkHMcF4^8rށP³;VRCî@y1j |D.#]RSuVL~tN%CRLsڎ{G/>ٓek8Voh9?"O%@ _ 4 KzavKlDxGwSVd.968(ks/data/cardio.RData0000644000176200001440000006066413265504354014001 0ustar liggesusers7zXZi"6!X>ax])TW"nRʟⅧ ""ȏdׂVy\iD6qC*hi<$wFje˰\+qy'1z(ƃ:<:E7TtpáW uhȊѬnSĬ0PnHJ!DA6 Q}'jk $hq;2ed;mN@38Éu XaX|6 %hYh*̈)Fzp0(ݹ i$\LNǛ㚗qLy]ڈۏ<awKҤeV d~16d aTO}nHJa>^GV'qoOU ڃ]s& fX ^/ tI!lﷻz"BF6W$|5K)m͋m~DoTpE۬b?t7hh#v5mO6J-JXޛ7 Y >񤋥JNC @I.ii =yp/D8c2ZM_b=1,/XDkEo_D~|օe 옴J72<@Ȉ5^KHtfZ+:'Fֺ )& ='SZB8c.I,| tg4ݲ\)'o覎UްN'Hか.fw,|04WhbilzsoS_я`B&P|_FT=(𷵿c{;^&G|jqm}Ӌ0AJO B&Ii@\ZW9s~G S/:L'G'5AQQBllERl}D`il^;Mp+YL8iZ@?=]8wKx?N^1Tih'iH]SJ7/ wt}KgNU/Z`S*\ValruS_q*Vݥ#*f}^}WģdyA}nLb!@zlyY3߫ʟXSD>.f2jXXK.WkȬ_i8F9VaLRV8gڭBy/zx}6g'PdsEи6h7bfwWB(K3Ŏ6t-Iovi UO qwq>K>xC=3_ Ynl,T,t>luIĤG`KD5_ w н*u!g ػwp Kl,0c. !~ϐX&M#d7 ~ _G`Kxg~&G^FYN h`"r=j=1t/ iRByػLHD1hd*d*(S~,cAu9Нb0iNhh 7n:ԪNqo*Zŷ, 3_Pg]?XA~H4n~;wۃQ;'[9Kz"nrKM>/rgzJd* HQBbFΜFW6渃zpaOGd3˭s x`dE2Fݽܵ:0 w-}tPu~_ x+G;a:7c-_JcL?Ra SIA8_.auAnnן.ɑP{*ZzӉӗTG>x%&hemޥE1#@'\0,QY?V$u:l$j**o\::k~yڮ|(8+ׯѮ, E +MKܤ)ϳX{}V @A$BasI L[LvmGa;NC;L6DIQӴ;fh<ZJvGWT$PU:Hl!sHƪP{ zb.%T}jM+bشPq36ʯ3A_p0ڦ0QZ{_6JeЖ5t'iqy0ı>5ٮޔ4)0Q8e [ cۛQ* |&B\iTHޤx}WcKSPAq^PnNWgLA6(q.2P҂+f@q+MqS`AyuQl'ƃqNHPJS̛Mo >bҼpqŞ(qKeJ|*X&Z'/2-h=`gDd>YۣЏ>[6 ʃ  =IcQ-!|l≙rzTH*IY͹#1qQ"+!y0o-]:6 ,\ G $q[Yʠ>g xI Ց90߲_meZS1,x_e=%ޕ*mCtP]#<_UhFLX9~Vv13l/]Wo`}{ rC6nʴAh|eCws7>a"|VS1߀x)/%L^;| is3K$1 ,Hy1MF˕hzWX6A Fdi/o}kɌ9<"ldS@Ҋ(zՋoO+o5hd0f9~v{JQ$|7ЏY z)oFBҾ "m5MUͲHΐc)֦fX?8yYj"~ߖ50ǍR<{e>47"V8@ ׵[oୗTײ2:T3Bsg!tJ~ҘFm3)i("$֤T1NUmPF` ž٣W 79?xuXs9AxȜ:kG@Ǣ e⡶DZ#x"=#Fu N 㬻N-(Q(ȅS?NْYC ߽%gdaNӰk d|)_j{Y7˾ٌ{:.S'AbƵKhs 6Rb J>m-j$| `M|ҰPB!z$$FHd5ОIH䑅Yg#8NB幵䠾 کOWܠY1蜲bsYnhα=on._D,̔1ZpAڹ}BP`}A6P&]uVc"XumQ=5 FV>uwh^NP7dg _P( IIΣtGs9F%4FC`'_U4B_g=Έy)S(A $RU iHsʮ:i'!{3*7P;5 NP/rgD\c*z'0q1@Fծir{R::fQ[ OXAҜj]6"F+2KT)q/v}h7zɯ}^i۹4SCq/؇'mѕ#o]Lz5AE6c_f^w12l0ڡyߠIڪv2ҤǮlIdÐKH"IF|&m +!5( c^C^Ź+{U^<9šl.cRZV1J:i~KydYR W9 (ui`6 l ;"N-0ݜL៙!fHo37XikuUj޸ f\tJqn衕mbsuUwuhaq'Br^oxWDG/=a'R:*E:yևEr٪^N,RdnIroZrc8>XZՓbħP4%?$WC:)bc{@_œ]/E9MqHv&xc `{?ID"Ź,:'4eل8rpdhO|# 'SYF'RR 9?%{W#x"m%L CtYUP|ZY41R9J`|sՅdy @WpxIMOǸ<8:!ekJ066V-8@UpTe[؎(|]%:*ө>ÇK2 Oc.>eC صQ!E_*,هfBK?NW7p6nx%Z,{V |5}_jSC}Ԛ3X ~r7};gEx4@bT)pV߿9PuĢ}O{j8?I*$]⺛N Q.=+62*fecQ@$=!FnٰojTx頸ѳ գz34MWӼ'YHyַ֐xY룶$^&y׾x+(6e|Mu/#5h#֧D)Z/@Z˦ǒ%#Jj.=Hq`IңEkM9.((]E1ifsV7y?kmyJ6G9=L@b.נ6lYderˠ(h"DQI]|aНϴZ z8dcRtFO8x#uL @KDl9Na1Ƒ64ahfKw"`MPL_ƀFv}WE;#]Y`:]ˏ_}CP@ 7 ;[HCF8nL0řI-CW7Z/tSbjtMu׌~WtMq )lp^=6}%JM|a494ڦ &yf}'vcHÄnY͂ 2nSPڄϹ:x0 pcm@D|GE,ZqZ Owo1}3#H\t*md4ef>CWLKk&-x.j0 |cVf\wiyw_/VQJDh;)6aaAP\"ub;!AF:#T,)^+!\ OAP=/8`@2,zfׂK%fB!T\gG&дZשLT5@wq@{< /NY B/t K1eJ'ޣ+um UՐWVu1j%luο0˹}ܱSetI dp} ?_U}}D=pNyӳ.Sk|M)A!}hK;?6%8yW?[Z4j{KHq0n> ƫ,r+,z85X?:a~=_ԻX SwcHeE9b.]c1T$/Ԟ/rmQ6c.TM0pY-Wv7qsy 9CU7LyXi kG4 S6.OrLz 7/Om [bʄw,,{ZǷzoh"OF&߮y @L:]G֣"MgVg)Ls(":,u 19plM_9̸  %(29fMʲLX>AIjOcotx_ZS ]>M3ٍ@˼v:vK1*f8+gg\;z|.4J5b]^a*B[ dp/Mn0s<ڮާ~?9嚆a.eyfäP!QL 0lSG*aRGX(B~=wkE5;W" L "m(NOͼs5K&Q?[gqv0Ʒ`Ҟ:${,4A ᙫ`*Rp>GU9''?9Vڧ2>4P޲j_".?x'u8 \%'|쪪1jޮ۩h %A3q 0a Dp˭az(z \3R\ "*w@vxt,U¥8>Əݗ6[ CE&V4ǹ2wĤݫ'f&L; у+ϛ$1XG5MC>Wj@pE.BEu,wXD4Vh"ȲKg]Q*_7v+\7D;J1ºc'taEf:7W.)r,Ca|bD"p22;NidĵgYB}JSej~Ø cA1Ҕ HG& sH: u9|mx=( D!y@ƵCx[p_;6k[4-bbqu}mm鼇9y>-T8øcHӔKi:2hyǷ:ZF_BNpma!()?[IkJC8`ˑqn`+eATyT ;ɤ ]b{Im<1'?F0ͪ3 Iyo 8ؔYOOT a(OcFifDÑK] gbͤgbz&[ q}A΂OZ@]J)0םi!~&R٬=]];KeV< > :G,©E#3wE 5D3K Y[w$QkiBvLv$3G2fZ{ l.k^[M(/χMńmȸK'~<1)GǿxѥYvs 3zd@r?@,yOpzCأ[kA) ,5zaɳ{-ۃ혏W/ɜ=C^ӬNС77Hq>jDW$Dj$yfuu[\o"t \?ϰn x/A%4C b$;w\,F! _pc e/DX6D᳥:bU}:43VS0hUUFApS6J qeY@u8v4'5VG݋z‰3bN`v,/xi Wi~i 5gD 7-Y+fb:#-n-u Tyy:7g gTai|m|7:Kc:}ԿkrXp>W*MWA-3ˎwpay=w="nm9LkԳ懀YF/26uܴ10ѰW$1օUs4 c*+PsSfڊW@ -@W(/F,~g=_V)"ߨV {a<~7rⳘ< ON.Q@ɶKŧߜ d5gVnY;\2waRjۈM;y]NÖȅH 2sa(O76Z!P>Xr$k5C&SHDŒ7&fh VA#w2506`jT0Th6/~-d1Ld T9"sΣPUPILQւT3L[GS Qj~Usk<]Cr*.2m$_4C~Tͺz- Vup4r1|pSQbsX!%)E)nU u"{$+Gv u''"l]nFڭ>~tՎ^S~dlל wC׭Wap3:2N W̡k)4;s6YFU,!g..;W#(N6Z.oz*l8(\~ĞM6Ip4#4P srE2صW=yvr/X>jס-A Xʕf/&FJ<}'iH7'LRbh90ދKiD^h aYcHpBhJNWv\pPAp.߉  sa3ZHz={Ϟ*-uG7 \L² NX"rME͵أ| fޅUY|{=jKdh܅6j- uH<ήOA!D&V{L,LbwGrל$Q^';#NmIt.`A-e88,^cj6N17X V$KIĈ'=0)zNh9pQk=F%_g+*NԻw&^>jDڌ)mkܫA0 "x 6*"]"ה,UC-X"E@zϷml|< %x|jݮϧ%<ŎM ZSK7F0*#nmTDÒ44@]LBzE)XM](JĞK%xi "#X<߄׋]v38~3\eקӭ~SUD2RDcH(;;vA(Awv^*z0lnt@gؘ͍ :L5r9ȴ@qR%6Uy/dWvF[tH+qoLC}<Ϸ#5$r_ ) 1k(Km ~w y`jVe> 6ߖOv2lclOS}:3 ]j]D`D.V,k _W YșpºC6wNP?/ 0ƥ 2)I!^drK{< Eto{M o)35E8ƺ*r1]oڧ5Ma^*2Hχ崮?4Ȍ)Aa>w &,`Kv-"5=#ʲ`PJhZkȽs|}Q%1UZ$Ԧ,W(l\؆,MyJiϦu3[Q4yNBׯs:5J+jcNLJS(Kk( 3~*0Ckѵ | K ,p(e2VcSa.`kØ#-i>#m^Q98/^{{i/#%㍽vl/T+A>0䟔f3r}|'gxaI[cB.]pA^]@?: dv=g R]ge'2D0;܎ ]^wwLk0u)XhZĊlz7!Ydq8j.UcԤf׃ww)4;g7› ڷP#K0عYKр?u ]DKnO>}AV" w{/Qip2\"=;{ R mv*+>F9k}f`L9Z{tmUt}}q wAnE4DZZC[ҷg6*& )!=Qwgl!]_TEF(}ߚ/41(>З( mfDc6 wwhڥBHT" {@y2Fw_?&qj`n z3t2=PsoK ŵvNE7R{>٢b:]kdS<ʊ`떨d ֽ1Dxs#pճ\wg.niP Dx@Pg(]ys5e6#vC4a[RV^j~֒^P86CS|g&gъ*=T5L|O^LhzmB"1}A(.C6ϩt8},'cZ#u.=> sٖ(> &y8fJChkļD6 ZT6" [aDI.M4NZ)`I,ע?&^eпˁ*L.n;OfS < ێi&-6r12AFYlIl<˟2>5ԁl0S!SDlNH>yv wj)< w`fVnP4 &]E"Ua`<琢e̗x+|&ü9\nXM.7Ky0e4"1|UGB!I>6Q/,l$uptcSa܁SϢ&^F0g$v,BxL]iwcvefUOg Gj8 Eu)C`*MV5K׿:aN1«D;E)}P@ȅVov>6GJL!h kV6SM)>ddREbǥE+GN[Q=)aSV~$ -gOb'@.R&  $>8Y;6{+ר(=V=\42vqY{hP'}G ?<(r{N1W3h:d|BaEݸPq!Y_C G >Ff}.P_Ht#/ ~̖h;5qTA2PLRM,h[p:Y^l6M̛̕+ ܙ9Cq9 ĻfS"&Y@'M3 l^Dk%4Tg۳x=-|2#{'z9Ob3KRd?q1Δ@)gyIk0w˖y9O8fS-3Mucq.h0ܤ\^K2ʪƪ`jTY)LI/=!t?A3eQk nu7Jq|>{$BDz͵AX,u9dECW,Nc|<lm eL F m }2 HWvS7yG!hx*# Ǵ{kR^ De F#\8p(N-9up.acG2y<)Gg'(@|]]˟dAH*W854qZN=s)Xn zR닸N<`[b9ne4*(6t"0ԅ xZ@UsΥ%2#@QQUiFwphiƊI蓒H":,"ז1L|v|A<^.$qaM@*Ī\UiR9b_ IJF:czO2sPH׻- F@wޛq1!6k8-C m\u %; /mkwTzC 1UU1_^9,2]>]6epTƫʪ'SNuA[ȯa>z5/f7B H;ςX߶If}05^~~RڻjmzAaFA|޵g'L?\4w>,_p'ai/%dj~MOc<~ByC-:NDq)讴b!Q`R'(uR,;{ #c}قj pEq#Zl!0J1L~-ȺpHO~p*=,_g92_Ó)ZR\W1ï Iq~XWW[CwdɉM8ŁYYQs֚j)e͉AF?/+ݳ \?{6eN{*T][k|k0qp$湎z9Dk>fN}V"6M];zu& nȎGUXni!+ޏBfF+0U > j; YET` HA<4\饸 şaՏ49uKg"lj/ܳ '6gN)ϐc!F-W% I56zB!fTROXuٲ9}nWc[vBՙ3;c+x#+L s^B#J~I z_nz%=&8=Z@Fe=~՛;t F-z+B@dcQ>To^]`7>yj XePMX_g#ǟNO?g)}7ѬcQRHOWmO_e3-D >+` эR%0@:uM_foHz;qIz;>"\iZ'l}Є{Ix!D9Jw BebbTMbvbچ״N ̯.SyMyUqi̻) w=¿K/Öu-Je*ffBIl+MȚp >O}_)`=J-n/- G&I7794&O] N)ͼ%NoEe5 1ʢy ;9{O_NJ @ֆ`=I78r1*'κ!l-wI! 1"xzjn5$E/`g0i#GO̦bT%a;rP\Th`=g$l^<AK!01) /B[@ Mw^8cvb {ǀ4Sّod.}e@jI4I4!,z'Z] xɩ@Gf} A2\yc+K$hr" C69 4I"}Pz~|+| ؝XvFm|:?kEl:q{#Ǎmgg pTTuP\cBD=rjtX,_C3ݐ[΋LaTW=ttakZ=:/I[e9yx]- FE<^pu~Y /fSA'fiEg3`!qwu_=O ԏK!c?OYZ )I.3nxHrULiX߁d3sb~7y晍BE#mgzI}hjL:A[}=/RP<Q$A,`F kQz_~:g{:CڥVQ!VvEFc0~^XHNCŰ"fG?+if{效݋"9nPnm`Ʈ1*,Ёl]A_cѪlhROi&bDtmSlBq%%_7vBz }x`I> r`/TT pXݗ$UyG3i~|xlIg&2NXɛkEbs,WVy-g$fPY'@ K2sL|A g)O͚!6-Jt@(׽ @ZP>)%߫.v*ISdT&Lߡ&ubaއZ³͞KkBHB:3h?7<z{&返5?~W ىȱ_*~^o@ AB),gH- Mho@ 9N˒Pft2׬ Teoqxz{5^J\y}": h0qҼO#=D0{^D~ |tzyv;7f,fCPC#*,ÅNVa6*pRlD"^\f=)MI$(+)A>!л"B  @g&@;K#M ΈAz4o/ 7XBї9S ɧJ!!nXhx.C,xmr[#2W3iR<7op0}f,W?O/WmÈ/'UNC~!KP[)NS!,n֜)fAf`̀4n+LJ17r J`V[OM,G؛sxxyɉǫ@$*6B|O fcCFkmar+,.ڦ&Afs Ǡ!eF G\yt*"tQQ2q0ц*I:E;7#~?` R@6UA؟WiU5b#5\кo{QKQZ-y. kbC&Ň98(/ٵnS}]!l-gdE6Ue(*ﱞ@+4dzĪ30.֗)k+7 ɲXc<)UY%_'thzO (:a!lh9N4NgT;`w $RZX%."mv2W&{Q[ܐ.cXWGm7. v.ssw0ɰ2Ӝ@nP9 `16;5=fY3{E:DBHJOlܭĪY9сƮI *??K (.iME!u4Wdg{S/,[eSFgﺨSp؇x} VX9'BїBjv1 f}a I"R"&S!) pC!STC));$`x^p<<T2m'IXœ:Ԓ,,]hA !Y 'b]$5 s=Tw;TM꓊9EV6 2MA%9ǽړ* '9{C)wXSv1sRGI]jf0]7?meg֑{}>yI}擽d+,'*#hEh+FcM( N`}9Oв e`]"-䷅I9Fh/][KVsP(L|vSEſ)exX`yu^z5eXUn3V;쪌S5y~Lj 6鷊u;vw{aB%A͟A" \oc=WשoQEn# &Vk&/:`^@J;+ZʢYpkZg/z?&edok<8V=<7s}vU1˹j3ɽ_ކ|So$2d;E 7yw8 PniG:O[s Ey)?V-3)p#]}W!.kW#TJlGc{]\B9tӨBah j}zãc/eNKƞSM|me*?>3[AҕqD0nPS$ռ=dJW UpXKyO:p+' d 5=Ѷ;t5)oG %~ɥŻ; [LϨT$KYWS* ;|_ &ˣJeZbj5m;^zG"Gl`bţ6-B(ZuyyP)sGƸjNO#5#ʎzU$Y/>Sn  ۫C~+-)o;&=…v=DVAk_~pwH7!VgIx-m( w #ˁ0yJY|;W}ͩHYom>#]EfRțC{JX~܎bKv Y0 '7Så#hu;e.U6h rjbO'' tIq縰h%{{ OZ%K?[/ol`b& e{_~'@sl grhʫp|c'1_9r7v }7*p*psH|3&K؅n >! DiǓ?n=K>*OQtή];XTR]A)p VgEt}HSNP^E<VJdwsZ^xKG4YBb\ƹ1НEP08ΚlEzdd' Fn?ۏXΕhF%*-,G됃l? Z6}ͻg 3%W5x)#J[3^ۨKIŭ(@&SQYD,U5eBHKfׄDž  ć{yHzhf@{AC_=k: ~7Խ2-u[Mꥊ(ȧ2O2A+p)"Mhbu&s2m;&fU\\osg#;Kc.*]jѵ!;ltM-ï%1,*8+N܂oiY^n{Y!~hȠ{z fk#ZӀ3AӨ'[:T;8qn8Am炎B! _PR= BY&ECaoT[gE#+QMh&Ez mmd%\NiEcf"Zm}[!UYOBź O Ô)9;ͩٮi9N4Z!dM}FKT̚I)G|zPa0SQݥ霅+mt#0 YZks/data/air.RData0000644000176200001440000047041413265504312013303 0ustar liggesusersBZh91AY&SYO4 |B|@Q$ٕ!a(Q$Q@5BG(C#IPTVidjUTV&d*)0* F(2) J1R ZJ )CU!Š1TQ aR# F&Pb2UPb*)X)Cb1 #da41 "'-4HHk h4@+@P@@>P (PP(H PR R UTU%IJP@ * P *"JI PH @T  @ @D$AD!0_ @ JEHZi &&LF &MB&FM4!L4@& dh OA=L2dEOɐ@@M2jA<=ɪ4 1hPGT0)恨B Sdɔɚz%<ڦ&&i= 244F2`hi O%IHzfT?5@i2h JSjMjdlQz'4l"6FTɑ#=y2f)=MF)ƛS'ԞM=#ڍOSڛB iꪟrHRqO9.=6ק~{o1kߟk)?E)R޺R(kBܜҟ3l;'{{h~)׿Cϳē''z'/|==ݞ[qx>(;{N2(z;o1yp^*fNޮ||AUœO ܼ|sDzEpH/!|{Qw;<~//IT^G=(yNB~=Z^?vQWy|e?E']~"'d*(\}x^%h`*}6A^mۓ׎_?>'xg9(+{++F\|C ׀⮼||8j>Nx߉r񲍤m66Vɰ-mFm-m8x ((LY$G^h>_|%EG ,+O`T$3CxaL~Bk?pГ*+ +cC*R"$CD$חn{Flbs|)ECa~zo̯DyO<6[wynWe[כ Uzdt*|KZod<׍k#R8; _${2LCM<|ݳ%1zwy!`yWvr<üzJM*{`89k`*Bl旕>^vWҼ=G5{57޾q;VUQ^{쇉⠹޽^PJpzs¨=,gԪHLT (="^>~os(o{R{{Pf%5ۼ /n ᇏݯȘ]{eWF]_rC/f *(| ({ޟyLZEŗ!b@d@Ј@DK%ţ:l=Zg* =7"2C86MMExd@zBoaeӕ u_߄ ,:?D+,3,  YvuFTdTUڒ-@GfIL[~vesUә+wBtcl{5vYQ4sݠ;HB*HfJa,:u gGe_5taC2jaRLa@wRU){wٚ>뵽Wi?K厙&Uu2ȹfmvK\ ҘM RU+E?w/w\8{ao<`ݣUEH@*hx]TKä~ғo5+ly ,JJDwF]dddfIUh YYSTz꥿mRC7I!bQ~<2D;"&UC:f95kQC"[+ P,Xhдx5e2Gۻ20J>'׆B}ߓ/x6 T051HI~LL&"VzUս'Q%U'ߜ&ΊJj8s& Iku<:2gmؿ dlA44Z[0Xl{0eTŘ:t_.^Ojx!O5A4yqãV>LCDS\sk4Up 7s614SV~ܺqVW]jp,2:WGjvU]Y݃?jk(0bvA8{70Uh_d]ŢKKxpn9VmXSm#*DvAP( \Ȕr5( "wJk8!)DTd@mNbRd66^*ot_qC:dЌd1 ͗Ff b3,77%]7V&gjLKQᰩi'xűP#ZZױt_s(jmm]+Rcx:@k-RXy.*>"GQU@RV]&.a9 *Wt B0,GJ֞F {Te#!W1{GߏǨU|@vD {W\b$fGu"nY ~J_Ϯo+B21}~$Tf9q{ r5E%9*+| D{!~mfkrO(VIRE6c-_tKC2n[.JEeoAVc! b2ѝ,m#L-J3fr'jDPd ! HeF)~t*~H*:HBu&ɶɶxdgV%+C$9te TdqK>w3N^Ev-Um .ҏT: ƶ=j0۝$6]7lMU{(+7cs^98 L c5DLKqwA T\n: "T !xJ&{ ;.-<^Wh[I)~vW_joʽ4h 67lT3*:mu*EQW7'~u 99 ;~)+\{Mˈ{s.1f_ѕļ/E+3b1;i#,t[QZZƌ0U+7H(`TR9QFkc~||+k~tF\47Ң.ib'Kն* JB-^3욽74*K.B΂x,w+>!)ߧ Tչv\EnʔMK#YZTe3yJPJWosiñFT;XX:Rlll+)v5S."m}j=P_wzSPuLuPp)n2+#[i^j7ۮ;&duUiĽ$C;VBa2*DIW"]?=BصY]/ZۗgvFdhl_ZOSg6>LY.))NXjvG8)ҮȪ^vŏI_sNRYyo H]6lttv4 zϝxdDpFc5s2ގ!C12r'XAwKt T˼;Y*d gǜ뽐:Goisf.4 9oƔIŠ-LXϗ xϺeQ w³J':.8UnR2_{LR. s ڊeÒCp7e> +>V2K. E@{vg_\C&d ʄuIdds£a{X7W9_K^3J&ɶɶȩm`F6cپ LyO ]4Ζ(;3V' UM nbW|%&1ۣqbUd@2ZWmW3sl-x(t|󺏛}Lr U@EMmmyҙIctNӿ1F=gǝ\ 6]}Vvr8Oy[APzXbm82Qe0۾#펳D;fUt'y '3RW.uv72|-+ÉxnTTWҫ~Iq\M_il`Rtf&HБrP0S Hi`h v+Qӿa*\$ywcod:|CBf??oWOW7/XtXtڲ? :լߏvfg>=b-c+GGQQL+4D 0RLA#O2dUTcGB~"20ܕKm"1Ud0R9 s]-Wy`0R|{c O;?S_0BAϟ`_6|7.,nq! 5b{$C򣺹$goſ“چI|*69t}xO+ˠ*$׊|oC.S{*ߵ_t\ t8VV՞^r}s%%NiGB11/e+Bܰ;߅R4nMmÖ'&qޢ.nΙAZ{]y 8Tl.UY&!U9 FFWjC&{FE:RUidMmm\+[";-#׼iQz`C3 Y7\o`wϬ@= S5Z-!"\\R 3ʃC[[ޘкv]#"k_kvU-\y4 {r$KV۸+8ƹQZ7{g0%ZM◹'oc0F&z4`W1b%EpQ?&e1l!,oJ0⿁Y۵y1yElC|g#0 @jB(nqMeO0᚞7I)&"Y`xg(1-ZA9:yGzfu:o[h:<,ڳp%ʄO۰dp  j7,3PXP֓Wy%Og wҢn'wgd ֊FSBkw bkNlMyMo] c, 6Mg4-: o\\$gB5/OeJf{.SD667>ʊqx$-)F]X U˫V;aWpqYN0٣XL&O6Ie$^ !Ĭ;dN|KeHdmrMK~ft\ycucBndn\=D i21RKL!{5V2&#uo_5ڵӾ[8ϛZW Nv(9p_BZ>57VWֽVyf]edn$f$YC8`#2V^mPF ,wh,?MmmAz4b"aDž#IZ3%4Jn>'ylҫ2vtwIYmXDl;n2׊V|m\MB L}lk l  4Љ} ¸.^AyI?n8*3 /5UuXpZUnP{/i8'T(]_6""[Byffѩ@)jw;=ON{`~-UXS}vPp=ZW-R-oga(2tW_Dz ^ՏHiwOR۪x@EaɍAeD+@& 5CJgB-JKqcm}/[jyM\=M1A+6ڣnMA—sRsX0z &|+-<-3MzKm71EJE"o,Wi9Qu`\z^-,Z0P 'g6"hDmpon|z$t?Zb٧ 5KD3xo06MMN@Q+nM# }n6(K+AbY/5 (AkQ .. sZ֑{Z|6na&S Z|Ϸ)udcBx7|Un'zN-Aak~bl)lkU%96])+Ac0J陉ݽ릩]]ߧ!/R1rݲ_|{> ˸~?+ա6x1 iωxTLb!>%k&d|Htl1־Fe~  ʧqݑZHH Bo,PjkMT0kt[%~cM|J:e.W&z''Wb :E0<ЭӐc.\!1**|Z%<:"-ޥ ͆fz^Swb5p$j=/ki &pDm"юa1ˠCBD(&qA[qo )C&G0kt"M=5V&oZ-~Za`1F !cFZvDpY*Þb3QRc&+PY#.Da:}*׫}&j}=[s8 Q( 5r * cIj{h N`4/b_64 DρӒ "IgGWҗ5G O=#o(jv]]?{$\^م<ħ|?Zt 0a;kk1W"رBYb@QP60iFmV|Ȯ5iH޼+[TBFQg EPhDzH[v + -j׭X9d9=Tf_%}p^ xo1cq8aڄ2zOe%GVTd 1JѲ"b׳Ke!3XYEbsgU+C M-%`=߈dddfQP(M͢AkLa}ktc\@iy:J):NYiwQf?>xFJ޳r$ЮD 7y>Cړ8 lGjQSx"!`D:xԵ=}w +I&H)b ^kۋtxլ٤梭w)lP'%DK͹}p fQ!_AT7ӻَ3 ,nO_OYfFsT|+,eO.e]1u_19%v~+{V;VYe Ԡnu]&d`9Gэ|HՇ!"ɂ|: ýQB>1Njt-7Oێح78N]huY*3(k1ښ޹_euk-6&ww>Rמz B)+`Xi_AG_=2芙AI@(a&Z4/ni-T*ap]U"8!h' i̟w2JІBLʤ(P` =<FsA%ӖmA#=2EY§#ԮV\QXnf[,T.}փ9Pf"5KW1E{n)~e7rPصAԛĮL?04AV15ܴ2\ZEqe|x/84;|iuџy[A8+K3ZjEh51PT2RU8(-(ĽH \*azCӪK˫svֵ m|w?勌Z'їG߮-zph^ȷfE*4a dG-r" ?=(7_fօ I5 UaPhf og_shzKlˏ(} n˹um2uWrx_=tR n|Pj%Xr$Ki@ N,Z$Gr0AY/>df!`mN-M\8`=qPO;Rkĉ+☄}OS],1+J?VB& V$:N-0m^NR3#b'r_I 4@JXq?<)=$x2O Șe%//LWç'Zo㙬@d.ڸg @6qh^[*۠qIjm]1x/#l̖TPMT]Tj.wz? !y!hcl_yc0j??fU]×X!v+ٹ}0-FG+ZMmYDXbb`-{EUPТ.SmKu8XRF!/Y;ӕݘv;`&0IkUxSQK(*h}!˓%&㹊Z AM&j9m7/^s<-OLLmKxj y؁깛O~l' /nd~ϒ %gemjj <\E/-kZXQȣs"Qk[IV.j rw8߶RrWg*[taɡ)$IlE Tpdnk\_]Kšu^kD!- yD@TIV̉5J{A^Կ{2SL@gFy >!z][: gd>L;DdhqhBLr+]/~$>Si6[ɘd9PK9vp4(֠ f|ӎu&vT ۖ}#4[erx` #\S@p#hy>=+*X #*If ~'J+Ȧ/n_Һl*n szX8&X sHOƜ͓|)Jβُe9@ sMJkndS. %/#<ڦQkɭBLtmF]g#%.kT.i`7~9|lM" PO a{OZEŸC?t͕ \,6Pg`XǨa  S1Hl)!ퟰъ#^$H @U[jOm*UY̖{@X`3 84xգZ@w~{g4־JEZd}NMWR-G[_5Zr7S!`so.yFljzB`+ $OeocLt} )w*O:VɊ_% MS;zWI÷Xz~y'x@U%TiQ/ziH _ %Գ<baP= 鐖S>z)}!¨ZIͶe],@|쨛#-bP3EJz&sVʶLSbS 96׭c5S67s}T㪷q'V@4d`JJṚYDȐ~d[xUkBe'XȁSopVő8Q๎cFysbX_q?M"w"#;cWXR8'L.RwB653둯a[ncxL6 6Њ: zQ^eV=AI-ocovqp Hqe1_%͉vgcwc}1mE-kfa}ǍmM"{9t\B%̕%\aQ8qfa5.Pʭ2$uL]3VV ,5.?=?0V0׽t UiM$B|b;ڻ"fF!Z)W+!rz,ԓ G\o!7x~m0n[wON_Yydf5\xb0rn&Ū7X{Fwd>_L+*zDCL$bÑhHH4m%emb"$q*UYIy|ovŌ-1[ty7vTW2ܼSnj$ vz0 \`z\_".ϫp>x| on{2 ρfh2ceQ޹ ^%ђ ԅg`*\^0?i1؅{vmG;]u| %iK~.ɅKz=n}p78RT`9¬D р ^#?dU4z?Xo_ .ӽT5'@j8e*jP0hy򝐡gB['G,UԖwO$΢,kfTx',}k@Ŏ[)u,%T0VcTCP',{3qVzkA#Hn[B?|w4~(|'~.f>ovH>\`BDyT(n* r>xKG+IJ/,'(DE(sRH<77ͪimZ+ vTf!{Ad N[o+Su&Čڼ ȝd-ӬjΝM BXFQܴE߸n(!_*l5 )~=7vNnȿ+w=U5aWG&! xfUNOԼԅAm 4dmK}C CmaϿU3RN]׼:M>5 E$扸!7Q[^\鎛M' --ILV3jl2W$w %3mӏ^X6ZPXD4˾ao)Z/XXMˆH-EjC44' o\z)ؚ"M7zPOwB{w>ND"2弙>OoUyޕ`QnP0ˮ|ssye]-<v}}oe/RJx1OH;H3Z)/cDg-GMl[nnKi+T߰܄#ڣkc+5?1yYh}x0o䪺&~׶ Sx?㹤=<ө^窎8%^!H7xr!TtiÑS6%ظǛ(b u,3$ L_ ]3r{|+N۫M)>7ZfyF Hf\8p  )y1cʰ @|~[s ZzVkӜ +_IZm S* [M3anvl(T11N+G1c3 kǨ'ze\# ϣ;sv-2;2%g쓬&8v`7mn48Eu(j-iyѺsh~nYOd'2o ][fqs@i.J-W`0l4uvj8@uʄ8~J S,{3h\_=ߘCetm2ĜVDjЗpnZAq4\ j?i&vkp_$HgS^4+h*Ru~ nR)UӺUD"nԌ(<#lU^-k ~laƸcs,p*(#M~?ǼuO"xҪ:W3u R-TA,ܡA%l{QhΪ%'r5V؞No=!DiyT u~/?9;_bvʲ-B;FY ?k`8c71,=s8\y< K0\N:faj]c]Bn`"n|LN^"?EԉbO kbh*l RYfGu{Ʈp^b\\uQպRj޷a{ݗWfL%(rRΙBS' `zF!txnQBdtY63>3/b`h.PFH%`M6b_Ysǂv/j>/>c82xo^K mc6q@uE&Jk+Ƈ!VY8)bqtB >S8Q"~#4μ^x$+TnDVtQϩNsLt`x ;>YQ"ߢۧB,ٞk1qp׫7n}oٗ_Wÿ{v .(XXC+ęI"2}Hv$euQtR6M9`oIA\CUⓆ7¼aYBizȗ[(38̮9UuM{^Cs~ ‰Kn0+ S] *7OSI V0 8y9ϭq\эZ/n-neV.Sq]n''\0nYI2bV`զ(P%A5YÕ^mc@G 8DMCVn/ewƠ-g,è-ٽȏ/@zcD[>]xeIR>,8dEA&#|/h:Qѯ{Vqί]QPpZRե̷ Ov8oV",쵞2.TkɊP % 2dI^ν?`їI̐E+$^0_Ը|H q^saJ:.$ts[ 2ZRbvp[ >NS-Fyg=u1&S⋨\;8t~KJ*5r9e՗$` N@xֶ].z#2kLiO5)mLgaA&UJUȼ6Nkdk԰ 8NnQ& ~lrahC+֭oM흃i)>{=yw_G ߨP!b7o|R)!cyVrJw\8Hm1fወT Ÿ-Fm&qBuE7:|Q rwᑩi:޾OX^1wnlm"XBRŕ%U;|jZ8ਥwnql ׳[2#"%] $AW'n"d雔Tq\Z nM8Gxy/*[1h3է~ˁHEuTʸ"BzK¡L<3G >g;|'}k| )_9nW/tbowI$bCdYlP;R/i1C z(Ug:mC2'sX0A+… D_0{k-j! s54Mj}C<*s(@\dnk>\"]j2fijvzx%6rXTp|ZȨ&H~DQ1L,H+$l_6Ly kWT*y@H"63FmϨ]U 2!>.Xt}ˁ8 +NT|m4 ~q׷cܮ9O'%OgS\_p+_ ު9OљM5_$\^yPH{VfYȭH%rdnӝܫVZň94&g]N{VA2L?eW Tԟ VrޗGE ^[ -Y$,L- j \Th*Gh{VvPo;BңR=ݮJֽuj &n^UvVqEHZjޔ,Ŋcnsf&`3̴D >ʼ~[3Uxn9ArdRT-(bqDEhU>yT%#];9c){2khy-;yX>NTRn MWl=4<0&-:XsS?7?`ò*TR+VkPQS@Ŷcy_tkukpu#'1(P4 _6,  1KhC39 u RdŊw_2gw5֜ᒁjIk,Bu&3kCpbg&'vFi ]d*Ḳj R9\Ӧ?FvBel]ϽSDR uK~Z)mi%XŒ ңKzF#:oFS tyX`p TY)C !Oϝf2놆e1 L%#m!eSY഑E;+zn4 WZ`gʛpPbC>Aތ#ƸNGx*.UwYd&Q &R+*HPW2A{ tRP*Q@gl{hv8h"LиK>zbY%&昬ZO הꁇBH;s\7Q C'Wi2&'^=O̻ =\\K̴1B ˱ލ!5t5, vl*Lΐ~>;a pO=nwZo3?L6զ0.}xrQg5D<6KNBhO,hҪXIͼyܮ|l45qL"@Cn[a< &pd鮓ULe"mF$ܑqb(%OA6R1wF$\dFR >E}07M%cQFou1mףXSL lE:w*}o|pųaLl8,͌ OxTo$SS-#x'IXw޺oNz'SoJeP3"jSSͱEow|]twNRyi[ z`5:Rꪎ(z3Ƿ٬|N6FUc3(LL%{!o9L{)4i]&qxǁ (/ N5)ߧx[Q=w&eaae.Q#)]w`U|\wQu¤ ΥӦQ%}bR"]n8!W,OcqM{\f{ܵ24;LV 'c`Tt^5(@Ƈ_eOjZLwI{w u2Სq@'",y)ܭtmF9ɸx'J/0xVϨ_K%xse"2{_≩s/>ZyJFyB}~uw>LU䩰@NM?))VB*֣T+˖K4pٮ.bd܍ O@´Q3Ì3#%=,'7p/qڔ}YȫXyf A w(IW P2ކ{庋4ql@AX S<}.z{q]Ves?$BZ³ ,0}&y@mXJ l\ʣӌ(UJk߮&%So܄J.-Dpe2n57HĈ᧧-Vq^|=_ˬ/a5,}+0fݑ6G[P%qKڮԢ y502ˑ| Z!cH-ʸ|h8Q5]2rs,T1%KZ*.*PZWO*D<uFڞs ̔TgLl,)qޓ=1 r4jߝk\U w2 Ŝa4bnGN72qѪjbq ًLxlp}x7pUm z(֝-󞝚PӖ3+()p۬5 |b>ov|GOz厳yGq~%FE<M20ZE՘5&x n.+%*i+8b{gtDCRfjz :~+` `TdL}3ԐlϲMXj\˷䕒(юV8,TpMox[ լ 3{C;nkώF=hTr :Mk8̀A% ' lۧ(" )Lc" bВmɸkxKZ4CԿ9LR"lp͠7ck%S*RY59Yj̟륈4B$ӢlzfsmgBVq57֪ZGH_xeL3z"С6aVYf{ iJ'oSx. =C,A<{_)Ǝڪ}t~ V^ 68!6f\!OS&0*~ E/^ȻVh#j$Λ_Y#N5Xf oyU9)r.Wa5l! 6mBz/[jqZx|O[ ?i\NçхCӝz9P!7/>ۏ ǯL0MctUlz.,\$'*g0510gIh5i樯dATE>A0+A78Q[p ZWxO, 8hXih!^.9o`#$0뗯bҹ9&8A};ǫ:y 9opnuYia^%3<~^puߞ>FXV$%+mQJ3 %v\7?Gg!![d 2CNF̙};䰊 ^qN+`U^7kUO"$= ]LW0xCBҧڗ-drOës`ΌT̒5F[sfż\6}*lG{U.RtC֜}Y=*#vGu dxR!")7ȎUpTܭEa&>2{a[B:n^8N͢2:m(ݡIpjP^x}*cEvjbgIJK,T21w%[JB^hvT5rv$ꫝ?tjs8fY+؇st:W3KN-3wE+~8hbpe0!BO5riG!8ڼq`f8|y'7Mxv]wUMJymIthT-]u͂l2HJ kZXgCfi9f)a}EĈ@B,hD*׺tX “zل{cqQF|ojڌ5X`#ux@8YLd=&]I{z0vv3Z'+>طnvc8ryoyV] ZT zCpYϛ'L24@[EGMw1?T}Ϳz뵔vͩ}k#xœQOAƾWiMHB)SdZ=pjs@tSg,YjotF} DJx}.8^.~Թ̰8ɒPZf(٭Bhn-[H8!3Z (`<#y>k^-Ҧ%.ka7haQ6p"~>o>xNZge{=B$ [7}JJMꌪU}6_IJw90^8sd`#kVH=bӑ5_f@dG5ۏu!,$Q=ks4`%PIxfBtͮ~gY$}q{W>.'.[⍃TFy_:p~uJbþb͏_N([8H!`^x)[ /MY\|J~lmitsAtg&sigﯿ`ad(}V| Wka_$Aba5>%rdbNpEFF멤!K7J}i-z2腢q9.Qr۝}g6% @_f\{.7FdeJ) 4.U%⿉DaQ0 F%ETtl鹀Fʊ~M.7 'pIBH8 ;ILU,DҊ{$5 ǂ(N%oڰŋ`0M p3\KGSRlxk blZ ó&j;>ԧxJ3=^oѥ T\~Z̙tLb8Mngb-ɢ٫sԋa6s48Z b!9'7 aM71QeztX3RVB-H ˒zU7)Z6*0[KZ)P% c, HCKυ >:ҏ ^ 7 qV۾ݸ\#ܢ8%(Kf۪&?)Gʂ7; UI [,IY ^8K2(Q]՟#yE.x^wP^OY6Ivt/۝,}/Mo/EW,ۃ+L*m FKЬ5{(dŰ40\%d-6Q4EQ&ٚoe1;ijX[v)zX M-lM1 -ҧ#v<.50Q+~= c8B{Дk^͌W\_rCߍy0&s_s?24gw6W+aӑs nnZyf3q 5~U׷*E;̹Jf5SM#m(W%(9$(i@Զ|FfF1j$mL/2pd C'̅Yk6승P+jT0x=T+~9vK^#-S1+ #^5Вqɯ$5O7 1+kj{^;+HU/K(~z7kyk[)vϻ0ShVj:jGd[Uk/bd7Wydo l'gGqZkwڛ!J=PtPlE`$hسAFnM ,`6t/jS+xAJEv23F͠mE"Ӽi+%-L ",4A12*TB Ov~&3 u&$J35Nl/W5vWmb18, SݜZ)lgfJn7yԣ™ܕOϺAB]~WnX&h)5O/;FW># u}ʽ<?q/ ?ƥ&}QXKOy?MG{COƞ;S_n0(`NS/k= )B Z3r3-)(VX ae~ӴxP)%*~< VFB \ec§1+YW-ڵuRlUy]kI k\NDQoLTc vѴV>>*V P4jX5*p5YK?5bjg|a9_TcR#-c9Kl/ÆUfGk@FB|]c xX@#d/yaսc~L>ּO8plF#<ޒj։~xMOk˚DcJ坈JddD 4n'E.06ڞnZ&vi٭p!r  ng؉&aPq: o5$Ng, Z$6\nL>'BQfHPU`}j(4hJ-y 3pXlqiQ *)VCТFLn B QmiC*^)~>Cc*TsEY"Vy' ٝx.snه >+v An*8 WB0d1R>H%EXƬ}:YMԹIK9^w-o iH#,Eܠu%p9gwSIt@vMx|nRɮ1{tnnueZW{-s sMi.VQ]sJ꺁%=ʐl.{+caݤ[/XQҁzCP,nQo&TjLjJOoB#G|~eϋ;|j'9=/=_?Mޜ)'2Q9J+&*nAFGo0 ѰvEn(3 ֠{ޖS70)خA 9&o+k,P #Ȓ:zn5LbdY,DniMw>Gs0Bˁ AY2R kHJ$\6/Qsak5\a+hßjp[7yKbI>ɬX".lJN璬:K^2%-V/ST{Z};T8eNQ:PSҶjWT>_:u>soV>[܎]ҟYi?I v|i.ђHг>~KǬ믆KOu`Oڧ{Mi۷YQ]Wwig}}왞ī9Sg+isr]d9Clk_v9O Cݬ4 D'yW{X2kI7%Q$T=ϥ۳pͧʕ:]o+i$;a̿WTj1wy B%yǭ7'yOj9key 5vNyF38i^V7n2ț>)Ds9HHCxK,mr%p:[C4&4'QkJ̢ 4YQc-.j=Z^j>5M؃g6a]3S]al5{cݳP`;@jٖo| 6.Jq*k~Ͷ}|<67,Lɻyr74V^ɬs /cV=hW"w8FݕlSδmlv|nb]*mgd7XkvȞ@0oΊ<J Ls O$4h#/ >VHk=P * ~}`Rs N+ml/DDuьNG%Y 'ػnjyNjįo|ի.NS 3_x%6.5%ʪHR4GuV1c6g1ϖ{="߾H-Sĵ?=_g!磊\śVn~8]0.JU85YIf8?cA ymbcD͘k1mt_˨KlwT}0,jK'< ɣݭ%X1-l4d #erdYE "7w;C}G4=;CGoG >,bѿdqKD2j5= Q I~mLYq\<Z\*F@I&Ĭ>sg9ZD AEK4 C1[#ljRwڟ{BۯsMcDzHRLRe,^i=LVxMv$ R.MO_QH4[s5wk_,c&݌ BWyEkf~W0;h3SBu!6??sj}Oq<>3qνJ|W鏽\0އ)=| vOmaԖwG Y@.!;mVO'N*y |qOO"잻~-~[oE:c; Mlml -\hׂw7Ho골Ɗ?lړ%ިrIIE8'&;+RJn^V xxzKR (ܿ#_Uc.}U//UcU&=]̢Xq8%S Խ!vwnIb -~G*VfGs6%:;jSUsM'zmpTqe>~R_A[tGxdVX n_v{Gw-./cӴ jvO: AM!}ˎd1Y$ƺ %4n} Kֻ^c *I;_vyնXӃ݋q^/~e`{8Ht'F>GV7&=G||z>P U~z0P(~sj.Uv$:XF^#*B4-R11x11Fo=>RC|c>R2[1ZFVHǻ[+Mh6]ٛ6MN^ZMj2*Vk@Ø[oOSW9\5(o,pᖗrXB 2pk3zSQnW(/kc/%~]*o/40O7B=#nR=}>(b6pwrZ * ''3WG;_Zzbz99RJ Yp,U;t9dBASso\{ҋp?!}{P9g%Z;uha'L*0G>LPĎ,[h$&"\{yn}o[򳰴][qqXG='׽b 6wy^ϳR0gxsӾVNP?J.nFyS+ԉ4IB۪R9|;[60$m@KѼ}v+o|\TE}(:SZ?uׇ_u3k0[f1k=:P GggGRgC𤋮Fgnvõi70ב/Z#qH#GR.gǧ/+Ŕu/V9F]̧K2M~z1] $pGL)SzcX~{C՗ vdΛBwkխn_u|#1m wSggkWM!__J2_]KvBwcӣG0sn\.m] &\v .2M[R9gVy>nks+.Bv7]9&-ѤԄ7DE΃0l!S ZG׊ERJ@BIQ(l]l;s~pZj87i#]GM;I&@fU&bwZ8`(טޤZ HL1 Lk[=!K]LMOrCB;Dk]ə.Ȣ,e#)F{uvq'nrwOwɮz̖mmULJ%)d_.PkMy :>D[EPZbəQ=Q阡rM;B=$_)g7+*ܜ|wKrQ s_8QE1+ӄd4 y|67V5U2ܟzjd.bwR@VJP2K6e(+cQh:xXBM L*QړKgc`2 X1r6)l: x} hs&j*US:i/Yd "J.|dqO#.Zd{~ys)Ck~n_,VG?= <^%fåb\"$0!>rעld4WͳOn/Q|c8S{y{|ڊAU|;&X5Ĥ}vHږ[H"ɶ4?07WHm/-iJ_.n[ Z_.TCcgI:JD V<ȊzO2\S\XuE`P_φ4>L^ueoW+cu\fVVj tv $Ow@MIkB?ٲWWSg>ΚT>5Җm@EUsWoE}j,k9M_33)fCN6y VtHOЩܷBg;߼Æ?fva7:q AIXSGe|TsZLv2a*>fT K@}vweNM#)B6n{9GYyXIl`\ nb]AmX|Wh -շg4$]Xm[#eÛ;- )kF 颯Nf؎Xy4kXvBHq~KO ?åU-6)z?Zllp:Q6o{COF.O3>HtVa[iU"Y@?ɻ]^KU;:r}<5v]S{~;ky-CO+p?Pϒ&#* U٩)5jQ`S}Vt'W*:`ru&Wm/Si{w7A 9aWIۋ 6+G61(dƵa ]y޹VYe3wW^Ŝ3q1.\0nu '5܌6*_ةPhSoڛ.]e*E,)AStSjM{ʝKI9"1]Qpy{ '{cüxeͯgq}N߮^>Vt.*K!Vj/)0XvhPwκˤ,V{ o:q^*?3x } 18iI26*ѷ`>m;U޳jKysmRWƕ2\K,Pb|^ߵ r*1c!beguYlɺe./)%âoM34XFU&RI71s#P 4u'Kچ$j*zL_~Ret6kشDÞzi:^Nf-hx :[[IvaI@/wp1C{[<F?!b`8X!۩xsGKA_U?Crspܾ?n^%%P0]AԳq7E[뤝+ge +;(5|mS "VKJeg?T淾<ʻRapw:k\ep)8Tqť]= M'bm6<ql84"(Q {de Jf-?.«S9X^DOOKUT2\gMWst}MU ;7Wgg늁17?k(_Kfmp3EWOiCNtW3yoB|pX\4s:T<E%}qM! wx2h`Z(E.Ejh}>y<}ۄ~rl>6K;C\p )<7ZѠ' )fj:qs L4tDw;`_)JE4z/@= <:u4udo TRkԲ<=>-Yy&z| ':jųdFe uP#2e&t/-ZZ  0jqœy=^KCZ13<7%=bٵq4y+4E:6*{GL$Q1 BrD822W1XA ssfBbgSˑf5_.ꍪXo0fݥr2.W3{m9EpC(kH6ոs2_5qOic*ڙt;:3<:^aً]Z)2_v7"F/a?H4h^oKq[or]0/xDvb&T7y S#h3ݿ?"Js+J pĻ`quvZnҶR$b98Ӫ=v>hfg0.BTM+/AձO Wa\SVk>ǣ-?6)궕]h|Î؈a2Fe3NX +DWpBVr*梗(B3\'OgIy0zz48d==g5c;\Fk Ȳ*r-0*些EJ+Id^`"ZjFk6j:}%wGҕ@ZMC 0;53b) o}(AyjƚȨh<ؙ3)ٻ}|F|eq憮_FoOYLI xHCV^eu$==ouӸ1-B3=nX_Ά69F ŞۉW u. 4V9^lбZy$b- e ;qP鮃9r죕{g ʌG \Yf2 AƜ{NI[ѐ+obt&P =6|C. ]8 7\(ꓥuX]RW>D99OgrW^Und|l7nGg,g!Z'(T"wO!*D^i[Wg\laISΒctiYOCH23E\_Ӳ=^{x%By>oMlji#<;&H.W">T Ƭc?jCQYzUYD8uFsg^ˢ]EՓY@bi<`AVp"S"OM-! Ҏ *Xct2 C1&4AbTcȴ(Ûzpt F[]\v^?/H4< :мˮs+k9Ϻ\%-Sվt.a _%4x(]ni#nݮ%DVW'%8Th `f:cT0- NjR%Jd] OAy3pGȟΘO\]y6yK4#+ lxאְU0mԅ(Zr2_eԽr / o`l-?qPGK?14u`r5Fgǫ[;v;CFS g??^7kro-|mZ!~;/G1{fuyti>CCry~ n«i+Љ&+fjUMr]VƲ |#.]YxT2Pn~5%x挻i‘yY, [M i Jp@;9*hgS9"V(kW$Ǫ]~bPGPN ;Uߩ%Rdc`nb%PyA+߫C2ƏL17/j>;^L>7D0s5ժAT͐Zg;kTh=KXMuK2LSh:6why;CYQOđ9g`ј[9;܄z׍$n#գs[py3>dcGI$_fF%+;ZVʍ1> 4fkD9yxLxyƞ`/p  +!,N⥖/gDd2g.~M\ϓEbƌl?-E]'=%1}v{xr1S߫t4"ҩmdoک?.xr`x#c-U*l/t~:ќdM[ҿ&F0Ԧ_sT,aA\A@O=Հ[ YqY51:\، <ZX k-.vBMʯvu2ͷ/#96[3ixb-ϩ%-0](?I R dԮ[۟3/;76Av^~%|B wm% ??ŖtQ#g0| ^ ͌?wZ7&R9N#3-#N $b-6_,!֦!Pcu3XE@prXْAb'|p$xXYZi \?dQK>X]5˕uRiǼ9Yk9Qe/g#KFrd3׎?ayIbx틁:H(R*lnm(دmDNa 49g(_Y)Sh񲽄W Op;5.:$I)'fF{?4~sr+Q,]X )FTtb+)xME놓C\O%lZh>Hzd2̱\??K_,v"lfJjK}+-V30s.дg gZ;=\)N\,hvRל~_(Z \D$ 's'QOx$q&e1\tד;+yrSo]뛙XC>k3gͮè2* oE(JW\#64I|EVcd;^LE|f#.C"$\3@ $A\L6dl"zC;/CFRE=T"7XЫf%O7{z% 2v ]6#%M8md9nK}pfWД ҷ7*xي,`jo8kX`u6nbhJeC1>ʆ0b @hxe=TF|9e>+1Jڵvd-`]J%H=QVdt4~D!*1;9%ls-oGW'>{CKWʑD fvO}on2F+c)NeU*ٖB  !S O\cG5Nip]SiZEB9 bIuـ `>\,h=*IxJdca& δjxF3lz8~tuOMRf'sVV-ϾPȓ=L땒jx #90_1,b]C48w1zt%7pU덗#sQcInA#(!u)hb195C cS-|9ˌjh;[4 x[ZDOuףpc6S%e7Y4Nmg=#SN[4m7(4Us0IϞ>j_^[_?7QL.-#E;&-xdE~ZelMT2^i5>=YҎ u1__0o,{L`<:~0Ne;c}}4|yJs8ְ>U¤Bɤ#P ڞM.T8tOAzyt-g,{ ,alaʝV;<$Dc 2!QxoVaU!lN`jxVˆɅ-_{LvM>yi>GoxC*'*ozz8I ZrUzƣJԇqTHWgI5"|LmL4V詎_kjI2HRɋݟ=S~Aɒ@uEw(JVح&;YBNY+1f[7 SX/k T"r\ 2 ߱s Cba $l↙⚊.cKLn5qh| /EVddSR>_wF~3LFO=IIˮ6bsQSdz\q> oVZl.k!-eZtfp-YiK^#uw&fx!S-}y.v#l(KP&lRN”̚7ˡ5S&ASx* [Vmys/̔rg؁꿺b͂ 1% lL(|IXV#596՝չvEVk4+jrAe1X'"8unQ'3]5^Ge3|}=V)Uo')4HM̬"J*=Ab$f%E׆`wo3 ,!^Gîf톄6^-6m,3(. ZUyϕa4c֧*ľ<;_JuQ K^OA4,j{WH: J<4rA暙,paCU%,G:bҎZ^izdˢ@[NP79p֏ϲeoGO:ߙ-04j[ jx^1йs`8tZbd2m`,RŹ813\>Ge]1n( &]h W~A@D0a(vertFM7߯0P?@BotJMƉbcwDKq27ݙgmS䪕IrZvGh$%#!APŸk`{[@}4>V51bFw5Dw/aj\LP SǺū5ILfdzzO9A,Y_zöZ`)_tio)yDnjt]M+yHyX&v$#c]ӫ.ǶkQjm]0Fc[HzI[2-]fb e c|\o[79c#]÷h|4Exu_$}0lU?yT~m)[ILl6Q@ÃM@n{neN3Qk@^d3-V:z3\KZ5u9ġEkRP.&(W'j<ܙc;7'KZ@W &dvϓPoM8,|5{QǢCۻ>$wcA= {|X0:6m|w?k <"a,#(/i1@2biNNΟ%~rKFCܴ͜ l~6& _Cz|D>^Q/s-)TcL6 rv$8cUsC/% R1i2Qz!-[.95(}bLeeг&jMk8~KsuV&k{{>[]GhMDeIM"s D=51WeEfmp?.GTRC86 ֫,툔fȥl]L(DB/J2ae"^¼ SsB9sUbrs lIao YVa?) m+[UշVd".2zNXg & ~>!݈kIO@ϋs_J#Ugʇ\ %LbLy놜=X: )Nfޕk{D5+{MKsu ާ;| >tbɂ.nޏǨM:-0'Ν=>ؽtkK\[JBPim@,^ܜ1dgc~]^#E.`P_^)X&XbSv@Cb'I4b,׀3Ԕ4{YlE -A!)eaG"sy)Y?͛w# {Z:>g-nfnS կ>mxs-R% ;{WCbXSio^+̼oڅ+tzvȴ:SAzA }|YCq" 1L3i$IbQ-P ëUcw6"[հ`]pOPmAΆ|d[F;p욫YDXE'<&`z6who8dj2[=*M)s+PgF6A~^j͍j"ʂZxdCqA/LҜ4aU Wi!3gG+Y-)ӭr8=9Q0gt& ߛQĈy̡p731BWm_n3r *[|.X30;O! T0@@ E`cD35M58: Rhݨ^=ar,m2yVR6r>(rxu,TUk\b{rVFIbi3[ I|ҭbY9sͻ0/Uz{nܣU7k%di8.+wa1`BtUBA) #lRw41U4T+bs36D42`Vb@7o* M¡%nSQv:dR\IʑG}+mGnӠ&Upz[K@_duĶЋi!ǐpH :a+99>@Â^Ñ\d^VWf:P?5/8<54߇sYg5kgFسes؉њcݙĢw!L"btA[7v5Ob{T]^7[vǟ űywE %Hs}Z . KYJE.RTO+J+JmNRB'u:j1b 7^{!p˧[Țu Z#X4iUzs[y%i5jb|K ކ&);4uyk\s2aTgi-L2cԝV슅`]HXʧ1r*32M˻VjV?.@\L"AsJb bqa <~zOQ~S֊M_<(2YzЃYxSvMi!E[$-:pNܻFH$H݊:pZUYYȆȋƿi VOG1_u98"и>J2Hm!Ojg#3BvkWIVO]{(]ƅ[Ud:PJ$,{"%w)w-u:uHwve y0:+y:.FY<,Țqf\D5 ̛yxҸe֢dYTE6w9ʅM& ])wߖ|<MXyW7+o̧:qӄ{wCsDt>o_ʝhdq^rJP55T<[# i?=9lM e&I¯-պN\DrDr +<U>^<_Pk&j9?ONjz" u76Ҝzej?0D7T"t _TշD6<_r!b,>)irL~HY/^pp]mζ򔲸Y#Qoޯb9&//הEl`&Aʚ*qC&.FgѤ',w/dq5_Սډ3=34Nc|:K|?٠i'R~m btJ G)/Y* %+vL{GVͼ=e >#;TQ!,LT`3)N# opbW}BӶNftuJyf¢RU?50=aV)?<+--G80.=x)82ةX1{Kn4=M?SUg5˿YO04A7ԚYԎ+-m]WZXM'G4雭#ʒ'C57s0~|}m*#^LL.Xiss1ŤoAḙ1f /zU._Zhk᧼j [67ԀݭVi+9PZ8_9y (_{'qC| ߿I|%>Wʬ+FLT|[~0t,ޛgΊmXVYaj1~E 9W$hWn@@n껻(l ;s#|W: +_#S|S!h c2soJusy<Ԥ|yE̿/OG^TkAX`ʲu X(hy6YaKaI=(*pl0spҠm@C#eo5.GPFIhHū{9B[ny rV˨&.m .ȗQqR2}yZ1;kr2ӭ12|j_]ZtWb]~Miqsnԕ7 ٨Hjʿ{`cl+D#,)<Al2 {1]-![%,Q%ߗ9Ts 4 CՂ~Ks׉_WEO+Yw\ `A\؁?jEe'Wq(3u릶FxJ@tj=Up~ `y9mn[3YBXGnHex<(K^Lrw"mQ2vVx0 cL%|W:eyB']捞mˠw.0DQ[!dynItsHb ɛKO΃$0g}{\[fK&+lZ{ Z}_<3H#+w ]TN"ro}_w@ h0IF&[ܲWC'^mW%LX[=ѧ|^|K\Mvؽ8.]5YUaD٬ RRIbg ɤ:Wn>T̥ɦBNP=?}3>&w*ro9à@ j/G8MJqԣYӦӯ[|ެmA; 9z*1vyP X+ p'ی,=lW /pܘ~~/I^gfNc,8?~EE,Zh4zO1OVoT<]0SDM4YX&RzJ\y~_RF XɖC54>jcYxG1Wwi?*kEr0mC2+)45,";<䪖SiĆmSSc3gx_yUI@n0=PljsaleMNi@X[oVA) y2E7Q kwkZ<.'hRLSrW0CֵUDyмR>r6$CX#NWn/vu{:,eL  ?hu4\3՚L}4b7 7Ag۫ΟyoLo7,lܡ+NuqKȃ/C[J]:~vVB bl* fZE=Z480"\,|:mX&csFx1&a؟dܷye^ӫ(?ic}^'ƿLf\xXFyHK$Lm-o.< r?/]38w; Ȏ'ɕn<, oSAfaZ9ň/:O]_&f: W81 Ob\m$uH|mx_sГia"Bb4MQٷjSOi,ϱj/lr6Xˆx>T Erş.t$K1RუYZ߆~T)s]!hmM/6ŠN(eO3c jm'.駝QqM2?Ϩ>D YvyDCH# ܲrc;ۖ`yܘ81FkE]#8٪bK|-50ĥ[9}X FjTtBb&4e99˾ѯacuwM ͅ|z'6f[!!A6;5"Z쥿8NjSAMxPȰ5gulNMcv(qO׵}Iߥ:b3iϝ Tf ﯯ}QF,-eC7y [0 bUռe4mē{)6xW@$ JDjV]g7rT| Z#OOk]AޫC֟d)Ή|żˑ(m]m\k˹Wp3I lS-Xf}DnJqK}Z&~xy%hHO3S1'V69l?s^,|DѝaٳgԿ[H(FgSnWebS沼jaaYfIqblH3 "ձM*52⭬VS[ٟNyO f` :p/Ӧ !ʾ٣?!MT/V?ƣ d(G|xnLYalN8d}p$Yɠc`qun*`kH~n&=Ȉ`;0RIqn+kwüV8 l],*RATdJY@йEl=-Ihx琟&W&Z ͿSzt&ާ֑A,u!.EvL V}[!q=.Ua̜3Xa\;9pkew2vӘ+iT)t&,?*M P;lxkUQ2|3+(u,F7mSP Z9[?~a!wM'ь)@0>Pm5-Vϑ !ZW?FsZplyG=fThh~a%&i!ˈ$ɆM.P2Q%b-+v V@4p-cW/6ـ 7P=xvlj{3icRWzb^bjZHW:ED#9yNlL7tvαwM'nn;GIx Q~}hSG0M?gs@/H띛 ν5 :G|pTM9!3 *o>/fmj9}Y =V7DzԸ[4`ߙ10w~|zV[co/[ _98Tg#WFlw߻Lmػ`0=co1c$$˪!&}˄_/v(>o4&;S>S充$`sΌk{t3lei9uHX=FYkֲ\l?_93S pRU @pBt$EjLZl^2Ca4z.> GLвRk6WM]Գ$<6#sXu9sUgˤ&Z'LZ c? h1,He1GRpQ覨;@pVg.ZbcWֳdبGÑF.R-lDV>yiEW[re&=5åλ,Jo'b"L2iX<]#ަQi g~u;?y5Ft)Б b&{K}1~X0 x:&lUW_jDHؔ2R]D:bZAJ|W)sp@a~g#ԛB^^Q Y,T|2硇@ Uv,s)M+1\{6ܾn%#"{__~cz}~VLSvJIapu2ЬYڻ mq.81e.m(zAզeW\jmvO3!~f8>>SucZ5{>=/Y:W(:ͫ4qܿʁ3)-9kzb1niSє֯MVʇOi@'cA#kqG&c22A=.g_kl߻{A3׏9v[oc;{PeAw˻M%τEmzT01f庶1+l>ʧ<'!p(DElltK;i|`|1~q6xEYѼɟ݃g=IP^+EuҤ43ע AQۦ&윹,pyGG\Q1WA*q͞AWv- Ȅ@F) <_Eo?-;^TVP#y~_C]ĜWiQ՞/~s>o%[_B:>󼄮¨4qt4W.~Nx8Ũ2M^g ~y` >SpmjkJ%JU@ V#n}HVrfuE5`wJXI @ 052/Ą(%Ԙ臫l{cc" t8*o~ۻf#w24WGcɾ8P{Lb3HHC  !t&4B/?w o%?߳Ape  G^Ac< { bn0ii(T!!$|a5g~ eGs?nsυ%eMFmd'92۾u{ Ub52@ )DaMYYfZ1]-4^HQ=bz wKuǛOsɽ jЗ_kFS _P_K;!mk(H\!GD"ЀIoe0opZ*R|ax(sd<ݏãk*2yvԫ1 35ܩhmJZ|֧ b2,v|t5K7; `ݎZ٠k' |8},T6+/Х t{lf O>7[ʔhE y]@FyHytXQBƐ)ڔ"Ar"MqIQ`]VYr`Eg~tYC^Ra]]/wi)J$%6q|| Zwq71QJ^r{>z<Wu̦T#u*4e-i~v9SWhԭDJV^dHjo—ѯ.} " L‡HfJe@@)CF'Cw3";y5yo7n]8 ěcv.\BLo͇ec cj'2ׄsܐr?YUnt-9 =57K '` ;mN14G)2$N,(4q])e40u Kw}p/D^GFR#Q!Vuiʵ(t89֬Q42媎ta+nGM ޏOB,E5щ~forw%8A4 RtJrHޚOtY@n`q'εfN7>*V$3v O*sSDfX8dI/ZdElZh^p\5\W"xsrx:zku) Nd{dM?( $OvI``r,u|WL5&=]E^u8#9N Lqw(lo\KLlSq?``R-- p&v@@m,O!;оqmc$IMk>АV QsC돇[Y⑖aj?OSZ:?̖a`(1IU"e_K0>Ӵ^ct.f>ÄY4.8+j{̹Wx Ȕ8-fg8F Lm>P*$-~{WEQ$4I FFu7; Pɣ?Y|.ʝ׸B0m*+#}c Qs:ꄁ[˷)`g {qd r+bN`ȝT48_D;"jN/GfbJ.AruT(a2`*?gVw u T|6מTƢw12cx&=SiY3v~L9,[!GO+|?-ΕIGlʑ%-]fhNV\_&XUElµ qeoE= ^KE}l-jxL8Wouʏ+NW'F+I?iչ9&[P=}o2u'3u$%0(!™il594(4^jꫧ%(V[LI{C0g΅B& :&|RVnNr, ?W5e1Y04*ҼZ^#`ZQxQ*@d{, 1l9ؘVY0}a 1=iSf,ҚŽɠ-n5;YI[%EE8ďn=DH&^GMJ"8fkZİȟ.Q"E`h WdRCяG?TtwŮ4[ěMkC*"<+% :g&o] Y );ߔ=cKu|UN_wUǠ jUA/ 4 F);]#!p9d}jLE۵gw{3+[HQ\~)4Y1hf<]Y+y BZۊ98/#.^=9E.̢<8vGI)"pA֍y(KRO8kwMFI(015\tO)JHS/5+nb7\ L{eyM獕Jqn*+e4T*q̊+t.( )܋xZT=eӞJ?TGZ~ 58~j s|MR&cD 3%Wm*_abZ<G^Sf][ĥPtjw&Ӧ%IHl"Pxivr0@Mmۛ(5%.6+w`z果1Yg w|#VneJ*aLjOIyr&:gR1xC͹1.2:nÊ{"$t/H%,(M^.}l_/6WE3h:]L0дWIi}VjG 8i&`hY)xu>5.AtTڮS:<^d+@XֶL7^FW`GZ|(r']$\߬Lާ[$bHߢʧ'efS|^Rqĭ{WzjA^>3nǿePjreA<8Ŭ rv[q[Z׸+ _­b>F)Z>(P-V /K o-V)1I7旞ח!b6| ĦgQK5Qbkb|{?# #vlDgd,}5C7Cgsy>փm Uƺ&:לmֆ~^Z 85&FblLnx@y*8ɕdH' $݀ZCSNt'2Uc->͍e' Omb~䐫ldNQ3^Yq2ϫd*ke՜@F"P<)Dz|g<|_Q2ݼO'EXCrɤm޴ e"˙{{[D)&IVMH#XDJʃ+XY]UBE7*c3l_c0 ؏8٫oJRum1"LBv]/}L䔄/0p^=~ԴJе$1s+TU\2w[iHINZ]OK\QgQ쯻];~;E1=yn>k~[FEA ._i@Z :aT3 `cOIPbƫO,C㠥890\]a5ND$\#ּAWrʡmZ&;#aȲFx#T8rժZ_jFA(BΊ1P|ׂR7=(y`^;Ê8Vulu2oi L#瘚tIFgG$gNߏ8#a륹Oof0+PC_i'qiF̃cJuُIOe[z5R4б;b~ *CgfTx, )$\<VN-FBMY?KYzy#jպcj#w뛜g㾎N99ʖ@d  6D3媒Nza?]q T6b ;_LBA@x dTrLnAYݻ+oN=y`5Ӿ`@b +n+)r]羻4uꐛ\oP,R9-lFPBLDSϬghZi\|*e?ƟGÛ:nzި>Wr(ݺ݉e&Q2^ Ԛ%1LTRZ'N^Q!rJ"VO,9_%S- .wݙ92jwB2\?O'F2]槓Q߫e ni*4mGѫOoXXfүxٵ'ɫw A6ov 2}:,GTpNe?QL\|Ej^ڍ>@(B^rʭLOJWĪ,LVZ6r\R=殆UˣmGi٬yWTi-FCCzBNx(ai._ՀVQ"%b+x%0SõS̴"{"{@OTO_}:W}YI}2 $Q2 Tֳ)p&s=X0 lkWh[0Nfx3ZV6IXsM7'S2dԍ/ qcuUs30u̳gK]ν.ERف?1 w@i&+WN|FqYCo,¿֏##I%Z,2}[BQZ35DǰueߞB߱]MzT8G ;mզsZ=V"R4c11MvM4ZYh3\|X4mw}c->{Ѯ-8PjZ2Gs=nwks2Lɷ&]Tܟ &=qeJҕ|w73?Z~_;4SPܾ^%\.:_Ѐ47_K1;'ͪobZu6ti>%YGOIZ(Ʈ3g [澯ݭYڗ:(?ms)ӝ@U5]ۮ#3`wҚ]{RFd>S@_~W)ΎCYI2u?ˋ8.glʘ Ft_j|Q n&Rn*0Tr~ylt O@NNU15'h,-}pu_ 0T1L0df,fE3\Rv, s_n=/q,Ӈ8 g)t}8yv~i|Y̦h{O_g޻,RAAݖ b+x`"@.}:pSs 9Okutm'Gj X)Pe{9v΃ȑ ٳ#dtm͒>͹|Ai-|@/ɯ&]ջ Da7O˦+FSp.]/ Vf\<wF8|^BjPlt1;I!%րY]Ȃ}@'50}ӀwPcO}0_ZK_$?SJ;d -_0E|f Q?֧ Dn GUȐN:V` V> '޳yђrxapGo-ۀV^z-Bw@] V %Kɘh0X))Vnq_ tjɵYc-wFTbNy\UX)#T-}GIKwx3ӓ-+ mVU I}!:{\~l V/ܟAR+]O/\LU.U8cȫ #:azI4x4E4oө4hJ"PVGr|_?jՠԀ (cE7iM%[%l5ޕ:WY  b?!P {HH>t_VOih)p8eu S& $T,qD%p)E/d`Ly&z'ǵu0فqfA@g< ]@A%$-K#:5$Oy{:\#cg3NC3-Re8<w˯jOmUs/e hֈXAZIw Ҋ*Ç?)p# CSv @ 7nfn7ds?r3@s!#H꿋̀*R"?_Ѡ4xQo{'ǐI{'u$x?b1/Xy (d *uD1hÀsaji>>QCk?(:,- r@'5jc%CyzS==6n yq<}5J %E8cЗyEevA33OO+^7i)uWA-2%L  NPFOfQ)rA@ҚlBMe*La3pv?|NGik{'m=@(0h,P! #@$Ӑ[:XbFaA3F 9~QvsLnCFrk>AJSd02.@(3(Q^}3T9 B>].}TMچ&TozO>& D {L3r9B*//@lR o.N2f_sjB7)r,Y}5MlPb ,&BD++?PH 'M!HK!"U^SQ<ē9Xi`Hu~6 ӳxt%\*/[LR&@KET* mE$Dϗ˜t_`>ia+[V qkz|gY*(d#(\h*)5p2zGPJ(. ӊ6气@Nއt~Ns ^:gs5;\ M  7C_d^(ĭAO@XhDzi rd@ :}@3ߕt:q|i`ETsLA`4JE٫8<^U8tO670YQ>|2|-j B,}vl 310p%Qqf(pH8R--C1a*vS=?o“x xhP^[}kgW@ c9Iq${6߀V9 yRg%lJ0/^r⹣y-z: 8T<6:QW nb.pa  <ǗFl.Qd,A Zrzt0gɑ,ɧ$*i_ˁk/F^mo#lJ4 hD89b0. ,O_& OUiF̈"qDmGA*.q^~N~bn02Ks5e<Ӎ9P 1Cěpǣ>RC5OyZJ91RڪA?o>k\f;ـ'LQFLҭٙ9PS@@TIT'PG2%#&\h)fPRӇM``7f+\zrs~ )ǎaF'зgb4 QrI8ViD52$$AG34cfSrgSȚS7{%$dZ5NE2̗) DDbPrH) TTJLbS!JӓL4ŎD0% Q6UOY~u>lM{?t\ڕ(8㖪ԠǖsJy&!$anGS 9@!9t&&Q@)ox)X5>q'H%-Idwpn.H0>] +}_CW * ="4:w0ʱ ڌbrOjj c$#A*N,dg~ TTDC/} z+retkK;}T>?'~+_GۣԟKBe{fy  L,QJ Iв%1 IMf+Z*bV4W|a.fog/LrmLDx4!X)H2ӢZA2ݲ::^|4YMZ( cNAxskʗR@0q3wDž^iNϗ[HF穦7diTp0Ơ5DkQYj1I'xZabB`"a@$'])qܬobӈ^pZ^o px!pIZ;me"nUd "-o,hTWAA (d3A^ ޙ#=-(8DDw܎2\a`9]KYmkQ$*tsH$P,%Bb2Zbg&!!Aa/hUFu%0 6֩ )<3R-mFREPRI=F>Gc9|+UT`׶=:2q\y'=jڡi7?[d%}!3KQqit+*l\QSt];V[{gAVo'N|i\~_S+L|8?֣9@-5*-ɘLyyGhNqV&F.&2 &S:B>'y޷Gv. #lۓ+ն*ne]S 5AZ@*_Oe3 XJ#VԖ8R=G uǭr UmfƳE<'ˉ{˚:[ NxppIϊnG"&: %bj/H0>-&F[+(bFNbݯ KO|H2GkpYׁ6{QN\A.ճ6 AKG Ï 9 Pfg\CQT 5S|fDPi}M_"po~&]smT4Ix@@4JfI 8p !Rb?5tL"FDГVNCa`O8~RH¤ya͛.m=o]ƚb:@a,{a4r*tVF5 x㋄g4 ׼;?ud]K BzyR1ؚv\N4p0$ xD($OM '&!l0(ZzCHsIA 6%<8iǞg,|xr4ӣ؍Ϗ>Rs@"ЪXH8Z c&dԜ'j"PC z%.zY jUR^Ii#dߑ >Jlۖ@@mX}z#j2 nDrm5E3h`kͬ,Ȟ Q͛>O'nZ_OevXr]kB H >2.9E̫2\ƴDhMQXKlۄӵ0cJSN+x~*Ghv~w|<`|]ZF4V၏d`0C.N9Ÿ0<ĚGҤ # oO߿ie=i'~M{p8sC6P/ 0  xe׉$h͟JAt vƅ-u{hmJ85EKºsZ.W8j}/m?лݻ+ e$#ɂVHLFm/ Mw{%5':X/}4C(U >:PtbܙMN 6x,z 6{_ޠ'<`R8l[#|ZuGmNO,;@ sqo 4%άz y_z+(Owwv= 8گ:/vs}ǯ֦fT pDᮖr-ӭS7#r~SDR1ҏ7š~VhkX]fmWZ2.p0JKD8\ddz}>AZ[wmU썥@N0'-^ ,Q;SuuMoFEFgq+`zkEق0Ȥ,mFmi;[W9R'XzHB,kCI{7YrUtgܣ󡨵镵/x~np(:1m#EÖM 444FQhJhk)w+86' KHR_ZjRBK4>c\z!gEASC"uRtrImdlg&A>2עmTQJ=Bvu|@9O,vHv6χ^gh]=eyt6(csH҈L](b'Z߽<pxrϙ|~IB rx:^SsxJt&L W>2|E6iIcՕehz(+F*ƣ70 4.H!6}mA 8NzDPɩ[_'y+zR4)Ѡ9ϖr&~Nn "t&lTH$)& E5a 1,nv"gfrk 㔐Nj^ĺ E.=NbhK(""V_,i0dHzJ{yuX ^_!N!\MMov r%W$m#^ 8-=&(n]G"oq9O\G$%1B"Ͽ`$`c.Nt kjJViZ:sC/_I?̽u91 9'<ɲ5BZ PPd84I2ycy##4U:֏KK@fk|ksZi1/U=Wa1~/J^M.}27cVh@ƛү=w#gDҝ[)KuXFNGxت>ƍi ,J|~ JSt)֐ʧ]))T@u:~ :bVinY9yxn?lA⋈~?_] ldI>2iCg7^/ЋڱӰ`\G۷@Bأ6%G#y2H=QJT#BܸFR“e{zٓ5uM őN@@2a}̹|@s786Ng[Ji7.‘9$ѼxĘAvހ/䠢8ggI]<7[ij( %W>7_Ѱ8yED8"N* )-C5tr),rJ J#;JCD^ u0s$y JO>Wz#c@`du)Ž6÷N&UnZOfrU1 (i4%xjA1:-sS.Cu-6z:e\hI Pu6mm=ՐHGqjK"_(--(m-"LuΌPJrORPIS:dIG%R%PR\kdȻ%rI$GLuṙ~vSn^SbyBd` z!o6IC,]`H4c RGBw$k:E@Qh8?c,xT /h:M,a, a e{؊u;V,xw0j(C#*uLWؔfgGy1%6PSg&$ZhlivHy бH?5'+UMͬC[m}TqqN)˜?Źbp-1J I"=2*;Fvn@0t} :S L!YS1-ܣIXRY +~BE%PF]G`@NEʻ;6RT"A$ԶDyF c|Giǣ5XƠ^D%sí0gYL9̚S5$" l0ZY5K鉍[un!LD(M "$C +ꞓH:ġ*wDɫ {'<]B@0"}a`R$ ʍ؏Ka1B UWt+- " n֡e]h&A±:$Q QujɪY۔Mc[n9 7w(9BD;.s Ns"6qH# HG^ˇ9Жz%=4Cn|NGsPwS{W>O ko'ɭUНBe-aD(H_`,3gُ'[1:Ao(62X$2Qlu9cSۧ}ae$f$nn]Ѧh <ʜ i;&f)^v2W7$H|U.LMHţYa2t#H>;N'*Y_YVfu9zd@=d)0ӎԦ3mDwNJo1sh#&N_Z p =LCy!FВ"Jpv|4Bؿ5vpg N{\AAQ9e"XVc~yyhq"A_UV1z؝Y,:H3ǵ ֵ+=&yT1Mέ1wZ\4HWsy0mʺV|OySTʸ MgjMR= MLXT$B5\ S#XcV&p4 #x-ӓKͪvI{qD_+D':0qrH'V|ϺTJ*u.c`z69/3v;Ϧ Muy)[ mk܂9,P@&3.FJ벍Y#(W_t']3S[{Udթ$ Ц&4ЦzҖe<.y+gj Dɢt#mkt=PѪUټ9{Dz;6!r_\/WV):z: 4 oyV!xRW.Si(8/T'3^S*v+@!JFqrn=%bL}, o%3G8Qn9L'9l^-J9MۣeepM7-(1ģwV2e.de 6Cr.tƢE3`Ho42+t֊0;8Ӄ}#_j@jBTDlBWT@|m9vrHyle,9|~frHVÑvMJFTO43:*rf oׅ*U)ؖ.\U-e|)5hI\47!uݖZkx2􃫫Gߎd}gԚs6 kI3^g{*yɕ+Y eD,nW)\SΟ8m̝W|z l|aǀ0wvM,q1c7 E:%*Q c!'S= rY6}-:asZs,HIF:۶A$胲xcǹW~̷\D9*N&~ims~سH9e77HJl}83-]쉦dV0%78m'z(ºG XnוQRկ-)eZ,4'9У1evz,HOsn빚ܲ+~if*y74>)7o ҅}K::ׂ1 .gmċۤ[_wF'=kT@Xpa!+qq> [M7fKʻA,2VfsN) x|,)<0[t,EDyעR5|vB$k;-K8 ZRyڪ> 9 - _?s?4!BiKIQY;Xda9w~'i_ןW^VnvǠyI*GIiD8ۭ }*솣NKת><7rs,.r#&.LRJZGLFi˄pzHb ^ۏQsѻQR&!F܊&ٺ]?7NÛL$:EK Hasd>T H0T񑫕lIEFIteA~ +޷2{%U0!po/ w7}KWZSz|+(gl޳J$D!Pm> ^D]{UӇrm4|26q驜٪DF^–vM1@\. UvJ&Baiv_ nttC~nf0/JKcI,m@KMc)τ+{[K?YRKxZKmqnq o}˗B#C2?RnrolHLIԸ;֚ *_LgT<77|סG.s]fʶh%nO –m 92꛵G _{{p|OmH!T\:UqPXMץ_p,c?e(csLPvyW=С:@IH5*#spK,PտΖ%3OΤlBr'^|1|ѸZV/SΡQF=$e&vaWg5}hr9sh'(5.bֺi{--Xޥ,b9F9UI0v8aiUEH:I(:6\%YU /kUAaIzihϯ60d~mxО[>]G8,#j0ahlb )+֢cIyЩ8!SnF9RCqAϽI6P*}xӓunjS+e]e8'Ku}VV+*IMC"$cL&j~^sy豳ҎNl"Ͱp'*} Aac$$A8,/7As֭XPR6\^bh9A\"ߋKYaGN.&S 1=_kvB@J YNtlEDaùgsXySċRu,qoZ?9E1@{m}?EAx :<E+7kbYŊ4nNaI"?pW PwU$ZC&1LuMD8<͜M@;2m{XN8"t'-&7?> @ Ei*h"L)DsW?>1e+,u=eQ褉i:}~'{hv.\pNG|ϽMv@.snJk.H|_< ^xym^[ٵ n @sޟweZx:nנ)`A;"fe.ف|a2ðD~qķsk*#pE~s"ߟi6>N>#I ""xT| .)==\';'(،YWձ~Xخ]VCzQݴ\M-Mh$H.3T3hu!7|cQvs㠅R1u\6/H|Ӡ2m@+ÙadJzԾ'3qT"}IԿbqx.gL/?MSahY"Q⻻l8rVc1]/mHevehS2x+ Zy ^.)n='ux}C[YJ銥H F9q!^:Ҋ _}y*ZxtOY)25"up97WPmO]zj/fH봠blzX#wLxbAaY -O}eMjw$$̪6{ tߝKb*vMz⮫aTE"cM8.}8OeK 2{5}~˭WH4j0f=G$h`^?dMi@PAͺPܵ;E.m~.?={soiN^D;\_(\gG{|бѣQDtӳ鸣^N$EB!<9|{W77 o>룉ٜRNjyQI R ft[>oZPB`(;<'N=CCbbd:.; U\oуV'nCVt[vb>8ѻkf/Uejip3mãĒmq7p|lKv/I- vFEd%1AOvOڅ<G 7ۓ7>ژ{Eەn, -lXPD)*=g8K$G^ܗBe7׺M|/s-W콛폳\>9|AQlyzؘvT׈,%ufR'!+&$QMG񷶲~ fIxE4aliFt#}yP}(Ë\JDFݠ8Խ[EA3(>nzÜʂutl=Yqe) Ɵ5պJ٤xCWKNJh-U?ſzֿe~,ScY=E}u>G`e%CTv+O Z{c#o<؀!7]0LUAQvUyy3ܤE;,}K>v;|E'lUS|I:IV{wڍJi-^E~is0Fw}yecvuUQYhiY+Lmv>'/BɨSl)(t6擨@T[#(bj5U6K8+w=^y-/&Mff;:)'J~tKˣBp668` a=mYwޖsCZdF{rwv#ϕy}7I&Mwo[w t 5:!Yô1U\:C<2h>ã `kv{,3yuOg%S^29?,,^qO4Ve"rY_WK؄0kSK@a,T +s*%k5=W*q/vRyZm|Y.@Z@ƕJ_/*I@|d;K}W6}s  SrGiR°F-OoοvUקoP~ 8j?ޟyN:];r]5(XM#kE6e dMǨݎeSd8]t4ݴ֠?lZ)PL=GN)>O>'vqiJy|֡y>Rq1P_bnBzǽs>ڹ$-% ZYu^慒KW dk< Pԏju?$dL. P ͣ1П?7&;O>ڀe:]o5ʭcp D5mljLV)j9edV {D@e{U' 3}x9g1.w[j1r=քg_e'ӦcYt'[IŚ;#in0JPlm,pt HVEsy=e2 |dyg=۫DCblȔ Q 4Q >o\x*AmBc^oA撁^ ƔI!l쩷$oN I(<ڜ@jaNy-$szW&oYIXgӍӔck۩~9սQeg~iCJw/"gyhZ8S[}UIvb;$)DtǴmRD~SӪUV?UR5!%G?+κ;>UP9G;44URƚ\3/ЗҿWt{t<&+s+͓gco~~)JQ!"9-Run묪Է_a_,U{H (ΧOOjg*w&{ҎQMPjut9XWwi$$nY&DE9=ޏ7fxd/wބ_95@Q 7zi'RLhtRxNs Tܖ$]] '}e)? `Qs)x_3ARqUd-yɵoq+5^z0}zo{ꛣVei xi:t,4=dkHpq K'JtpH/0ݟV>vGW.SlL7^Uۤ+j6u#aFJy! uęp~Ԙ4 Q&wx6qU_r5 ZW|45$2Ud}*YYnBVkY3X;>77N˧y}Wj.v \ث2i/j7R۟٫e#K\!VZfk@,L%څ2CfL|My_i |Ʉz~x4s;qfc.ҏ٨#@'ֺ;ycf'?Qh~y xy [l蝅=5foNwѿYTp"5[Aw\ j EF9!UPJ5rLl*޹In-'^j'?:ue6;[GvE49bGjMk砄$n^ m߼ԽN*?4:ˤ}j1K¢j0B^1?{3r^o/bh׏},(X$6`?2-1 g,Ր)Y[Ώ"ia=?g9n)fU~c_B 7cp~`WEn(S?xc;NRGjOhE%8(בgGr߼ _e}Ώz|'?o;}fAm`66Q9)I)ڷ!\`_%EŠV& }I'g\/zpv=3t[ lvW@Ⱦ$Y2TI v .%+"K(?'KKr*,|aFWD6>F! ^1Qqgoӑ|Rl8M*'mIn {oFMpcwt*&RF)w%#y .Le++G߈OOu h"'>V045|]txڹh#B\o#+iVӶ&7svNMObkՔϣgwc1m(ǶZn寳Ul-+s8Q`%$XK=:u*[۲y8!>g:;"u=z4fn!gڏ0Wf<)J11iIJVZr{]tO@$䋒'w+ZhrjثZOʗ, ]YMhUk'rtS7 RD 8d^J@zX(a?JiΚ=?ƺm)tvz1dMC۵7dԗ4dq^!?+ayS=i~/`AQ:epZr9cE8Nܣ~RUٽ?*PƏcj:PO|snsݑjc-.y]'\jUw2)v h^ LݨN2Z;igO*Q2͞7+>)'%LnZ>kj):b(ҤZݗu/DSc+Y=/)Ү׏P_( N2eZ3a)lC>7]B;Ğ&,/fo7~}jLE}*`:TGŝz' CA۾iIWcjIwG$~֬R_/1حWwv8ӛrkR.}7 #cW#-rlH$]rvLH٩+>[ĺ:ggQƟ!b+\/4oʠ3HAƽA:x '%9r$Ti: ZGs%Tɬ'<~ ޼ř}-}8w^;׳0A`em:6a9uIo_G3+AnRc7oϣ]*wUOq [~`%hm~u+nr.:3o1%Ͽj3+_5IM[ew&T 3* ХkWAjK ˘dR/?IZ"U p[ݛ_?Tf!>}1oemk+TBF9i%~kC. \3Q)cL{Du">DŽJ-JwrWY]?xg>H5!wf-er6Yuqft\Ɔs;d2Bjɡ7S{hW':a} "{>owi zJǸrܟWJz}y"uGBSRRj&Qyg%Xݍ۷NHbS#Tc'Yg]zu-M6V!˔ZЁ'dJ6L42Αg q&bSKZN[9n$g/q)wqy$Z+ A൵_sR*Pi"%OԩWAѴ)f Aޥ/T'I8mڕ 7P&UHu,US!`0m'Qtמa@,.֚fyQ:TX4(]/X7T-2Zrlaߏ#ܧJG%MG-Ʀc t 8^PFզrTa|^j-A.D&ZO%@69iIVɶ%dqЧWaG8p yRb.ͷA~:Iڤz>yEHwKFc1J.U)ёО>!rE<ټ*R+qnv/&o=R߅C=^cjx~K~C3k8ռ1UYjLM%uHW2RմjA%2NΨ]?u>wcn6~֧}%}wsf#( s`'ZOCzu<ꖟ{nàW(׹M~$ɘ5=.\moLo)^2]L(>Ԋ9'WHJ+wjf*"Ư u wWffs g}RњEa n3My^UI[s/9[)2:-$U 7lh7Mփt.̇Y;kC`C jU]dyyFbNe=k:SL| ?B`R]*r2УB@qv@6"svO6NxK%mMܿ N}١#tZCfm4b8%)TGI&pZV55wZ?-Gù\.9Zm7hZ$TgէP}U=<ݾY<)E3g{M٦ƿ0׋T`c7*@|<>朌\ݥ*@e\vʷty2Τd_t=q %k[+;6 Z;V0{1\*´=g{i>7|U?d|6^kmbkĒ=qj]̒[,Hv&uUǺ3H^QԭkLUuE=>F ?~,JpE).# T{(DxF;UͩshEuTMƾ"K'Eƭ2GvҐ(`}CXg(v n EՑko̰Pu$I]xpw_z-F.]E6nBɝQmŬ뒑f"P46*,,?Yӛ 6}esxy-Q-;S+ pYҚԕNE O:hޕuI5yY76CfyKQ:սʒIX6(lX[F9Qy1,FI*'Ȉz4HjQȸ n%y^*NO=NA#)QȳO1 yxVx " 2)㶬\gne(OkůM;4nQ}:wvWU-aދx^qSQtr8}WŠ@/y9mezݩ,]t=tRGbm8. FC”o;< yQڭժQ]$LmlܓGLSPl(Td2#Kw6V8촷x==$C ‹,8 Yj%zkb4&QQl! o1c=ϳܼ3zwI2~̻d_޺V8lDM3}o\KYY /e ʀ/Ϡ:y6>)8՟vr8@\mq^֍;g+ɑv$S"hMlڼϦc!/FK '!?~5 >>x9b5pln%oYn=dzc:*tUk,1P#uME è5wE[\z;:V 3Bow!^gdUv76FYC?QWuE;sz{> O{OUpئp}^irc/soau@ڠܧ w鲓2MS۲ܨ!)(sP;RӅ])btBn;6KmY;Ouٛj=? A708o1 ܷUhI2O 7xNI;~lKPBʄhaX=+L?!md=ZޘqF-3Tܟ}DdHpTSJÎ3MP S]Ul&~P~9cЅb>ŹTpcADFH3 N kr)uEQU*drƳayiBu+Q}$:Z.s.V4CM F?$Kޖ =IۺquەޘnzO9 $/p4Y|7>I3g>3qʮ}1 "t5Z@Q= 9,'1UT3Y-]ڵhfj3ϬΉKbp_kM=cfU]8ҼH&6~Wc*mRM "*"vw9AI&ɋ {ltz^?H?7U~ ˊ:w{&+M> 4R $i1b-"xMJ'4{_}rPcxWg6X3CC;NV[G= hɇ޽֣  [D0tۤh|bʴ>3ÈS`XmۦbP2ZX?&q3)*aUdDD; 0[_k0T4l>Wcp_mA%?M+oz V.g-p;^DJ}e_7boi ddNɺid{X1N{oԿkfH̵7Z(I1[ΩΩQc`:'.1),>^bVSp۽9&%}lm W-MM`(qW=fV5ˆkGT pw~M^ω}Y6XuI?UN#Y=qo&\ ֯ߣ%(P)B1T6Pm=95XFFQAZ^8AX6>.T`G6ì֦":8_jwe%tƁ&⹥]Fˁi!3[" :Mńs,,^k^^?*bBi{HLuZ6Skm$=6QRvq.EVuedXx9$2}v-e1@sM(Շ!]90c4LjJqº:}|cze̡Έ_J5aEp2=kuUNq4Ҫվ%i6=;ox_[Ɗ'*׸=LH+eM϶Xn𡸺v>x$F$۹}%vg[ ]{&ܖ eT@quv򝚪rH;Юت+]ҕ@*'/[Q9N ԑ CgE:3nL` )HKVm (G_HI/?l؋Yy1~cDϑMEkPS4Gzze~IZeJ^5$/QeekzΑ[g( O'ZY48`%t̘G<&/Di,]c(K-*I+<n|j"w FН!#mJnm\"-LGY(zܙ <9w90v=_ ]SdL$񯦼Nv֚sC™ΈZ&y _Utm Q)Cet있3qRsN/m^_S?ِ=k_aXeXka`@S 10Qm8:C /2ꔻu9flL')`v'A2)t}ڑ ҠMqP4i?TXI٫fAj-N0Y k[W:ЄtAYnnyXYD gk4,1fX5v H`|lLTimҒ>uCrDaf{P2ŧW/KMo&nm5jk^{_әȰȧJ[%Ǩ3ٗ D%1gTY!> B0_Ó}ar0[9?|띪wr''qg+̲@+VO^{IUG%)%)d)\mh|jq;wy]|GAd&cm{C)RCbG0lKWeVfG$PZ2 ώmܴ(ӫlynII~vN{b8;Ťk{޿Uo0> Ҽ*PB}4v^وSlU9[s>N>(w[f `KO8?Fǰ6&Q T ?%`5g5խ++zW^NY`&VX5g}dR7䦖[Ͼb;J?%JK)DC,\Ѥ~:mFt预h\)62ǬS~[&q f[I|[ :YU۰ΐjp&'TS-DWȮvt*Vdr(X"IuX4N楙?C1y2<'7ENWf^GFZ-)cpC<] w?D{v4S#.27tB[@]9r&=(O>= qx3.$m'#f#"o6U|H@okT.5[,?‰5; 0$Z*A2PRbѥQ_ocgOIX1B+Y^4.e%}Ǿ"S'FO]_p"Gf3yKRR6i~diV&K~d{[kZ7lE_ʯ1AY$^'!V2(^ޒ*Get@QB6_WZKЀSc892*7+a_EXt cG5<8eNƯCum+B~Tf zGFeaࢉh%*ew7N|qާӟZ խDǭW>1S_&LbW98{s5z6vz\>]v|'D0!iZ_GSO2OG~)#oO(kWئpo=a3or"LTDd&C+Q]ëDHofSlO=8ԙƅ&ťI92ayMרd1Uarb]2s4sfƼ} `_Ma6E72KzbwSJn%:~ ;60tXu$c`P)ZJR On׸&5+k+^rR[-lٽ)R}^E_d}~.VKϱf5}i< U提3ƹ3Z),^-;&a*1ZO?k]al2U$SkM+کdk*u:wmkgg}̿rU [ 4kfgOv-sQо]R6‡YD}?u GiHn@KMJZ59|&ZxsR\J{ OFRLj_/ ޶nM?)GpW-E:|e}dg}=v'?QԞٰ],H3Q\"AdJF$.Fc'Ghx>3L.@RH^ L(ˮ?N_55 { RM%5nKM'F?rJk0-f]:8T)NÀLra5g{Lmtf$NoSg>~oW,nwnzP-;<&8xѫ 0Q:]\c(9kŦH$ƻ'[ D۲|XᢕwXYtnVؗV^C!$ c A'7,ݨ.hD٨ozs 1 ˫Z5r- .Gf @*"4q-5`(,26f~KkSaw,s°)䟳 -JLl^Ʃ3-pxzjگO);r(,Z q?Vk`T-bxӐOLܠ#2-^1ۑ,/9Qտ0D$2`3¸pCPPƎA~Ԣmxl \̅atq׻-+=e^Ǽ+.c"e{DjqJDU\^,`(ogJ3Q7UTٻ,`g5l/z7hxxG$t4depzSaZvP6]nPRvNWox19~c1j270G>:{fdhܨvJo>ŏѡL@ %z;էaf{:7<4fs/YɆV<: } 5 G?Ħ︒""cf]v*z-qLVg)K+lbKgT>Ҝ=yϊڕ Q"՟\Xƛ/ua4%;( J2Tr(eYm#,ok#,'j)uf[_ k~[\#@]h$uͧsvjJw"Xady UT|w7 %k/?ˠWgZ6%SameƇY3r{OSG_b~ڮw-ei̮ãT:fn >AfefדMTb<ߵ8g-3)|byd.$;`H`~05Bq^ oֱIB{\\P/\ 2H ZK.qύwoJ@.]_CNQYG0jL_HX kNa葳醮-W6B~^ejEՖ);2lЫI]:O9Wc-)8=bI.r| ݮZrH?m) OnۿT!k·C)M`ǰ a&& g/~fM!Uv2RPһ O1״^9oz!)f,xgW&8c3G΄W[$m_k=inӕ@[]ʚUYfJdI|jYF;Uz0vK⛟`ngJ.]A*Wƿ`dx<ϖZTߦ',=Ȭ풂!]th尙8 ؀Pal={τ^1pU^N!Bo3#p:nKLO+6Qwq<4F6.U bʍߦƝŢȮ)l8|Q;%CRO-I\k5!&f{e?H יFP}} wK(2 2~1V0F&wJgs3'ƒF H=*{G揱\o"plZ!7k-o'CdvNZm_9 TfD,1XⅤ2bGOx0nyo\|Nɿ  QyBklp^LttT+]OujOk^ )VjJUAɮlz@Tg'us@W٫#l[5w0FK_u5t9 *> 2y:?B,̘ Ii]dǢmܹ2 >V~cr~^ݲb\?V 犊R7Ȍ5,ef&S:s8W }S~\kwofP/cZmW$fbhd+ЙG} {Xwdt@[D8Zc0v)T>2r,An,#;[H v綸;3\@u+^{#ʗNw:SqSU8g败>5{EC*@)cs"E7.qqDRί}9R]1\6 S}oC޿qr+0V3W3oL}.;5U:WGwwUʻnj_GuIQu(Ԩ}Go65jqŗ-J;)_;*9zj7ArӐ+Y7\xx̽c== 7Vk|) {ʵ{2<'~'urJ7hOu~^VWA\ D2NYz=V>1vJcsVj(T)'i 0-Θ(+"]9;p7QmVM|j*? o冫;`5%DuذJ;Zx_QjO8NU&sO)2}g1Wjvcܭ+>DNLI*Mp1>]/gڀGsc&fOM0ѿ$ݏl@yPU1)qop|.}eEJO3p6y9Qj@%F p_GMը_<`Qv7wjHQÑNoxwJ*ʙU?mΤvMіLw=&hr^Vצ9j:F:Mԗ;yW;--BbOH?#˷MƺL}lrVsm9ک^H(-RH?`*v@[HׅMdLԌzt` 6_$Խ8y[,xg/%X}GV*_F'x[&ˀŔRu$J/tv-0l>/e?:&x@K5ҩ?kne Z@c)j-S/W.|Ct.2Nu^璬:l"Ko, AkA__zbN]HRuIQ\U{T*^h(lJ~^Ѿl84+Kze>uϝS/b ݹc-w"!y6 )]I͜^/o1[]Wլ\dś@T{J\/:FLr '8;#]]_p ,B<ӹ= |Qayސh׀f@[=f;3`&ƥ .pF}7M9z9Ѽ <4 oǍ]cE%_qH|\N [uydh af˯u䘧&[&W 3d~߃,x3WtWT -¥'Ycצ^G%SC7Xp ]Q]oD<v]}4qOg53 7o)m ×'w"d&ϯIcY&Q_:Kk#Nq_! V*ܬ5[[NgKHx S>E9%iN?: wz:=\B.V {x&6['mA2V=뷵wWՀ\-8B|yO e5|TۚN񑸅~$_F|庮nOk9.>y/ ,*"OnK?Rom,@MKY?lIN#{4sSC~>T @,G9%b z)=±?8 ʙb`,GT /xz%=`(Vkԝ%1dۯ`.*A]n)YuU.ƨpN^v:)Bv+: ,;_q;*X,xחp( kݐGrDaKT#{vIp V?j}ŀ,@ YQf< A#\'l)U !ý(~0 :!p[*~}O_ CzEO[ԠI={%.dw*v K'Je*a~o_OT?S w_o\'| z;ϐ `w{ ?TO߲~G[S[߱O=}}OS}Ot/mO[~#~_{U>wSM*}?SfO7*~gj}*gϊ~s>{Tϸʟ~+}O:.}u>|MOkϒ/"~_WSwW? /TJGx/T;*~G|~ާ|B|/܋ A/HΧf߅E࿸K/P/OËн/Eu? ~_ 1}_iSP_ }q/"Sb`/bSa_}V/܋A _/a}OQ~^?!bؿ//q}ȿ/ bXBX_ bEQ{{Ow/ߋ}ȿ/q}\/q~_t/_/݋^X/ _b//q{^H/q{6#{^OE/н{^A{^8^B/q{^/q{^/zMMS {^/q{^A{^/q{_t/"{^/q{^/q{ާw/q{ާ{^/q{^/q{^S%/q{^/q{^/q{^/q{^/q{^/q{^/q/q{J*K%(KMo?m?~?|I$I$IBI$I$I$MUUUQ$I$I$PI$I$I$I$I$I$I$PI$I$I$I$I$I$I$PI$I$I$IBI$I$I$I$I$I$I$IBI$I$I$I$I$I$I$IBI$I$I$I% $I$I$I5UUUDI$I$IBI$I$I$I$I$I$I$IBI$I$I$I$I$I$I$IBI$I$I$I% $I$I$I$I$I$I$I% $I$I$I$I$I$I$I% $I$I$I$$I$I$I$UUUI$I$I% $I$I$I$I$I$I$I% $I$I$I$I$I$I$I% $I$I$I$$I$I$I$I$I$I$I$$I$I$I$I$I$I$I$$I$I$I$PI$I$I$nI$I$IBI$I$I$I$I$I$I$IBI$I$I$I$I$I$I$IBI$I$I$I% $I$I$I$I$I$I$I% $I$I$I$I$I$I$I;"&ț"llEZ%ZJS*}TUT*ʅS5lK/3R-ڥ ʈڪmISd6أhJ\qnL<$u)TL% ЭȐDRt$U ܃u@@K%#%"1 0 %rK=M$17CSI,LP*D1B\Ј4(OKL4-3G@B-t*<+U S] =#BJH<-HT( $r $\HȐsr/ #ԯA(,*T+3tp\CK $) )B\\RB#- S6ێnrҡVԅ)[TFʦҭ|TV͵Tma6ͪmllٛ4cllkfm[ K5fl6lʛUmY[-Eml36ƍ6#f؆ԍl̑5ҍj*S3e&ě-KkYUh[lͲKc2ldK0̅Rҍlm* 0ڈR(iU[Sd6T6#e%"iMmj--iH|2J)m)[EVSjč`@m$%R jl6*&RlD|K["VM+=s.Tٛm^d/]"]d TM-jmQCjF mTB؈A_sns =H@2܄1\%4TQ2]MqQW0* <1D EO=S= O"QTQ2()]U-%̯Lr R%])C*1<)70*HK74%ȴ %̥( R /D(W4)t ʭ%JO) %C22 3QWuR7++!/=O%2 05,\+ =0ȐLO$BLJ** =wPIShel mT=ع!m*s,6lmEiI6 LTZ[6nskd]vO2h[BB%"wj*]ff;hat\u<ԍU-Ilwg8CVS֌mmKd.5!lIt6әԮٚNh.grV6J%MU6K9ImA4Mt] 6ڤ$.5$' 5tb({Vl܃+mc[a;E=eCTIzlm٘RtNhҥjZI[6ک]^jJmJ6i%N涡ĶJͱNحI*-QtNR7xƳj'sl.O2 R-6J6U6͡V͕:E)B Bm4lK֜Ef6Tt])F-أhWms&ݶ[Ju.hX/r#s\"VѰ}#5lRl͖}$cGS>&/-mlNkhM|{Үde/^vVe[$.ا NlmmNv󼋘mm*MMU2oV/XfeN;;4I6Ķ)FU]ҽjͪ=ss[ ն͒v.-lHIlmEuG6lڻk6i6Y.UlثiUI6mTV-F6Xm9h.ǮM*-M6$lX޸Z陙fU:.UM)+`R]s96*qmk݅u]U܉DؔڋbmImSiB2j w٬s(]Q6mB[RCh9Mvv.JyM e]kklٳmf*]jj+biMJ6$ͶN4Nt9.55A m;66٭kd; GrwP6lSjmJmR{lO3Zlә'^d{bQ[A=Vpmfl{QzmF6JỤj/(puȔB":flNSGr3 mVҍЛJ6dMllk[lږ ^MCjmH操/[l ^{ .'*2l[d[Q6U6jUfq)ٞ=/ju5 )/m9"ͦ==I$RI$UI$I$I%TI$RI$UI$I$HI%TI$RI$UI$I$I%TI$RI$UI$I$$UI$IU$I%TI$I$UI$IU$I%TI$II%TI$RI$UI$I$I%TI$RI$UI$I$I%TI$RI$UI$I$$UI$IU$I%TI$I$UI$IU$I%TI$II%TI$RI$UI$I$@C$I$J$I*I$I$I$J$I*I$I$I$J$I*I$I$I$J$I*I$I$I$J$I*I$I$I$J$I*I$I$I$J$I*I$I$I$J$I*I$I$I$J$I*I$I$I$J$I*I$I$I$J$I*I$I$I$J$I*I$I$I$J$I*I$I$I$J$I*I$I$I$J$I*I$I$I$J$I*I$$M$II6UI$IRI$*I$eI$l$MSuS3333333R4B,D|9[3[[5||{ -USh"M-#G6fmmfb{ 5RԯmR{fĶm& 5Tk`n{ڣ뻏}JZjI1{)=9&'D 6)6)6o۽}7Z1ڈlsrʸڤkm})tmjmjmjڭjڭjڭmڭmڭmmmqqǶlRl%)^)Np.JS -||nUKWTFЮi[ +ES>>*;UUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUvm6 R-rT;߃LʣP" mb=l#ٜ֬!wwp;;XʱcUcUc*ƪUU>|GŜ?w j]3[KDoUwt;+:I^k֟^TEƵؾMmm7Zl>nI['hliS~=A'>g9%-|OhM#@⪪*z+V5V2jjeXXʱ!r*bڥ jMXW19öY>;WV1XXʱcUcUc*ƪUU9RT 6Tz[*j'íy>8;;n;jcUc*ƪƪUUM(>,>F+dҪm M6m|/UUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUW9s7Ow"R6JE@;8 w:gF iKh-RÛ6b%6m|/-UUUUUUUTUUUUUUURUUUUUUUUUUUUUUU|q{\\p ә!|9V+\26fh>6a|"~G߿~I$pDN[mDddFTmvQ|Kfh6h>VBW{9rsTlesKLsmbfm؏lh= 6'8fԞ{ yRsPm(VYF\m1b;E+Pl.j[gjVzmiCt^tli `e]ٶͶf+8yߥ"(̂"#JU<05LrMܲ*#-OA=W(һj%k0;4ڪrGuC66]a<W wL3Tt];תmdkB u.ʮUnH͛{vOl*#TٶZVa{ #*l.kj IdNRž6غ.46jY[JEy!wVuMYsWbz* OFU6'H1Y YP k*Jr-%9k!t]yvW*/Y6[`t]]GmW\zY t^<ԧwb9F:.׈ld'skm t.zsR6z:.ڊs]l'EyU.iKt_P5nd=b>|S:.^SonP/Vfz]Q'HK'dyEo|,ܩmU3mC¤XGwp~w>,~"Iwq$*.WEfY͕r ǥ(eERO<3<ml־v2ͫke|Lm3S3kfكcSci;M>w]9Ù,s3T||y;w"\hIw6flmUE[PخV.ƃwRl͒܂mK. ħs*v.wxR]UNAt_jEOz֋Wb>@@̠#nU\]fft]«zm*zlE"6*lC6q)i.6p E2*^Knq#Umly{~o|>|^w- ˖q ְ^{;m7 ؏a{ ZwKl-*6Ut_C"m\*[36C^vNm ͪ]E+EGvֶt^wz 9qRٶwZ.;.mUmNkm.z)-kE&zt]Jwp5.l jc yY+&Qt]J^k+]Ea]mky{?%o_/S-;\_o~[_#)=>_'Wêmdp ^pFԎ ٲdxNmL<*L+Z{ڨaЃ1 nlt'#I\)=Ia -P/iAeK@ q+p (az`if0Hg7=`*0SSiF36Wdٴٶ_]ٱ[/ٙڶ4d~y}`mY>s@׆11.6NPC,L nVR}_Z?HW.(eOA_ Dڵd x VX\ZwްQ W/o{QXl/Fwf1CIL_~B SLE#<_`H)e'e 6ot1!tΩLA*L䍾Oa:\@c C@s 'DF4zV|;U"Yzt%V yF0 :~?]_+}?}./ߞ'|}_Q}V?':G_/T/%i?Q~{K U_:?cy~>#'qS_(C~Q>/}fA/jeʗ,_+)?XO紨*}^': }~IQm*A~\?!(K T'/i$_;?=QJiWMe\և46#.z(-.hM.wflIcke[t]D6.)ci]E BlԹ֋mEzWr%6JżEy鵴)-aJw!t^gKm͙ sC躻sNbq\OZZ)iEbѳemKΥ60:.X[F7Vut^v)gyU)Vt^wYHkjW-;wJ]U-fܛml輻R]ThvmUt]yr*s"!mV]^.YM&Ҷ6*Ru[]E޵6+jl[Nخٲ f'cjEl6nsG2'q\qB)=Dzm[ GEy; fҍs@d.rҝMQٳ*&iWrH6mi]EY⩴N5zԮ=aOYlN.Zs;m,Ѷ/Ǫ8U%>_{_o[o3׮s5mt:y`v,Ex5x\l7aij3crUd͕}^5m6|6,F}66OjڙWij6}TEollNI>MWUݱTxUA燑AE痔T^EQUUQQs6[Zՙٚklkj^NTUEQDEEA\4ٛYm4Y[-3Mͭ4mf6mX͉iͫ[[FZٶlilͫk6mZmimfFfٛ[my ;-.mRsSd.ؔ3U`t]([6aGas6le]Eg:sJMTS֪zmt]}km='u5%vWEwQf١Y;lmljwyR)[Z Q6F6mR6*bmU/ax;.f!+cmEw#3)ڮmmʣ-OYUlnqWEue#cj7yR;cfQt^u܃pSaMbm3i]ESi.E;zңibmz¶&t]uP1UڣAt^`KS:.J9̥mP̗Ewq[Uͅ\\ĝѭqX]]lJuMl{mJwEmljmEtWKJ9:.<62UrT;E]+nfPpck!t_f͙f6Njk3|xlڛm|j=ǛK3G>3jObCkU|Bv[SeW0کʧuLEtmʮf]͊^WAc9мW2W*UyyՉ2e^ 4y@WJ^!<-͕^kcex/O% ^6*z4斢M'Y\VssY*9xѕx/~ׇ/ywӳ*Hs3kQ *!Plfɲ|l63kce|meKfٳKfճK6f+O}-Pl~\ҫJqz mm65ljmib/"#ȼ*<(ʀ fZ6YͱMm͛L٬m٫ fYlkmZdf9yTUxQyUSff66l3mmyEDESyx{yAUyEDyDmfzB#֌Wxё[\yM=gEr,دY4+R}( (  a{:D!B+۷+Tl%="I)S=?OTڧQI1=@zAiJT`h =TFM )z%4wȈ4I69* 4z gkG}htt O ~/63t:xP=EgŴ?Ţ">YT_z;'*)/QQqxȪ5MZV-2ne+lTɨl+TY, -vL+J2k;݆V*m쌶5RVK+dgL2jΉqGpXD;rG+YlMLkʖ\5kI.*6HuN#܍4LUդKwV֦ZVt5QkC3uɓiaf.cVVnM7mB644,3mmӒi12\uZQRLA N6fq;H댓bVZ斬e ժ 9VllWNڤc1"gnqYV-K]X1M9P(Mfɶ&\t6٢7Zۜ.RFk k2UNbH۩Fk\ 5BmdmmC`b6ͷdX9,֬ua;8vFhq]m[̃v;UչuYZ3VY5uncufr]4Ն-ե%bk,*Ԍ8Ǐ'1#i2UK5T,UenHe֝eٜYiƴd2鳚q6г*ݮZZN-'Ad۲3&6ն#&Nc" X݉]ZkXZ.Ldƍ ݧjQv[d8skNJGfntIGav[#\Y؍U u-i֋Vn6;f3+6&nj0rp9f٭[nph̳qۦGXqfL;'+LN,vӀ[b0H;NmK4,8YlɓigjmMՃ4Ec-m[7Z\5 IΰZV[eNHV'['N4wiDgj)ʴ)k˻V]\w-Ym4ZB,EEFq(BdvZF,٪e-gem8ʪa1:0ֱ%iVw-V30m\kYhlJг.ZXagLakej*hrRugmM-f BܵC9;N8N,crsLfaa[[VPreBij&al%KZ䨜jimlѶ-ivڳr.HhB5YQh2[' imAwkj1.u3SnK-ENt;[mImfn):VN(9 5&Ys[pڰ8q9fqRmہ$LYVQmuFYY \65,9c+5"!:̭s,1FK+:;B[Y;iUm"m.tɻs0f\uECnbrm3Is5m( u[l;ќ7aZc1ŵY$Yem;#sfuGqe;kYal:H(ANDQ-nkkqf;;8R (.i2;eδv;'5Ƙ\7UMZM6HtfҴWX3eڻV2kaִ(Fkn'mZ;Ⳬ:&[erNIe$ed:5+8M,)'4ܳ(Iug;8Tktb9vmYq$qe68YwbQӑvI m43N ؚӱ;6ɶ[YRf$uvhvls,m\۬I,fkwa89wi؄E[`Yue%w%WcM13ZnXMDS;iZmPdԗe-,Lۻ:FsmIHKn;mP؊$vkY'R 1ue9ͲSDݭ%ֶ"Ŧi\+l ;XE٦"4K5hir6KJʹL&iaWP+.g ]jskjJeڻL2k,EVYuYcI T#k+- DZ3ZFiG #"fUWk q4ն[mI!Xͭ$[:pY[ ,E#-n0iɨkeM:L;4Ls)aUеm`fNNQRTLYkBYISŢhkM&Af+4qέYJi4iY5f괹cd5-ahb5ZeMjX#Ds\(Ye+k$Ҭ5MrcIKERՅ*VִĺZ\(w: ɶғ-f"S`K &j1e6#rkEq4V [YqmTE5bq]f,*4JFu35Yfl%4a[svic[ YIU.q+TY3$TVjW Tl4lٖ-gHvVӵ`δ8[1du\ʒvPfLGrM6fNZs , msUiU fřŒl+U+ J*Y9Z冩]+Yd5gY;ClZm9aѠul5cc5nM0%f-55j%265kLh[ZݝgƙŪЌNMZ]9c46̅,dP1HKXuRʚfU Euf]c.KnbS)gk A̐4YS8,8έR2ң.uji:X#5fe7i 6s6JjFP,jbh]%B5֐ih3UIeȊjաZp*mRfW i-YjJ;JMMRCuf3NZR:q\KUE,McYcUiM9ӦNs]Z*IZڳUkncqQHiRѕd EUBеTĴ$LcuTNbRɝ)e.d)])jZYa!Jسc!d[+5mXLF552hucFfZDhIZTԺW[TE)5VeҚN9&NYYDH+ms0kil̵h2*inbCrL)ZX4L֒3]屛Y[ZilfSTVխ%uMgYuZ%ʝfK%4eua-jffYtuY%35kcM.e"vb\4mmdmJf-e)6.vldM)cX,6M֥+i\ZecL͈֬k`s,5Q'Y(җҴƺbsWU2ZΝU0iuaլkb\ˆ5Z2TXHΫ]0-"-kfM4UR#NAJ&QZnȬ;Si6S :V-1 PdDr9m;l,E-uG2)imQ:#Q)`ekJY:U4Z mh:Ṿ\u)EµK Y*Z%:jT,2narՌfZ%*gS+iMvUʫJٙ+U\ZƮ,Ś(RhYf:Z c.\eug+I!PkkXXkZaIi+S"vLZKZsq֜7s[XXK[jZ%֥d,ȪTudjVQٝ48SUZkv5PZNXljjj6LkiT5jgQh4mōkKjjъ9EkmkDjLdM4Ŵ Uu..ͫ2K2XeE.e)j:kX ;s@gh)n$0hCY3SJBk1mSVsEZĖHZ 3ZvbHKLiVCYYYk5MJ.3Y[[1LN9VneflѫfjḥB[4dTuN Y[:DM6FYٜKQR隄h۶$Vije\F-ڧNG)k3W.aWIij`vlDͬZZY5ZZ)]Z@sVnݬinZ3KLkCau(4,T̜hS31W+Mk]+ZX# ZNՔ6,gL:ij\ui7lYp2֣P\ɑ%49[[kERcPtb]NQ\:;Ncki Vk*ˤ̬̰D̋Fk6X2niUZ6MrqXLN`m6sUkkb2I7#覷f 6a&;vβK5\eqL[uҪŃ,eTjZiYXYS%gZٕ*sl-imSLҕ90ŪMҧY2,Z,,Fiƅ5ղI֢ƛLtMMkZYM8TVNkK5sYID4[[,U5eҡvg2g6V䉮t؈McZuY:"YZZIӜK%(u[&&bWW&ՕR \ʶ1iK&\;Xk 3VHYդ&[dZr-kF3dnY6ЍE.eqԖjZC4-J.\YjV]ZuZvVLm(Aj-mMe`-ejD6'.94mf5-sV` XY[kCie(V jrj5.ֺifXEvLN΂Ӗ4t%u5KeR5$ԛF֓QqNԙ8i:jkijfSg5Teih2% ֥]\5VVKf1T;6jZ:(#fn5ґjӑt5I볚IVmmg4-mk-Ylpak.m[ʬլ:[l3ZSLفdt.DvYβ&UpWJ,8KJ%u;%8%փ+:g`,֙+t9DU,ɚYZm*k*4LNrIigF&XNh!fhZ&rT]2b&Crq]`Z)]%LU:ҘV2͢v61S*k5CUYYXWV%VFRJ2DhkqcIUS!0li&Z"֚fjlJqNU1]jhgWBZM*hanT tf sY5Wգ)VFR,*iM2:4t'Bi3FƝ:4c]&֙XT[%32mYhͣC9plvݭ&vhLlM[-ki,E1I fPO7ggE6֝]vRJpX:J!sk[F&MjX餹hLp1jZ;әN) UW,œ ZXnl`mۥj]XJk*UZڮf8u]7S1̒)vkY[P4]F3bI[UV5i6pn9u5IVf3-sHTS6wgeqᘗ6$n:(*\qE'9B,epqQm7am+̖twi\ueͦ9,-QemEdՒݖRQX.˹$RQ6MvumtmdkB#f&%6vvM7[h68vV6W(w:&ֹm]ev[meA-mͱmZ3KgW&,ԷfmGeVvPPͥЭMYK hX[(βtrv69,Mbv :.D; V9]5l,.\⊓igge.%g0T[mZkQukf[ee:D晴gGkV8eG\r,.5VAe]UW99+l@&%'V-tvUXvл:6VVqnȶf3sib@ժ2*fB86['9N""Cm,sk6dB5bƝ% :+ke]NXY3dB3Y"-Zf) 9ծؕgYk]TFʵ'Zj(qAw6'6B+PWSZFAtilh(Y%kJM%u#0l4&6# 1©e*]Y;; ̤+87.խntvYuF[1)ZF*rFZaIN9%6wXY[2[ZKiMbֶYc3m-++lַGlk iSaUhn2@pDL[bj; weծvbjfӋb)-dqnЭ㥭26IklvldlvlC]$jۤNE㭘;])n9ݍ֕E28t!UI%ΪN)r˓m6[ +em]ֺE:8ݤu+vZZv;l\əURqm&mlZ@:-n+ G6Z4vl"VQ͝vg'-UBc9WljJ#am"f [KŰXĒwvcihiegݐvvP4m2hHhZjUr[- M% wWjܨ;[k9D2Ĝ4ecVuuKm!e[j 5'bDDZ.m$qqDvgIQ9Qf֑8km F fIkI ((,d2ݤj"Q(g gn. M*;r֪Ύ.SJ-+v(ԖGJZv(Fƶei#EW ZHNγ!m;[N˴$r&\m ]r]rkZ]vnwe[;:a9Ifͦ61K3:ٝg]T]d솛fZ4Aemei2W0:;ΰdudemffZK$Q[k&qՔ۹L:NgqŐˬM 8m;-ݻ.8"ԻkW)YrYmgpCڶꚷ$[#iG5]L+8[᫴esj3b ̫j].j cZ]Zvu-tr;]5e[0f$uW!6r% ɮjS"&[3lXa5Ř֎ Dalld[DJYYhNm \r*dH+,f:갖CYdnݶf-b])0U;LYSZ5,:2rij-,kilQG\32#]WL֨ZӔk6q4YUƴl`jhKK'ZqNō)'5굣[Q-SVkKMXM*K-44lMijYVUjY:g9FkYUlImf9Y:K՝Mӥ(L֜]ib֝`d&(\ii2qCNu 5U\„ inlh9kEJL֪f]XRuiT&Rke10ch5 )]k2Brim hؒIYZ.e2k]ZC6uYcf*Y6XVS-&bbi4f]qbCֲcH*n5ΒYgM%js6[Jni4(VUf)AڝIt-V֎R44&۸vg#CKl]mIjL[-\R݋fZ5f fM,YBVi5V-dͮS6KYFl"n:Jjɕ̤-v֙K2QivY"js5fhXֺԻVjeE֚BE.cնf9cb1&ZtqfLc0eeXɬ` VfIV4d3ecv0Vȗ5X&-,YӨ;TէZ- 22Jj]k2[eŭh1VKf[]h4qFIjĵwdN rܘ;kKGXkYfk,k\Zu&b:]k18kFBS-*M+SGiZdn5D:VDiɉMLՌ4'2RikXi³k\ִVȭ]YѪL(Qc5JJ'2lfM֒KbږVӕ*ZƔUiu`Ɗkdձ4SfZtGK+E5*dQBo>w~( %431Q{DPMYEwyrAsUv]ں\aΣ;nĉGFE:J$N{k;HZl@^unh  6N:gE'"zH*(q]v4|/K?|xy{ǭeN˸ԚLta"jIb( ꞟ]\xO=.DdN\myD6(1fZ~+Ҝ;+k$:/n;و#r4Di`(kr[}{u ۻ/mkpVewG9z4;~9YUɂ¢8n,WH\\wH6gdS7^H([ɶB Ҏ;YeYvDRMHf4h&KSDQQ%*DPB(D)53E.G*ZK;)J)@)j$i$C*PݐtZdXt $A@J- DC H%-w2 !HL*:)A*5>`tRon9_H Ц 8A iZ6n+B Nh )'uЦ ƹ@2.IFJ7`blZ5F;\/R5uK[m;`=qT=!!:-39Χ.C]Z9 Z4K-vdϾ3Z z7z?RR{gs%N>gmcG) {&,C &*ٮ:V[ GK_muŝYiYm~ks,kv9B/)8P,~14 9rwsm4[c׬&Ƽa88#SJauyw^IKIFlgT'qϛ9donWk)i-FǾvwmE:"ΞY =pDwc=_ۿ,YXp(ʿk{wYkj8"HnN˹#Y-.[Rj:!E7lTg:44EVq'rQ~{ߧ<߷o4BtAZv<@om):ꚝaE^۲;TvZG<ɪ}.H^ivHsD䉥o{^GB\]O`) Ɯ~ݒZ=l4no2-4kF"%&5c(4D68|NVtunO/b#$mUIˬ sy6";1]FLQUNJ]ʶE3 ZXH*r>_ չ"b"%*‚*!{ age-+;K-6 ͵b]D9MaѸIaYXbvYYΝKQVldnL6v6e,KZ)BupYV ˉbrFNQPaΥNZKSBD)1fZqnskE2d֡-f3X2Ѫr,,ɱm7%h8l#-RLIvҺ-eEberE6,Ec1d4!-56bN\&fôÕUκt)3.YmZΚҲlkvL9Qta5 R)ͦfNZNkrdMPXpU2Z:clՉ[C;]Z骔YidYLNj+դZ-Y+rUԦiɳ;&Ișֺ&5֧lںH㙊&čn2M*tMRFvl-P%9j3L3Qd4Μ\5̴su1UJ2tūTլYFխ2 S"`F5feZZXS4ZQhlLlAԫp[%enM7,"٭wY+EVX,֖r3V2eV3* REJH 6L+Lj5 ӑ)iYf5 l#)bεUV:r5ui8sFwZՙѥZ슺1ڮ'Sj-XAӦY2eSM Y3IkuLN'NՁ济5hh $k:j3SZkKrRuW+UXmF,3XՇ";FLqk6mK++&̛Lr΍Q&V665Ӝ餝,f*T\siDRfmu*LɘΤ+'2eɍ: ZQ)l֩iLьIɚKg,5rZFM6[9 ٸl-,c)FRjķ4Z",ct]YU]-M)R\SڡIg4utغ:f`iхLdVZƮʫ'#;fm"m*.]VvSRWm&d2$*qr2+֋f#66g!h1~F,,22JM1tvW:Cq9QTITK@JPX*PuȪ҉A2PZfvBeEwHUAҔ들莺:"(f(( % BCDKHҠk*e)/c2TB (ұri^}Ẍ?\+؍ m9iXGH:ʺ) 'tb KT$HetRMVD c-ܭ.cj9 $ uŐ& PF^LIݶџl'}yz*Jάb&Jlb$%wׇxA$ts/ r)u6'BS` FB*SO FKju%N .IA݅YǗ=:q?uy|,@uGIEPgհĤ1}:Vf>ZD @+[h;[e'$_Z/zq$}..vj̺Im-r]43Ǻzi.Z5LRkL"cIQM>r_sku3~'%#*DTܟ8ߛ1 .zDPh_Ò"(nTEA83Ύ..uV>{!:Ch )ѥJ RvR]b}[o}f.׽#:D mgg˾^\1/|f%\ڵmo[B*\q B"nP>_WXYQ6ašOmXQkf+X ȼ15DLYq1i͔%b3U^VDN14-t`,ca.fN5iRp*t\pZ3ɧG3-yNG[ Յ-(2NA'sW Y1 =fKi؁Q1sNu-IS`\kpv 14RΘ. 9si81҃ ǀIg;Xc,NNȌVVh2+"&2QcV5f.K fg8MZ&4 H"f+d.Z be1Qhts݀UM@ِD,::B/`3:t.RuAL#'zLQfXCX+HZm}zS{8Ʉb 0pW ;^M$j'2c#)2$gCSo >sp-zWHi&`q5inf ڳd=`c:Myx5޼B]>TRp=/ s%_Nef3Ak>#SoTN1`U6!4]aPPF \d.1זO]ާ>ykm/{&,yz ڷMk|\/7 wQcf|P5zke8OG=yH#ɣ9 b#Is>=8rRMto#w^tx/o{O6/W3YMv\ 9gǷڼ{Hsz*| zW`xU-kzxobT/jѽK{ W{ 0"1K^`2qcZ/bщKyX|N}.Ny*rU ymѩX6THrglWOOZ"Va ΚoBvx ܘyu{ьxx|\ԚB}&'lp K20{^pooz/oF^|39|<{})1F>Ej>yreXqODbsY-ycOռfl'\޽ Y{ܥh}gϽCYEQ;2e]̖.#0E =okص{˙_eypyNlRvAtBiL8 hLI,g)Q`Ky<^,so^y_;/o[iFU5z!lwC{95{ڑ&5q擡YtX={=m;*6Ál@^JcK# F=׶rdmVb[N˭wK0Cp9hMjSЙoZUi +yQɰd1>Aָp6qg6YQTbMRqx))Jڶ3Yר&8%YM@ZABG kFhNDnȪ.c+9@.3#hFCBlF3|*Zs`)0&<'Q8^hEXMF\C4m#ћFNmvfXxx$` !\uLMap<(\Ҙ$cFUr<Dch%:˦0Kʣ8&r u3aV6tXQærj3ب0l& >4B+Z]1!Hե/.hh`2`rҸ2t ugh$=8PR֬EKX hɓDC!9btrju1*ԋI g%P͍ ӣi~yѓW&,Q\5×FT]¢3V "ha1Q51׾_)nCݮr]^`7 XrsX9ˎ# JnmemL1`МyM= ThQ Q6,:9vMV#cWsD \R\NqxL=ge!3\8pF sbh8x6EY֍ %erK .(:sj`à0VMga*[HU95*x4f).W3%mydؑL܈Doz<`+9Eq0kK. Ƹ&1\@2X )kBl 3HOk3 kFIVx1;\)6Jk.CkW.#B& Ccq<{] (- 6tȣíqVM]1v\:a883r:te1akV32U]8rr)GZ1s14ZCkSvH9z\RRh +  e0{&NjNN&Vlj8NA90$s1Hq9ke6 i0 ѣZ^MbZ13s"DsƤJHʰU I5 `U-dָFh@L/+HŬb CkVmZT0s];W@5jN0sQ2GDZm9&6zQ!<޶%`q;# [92gBNaq‹fCjOuZڬFFd9a]NגsxဃI!`Ye ܆FѢk1N49! i]/qY6p&6j&$Dr*D\ uTp`ƫE@,KZ9yư^Ȋb ƆF̪c`"Q6([<(*gKe8cc@YŘ228.Yք/AT7o")'ea1S% 0U&@[Vpa-ZyE2N\8l )A fz @K2v\hnفqt0Z5N, hr&6KQ$a[=p;7E\g2S`0e)Eerq8pqy#85WFXg0uRs FG#: DW`$0ƕu(K"R0CМ*@]G8˨Ƞѡ{&3Y`LTq( 31 ˁ 3J É̑51&F-`q*.ePQ8r= YQUA"c|9 ÅðH!%X21^yxQ)^UɮX@5s\#!/2qlꛜf!3$agDXN 96   sFx9X2ȺgSYD]T㣜gz.*֢:ڐv7aMb1/c9%1ĺSOZ{ erHNɳ8L5 &p# ӕC&V΍`BbiD1{3lNfJa\*,Nz.p)%;ɜKH*BdT1(ȐgGPQyA"&q-ratng!L Yiõ2zzVWVc azG9<t^)o[=f,:y86OLs*k&*8&Pd(p. M`JUH $FTrɤͤ2v()0VsWPg; &4*-;=2h D>;dL/x iqu/XjcԑX.m]CѬ:A GFe(d  b0dy" 0(4 h䎚MM7 PY K.\ DM".m&đ\ͬELF L@M)p.pa"aٍl9Ŝbj$ٗhw8܄eȆ@Cf\:YODu)؜1:@lk9ɭgf) ITymo'/bѡ{Wj kY3 nr K<=/zgVtxT֞u͑ٽ{"pwI0&b69Ü=6u,h dћ91H˜b8u88AcY0.s&BIb8DE2!B쑅$K 8e tRVLHڣk w/D4C%:yL ZL ΤG$`04F+ժmBE%KO+( 6αmV,gB2c5htI,&d4Xk2C<ư.Ŧ7ˍvl6kdn*ȸJȘ803pF&3sH`莎AaZq̈́y3ϧy*]k1Wp˚至ܞoW,0ٺұd*Aqs{DjG&cF,2#XF˧ѲCLx08:X 4dZ03"5MG u{F˜yXV9Z3vTSjDdّx@.Its$j2sd @#6ʺ+&hcwQ ;' LFi"wtN `P]{AFDҶCJcCqȐX] <\u= 8d!#Gebna brSMNd|ɖ'&ɞ9s' kA9Ǝɭ!)gX :zLChZmscT檻i,1dW`fuAh&HչpCN33k@1&^N8 B0+.g'.y)ΐ4M޲`Wq8.†Uir'*5qq9 Q9ɈsVyQLS. @L( Ia'K%6DLk\Bt`fܦyŦg;}&WV0ZCK`uLUFC\u+6(4`:.2(Z4F].4:1;qj4(c& xgGDQ/FMխ#sT$i<)ïxM! Ts1؛=0xYNZd :8Q:jK I"lN=x%s%SG ^u6ƠLUpd,JhS9M#")2vNԀ`ѥ+(C2Eevq^Ay!tGR-]i(СC ,g2&v% AkZ@r"PP!'цӱreZ)\\l+#0 PC v#73֪Ɗ;@]T`6w qX3xf#pk>cpzzkYzP]jMU܆'&; Vdq9XT9i^2ִm (qcɸޮ8(ձ;ϵb{A݌BY0p9a:eJ9&O g>$iec4,h alDҁa4ӂTwe{'mw4]a(;j!dF,: lQAlmyGqo(~KlɵeU&({A4t)%?ÌDmzʛytI܅8:"ܐQNh֖&J#8`$uzIÜ.";=z^ֲdjfz/պ&Hbq1z佬mBOdQ1y$"'MtCwKMUM9NRDƃIwytq8.u8t~1mi^z՜AfdG8%+̒9q֝f$v٧yqDECʽ$|gEM"(kl.-irii~tzh//kATJR"r?snrl"uh('gh0IT%4?CV&"b-nPT$yט\_:ufGi;":- u E7hñ 'w"y`ǘNk:݂i)eois@%4vMԽGvcfhh1XѦ)51FˊhjN%4CNCЕEhƬ::vjm[aSprw@'c-۴M =_~{}dփUd]W3ܮɓ96D3QֈjyMy߱2ϕ'{͸:7G~YSM:YEdbQ:ut13oӣO$yDT_:ΣQ@W9DSh3,5sm9˴3L֗.YQ5iGFSX̲f]iM]I6)v%rK3hشD2*]2YZrZ6fbuf3.V 1,EZ0˥:]tʙ[9kdc(jU!kIЙfU3K\mN09juYWUQb֎t)qXZu&j uk)\-d YLlXmiI&CiɹhnV,LMjɪ5Lc*J)kL-i8j3+2#lZIrRkZT7'vM͛eBC]&.֮MTjc[5Mi&E᳊];&ƍNu3+I[+]T8R$frіnjqW"["M 8,kD,I6WXL5Ůk9Փ \5iR$,ƨHMuVm2Zc\]%Q̮uX] 25hŔrZV[ԪgFԺ%̌U"YB6Yc:t#ri՘5tMJ:$jeumf%4TY̵Ѳih\aCmmZF6[7r)*\pebYj,,UTM+#ZibeK[WLUILua,4uti fjJ+-b UaCkk)2ZŲYdt*jJl:j;Vʖ+G \Jfil.v16)̈BEN5keji[5Ѭ̛Y)e`hƵa6p&s*YӚLZU46ib$*;DitiJa2\Y0+Nf-hIʺZZJK3HNؓ4,eVeZk0R֒bɭ):3Z9XٶAiYX71bXR"՘4p5d4c]4ӭ inrݚ fIҗKU呬5:sedrա\(q:Xf\&XrL լPƵU-ɬͬDV霚uvfv>oV7/aýl^ٖI>=c䖵B0F@l) TCPl@[a4 +Ji}J9Cuh&(1 ]J*5]W UAQ.:+傐BF%PP3BT]-*D jZ)SHN r(T ` TW$;҂R @SH#J *P('(HEG۔4}"n0 SMP! +F b:F%"H K81虎E#V_ro&¨ep -jί+-YGn{aӦ|?M"YՑ4Ca`hn"T\Pq~;'UlДDQP=nI֊b;'bGsٴtW5JȔXJ]`@^g[\mTWg3 Kn,:pg%+Hh1&CEkQ-/lt1630qn::Ļ^wi³ڿYMgPSydh qt:誚 u"̺-ƶb wބYn}$^[7Ec}qN2]i-HBR^ݧ}wN}x?z_7w':>=#PjJr)Eiݻdˬ X,x8QUT ʪ R՝e9Cl@t˲dfdڵV8&̦YfرLȌmekU֩ZlIDUR-i*ؚ%[Lj9nvه Vȳ.ծYXXv"ɣZJ4dfZ$*&M**.`1f&jeeZYб5v٫2pjvMl&FJnm[n-uD!fZ\ڌ3g,M.MuVZeue \$Ǝ[F2'8X5uҲi8U4VlՕm,;V\ڛ1@mZ6Mu4ծ֬hĬh"i*k*bFk85E74$ȑˑ!9uUn v5hF5aY\-51KijVqҢUVLeZ#ZU0VK%jʘp\m]XZV #SLk 9c*.eVi!4d%CLJ̶ KS-nhiJٝn\RM%2ٌ::gVfd]]Y*E[ #e0f:s$5[bhVA5X1ѣZP\妩 ZL\&,լ̢Rf]c&Zb̓kL.bSdVjr(&' `͓'Ls*;5vTmV`l14"-u*kUJM[V*.aɤʙZiJ9ZY("Mdk.!ksSZdmeRYk%WLV,ص1ɪVڴYImldN,ӕetm*6ֶR- k-bdɅdic-Fi1l0e-b&HUr,4ښ溙SZlMRuUiRs5IuFN͌ո4sNFi թbdӖQk҃ij]fiĎmm4WRlcUS4hI9#s!nM6òZ nm#pe389ƘcQs$,ȮEԮbڕmvhkPىZ6iRu)ʶعZ59,5XK# %ofmV&ykjy|1s]h~}s/0>uyYQU%G!YwmD ѠVJl]'E'R:~ TZZ6QA+24CH'j!2) &JZQ )@RrSRJP?P JhQ ($_nDRR@4 RA{% P %A'DJ͓D>H4DPkUCJ@iPDVA@>H f@k@2ryǜ>vicSNu윆=R auweSyR帺͵Gyɻ pöUeYՔVw$QG_ºyﶈS5$2QtKlee|**}We"z 3MZHѴjzב h)/;{jMAKE4v3r^gѣ@И=GYvw丼'lqȡ)vP+g:ѥלϞn&%۴NghtV(N髁VzR$Uӿ6\=QyK%6mY$w9^ub|vNf}[]ӓ#nȁ&MdؕyI51zh}bm$|qWZfk/ZyXkOlogx| ,d9 {yxe@8)$.JI (9N$D G(B##H +Hu:stEI'\T9q;TN.Hp;⋈⸧\G"CIp8#q')@ttQu(EEuIAGTWqqDNΓH9I ReiRW:))\uq)"rR]'88N((:K(JNEK(P).sRt\wAܤA)KLHDGpQuS!]N:@BrR:9::@ .\t\tJ!(*8QqE89(]#D]r]GI#ȡ8S "(IT.('u'()QTBN!q\Wr\]#\W(8qӈ:8;'%).:w;B H Y!IP:As.Du+Dw:"QK".(*rHQqt\t\QtQ\N$rWQ:%GQG$u;r)89:;+Nrt]PແqEr9wE$GQNruQʣ\:8B+;'Dw.AtA rwqR@!KMQ R%"@PS(BHq;DEQE.*@($D98A]G8rHqrRt]q+ . DW*]QCp:;HE$ Rt@8r8N!!t'9#ĝDqR:Sq$TW9S w%8INrSAGrwr tp'HtqRsIM-U0KJPS 898⣣K:#H::8 㢓#Css㈤(C(.:C8r:(# rN;(:J J8褣)(88C䓂9DJA(KJ;@8*P.".耨Ⓓ" H. ;:( 8(8%3%- 5 C5-$Dq9Ԑq'9r]!9GEDNWQAGwIQ%]q8QQpDq'HqE%EpE'$qDqqq'—ApDD]"EGRS G'9qENQQRDu\w uwqtp]wGQQ!'IG'PRIQHDrtw.!ӑ]AI"QԎr\$DIsrIq!G'PutPQt\QDtQEНqDtttErtDqQIpIE(THIQ9ܜEQpsw qEt'qpBwGG'AtEwQR]G9ID'ED sR\A9'Ý$]$t%Q!q$wDtWܑuEwE'QGĒtpGI@qt]QB5PEQEpDuuq"w]qGGE@wQAqE#$wIEqQIIEHwQtQNQPGqIT!ErGppPGQQԝ#HBwTTAut\qW$EqItI!I\Q9 tRBD'QIPKB%$CM..(꓄B+i|?0;X(NDu'9Qt^wEY~ݸ) KZ;ٺӲˬ*I|ƮhCE;&d(Ry̷W[.\vƁd)V.;6b#vc +C掻)sv֊٥`PU--uM.^V\W~jarsk(tmc;fO다vOcb;D]ǛI޻D&4ZMښzt>Oyy^{Vifkkv wy #4aK>n8Տ1wlf&v4#Bj;\4|(|ORtv0({8ǵ2e!+ YrNO]n:QjQ6)t)( hMP̑0oഔ JR# H*Q* @TFB&_ BiGB&ZZT&h($QWIDߕ!bJ+TP{ RURT4"HBI읈A7]Z`%JRbBSB@)bxHbP t@'XUT V<%_';-(C J@ҭYCKD7jbǃm#KcǐfiKlJt =0r;xtl:kZ Ggc{CG.pGyٝÎTWʌ̃oojsP†MPd4eEvZJ۷q4l6t!HÜmi-i9LR&ۛӶ[X7XuZ VmuLKUwYj5fZڸeq5L6k!d[nfq"(g,eILc]\ԦUeVG:tiΦNDpm IiQmKkVU;5]tӛ .u12kYұjNͬ&3fLV*ضmLɹmilk]C1˖N5#r-SRƘH-1 smQKGZ.Fr4YXsTӌUXfuLlWcrfTIV2:uQjշZv [im:kV-FZ9['̮ m(S\F\c\գKjjs,ӫV֬&Mj,]r\YVZTkt.Z Qrkں6k3sݵ5rt,i,6if͚YacafKT$95۳lܓb6ӬFikdӳ[cm93ȗ4YYm\5YUs)VZ\[U3U+[4Jq]]P#-RlikEQNkE!lM l6d6qDk[-"]);L@ffӈm.%!b].KXeCvjMbmŐN&Ɣ5ڭ6hmT,JS-J,IG*rZeZV9iTk:A e %殚i9ЫHkU4Qk5`sWVY&MMiYe,l営Bv[VVa*g*M5[IKYdfMe6w`jNM*Y%&Yn56ՙ2ի0UV3XIfEhRtU346M mZ!m9fS&5-kKXˍ4fbkS+ ,Ume-m%h1rK3"VujVU]SZ[Xn2rѭ&-k%0݈sl b+MVkVQ6VRY?.X>-7>'ilZфuR+--ZE(#@{Tn+#BK *kM"R)KTL#J/l1JP))f!HJ:Qt#M0 GQ4P5Gu՜ Pې(e{r' 洤@J@4K0i tiBT~~x:BNJ4hBQZ:DT4S?]h61IӴ,^^vN;ã<0^B.^UNT UcoZ04?><Γ^qPCYT]M7e"ttPi@O*sJLa#QLSZ]uluYoYG mM3;e"=wS%1dr|SyARgˢj%|v,ee<ӻ-geYeiԝOskv;{vEkϟ"s幘RJnH] L<DV/~wpU[I#- <ϟqmo":Յ=K[޷ lHQei~UkNWu;'"v j;H43R FjQlZU|LIl}oz\ކCo ܂j"&(KtC qĔAI: BCJ;HN.+9IR\UPrt]qøDtwȸq·N'"sӹ*NpN;Q'$"N@]Dq9p T]wDIӕtRNwIHҡ!r.:.;9pN亸NR9N8.(wGt:)ttwp$DJЅ#@ҭ43;*sq@N 8"Rq@@tQIܒqTqQpw \rGu㸔u@⎎.8㣩N )r:;+rG :w !"rqR\'\r]pドtwQӻG(닋;':I"((u;G8rJ(9NRC!SGBRE.9qu..#pIpDr*QJ8.D:9r9)"8])q8!w\Ht]:':㣮. (.((\8)qS.(u9HbBXJIib&wtpr rq%IQNq8NU" .8Nt+.wQ]DHKGqB]PI4DQ1 L B$Q.GB):$ˋ9\88ꈝwp#$tUC\Wp'uãHuw Tr:;븉::% ґQT*:)!(R"%f )i!h%&J:))p%$G':)΃ "p%p %΂Jr+J8R@ Hq98:.$K##N⎓."@*R8©.N:(:sCNN丸":(88H!GJ $#8.88;8䎎K8:㊜!;J::(:8(8)%;(89(.#s;9ˎ'N98'8:( ;;:;8M4K-$M4$Tq'rPQu\qpq GA!DG!$A'QN9A%PsIAER!QIE\tt\IGQ$pGt!GG'!D]$RDD\pqQ]uIQpEGrDU%I'Jw'tԗAQtTIwAW9D\wtuqq\GAEPrqtqE9'qDEGN'QwӔrQ'SSqquT\RDQ$GQBWp\qtUrw]qA$NuJB8qܧA\IE\]t''DtqEGqw'tG\QGpr'TIIwI]8Iq$tAGuIHqrE)"IIDE\TT\IIE9SQq%$rqqr tG)NGrTpNGt!p'$AR]N!%:tWNTqEE$qQqHHqq@EPw$QpqwEsqDw'ED@DNIE@ pDtqD\\qIEqAPq'Gr%9܉wÝ8$IQ܇ܔq\%AH%BA!AuHprTE$t%$GE!pQHq'$wuHA5A~4 AVE'VՉvȸ.̿ywI/k\'6SNm/nzGYڻ(ó;:6ܦd6F2~>hz{[IlASllv.cɌ1X31z,j=eyyhmHz]RE=1AL`A7`4'I}֓v:4%sAgop$slŽ$=+8؈i%M`ɐ81Ӽ[tJ wur .;IXBOk;nڢv0*Oڳ:{޼.htVDw8VV{֞Kۯ"9,9m~kۧW"dm1l0WA2(qvk.Ȳ!--W@4wGu˅]H_u1EӥSH!J+U#@ГS{.@! 4)J05%1%4 "(:4)H,HT- @F*e$((w 2r*JJ(TPj(__B>y fZ@<6TҎb4i+iBHg kzpv!^Uqlu'dt` >q^h,Vvרνvi=$3@[RCdh|uo#%EѠfSAKBit]iQV31{x`RWeYerWumWsq'' 9{Qfq."{Yhⓛjdat ,:zjt:~7|9Y%YWWZEGryYVUn"[:n-{j8" hHݚiFq;bzyiK0^M%EhM!퓥tQ-/׺ï-36}Fl`$Z#)1d4jQfd$Wg>;LOؔ"x̀@M8\Ԉ4*iӗ`*) ((9IݳtJ8K *r8\eX/n:h{/v);8*(ca me)G{\fշ]GR_.ON]K{On;ك2Phb}JtPD#j[v;lŤC}#v=^yfڰ.kfyeYrJ]7o=yRghhRz]{YyWZk/lb)/Iy-Z)WH&y]Zvu6:ˎ24/3( ȡʅ[:=28pmau{{ߧ;$K}ߣ,j$tNdz{=k>֟]B@bks/data/tempb.RData0000644000176200001440000020205413265504513013633 0ustar liggesusers7zXZi"6!X ])TW"nRʟⅧ ""ȏdׂ,c{u 6Lϋ>Lטc e>m󰯂VqN JyLHD'UyXӇ(kC)Nؔ;2\DήAV$? )* qicLjiS݆'u܂KpMt; v4fPr,.+_9ˆٿS#%K3 <ђT/n9o@ +Z<'|f;4M~ :^ՁdTκYT w:w%gq<<3q9_$< c䩔JSyls}9IF8ʹ.boHrN$v @mҊuDQlM˧nךm(<ty[YՌ7P51}j/iTLGēvlcyJ2pTrhڸ7RRuo} ~"v[dpw6duydٿ 㗦2P:9͵|&]C^^xF30|6}QlSl™i'ADn.[B~-fnՋLߌUr…[3& WA!3H=3ЛSf\Ɋl/7h (:oE/wK;!k^|w};r\ _f]ܣ$<p.bs٣cR$Y@L$ Q7G,4J"%m 7:?zPyÆҨ;|wnJZ +&o{K LIj Rn:/2PCK7V6߾~M5L6-oЕg'aA5ֱ.f8+kTBMi_3wG1U9Tf(Dcd} |ӄbDI:%@̐}ZeCWj-D=yZ`݅S&.j\%kBgb-% /5#ɩOj=sb{!s"(?`}Pf%#…>u'GɶYo2dӈT`yTYO 6&'(AՎp,s^]ϢqAkWɹ6- fG ;JnRTF٠mYpߘ2;y7D]T%@9OMe/EJږBjPa `%w̝&\%7ZGЉR.[)FaaQL:ݷ0XZr/ȡ٦?sE8_jhNm@f R`mLC#rg_w$:z~5P&#׷@?]Q .d"귅X /th BS/, TK4p]kR''~pfab:UEfX[,{P?k.qiu@MZeHڨZ`Clh<3%3/5xKIsM7yjd޳1vRTM ?8i`x]FC۬g` v0RF \7F ȩڸZb͈)N$i3T:(cEv;K&nn9Jwǥ)vcxޟ8~P̈́ X^KDx[IvK5ZH H 0 A~?B4yJf4JM!Rբg;8LÛngmP/ZqY2W3ǜ x${Q%;@#2A۶^IrqXq:_NbBQYW>G_*t!"*鋋&Vsl) %/ .D,\-#  !5#}tW5vˈ^Hg r0{,(|nݢ'S@[ؾ>?F;?}[8R9KGw2x;mP%CN f~d,ȴSLxFD-J/C&NL:_]zjDYRE 5R+;bs(~DeovxF۴ݼ&~`Co "/pB-r.#_v8;*ߞ2~Xŧ92ҚV/TOu~7!cXKs)P#, kӦV f=[:Fr;Ѫ婲扐& |(T=& +i=lkW^]'h~`-Pt08/h!Q kT2A՘ k\~@S6 S=`jʞ54FgϤk< (TOV$6Ut@&w8zkJ)÷,zqDe7\?,S^',ښ1[J48gg?9D^+b?HҪzo~$3QG.(bI3MZ7-XNPdQ/DžX/KPQE1X|\H( [e[<ƀ7'=hE83!#K_l'ĦH)񰴎Tө`m$ZK*Tw^Β).`'W n) zQK8رin ҍVT=Gvg@S=n`o+qkٰR 0jNd(kʰd0Q/ӼUl5&Zc@V1r¶;xm_J2˱3zxT(MwoZPY#'eb$NjeX#7` [Zo-ƕ!{ct/X#( KjzRoײ;Ί[X`?$Qy|UP5'mq/J bζo#5E+/}2p*`ϫ5Xֶ2-W7cQF5Ԇ`Z|wruB&^nq4AED[(v&,O=dMT ^p&ӌ# ~uN,f]Ѹ~N7\;U%2bHos>jѥj$8W|12$ $hjw=37P[4+ט~%L1Ki T,jqr}3(v8lSW,Ɇ.#Ͳ04Pm42pK/{r/",>:dh@GN4>`2frd: ^i$u X?6$vpY %VS9H+3 b4ɝ!4h((Af5nOpQ}ql["{;bls?LYА 8Ŋ8Te0s\X+5zVeMk̀?LMaz0S(A-~Q}=f5^ȋx~+(5<e^0m;@s ڇ ˊʩC#O*㌶/,Pf,WYluGVgCs[=1ʻH&|:N^\>Soyc/2ޘ k62gB9{ni"h0+*ђ@˭JѨ @IW_w rm´'0/=Z3axR'a'[RXbXB5$vR=4Gwt}‘JkZTGbuYz%SqZ?ϛgcQi޸-GK̊TGO, $p$dU_ADiW6MZѻ{*/Dau/j7"8 yճ>Yy2"՚}^-K%(UdkMG(OT?dԨGJe$Yvuql T~e nr7nQH K=Ô0M 7.4iz]p@A`58&% ht>H=$̕61)DdHIqN׾zJ%+8v![c"E0IWh AuӇQ,$PkjqQֻ y^y&}6XهMo5~E[M2UD m h|<~(k.zT`x^>Ap}IA.x$j 7 j P*嵶n:Qw. .3y`$2`텚u(gy-ͳőqa0,V [$uZt w[pjK!Ջ4[mq(#mn0e:kY-M1{F?.A!EqwXM$cŽ̇Md-uXba\h(A[8u=Rqwܕ; mh~-@hFQ#LEz緿9U* l꾮|2pa!Imظ0ahlF}vB*] *QBʦ>"KD}ƖlC㏴&g~#OhhH$ӲZ=ey+q2nJ`RU?SG=oq&Rl 󑂱;©޻7I= )0ArYҊQSݍL؞Vfp>Rk#[.(B#W.pg FsEsˆ ܾ*m"'uRj+6izﳏc:"e:7λ:p<=; su޻S (ZMI0N}e˖󦅴ɻ6k[f1qѦOiy:3 |[Os5+]sIlNz>-L]QɫLxCcvs9Um5z!X#UB;ۖxs0 ~!S;ClB \=|KCeLsj*|X6HPOp7#wI{(=nc`sIeò$ؾy2*[>5h >]o4;Jih`N=\PݖNIfZ!դl>;2-Ȭ[{V7v&dd {;I= m3_pHPoyTlR=FdհkQ4pc5T/4TZ&10j1{vnc"h; =hUY5x cGpI#Tօ*´R(~$E|7tM|6K^SL`0*dT,+c!r^+hr2$3Lj3MZ͡xLj[cM(k-ahһnu<{f@ AlF7đ5 KG8Mn"k*X--Oρyv^\-BabF:<׵g <[-7bN3̓*emR[0C0/QV_ D0W5ĩ6|c@gOp $ 3D!pYk;S&WR:|HLj /{1ָv5^`( +̱l(b| j(_t2{9vps+Nmϴ eUzQ'~WV_l! XZ*с>\^vKy챽4b3zǍLkj^ FUY'"'P2,HUy"U]G l83dD#[B2?SRy"~|4bhi tJ]21\:XkX/wcȰ: _ ( M0TV(^'ݯb.Źqw+:tv8n߈ S2Oցw"\mwdT&f 1LO\@Cl9t;K5DzC.IpzIlrk"E+7yl+￰8a~k wr[|OA>@_נM@@ $E1MʮsU!gV$nգ[W+ ɬOd{tJs+[? ffڎg:7D)0u=cX!Sqœ9*LL0#崺t\;)N(S@TF[aE@'ַ׊nn(iXuiSqWB4X7'Ġfʎv 6|v\.ٚ  x`(mjL)۫Kza \kB4(YA7Vn`*f/`ez a|Te@x XtV oCVvq6h:7N=Wd@+øuQ9&j.'<}%R 7 C+W41k !]{T$80H=/|evKH'@H O1P kmF) qh%.ᡏ1 X%<= Nj˲:QZ/+SRW+,% RTb:f43o;P24+TĆfbᚮiC|Rhwws<[Uq<&R"vE<w lv:  qfM]΍M{HPm8Hݛ3>$* E0]1KDŽ跪ޮ'-u"usbBy.$A[ΒEW99MAm˕Du=wv$B$}][U:ﺒ3d88nF,vM}FiH2Z]h'M4t/`Г( ߮-)<-=r"ݠ)QH 3drZak!(, ΒS 85ZTyDinJ*Yk/Mm75:hd5BːPa b$pNReP6nFw @ JOJ䛏}Z# cTr`R#q!}13'qFn^r2B8g"g") ҈eMyާ}sLzچ-BbtA L.gJF~p0/yEqfukGdZ"Vl5hH^2:M]S^UACb 1 X|lxKAlΝ0X_cRTi֜,)_]x$Rs\ȨdÜI!u 1p,s}_pJ,ApZeLQ 5SKo, +  ]/H ME"( W琉AM!9BuU HDq`VvqwL~o%s!>@O[zMT*bK곟]\<ޏOkҡbh՞}3o7GldžW".daE[v 2{n{δ:c^mcȭ$V=d/^o߃ߡN3ݟ e:ɨ)IjRM V 1|ucJʜSXz^S]%;|X!]צE/UL20y͎3Yڞilp.ː#e脄HrWk l"/)Scnv`1ƒZiCV%8uJ 7+VWc TP}!hmVyta*U7|8:ve[GrnA(jfÊ@579ގ]J AX:`L_ g?Y ;sp4M s P4M34/ \!-(jڠG] E\hʄZKgͮӁ\5C{z~?I-ҟJCtu<,y0^6?n\f󿽆Ah',rCDq/'Sg\`(4L)M̃-P>$PLu 5'9 DwhfT5 v\y4&#t⊋w͝!/$ KbXo=`Ǭq&q\B ^mKawfoa))xp)`&Aho_' !9cP9!jJH%j~F"C-FzFs0{Z,\5Q /nbqնoS JPǪtȧElyS')ɥ>Mr?U4|3ZD DHu}T\s]o'O\5Z۪ AǚY7KbD Kw#tLgrcČ{pDwG)35Yv@MڐmHqZ4ltrKvEuz_zHD[RU!T d]Vn؆nR O0@7Ϸ݇ٙ}SĻP4i#i.()]zg1Pb'ݥZjW%E7ۉ Lwj?8 Kk 9죵+{ٳ`R})أq|dbJZ,5Sr(ḦEm>6oȡsYJHT2g(2Qs)v;E ne{ȾNJX0 6I//.m?OV3ܞm~qn0x*5]4_sCS!{4*nwn%C{m{\88}J<=-܁s/=MfkH}*R@]deosK̙i(β{=p3\'{L׉\GhpT@Z,!H顝# |VC'3Ząĉ~;g BETԝ;ԮHgs c'DL(ؠh9SD.tg?o$6ûx*Nb1M^qB` 1̸37%O YA1[׼N VFҸ&`8⚓vW %WGnqȘ㙫3Aӝ0ݪM>c$PԶw*-On]w(;'iTC1XŞw_=vw3AB)"U.:+2xvYqx2]tMpLhzə ] e#q6܉^&vߚDUH}BMTl}Takwh`XĻUiRa"#սRY#/N5JmKy*Kqt/dm,%n8 V+YnqmF{ |KτgX)}^)JXۄ;g:YP:qf+ef *gYJ6PS5еx$ x۽yݹ}"pWMV/mW`E ngktP&cs}r/ĘQv%6kN^ zsZ sdZL۾e:& 3A.LTD=Q=#ef7-w+І;]gDAT#\h&6d- á>(\*% S V7u CAO/"l2<]F 8=ᔯSB"VFXgnaM" snJ1BJFPc;aXnGk{ ?Ytvd+C eflv=}~_%67 4hA3v&n/DܱI7~-y φxR' 5gapwUM&}R)X 0SiR~AC)T0I۽ϘH4Ck2>Pn`1{2m(HiO=>qi.29Hʤ $`e|6!$$_7:{b^|d)GK _Kġ.ʮr/+h!3|0X-\wڬcCSCvIzN5o;Ut(1/N5|Z4 P혴YhsRx IZȳl"U5!TFN~Md`т9+%贪ZT ?k%Йh3 #?IJOagi}ɦL8j(Q:%h>im5mUaO'8nw ~$>]pb5Dsg7p0w >Hq.(,VHP2$ S%l0Aʮ ^E5DwZ`twͿ(/Y 4PNcճ0QWq8jf|n}$ydY1kdtN{-+U `c)]^cq̾X;zeg`N ,ud T _Y\h3&j "PM mtH0‰"[io19|aH0ޚ l\|(ٔF1H)!%_>H+vX۽´Y:6amW0NnV2;oW#vu!,묲7ˬ~H-bnEvLpS{sg@őtr}hTDը>~mKu)9޿6o*2,=IYx,a()SΛBDk:+w\wFZDn@YSLE|bNRꮇ7pn0 Lvf/Hx"~ϡnf3U~𱗷vsOšuf]vQ(?vI&܂%ll5Ctq ,JV 4pYۋzK1l}R!p`sp-O'Rkp ^OW _`q2{ Yw5lu<a{?ʜKAF/0~UmW q dx(1aBu-eTzqh&oojRS=@cRY]G,(+;d_` xnm5\0xOR<|Gs#8īM-hYhV(& VӧȌlvmK=׸$ujN]D%8q\aJm<q<-#7R}`,n;>ȶL&'FrcMX}L4 ;h|OI&AFIb WY;]0⊀ 3`TS<5(guxՈSt+Yňe0`Y 3)ԩF&p[90tة@dgƴI(ZV!a#<$zϏ3 nJ; $_L i]ڥ09eInj"0w%v#G|Q_ @Q]h6Su=P½]NւfIvW5wwThm oqC&\C{9ߝZ2/t'B pxjrY.?X( P*M`§@RE>}pFNɅM;lM\'su.) Yf_$Ϳm4|3]m+oK5Hd,>Uw|Bvޘ҂Гͅ]Ж$kZ/[6U8*GT&X% ,=+tsV)͗+G#R4?I8KIKF@J֩cG{bg *:縭x|/@s[Bn/UnA;e8fĄtKwÇb\2lڸ[,Jz,jcタPz>]7CǴ+@N ԁ;*nLnr%:qD2/9Go@h0hW:ZAOFT@PTTnB!a'1; L:$>]Oh35zM;&މӀ;!?Tp6fG(:~ cYYb$e4.f (kQ"`3LMLrd>/7 Njr$N}'uA>BwcGZ@<&VT>yg 7bedqzy:rfu͹/)Mr@Bx_/R;fL c/E3 ire &ھEXǩ6!7d1<)Ug&ΰ:$vn<5싀#H_g.>ta &_%e4Bj6ve8I1yB|so7=w(c0h- xˌZn~M/[wHڀxdHvGTIR0ɇmW)mf5**O>buḠϔ'z>ytoY"~xGuiN1]˩`i 8ʛ >彈`o9xƎ48 4!r/᩹zts~/e?s[|hVWZ t$Zq5$Z}Ra (#s"N"֓O]^'dz;Q+=x7g&JNT76;E~笏dr7:Ҙd`i:5l-Lĝᄫ]FyD}i,F#kH|ñ*H* ^ZÄjp`l//Kٶ'b*e|H[T| (?SWX'(Dm>WOx$MKFRNMrR0s|>TY>JʭndQ="Sdo1x8Bt *Һ$\]Y@Ƀ( ]9̭ѮSy$uI&Vu$~uO$wΠ<~:@qSgK_&LcVpOZmϩ Օr%*f,-ҕtAّF̙JĈ$ CtJ??.=tC ]jM8-C{(V8 ~G)({3k9o-7+uH}a wQ4ȚSbF;"'-U@$ #<']Hp*e6QQ ݱ|cQJY(ZRs$ :web^9}3J,: 6t0N$,Yf kmg6gx~q7 Ln8W~+2en;x)?;kv~<鄱hE,U3ϵBP4d %odXQ #vn1-pychmKM څ3~0l2u0i ŦσDp6<R ͘4%*u.L^^S>O;s>A Ƽ%mX6 7?toBS~0/9[>lr[zŦ$Tlgt: J?5boʮ(pf}lW Q#՛=)gor(lvJIZm٣` t7ҍ;dwbh$@g'~5l-6`EҾ!C֡c0.9 IX#喉3ʽzhx\1v %z#4 m)W{tjDS#*[)M&M* ʥCJyGR?W+YBɶLFɰUOaVs"R@[H<$^qmY4q 2W4#;Z*(큈B 0tϬ{z.l%qg%wǭp$H{LX#`O\r m uZ8$ƿ$Vt/2\pbz`,_b%Ct 㠿KQ)/-tEL`~o-OܶRйXXc;vU@1NIEk$Y ׇCFY7? "nUT_;Ԟ}3=X $xz>9;(7{8j¼5:76^+a<;g{ֵU~~Ҹ[Pܐ>p?F)Iq`A}%,a4RDzgįnaG^ۊk \ 1#Yt{px{lQeɭk1}7ANѸ&ķBuBc]5jBw-y 01-O)hy,h hal.21c"f.X5:vツ^A^i{q.D v~[jϗآ %<$G9b Q:+|Őƥ9pjo#~: 7 4 $HiR1f^ IzbE;(*@̛`ڬm< jXwr@eٵ|joTj[U5'.s{|~LUm (Txo1 ' Ugr|܉~S oXm}WUXt7O DhCwTa<_[ճ/#l䊵 Iu)Txɮþ9Lzpum^ڙWMxla" 7IZ|~U^d>yM vi/hOYr8 E[?xoOG fM~{\ɉ]TFTnp6h=͕;$@Omd,lА]~hJuH/MF;MԔ(Q.Xb-*ļ* NN]L*K}<\䫰N5O8hk9۟Ͳ2wZ处Innh%xcOIfFJ}B̔nmR;|N vGIVQ*Ǟ/ڦheq2|󺬫M"='G^ܞ.ڢ@3h*~7luՖTwޙ8/!K8&G O ̼'qɣ_tzxqu\3<]9HEbDJ`(PҭN*9/s$ʥˬF"80uzvvQ8Nmڰ/I̽TexX3cWvM܄9b m艺 -U-!=RD*:dՖŲq ЫX4ƪK5Aa#994jn TQ fKWPBQOtb3 ;ɳF1>ry^zk% Ca*pQ.G  +l碲{!q${č.?Nm_,L4|hӑuVnNAZ`;*Le!x_c}arEj:|dL bfW=YbvWX_mSdc9> q9{>$tw%n0Ty:.o4cg97)$kw~#$pvZ0,s;+`ez@a02HU0sΉ[ < t[!Е;o3tfq VU$K'߃ЊzvaVѳCR}bmCf"`+<ѹWZ!=GRbj߅mui.f!*)j*jbS9[gqZnZ`,b(7H a?onN9l]Lқrp^4dR6sS쥨"o&L֬N79Xg 6/I;=&H\Yd&iDk,VIZUN ނͬӣRe*D1qQ32]rٛAs#^(`Ɨ>-( t h&RY=|62+>lIx,+BxHݳɠ= \OzKhx7Ί֪&Ut x*uͮ2Q{I pf_$:֗[}CS…051Dz#C"`8µ%""GrJ(0Pq\S}]C)E9^8VAmd㢔ӟ1y,iW.y|1P`Cgtepkm9#b -bV=龜Բ`p4g"`[ބY|̥u'KHRDJ$iEֆ$`jMG~1*̝F;m~G4@ fM} oʖf+7DT2i{s3yFzsXYdfdQى}įoS?\_AvšC Cbw3&u5vB%`滟?〱cՑ/O0ejXi ăX7Gn{_pzz y9]!9}~.FkiJ&p û4s^nZVg`}gu&R()׾ބNг.~Πb UKh̘Q_e:R ոZZaKϱ5f%- l.B?R&:VzbH`l{<7 0;S်a.@Po!*QVW6"oȥ;_"5%&|AwUݎh9E'Ơ 9"n#Oݩ+'moL9qc`Xtq5Il3׎) D,="J@$;(>Rj> }E֠vl&iD߾E.Zaؗ &\YZ..T[rFXٰW_f 6U$GE)9[ |D}tᚔoueBOLD VY+ڀ*B6 %EuFn=|lho@7f#+eH^2;c@Pި%&eIpQ 0|?iTQL.4˽ H`l<@=wf<j+J4Jg H^25UJ-}fIRQKΞ?1*VH)0^M~}1& /GOuf[vϕD_&O[ѳY~娺 y8&5`֝ߟ6r2kj9p=)yBW!7c+ӏ]*\(IxM2GdwDDݱXĕ`^<2#h YNə/ח\;GiGq@ގiQZ=xFz Х'ҕ It!z >Ayx&G|(LTVDI[.I mP%@ew&vx#LԃU(d^tFj-W=d E:ൂ4qrl (4@ όZW8gaw71BZޓoW]t"#kGd!@d>:ΑNٔw5$9Ě\{(-iE2lIvC:4+@JͷÃ#K64 +oH n-.Y/THL֥XV-~9 Ɣn.p3"_Or[N1wH#FFJ)\)㸭4ADEDuMu~gv I`oɈ F&.1K0B?1/FUˎGJhOb r)dKǡU 6 yb&@8+pݩz(;EtZ"pޮSHgp=rgj[in::Ѳ{ȫޯ,˾WVv Q@^ͩ}J[$qئnAuLY|tE4hb1+ֿՍ!@,Nj$ @f!c\eNHN[˦-<^S{8qV^݅scDY+xm vPPy&3+]4 c݊ >V$Ɂn9 a6F/Z/5# $^( H5fZ)gfb,jWA2W(/p~3=LT kG_Y淖m_Jp {ֿ30 89n)c̕a&GFϮJojlo/feo hDA4{&L6t=TIGףf#ȏ5ÙinTl9^<;N8B3`YӠv@pZbVð/7Z]1_@ =0EC^s]ReW me+W}? d~d7LÕ;{ B s.O~9$^Gѥ-V{j@ʧ"+g?Ӕi"% 3s5h뮼KbUL7zw$/i0:%j3ڐOҸ;I[I.7NT$LVwvqa!hA: u)^EeCRamF%{GfAfl,gyHAWI* 9vߟR顪N:^ Y!6o>wLO[ǐ +Ko#!ۺ=$D6H>ΑRNsU$4?R)Q`iq{JGvfj\ib';h7(|DIcPNh}@/ o|_͈ o* 4KC[o tcYEF/Oа$#QýYNrFY1>݊?/k$Bk5mDsq$)%#>D?9#o[)RHzᛷRz=#lvym%xPr 8!J$G5)F^+~fZ$jARj~X!ό#SL:0-d B6)}=? }(nZ e ;Wsax1|S.kr߮ҽ#BǍŒy0H)Rź)-t´8%V[ZuHHN{3tB[ Ηw`z AD斲+l@/Ԋ1-,s"L%]}-f;f60 .,G`]1CKf 6VY8%pC {jJ {C2sNR:,VY+sj>Ԣ/WohzǞ}y\I9x(خH:@WLnE/MԁFa'k ZbrA粅*yK\%_SEe ꏌu+S9B%deu0v]~/@I$sB-VaD؅/È4SfDn9kϊ3x(<\ Mk>3] U=QC_bthϳd '-9؂n)agr稛79aɾaK?ǿkqPk# AN9 d1şi_#5~K<쉼7Gp'ZCCBbf{,bJ]bp7%ӕOd R+j5H,\`+*PYF |1~Y6$<8}e2AԇBֽ$ę*YzM%],T^GȲf}$>Fʩq Jڶ^UqeyF-ѳ<'hDПg |"l)_aИoBWUNYm]\e9/65׏]Rj`XqB&}(Թ)@ k9}Q:3uʽ*9N*,{P o Sy=՞qZqǘl/j͙Xٞ\nHt}As٧w74T'F2r/o 5J}N^80D$:t!ҟ_+UsCY~zyw.vtx 1t#69M霾$G7YY|iPl'4xM`?s(/"ҊWHNB?ջ3`Yj"~";7K\o h׬8c%#4"N A ~9[|@yJvc`L:MWmCB"CE{β[ZJp" 8ZTi8wYם< ::/~1M?3(I_d u ŚzF;g# |ȳg)isD"_ uaF-,;kC鈲N$P.0v3r;KFB+>7I^>qt+6':Jb:P2հ@Hz}oS;!ޛ kS6$[r0DM|;XQˋVU4tփᷬ+QxKdJO;(>CJͣi7ۣi@}Ѽ" ɐ N@5kP3ʆ]5w'htQf^=L/s4.i+oG'74JAvPD1R, 7g. suC{.$*CQeN/aUپI>W,iQp2iφ]~ݥF9N &rX {(+Vb6_y%،XX) u1ުfh v_ zP0HNc滾H/,@&$k_'`zAMh%nc{~a&&AxZ] F'~п+PD"I.d9`_ʢ&gY8 heF0>(n z<%~NmL uG7Bz{VJ\,s0\@^ [Ei(Wxj?$ՔAJ:xi7{F1;NdY RjQC~,韥\/G>V6-?he M^Qh^U^l"8pP@+j3q5`Tyw $q %ߩS "[>c]ajJ^D-*_{4ɣP0? z@#6WtȿVHNRºgoVD@[Jjם&ESv˽k1XM.⺮{ ޺8t4߼؅M,+RT^m;W+Zrp/e UGAyT쑰FJcG29jZ4cKPGC|nQM,pò,% Zxkn&0͓z4]kBj4hmKS7ҙthg6cXcHˊGϏqka'R)Rqjs]FڹV`qKtAM[wCsKk;` Փ>sh?ƣnlP쎣EQp#7(8†]LBet y~B3 knOq"@،CJoНttswM!Z-gx4.#o>]kw=a 2+O Ÿ?-\)ҋPPm`]n9^T?(l6F%0݅T 9h)es[첀#nF艹̃As: G ; ~wM=C@ymDkm,AUp TqJUm&΢ ,FG#Ϋ20eldB>0'۞0iO6э45 3u'Pp;"2agȺ@;Vx<2clWOeI+ʯ3eElTohWK̻sl'quiَHPMB> mG[v9^Dґ_i{ .:]CMd,i 2aOWv㸨Xd))<.T؈>fp`Y "Oyf6ziϢV!޸g $Ic|MKӁ-ѕZ>0d-oDB(Gп >]}t&Xlg:ՏUI`cxY(9`֋vM_w&svi <13uMF@]Yh@\AbmiD~=?oLXKעgD Un`h9Cw'xHgusKI#* gKڊf7GPf2twfRwE`స﬘,Hb_g18j6KWHT !4'YFk9iLv?Ի&ZIvXIϙNJ`)h2pkS"a" II܅4 DaGk.a!Br綹EFZ Ϛ$.V^}lb3? G&U 2B a灧ɺ /jW\}FWxX~_bۙbU<ǵ\tHż,V )T(z-܄Q9׹\vcP+D -{ ˃Fk)WA?H-d}L@_V)ȍ'-7S11Pd6AL5o:ҲRɯ9 A<:VB̟)C z}%JeL%Úe_.6lOjQ۲ԪnYPJ~UntyVXsyX,n@ۈK*jg\4@u'\K^7RS$mx(xe2~oW{Cхv)c-{b7OIbhh\G)Ʈ)XZ^N9m!0x䯖g¦IEM ڤUot !DHv7K1ٍ;WMFZ>5:~Z ?b9)l̜F!6K<˸,PTcs QX!kd;v ŽsD%sM~+z]2fCeyr,->#D':5'2NᵡD#\w`A_iIg(RbZ;d?7?>I-b"%XY ocney BHWl+<ڴzT Ŭ$cx˻]*PP,*&12xe<_ *I=sY52V}ceRŒQpcV֍,|0/lPa;{qm-Z!0exzռ-fe{D-0N+rz)0v[-A*Z]N`x+Ԕ/ g.2f~Oau,{zbۗ_?⽝ 2p|;@-uT)@M5 dP(f5i j~'jͽIk#9axow 0L6'^m`.ߡ݊Q:`~:>}b"xn_4s0zΉ"9h-|JZ&-)i2땞vODġM=T$يh,0FmvJ:`A>wfc\dЛa_ƴԻFaD:3LM(3W&G&R~M/44ð <:^'z(cB`6#c{M6&Sdl|6,qT61m7|E}* 6ҬF 1Y\Y,x1̫%g9X-:&5@RF'}6n7[x\+sK 16 W1T9 TH- ?"pUs094@- USeq?qkK-ˠw̾ "'Rt˫?8a mϬYNS&@ +9R!-%e(+]Tmm z ?,ѕD ܽeOyE`n y^%,˭TxJw(,.Q:C8cu/U*ݱ-kJH,uHuJ1m$υ{dSLĉ5Jo&P&QbruFFub<]./НRGr,Y13Ha,<-GX%K'$}wɿcx|!?::@_Q lE˷ir7o'ePX3uSoP_J$(R)& kwtzp҄Z68ˮNJ4'^u.w|25b)\Ge. v,J,IUL?FnON#͝UUؐ[ڮ{&h^9-N)-Hɭ։PP M>UAT1!$1e~˫*7>]\oqa gJPWW9~ԓz.q-n**ga͌ R-tp舡b)”78%m7]B橶PAI~z{Oݻ)C_6KM$_Kyz{PU̥gfVN{ ~D4pqJoxh)T,Ord1,j2w8D$/hH ZD$ Q318[ԤZ46sN# G~ [>DšNo'Ebj-Ċ#AkVߞEY YVҿxDGnG`[Up,2Xlѱ$ΣO.qvHX o%dMInQ;npDH`uy;n85X)ҭ;L64!'+J8Ъ& Q//5qddkIMfֆYž.|VCIp ZJdM>xĨ^ڥw˂RPQV(f&:e6? BlJP-pnrZ Hi_laMZ6E&_7>)tobs.L<({~Y`-=v.=0m/ ✟m; ̥RP8M|5W Z-®2ӳyPM 71`UN5Us G{A'%ˮHҨWi/"K:6SX*Y7~ `p-AKVf^2!ΡcLQ@hO\Eؠƙ|acq-L!ĥCZ=u-QU^ iqjAc(ⰵgs{|2fall.VcƄϘ}(k|iv &oYJX~zZa"qYA(&3=ҴD,ԡH_Cן/f'xqٞ8~|eͺ,vݴשׂhב\2!JُS̱ M69Dq̽jQouL=d${*42sPCQHOo12K=#l3__~ٲGoRj-w"&:}*.؅V uNDhNg HoP@5AZ\.%0hHxt6-]R/LvZzjL.lۖ 3єc 5$<w촘׽i'yprҎK{J\s q=Q\in茦\ Rc`1W#4^"-֨'7U0'aXz[6"oxIo!Ipdű@9dAOEckP32˓䫖q{BI{n7 ֹpEf.8 mV0Medt kΰ|ecƖ̫rGf4*As2[hbZA澙Xz?o:CwT.R%ױ( ѹחzIקao;da2 [U9 q43lpuGLMPx=d /=@+nVM%n+="p-l(:]fr3&UJUe?4RY5VpT uJ^̛Tpe؇˕#h4;MMvCBBEW-5#cc]!-+f)^|9# qä[YYE~ntR$bZncθxNS P<`BB!1&Ȍ|,yW$Fj%;[52ޯc"?aL'࿲&Sz ᦦU =S<ޘUS C0B' 'ڳfULFxxeQql'\.yi 0>tao|e55ceT`7\9p \ŽyHZ ޾L)0٤m8T2 ëϑroJН{?{SqiuPP V>|.\,H Qc;_RhǰSMhvlܱVK@# =)Jˮ;4}]{snfu_P5. gG ; N0QP_QM~s z,_ݿsJaйVU.H@M4d_>ۉ"?8'L08&{;U@Mh\Xh]<83[8(_mB^Z#'N8^rx0@Jetw2јAt| B~3P:ؚ+*YGYiN-C=MJNdJs-\`.l0zqZ1^>pZTS<ə3KoX&YZv]ϸJX;h8yV:[sA2fG6MjŎv`!57"P($4= oZ&WqǤUZTc-K(G?8d_ eG $m6wON7NDl:CKF]aN|3KB=6%"|AqwRVꔱ~X˒0wWf߻a|3xAM!~;8[iGee٘TzQ' S+tJq6EcN޲6&JɀFV&|!R`Z{z ȫk_y.19)>_+ZR4[1g|peo 4tzUݒǶzphn 9 p, 1=9dq\k353+YËxM7H$; RfF_H`xMuhXgպFdW-Bd0rnJKvT8bR3 J;iƝjp~g YrFxG sl!-dfGU~BbKW_܆[b,)cRX}@ȎMX:sYRd]B5Q+~) U iX>`KˆY&[?wtȷgyil9?Ȩ(^VYfccT; ^5W!=h ͔4=~x&4-9UC֓,?</E3kvxSᎈD28R! qS[|Q]R_]du^;I/O&C9l|o}ӑv!p 6-j#zMvU"9Y'PS‚&ےgDggTV&kpe$~Ci3[౯_yTj@JXSG-{HE8YL~ mZ־޾ߑVhv._ˈmqԾ+ow;7+4 XhA& Y症? l~U:k 9f"^DZd~Ed3 k yr!| %MvN旼(KP,&]t5!D ;6].bHJeU| ERgϺzAP֝h&wĐ=2=,LW2%YNO!Y,=G 8=@279YE+A(6סxjdW֎ T&@3BcE=$>*RR}q 572t F0·9+҉cOط1Ec9STO30ÐfuDg(Uz%! 2w[WsL#sИk06Yڎgسeʁqv<1^rT2~T5K-iq\Oh-N+Cˮ^7 [y9ۈ_z<ijԨ}b>2nj~wS7R8C0*8ȍy W!FE||%mr?v.}oB JBqn5q2O%,"yN7`=˺iK*4:_m7:ac$Gc˻;:ޔmv "oJ/q5r(f96&AH݄0DOnz2s,}a0Ru;_#X\N ;n=qbWc`tv|Tmf5 RP[BjP=foyx^OK.nBA#_sl%yڴ+)Lv#lm VsY}萄@ m9 '>C!c1v$uCێ-7@Iqkm2~3M" */GF>.jmy6436n|6U*ڇpgcc\Qv%L  ].CGzht3>9smԎЦf).k*.",874J $Jt_zfPe>ԝ_C\@e6BgK-4MWvN T$8:®u֩fIa=T,@#&Ǎr"U+qvHo}V/}2wqY>D.D9YF_"9޽Fwqv;I<JW$s9c͋%bSRtaK?|bt߉,p%9@v4`7N:=dj93uOX-Rw,ߤSL7w/7Hed*\Ш=.`G_$j1MZC9$7ZXϳH1Y/;wќ;WM6p:mN($V](sh l<9NX jn 4F}oCd3'5l_/ WI-u.+VY.۬.4-ᐃ^χ7P C2˱K{ax5ą́ӏxl`Y =,#IWeepPҶp# v,WGM۾z8 Yy ;Q얁-ݙ%pł{S6―}nnT&itY\şڷPIԂP^Ep< W+⯊Xyhղ ܷb66@^$xx 7݅訯,ע'JKvf49p_=K b0ݦ*5+6hGC|7Vȡ^ Pt vC-vYFT:! SF' /¨(D 9_17fE%Q6Qa͗^˹CSEwĈ<x4sZbds<1Hl~wdua;`y||s o BkVǏkoexǥ^Dh ttX>;9z*?C{k$kPoц.?? ۹J{?c v(dЁ-0J@l>l7R/7sbǧ}:}B%PO/!s s0fi[ lyǃ{V" >+Y&dzGo8$?(csK(zcUlGڤV(?Ȟx!\TaDG>n n#%0JNAIz[vtWów:z"oG/!~KF)ʴ ף}-juQK8Gc ܆kT6sè%L'0!a2?}IGU&??S ?v Es5l K}Pɶ@%`GK%5f/.&'-v0sZޤ"5L4:K[r<4LEݦ̟c+1Ed6VM+$9ߝҲR/QM"~lɌ^FapJ刃}-ƺx5C*Q{^VyP'KkA`"΍#H6?ww 2P'x붪ͳ0Q6vN8 1Ȋp CW%8Lö5]?Y5ddRT#(k+AIC-9??_Kc-k]BwIzdܡ1_Q< R>W1CWb?FAhs>iܗ#H}+%$79EddwuHM78cT0]IwteTMRmy8|&psUY@`頜Ә #~( .M/$/;5¢B@SnxF4rs/D]P7t;E6$UpWowdgx [fx d $1i4wnܗ/b< FOjO)WhOfT%}2%H&`n⅃)u-r=P^80/fT7LjCO4ఐ0{*ڕ[qL0NE뙮}gRo^}5RV<,o*_lÝS<15"a.Iѧe,6bТZU\eB:F\A#Hly+WY߅><^0NGaDR*,~O,Z! q~{ansADd8Nt׼%`[,EhH͂ք/s@S od}Txh\ ~5"'o۲捚*$Qnd7yuÜ;e"45Cȉ6kL,缞͉:d ix3*-" &wDhh6 ؀hbv=,-ҡ:Kgo o^PF%Pg{7dop*&'6J 9ײ?[gô"l㖥y(*i.F$QMzA`1iy9!A'Y[|!Xea,V-*{u@bfS$'C`)!:,3$$bm6u ;-HlA%|jV@C(:&'^tІ-,xٕ%<SOh9&/T,WW$KSؔ/eh՚oͭG*6p?5E886%Cn_t-5򰈏 i^ob(ܕ' dž".{s 4ĀNW9fwh*Ū$1ᵓ ]FI6 vj;n&YL [e>e3n;',^PIM]am'v?|+oJἜ$/6ކjbgԢ YLrPK SiQX\I*N&^kO~xI%]'! =+A1tnQVck~m2PF΄#zE ̡| ƎMSߌ\VV؞(gja>vg0N]σo(;=TnkVKP+njs ϷzNIfLf3%pd/CjHByG֕ iw@Kpɟ9vzuvhC,}`OY{)w4'N%-ˇ>{KҤ+x Xo.+ + j6C1BkT$ez$w@IC9Yhcı&#yN2CvR6PU@-ܽFss`!ةUEW-<!N?>h9k ֵ[q\:9CeTn6Gc63\4J]bqK8n w;[IیnW8{ ćΪOUNfqДH`ޚ4p$`F . pT˰,xڰw.o6+3ϥIgGRsвpm [}5yiu=).ƫ/,'Sr|ڻH/؜wۍ"RVonm2Q2̿mP#nVq)ӇX7_(ZR'ALT$(˜߭h q+L"i.e`_螣7?$~?V'w{R6Y*p2?6k :gDT-8z7 SGkQ \V}F8#q~OlklT#|)W0 ^0ۧ)T_{(&EZp 1C]OdK1T!@TڽWf۩ۚl1QţDgm(_(nQP]VXgT[6&r 6\.(t&O~V8U ~Ld4>?( e=Mx.O/RV.J/\8ȗ iG5+ QA8sà/3]Jp5/eg|}Ys}{"ZJ60TcB7)Hd d{ӢTP:m=6 A޳;Zա4ԺNi~0ㆠD- ԪLvYҴ>dc`5*vOĺ{iY@2NV kpa!_d.'@e/&U48\ɹ!(9tҺ?pUl9,fx&UT]Ud7\2$fp3,}|pR[kzS[-a\8l}4l o˶)) <7ǃPy1qWk܀_]Z7 |Vڛ0m׿[k#p+C\G:_( qn;8q*װY(_jMox@vELzK.f!"sy#|xg^Ol\F/``^ u(~?;ʃdGfiZ9'"錘ӁB!-³ ,}C`Fx*丶v8yJnDTՆo-ܼ?Uk-biQs*0Bu׽H{#aZ&O 5~ Ū +[q0 ,ƙ`-;@NV! 7f箧  jFV3w ! ^-K˶1@ + =_vWa6}O Mq7GXėfiIvlT>P6wP~KV4 'Ӭ7xV<+tyNR#GMz ix("ns[Ђ.n)(@W5%>'45[N$h:}MgFn/[B{ضRnq'NNTF2YZdND~"jdn5c{Ov+ʊ.7E-+-A?,yt3+X؞ҌHՎ=1a8TusMcZ_M/~KnƲqG &!i8'ںş[k -cٶaߤ*_803x~t|Óhi^~mɠwI{6D.G%{#@T~ C-beX•c,U$2kJfO:H-g1B>#;R$oĊoHh]p6,U$m0i:J\` TUf_{T.h$sU%N4N`qI(/PʃCOۡNhY0 f~8"ʸ}G6%.<&ܞՂk\=e)}F^gZtbBEN`xTfͬO ǶhkQ\q$f.KߌQr;Д,ʋ?0u6?EHoN/Ȫ(] !:X|#YK\Fɼ~֢.}N[7RjόFEt<foYGT.,odem{4;bvL"77;e{Fi?sǣg8(k=9FpxՀLvq F:/~u]aZxUU[ K6Tƭ/a$,Z2ִ_6{Ǹ*/,}鲜 olv/7D\$\{РjT 5vdvGQRo0sKG$+ J H?o\P´ MD/;n׷:"eP4??ƾ4] H@TxDHkM ʹ]Ї$71Y;[:[?rGD},é0&saI1Yn3jVF;0EҪw rd2ӻF!8r:M[Ū=9zӤp'h*OTͮB ݳ."X큄:XEp xvVȍ`N {ƌr!cmU& TЧ#Ӥ$@0.`4]M/; :cP%Q2WLW1'=⦯y=cb165%2iI =9bO^ Ϛu_ٍbp q1}5Ҙ=`_vhp 4% i{b2Í1^WjjdD'8 to!j0;5oV"? dȗCC2J{Be3#٦r/We{"GwmTwr6ˆrDT~E􄻨 +9|:` pWG%w93/J4M]R#mx|Fh~ O.K]Ξm.ܾI b;U6_6 a5J HЍP ƹ"0=RH7,SW9rM#w6.*Bǁ݉ ldo04SCUQW9|H<%a࿩s_SCeJְ*?w,ŤfM&wADёLU( ݍTȼߨ٭ى-w feiLn4Kڻ*.ԟFe :%izuq)}׽^ ć_ :MFx!J'gI2Ҝ{ޔ}gfZ)nu\3bec9ɡ})MK4"B4jFaz;z#dYg[DryFԔ듎x1d =4d0T&zސj(Pw`*-\?S"@ܔ\<@u5Alp%Qc 7ˎ9?tL+(.:`|16.f,~\ c2'.+$|clDtxDϧGP~Gy4wsi$C6FӃRg`[*+ĄZ9KY P%9,e^Ad0>, sH/Js.e$FHk]9'(謏B!IDtuF Hi:P"˭x'7c3Þ-5[?aSRCX 7kJ5;|DA>0XėllU5.&m81?E10PPl)p\ vyH*gsr6YYK5e#R"E"pI<'rhLaaRZʃזqUUS@2% ~jAT~3]C?Fo9Zzbhă6?()#?Hkm O%ʰ'$2qńAZ:cqPf{^7 D6?o+\L҇2m5G#=}f۽=Ĉ&;Avne⛋Gmg]g@eb&B7#XdsG ̲gedv\|7ap{ج"KFOjVIt^"58hgW%$Y*3^YJŨ4[B1zK:BE?%>f:XĪf@piݳz$ى~Ͻ4Q)ϡ=@.0nxw_4*oPZ8yK:(eZ<) /ݖsgC:`5 {StR uUۋiTkݘTy`0 $;1YWp\vΦy/Wx A Ex8mĥbGü&Il!=]]0 dl믞kԐ(>ʲun[s; 0|AQaOIGҖmaxZ>EGi4U'P:b卲⩧k}Ze=5-muoeh,: =Z0WTZa}ˡ[ Oذ r/ƿx9WMuYjߢ08]f,#ЕU5Cjju&\ޮ kJM/^6 )Knrnv7,>0#q<@.~yt9"?fb*ovg9u4FÕY3$ J֐19ɇBK %$!dD"sD zE<d뺲Oʔ-|.`X4iH'SZip{Cf"ؓ*iB4+HGJ.$E=: %3R?ٗ|]ِ^&^ɰ*<Ne5ۚBe1]{Kil #"5(FK_v/jd`Q2XbwGAl–]Jdw(Dɽx ɹ ts(6]$LЗb۱P>دCif:t9(OjҞ8bp ?D?VXp/ -Go5(%-LHR +iCq*4ZEoSlvP*!TRĺ"&lNî(IZУI5ħyn ߞs8wm-*VrO'̗h;#Q2؁3JW Z*?nJ%4(An{γUΟpnHLx:͝)VD CI4 /$rrˤy#Gi&am~15j2'hH+x͙'p"L&v,C*Š k/j }j6/^D,/O@ d%~]Tޱ'pÙ?Pp?bh?<`S JNtQPԳ@":l'q!תwéf` d`PSDKҟӄc:fXCE%NP<5wM1gF.T nPRbb'Eq$C2 X?kgRt_n$ةU=yKb%UѦ[ؕ @Juqo053g$IÉA=R)pb_7p*,IS ' Kpjp%' wzzX4C# NY|cA?Zv!~! >7_C 4*X.-H vH+ mXڭO)Z!nf {>S<W!O%a4[ ~R*YOBkHJ[RV ,0 ~? xf/F U)S*MI} "wZsR~T3>f=aG!-NkQܝPdeӣ\=7W7C,]" 秘pӟƒo1 a=?!li$`vk>$P#睢WdJUįmE5PȑTޫ_B[F9Z2AM`ΘŜ;8ˌ5˛JW˺P~8a"c<Gk ӧkڂNURW+ԊmaGUZ=98خvL}a$/׊e  a5g9SOR @Q'IH8B!T>2?tUxr#!Ȅ#vmՓStK XA->y1_:c.,:\7)%t( ^:^mwer[}`ᮁ0]0#ɼ&9sw^^xv s-JOA"N3{sHkv海ByQަ{k]J7/U Ч15e3EƜ"n-n~F1᧫K`GOZ9XQ ·nF(mC=i #`ߎghcq> ص@n\*aA*,`n@x~+ eZl7J6PA^M@O &ͷqI _ ?t7;kO=c?ыWhkm[+-Af`?CYDk%R5gu4n- oMk_ m|G󊍔Td~~aci4iCͬ/(Y s;RIpZc6WSϗ㩻4}<5(E=dyqb-ڧfU! 5sA9rx%-[Wo"| JE :R }lf:~Y;ÊvM9n~7ضM!UfNtŏ1w Ƚ.kcߣNnfG%E-$0j>%*1ϱ $-W!W2˹ErMA57$7.{F'=]c8uI3Dx>nյ}ejN<z~Zk˙ QOS[D >\_a$&?GV3DUE>25خϯ;sw+ /U7hES=|aFSȷ ˦P.bjeReAO^Amp &P*"4ҨY}U]U!m' ^1yvM$JcK\8[,yQZPş;XVoY6~c٬y 8AV>Hsؒh{L\iTjLZ'8 \جUVe?6F&Q2?smg ):Y1]~r W1BE6w7'd4hܾj -#ҳEle]z|VzW%KEu-G͈to{KNXZA)cPC3<`H"\v^Vqsmyf!EZTg*kL4puItLO|A(Xm{"lv /vܛX & Svfe_أv|<c}Sp25 gy@Z e"/Tb~E/A 3Pι~ Zuq.UN-]l({G jLK{lU1稪oDžd[6).fhhf#ZP浗/UW;ǣ:,b;D/N^ v[eŁwO`jytgjN3`w0_g=PHfIE Q=l$Tci:<^%{f~cgtmD;vjgUTBZ˖i~&#Nex  okj/qeK a3Hn3\U۟F'{! =<"Fn'k> h'Q{AEKx] (1!DImȴ(@Pqp`HR2qe^I H跬’=E.a>65Itg;J>+SFS\ڐZa  ~ #ˊ_5l}\x36$aV6au;%M&L-];+LM} Uyb%R' j taa)ܔ@6R)K>LRD3t Ү V8-_y_pPdYF-D.a(4VaS#̳ fZ]##SG`gX5༑ wTa<<~k/ 5%'VU?l$_o Hi[ GnDmZI9o:PgYD9÷9|ƻډjEMdK)P#\F2a CŹq6`FɃؗW (`yj!J,6ZhPJDTCjc2% 4$٨j{zwFNr$/ψmXa> WzI-Ѡ&Q Z>]V׫|Z\uX0keee-ױ2jX{a&#cy ;=S@zoX\6]3=5:ZvF< IJrigKZ4ܾ3Riid Cf|Am!6X`ŬZXnzqKziqDZƈ|\'J:rkME&!fm#K8Mgi};|DՏWa)ìWצahh'{?2^el^=K "_r#t:9g9]uNVdAjncRzLMY,,jKL6DU Eok)o -~E&70W_"twE#<Ե١`+7mD1dwNlW A:XˎtO39ƺek['[Xm{|א27&EY c2|v[s.8yI|,3anMĶX2lo 镕bgN sOt+"^O,ص 9SvNQM81,a~6@UҴYX˨y#NeU9?2=.#&Wf?ygԉKm}C$AFk${Wp^p$eGVq3yE7d3{}[wZMƾN$4QOFIkH]n7kLgUD0ۯg5Jاl3܄Oi҄S+|׃l*ykW}u?%eo5QٞHԼ?"捜FSBp*00Pg5ψ0'6j-$%$Vu䠤uG{wwQBv^YL?jz{e/7SbsdLJ{0 XP:>7>4H_5~b R4h4 ^yWY|^w;809Z ȣ/03g ګJ̻?.'џw@djP{V ݗyu҃I O.gߎX9nm҅m7$ PZ?zfp𭫇RjOq \sө\YO/-_VQnOf{xP!{0&Wkuv5gA4C;9Oq (;GSS8Q?.*Gl%) W+٣LbY_DLaػ(.SW>!5+J60ҥN9.#ϧ'f92i.k83& Ttε ͥIzM@VbG* ^ Yn$, hLszٚ2NRHyF2IGGu0qY`ZcYnwIk4&VMyi6рIc7g&~;cАR1=Zf>mՔa]Ȟv0+eiS. .4M v*VcZbUsl!~Y׌x'z;W΍7pybxY촢"72vЦ?[uaŚcVG>΃m?pd`G$`Purs%w&z ]3mI38%UEU+ ddY-/ I _G#۰K)?' ` e Ic΄*sɁF&7'rA CS oK%r9Op>$<+OZ Svt^zќ+ Sac0m]^"*2iZ7 ٵ?//Y98qKOke., i d6u`I3mg:| ?2]HY=cqh'`e^rl1_,j~_kCJO "S@`MK]P;VjTc]8 u=m:'F;;4@~^Z{mAlC )=|삃1=zu)? ˱td>%,H+ڀƓf˲g7u2ansZ% G"pB_2z$=یPȜ.BR,!pp8cJcG,1WbdT5:̵T*!rJûK 26*m:cwn e-&i "żhӃUF~khXtlP.fjҡ`CzBE8MA eU!Wz,,%ⶃK+?:(w(˾'OʉEJxT'Nڙcqh, dٽ0* Qw|\د ֠&kRqσkz=/Q8[^ݾqYoңndžy[Y>ۿ JY#H>A ߵ3u h|U]&͈jpuILTiԻ,ƺ:nk &0%/.oB9.~sHjx:F!w/[L!3P7Bw9. d%*70|dذk܉P)* p#3mӿ~ʙ80UtxU U}7GMc6] "@<ށn4qvyjNhn\\ :'^Z-̈́JhL$'.P&~:g^_=ߢEp/9ȚN.ܱt15꘨oieʑo҅ 9 5];~ )9Zo=,}ʏ5[Ф6Z~pn.j rqJ߹7Q~,nlVa7" *AV~Z N<&sX*f64l\Y/>)]9Utdޗ,Д5&rY¤OxqNnnw /_pU^tkM҄2kb_NARE*Oc7~?fXAoͮ򯸢m^Z=f9Wja3gJV?0rYHS-^ѐd{Bkwt]w7& 8 ݨk5L"Zxt n쵅< 3*pxqlhT&RP D]z?9ԗQ{qMXFl^dN͆! j#⡓AhjpnqDX1ke;[\>&ÇxWW B҃](VU& ڿoH$Nt5GE?(S͇)&Kw铒mNDuf b5/TI?I`36׍q>z3,.%>OBTCycK z gC#}Q!C2>1E)^>Linmc3٘ )gQ>CHA ^cn?aȖP]Jf43vXN0 ֳP[$ {yO'*KM.?ެpQJT՗M+蟣V6ax"(/ =c%gw%Xt̢# Uw*"*:!s4&*->A?Ϣ5 0JUzN7:jxg@1?WVl!r賍ŗaiO;i^>ŋ|C;r3|K Ҧh\e8A[?{ڮ+ tт}L>> Cg"1z\:_??dG ^$$[ ~.Z,##0X*Z/!?ϛ0u~-QGD D+Nhu6\!ya_i2݃_ M g{8iݿDe伧+Ò)QO>On3 w/[ |BH{d? 3}ŐƗͺ7Rz~ 0MN'myr'5C`;,_q*mwR%!sψ֐<^ة_ФPܘ%9m] @ħ@hm.{?a!R#y:>$'CRO.\s[AzMz+*NnFj^)v-7*!Yr"39i1h 3 wMX),Q*褱z[YíLP='}i9b>9Ir0ύ҆X5y"k;$¡ Fֶ`9b,uO /fsEKjaTxs@mXF9<\n A6<0wc- P}o~̫ZL)w_ %%DgD/W,N<>< scj,kՑv}Oi3Kɜbu{{L7i~ÅqNgs@[N]Je&I}Wf,Gx99[76IqV[9g;SDnH|'y"ES#~^C)r8ByyrlsqAۯj\sa]L`۲_+sه!0x/VlX*-]P˰o' &L] J5ŵڎj5Ś5'Ē'q 9 2~g@d4ןAO˺*+|SV@x"ح#NX\NaIy^f2 ZYؙ`fp#x&ON =͢7/-.5S'9W~tc >H~EтzaQ&̘o"lHwzY:'=Ymm=pS(j^WVn,K:k(6E/-Sӛ(0 $];h8tڎHZ`"CZFRRv)\Evs0s?ޢ?Ȉ9 ̿xmiHcH[ Uzsu=R==S y> r~C״Q?u[͸`}4 D،T˂FuP"`חh%SF>0 YZks/data/quake.RData0000644000176200001440000007404413265737216013650 0ustar liggesusers7zXZi"6!Xw])TW"nRʟⅧ ""ȏdׂ9.4->X]8eW#@êhZQf&-1&Gek4y#U ze?ojTUpa!QVp&ю?zoFq.~@4'J4q9* [.%uP-4ظɷcOtuƎorhUh_͹yRvzќQ?E`=K" < CE4=kBfH*>)`Cv 3;"t[#pUu:lmQ8˔&jlh٩8.Tμe߇-56((a\8wj'0F6ͻE)>P!tg#Y̭kPneSuYd)kH5,Eзd!f"& "w˧$تgtR5וGƳ^&N:<on>0uP5BM{+'-j}?i\ܲ?~-*Z+/|kflC#GEsAB_Z8>˴9jk^W8lT`3M"V_4,a,|ڙbrv?!>CP`9}@{ɍ H _2y=X1-UB1oN/mq(jQ;VX/#,OP;pU RIA%1gMr2}M\ n;]K.HAu9y>6;S+oVHdT!ohOkOH%/> {qh[-\ÿG#ΰ9*%*lCnUV7I1ot$brxwu,%Y8 ե̹b(qEj:)h毺+ۯtQ`3Q2<06~d&f<%2 xvOMK4usG8mQCxyTtˇoM4 =B6m،WT_cRDA*'Ok7\Uvd0[ Hoz8Q$ƽG.;P W^Fr^ԇgU%?z#dvI|?pխ,e][DU F@WV!]A|~jj%l4*P*7]uR:+*G FIoK|o_Pi˲?tYiq`o,*O.XkkJbvKRlEezr%(FTmYϟIEԢͭ- L1Du_J;& ܒ/I xwFT)ϮXco8oVv~sqmꊯb!s'6kjt =qSPMPlRɤM-X1G6DHOKJ.;%ښ?hχKrv|U9 u>2nJ(rmt} :DFwď[l=MW@)M"Y:+'kb>Z1VF;@|fЛ22L_Ȣ+pu MflFs;D"yncx^OV^ 0vp^(3Gs3›]Af$SN_MϠ&}T_?ATtajmکhɄ EI@ ׌I:K+c_Z*O̧85ɡi>awEYQZgQ4{Ż Ι\aOT g i(̎HJT.ъ\o߫vQ%XREaS(0y!ެ1dp@btm׿IWjlxx2,nMlrYTg{Il[{ Jړ5[T 9igXgvAlFnnfL0!Ŵ/4N4;:RQ\QNqZ׵AT q8b hI0]ƝE'eXh5`,"?K0ˀ4bFS'Z/'N~Ԛ.JkF'ثIA[PҲ=8e2wgUNEx~8+ms'r#T Ȟppݕz#3x̄f HHAwRK!E#+᧚@aQm ùEn%iM K Q|&jLru-|HMzsj; Se??陷> ʖjM *FWjC>Ȁ,)'W\K> ɧ .u5:N#W5LcysƠ_t(UA < #.Cd>g!te{g,1U?2(2Psv򬳁|+wWM7yjx5ݡ{sښ}ḟd' m0vV5'} l»TcV1W;W^~Q~0yےtpq}zP7 DzNIs#S",<MG}otG!s&)]OƝtǂ!^@HၷeO5̪RTY}N;6up*,`5gynǝaCj~'gNduS_qLkZ@z+RV/:sёIr߆G {K)f*.d IJ)h,sQg|ik,+ ußAc6T̈NbtL!F$nx˽Cܔ}XFL]ʂ%}$ MWJˁm 8IPع0^wf< T+ lGD/<>mv$!m/G䣎}T ЀNh!ݯ*=ŻEedNih~C[ T`f!ln`U`ȖK4+(w%6$=ż#Q$q"^Dg6 &ݝ30[h=\-+hO^n" H fyclza Nֳs MT j0 y"]|=4cxMIDV%aK(s(*@l)ۥ2G@福L lr|'@Xωު (z0RAL28CF(;0gȇ>q]B|ɔڇJNN / FZ,dؠ!:2UDP4Yco[,%:,Q79@2tCFQB's!֠fB}9 vDZFyo ȥoyg3Hjw* 9KS39"3,l+[||_Q}˵^>IbtZi=fw )ߟ >CՇ]250Z~ Ph.D2M{QMN -\ `_個q; U%e t81:F&ҟM "9.<13O#AyP jh|u*"`ⱸB=F+-q؏y1BG,fekĎH)96]9"GA(澦yl]֜3lb7?,sJ m6VULn^ۧpԵ'x:PV ; 5ޥ D~TkGӄ7XbuSC=hM6 D"bmvl-f@GP܂ aH"̩CʼnJ:c9>õCmFh5iRr8jx\'A7+ӫ)s9/k`ۚ9=fyn%)֗fe=!pA2a8 6ۗKwC&9 Ǥs"aO-NbT &p#)RLq92ILAсc4{P.)8MQ40$:`6VLiPYmKKzƮ}v2w5fX A֙|*ch2CJXATdIfo>Jmpy*ppCd#Neќ[S\اVr 7t ڀDŽx`^tWuA 覿:ӧr :Mkg:HPCӌ"E{ yfp'8nJ+JP[;^t'zo Ǘ\F+C+#6c]G;6jl^I*EplTlVSyrfeYOԪhٴ 0d"z{Te@t&n`Z@J{8.Gߖ쳜xSm]z-t{0 ݳ3uCUaǸ3%ew ;ghA*Vi,/2e4"2~P+:1TDj:цy [m%̠XB7D>r`X}!6\V1lxIf̸374F8x#*OC|]2/ra/E}'zѠ+V #-ӿ$h#=Kv#ɡ.W_ZADض} !qVE'W8{Y;n$.BԙZtf.9|qo7Q2zΔva@(I(P|Ϗxq͔c8< #6UZzOwI/e50(K#]:-KHFS4Rr޽}^yz q;RNZKLJ<)b\-GDG+e`}wfZ  %}>%]ituAD0V etKN@I*K;|N=?~_6$ ,lwc.->@[ 3Mm|H`2,xWȎu,Q\-Oy^ ?w{J"x2"OrF7WXo 9XRc<>րs;7AQ_/㚟 jKkJ1IIɝ+دAnz ( )7WZ1?d4(ъ6 p6%ώQt.*MІ/* ͭ. Sko!Xҽx::%T9x$Ct>+=e80pqbXUn O kzkVIm]$j^Uvۡvpڥ's?o$Rȿ+xU1ِ!ۛ8%F긢4,ܱj l|jI,-"ED ydr2Y3^x 'B2F}@h9I }kDumJt RSa"pgU^;6Od28%^{YګJh%@ ,6N :!c=o[Wu2q7쾢SG9RbPt۽] Nd];fYFttl05=PʹMVҮ"}Z bbWc0r‚jQ{8 VZ,jl2 > ;;sw..ʘRC0v.!cIĎѢ`S8|,:U[=8eFWp$Gh, Rr-@ r9螺SFAvۆs[)sNrրCý.40\-fL~h|B 'uv`uZOЖHU}PY"겺gåO[Le{:U8;wnRxS AfkEAEq3UK%r("Dvb>Ѿe|Iey8o8@5Okm9gIYڤ MfG= ARW7Z)9_Rb8bB嗭Y ˊ[zaFw\m=+PFDmlM&12 xmac3\:/ĭ,-nbd45( 琵ͰL,8*HA ]b3yȺE}8M_ae/)WD^3yq%BocLc"KG L`昱VvץzC?"H\FhE79mNGHzu-ۄXBu|OG%+$_1g::_bz W½"VmŜQ˃c;5NjYk @ H8re 1pF뷜kk/=up/4u+8v {K 6$fҫ5>>F# l乜M*a'B[˻g2oR&p"F"klUh<SwHEĄ^~h(94RRd:Lۀ+riƒOEiw?cL|L ŨvL]˯:|99]W]h)Ӳwf} wyp.{TZbTL]#m oR=QxR=?r74$:X5(BpUm'g VL1CAP7zyID$ !Rd@#>ia4BҬZQO^_QD  /"NXξVU#{/jd|]h%deM/zkCm%V3Wdc:F^ PR٪@+G=?@~4S3M&"0(^ik'<-LbYԭKZqwLQwh}&'鎷4l!BnJ+6a1 Wʅ o ">-vql'E$5J|K$FY32W;lZOE$hj,F}7_Gw+]FzF|?OgٟR9uBuflIAO =67tX !\ ]_|*]}תËAfy'zw:ߓyҲQ`Zh &6+n%nϦj3u@N/Gyƫ4/ܚtbb@,\7q&Xpur v9ux*a(UhW4}u "R"/p`jZFTX^%1'2XhꏤuJ-B+g߯INw<*1c)ԢZ%؂ې'[و<arJ=J_&,ư#:`ƬAC4M8vy[|gU8*74M WLvC 9ľ'?B R-. ^^<\Z /us<MfF7Vd$&^v;8S򍡖2B:H¯x{.oH\tJ%=;-U޶9%gOfA3?/&#R$-(Ca}bZH*:Jqsz b4G@[ 'Bam[[~rw)]gcJ܋B8,Ƕȑ#I+-Tj7Ý9YtΛ->ޙ&❬)V{kQ0)k4XSDv!bWѮ1n= *Ci g܌ij ˝ zîfA;J bqʖ(V"3{[ a4bHyIP\V8Mh].(gc;I%Seͬ'fe%>thOZYswRR,;tF9שC\2r _~ dHPfgjsfl Â=jvG^PXQ{bmY[ ^'dO =cCM$ _#qqE"?~"~K57cs9 spbt+{ 81wIf`z&x⧷t2r6汵[sFae2+g3'Tpd"R%P!VyPW l%4 `Hw-\hLyb8r4$IY#WG9\+Akd9{Y> /?ą΄9MaxNx pSՆ뫯uXz_Oi`c/{d-8Nt`객wZk_6b>qB&$8% j: >[i[ T[4oo~؃DzPHg09slU.}17g~Jwv&О|ZeZ4Xg vpjۘ2j^2cNhL]B%Uß9)ޥ[~F7 sWy0GK[;i5 Wm_+W0߻RkK1Oݳlv6ZivaDB | 8@0pXMG薟iߴ&pA=MՊZ~`TB yց`4k-%JW!z/DH*Osb|Ģw-SMD˔Dz#E#t%hidF:[i6=fI6Oz2 3.i1f hs QT sֹx>R8T>,TYexaw2縸3qrf~NG,"\jjɿCHiQlrygDY;Ik٣^[X,u Ȭ6]MϜ3iѷगDw|hasD<?5*^!Մs6N-Uh8K0_/}+C;a kR{U]^̇Nsg"Xv2s\1 )Ҋorz}qɃiO&9𗚎QA0ɸ)/iDԯ4' )"Mj%ePExZy7rtsl0psӋ},G~bZL{M[yTu(Ը5q:чڭt d/0ۊvEf3DTK6rҴ϶s?5/?vU܏FK/Iepkpq QHo~'9B-o7FߪpύB7kS0@ID<>긍~Yh?#MoBx Hއm ã߷ڰ |%R >pM m9I&u͌>I^I1ɗkB9E-`y#WJxGp`JS =O?c^04hvUż#A*4Ou/uV{dDIj,-]yM:eFMJ &Y[pA@h@Q , D]H|=֧ool*tW`7?[[ۿfKӯU %:ʰZڂ;S-yGG#mlr됌2L$w1Ⱥ %N O!AXeQ5 k&0ĸ ^Æ6d_H'q,ĨC) :AatVXmA{j k`TJQHjS>sSWwquT@V*W}p3l} lN]Oq4Ȼ?"$  nW"TלSs|kڭ@ l60 M=EFϬk+3mh0U<.Q֙- ƫĻ6΂#kh|*/Y8z 7_5Bď7-$ &XۭYW][mqӒ dĪýb48?eBkQoukU ̰ۻ2LLpzWfD{zTwKRVAv> %yL a 5EՒiuS]6"O_Nߋ4m!03RK?KYJR |7wM}B'>EG_zx6 \>ϲ;@y!&DiSL#Ԉ,5Ԯ<55?B)ObƒL#4qƲB*X闦'5I#[ph.Dqr}ջ^̖pr5M%F.ʞ wdOVdvDqms3=x6tb+ vVPm +Roo!M_(z|*)lgiXpu(8%H΍2jZ]@O5W43*hHG/i{gPOPwXHfY3^c҆ZÚ۝mRý(KڐdHůl~"ɱ'a͖q95Gd#rw5Ǔ/FaЖ[{[2*p>bTj{i bpKׄ́ȅ;DE'8iVN(lh'Zv}!Z?+h:jF65YζL0 ~35˷K{ECɅ\e<'dW-e[s@΁z xa6[ \Y{/TGBp%D^,C<3 BiLcvT)-AhFGbʦž?-DM~}Fru"Xki'{Ɍ-*l\&%|鍴`0$b*>E=.׍DwؒY̶65V9/FkQVx,Rxj3Tƌ}cn4f8y,(Kx~U(@4"T(C8a]9Itg4Y5c\|L~OLF=N1z-нjш!v:M\i?2~#=#UQI8Of_7.ic[ ߲(Ł!Cs%9D`׋SE֢"T!1#tx]lH1HQDN(!IHUOuvXVLFm=R }'kL QG|< 1ڥ0B<%ީfP]Q~5dQ. p!WAh[ttɱx+ 3Tڬ7DׁBur'Aun|.0K [>C6?/=b+gd&Z%)J|FΖytGS$8jѿ5o\u5+ E8;]X D 8GqW$\/ [Dn;W_1;Gl!LPzkD1h?0V {GWC$E8l7쮫\gJc 4`{7$zu *e:9#nh領#tC]ܴ+abÚ&Ѥ֠"'ug޷ 4n5ߠ3T$4y"3⥏}0Ν4CtǚʞS,hRs J֘srobcs|Ž9ڹ? >fNCd\S۶\+\K' $))XDRz ltDȨbqR\j(s %]?u|\%e!LTTmuRo٬H#/%g ;ڛe(c0=NF&(PkJw{| KE貱wÄ@XCFs$ &5"+R % @/^3&D(T [Yyk|sxbO;*"FSE~DA,ظ,g+2ώ-;Iv mG$ouً@ ;A~\} 3<qB$t%fm6P2dY?AEJJ٨ sG$lf _TDFKX(!zNWը: rQfKjcoRbs1>I|DK^qyzU*l,a. 鞳ւHF`*HIDyދ%ʥWXt[#{}W ?/i,><QWYacA s0\U&B8ȁ D{XcM#$nB'tct{Q$Z<0h?_PETMݦ>p[d W<}}*Ls֭A_e)D4 Z0|@hnv.rQir~'( 9шzbӔ˩GT||Fi '奄HEL U"l ֢,qm7:$Bq8ҼFOT~9%+aN* k./V_L .uO-bվ!SkN}]ȬA<`{fAvDC f!G_:"Z^FM=/5?S*׃1U͕9  '?Uo.IZ$y=j! 9>wCDa2guϹH+n1^H;g{5ߕʻ%Q̂҈Xij 1$)tXedAs;LO Y%WY+4TRH߾dnF싼s¡;O%B#ѩ՛Vt>iR{ӡ|'D!o.s1O@n.3{'6.c0u؞D{ Jjj;5l9{Ά{ZBQPBg~dcлJ/KP2!   K]oфk~/͡8Hv ΧH_ދDOojU16]bs۪C$سq:? B,yW,ID+cxL3k9RDOGȷZ;tQZOI܇XDPhaE!#erk9]kaőiU# .:7LN!4~OvP Q/ E~3N#>M|}$艐{ &rI扞Jp9C ~-]_wp 8(z c%VItc]ܗaQkfWn[fk} m֝0' Hm.u)mt(X}ZPF)Yu:emGGy1b$`1a3r@pܐť 5H S2WF*1:U\D"X_օ cV\/'ܯ2vx;-i2eK\h{(tLE*]%Z0(z D;@n G~wӽǾ:Y@9d֜!CN#%Љ> 'XhYslj6A|~2"/r`Ε!Wk+V %< ~R7(6F|@9W(c*e5 -y@2ѡaW>7]F#=B_/P;ͺ/@ #qFcXeo›t“ wopT…K]h_ȩCI9\y@b#5|5U"}ؤ΁Ԁ}[TWR_P+ߙal忨x_qś>MKq㐤pV1Fʭ| _![T!G գiޥFl XN+*e9ѫ6X5{/yJ{FTys$Uł&X/ xRva;j kKv䷀6vĐ6pzaCg Ѫr Ǻ1 в ,, xNy α:\Y`̿' s3u4-n?-V'j@YuATkJ}BɀMdR9-*$TKBeT0<#9>yA] <L6,8.1A[5kZovj\QSBZARh_tZH̀KGT.$ZN Z5B )ˠGp&+}`&?a|pPEhJ#1 rvSb{X;@ǰEE%O&ya1zqc%CGifچ Fyw/;)jM21IUvPg\0#-M)SEqp458#t!߼VԻ[5QAd<&uV^L dWˉې_ @J7o nh8'ɎĉQhڵO|r8T8F?0cˤՄt}4:#͟J Y|@nH-NtOΪ>>nuB>Ʊ,: 7<иQ“O߶0b]q .gop~cT%6) g,]2`MiG2W5IT@ܽo2H-5~ւ5@>D^[s")Y3Z'[)dC|7&^FY] 4;A8My檩%(2F_h%3<{u .)z$j4Ҧ/8dkb-vPza,>?Nx}v !.쌇O/{WXjMA'U\T~R+D>1enQTw(iڄCntl”GבXF֌ u RxpѠr:1ױo'jv(9!ҿ;K'XEJӚ~%rS`E, Ql01}Uچ3_Owp_]'3Nrpșqao 7II~pŢ#救"0]\#>҃^p~Jtvsx. >jRz{'m $V˯NNNmh ;4D%K~%ߝGë 9Onx=,)x8!vR@. ZٝiMrQ!=O XJ t7,E߉k/Qe*u%J(^iՃۋ?psiajF '5^ /Zj`(CqTi?eǿs`6ъk>C9Q/7ج߹}YpߗUDl,in 8VrlXJJ`x"AnIB%mAIѩ8)؋7q>ɜk8"hzcljVa^1cԿg roQԚUrD>Lbֲ L#!3\rc l!ϏD:!(72=c"T^ۅZ=8Y7tRY*Q;Cѫ wEk"}^ ?бH`͕ҲFCx9~u;59[ / ,5AgquU-3zS C2@=IJ|Ώl̿'\P faG?8}ua. J l%(Ò =,<4)6To@pV̜&'|-aR 6DZT}"vt%=+>X7ޜ*fFYl$/VGj(\Ȏ^x xRX~3&hW)ړi$p_|TUSUjA'8C_i 2M^=qB%M;[kM)y;t'`xlk$|RFb2,liDds{ĂͦVޒ-2嫯 DH\J׺̫_U8_j Ǘ,Z{ )a`7.oDEVBG_@4'ä#LH9ƹ;P8 zrQcA7/7˸n A45#Ic]OWE4sD\? ;6uUUDJ:T ĎrU7 sxBRx*94Q$?_av> :jN)ׇ{k|y̗a-P=& 9+1vuf:ƃܲkSX(!w)u"KNd0w- ZE(#}>_@32>7eV~؏!wtƟ[ߪ- "OoCLFoHT-wCVɭG[ѽ{v7YLA2#6-m[#UHo9S\‚=bR~%Pfgہt]v@`T13A~Tl;1&=#^s~?\P=Ai=f09n;ďgm;!2XxҤ<#I6oc,[ Ad^$b'3>#i}Ѵ0rlYn>Nɭ/u_or5$I+H!Y^fߜL/wy@5VB E _Y j̏zxq%tOeyO],H?MF P.j8yT xh_uN)|0Inef2ǘA2`N$N߃Nv s^Zn?:.&_(qAy: \?Gd%A;~lWVz _-8y`tEy.x'sM@L#38oS wt6d腸ߚH4XU @rEkks1XD:O5M]ND D,q/]8Sbei:!NrꣶzOad+Dv6BPڤqF[ m RP:+-<}ح' ARrr1Uyϔk@C3 [ѐߺ!_gZ$QN5TcHsH,kt78ŮBZ$. L0τ<'O@SP{~{]&-]{ OY n18R%KJ>bl@qHQg2j`֊)dFW/|N$T0Y+1'ۨʹuWYc]o!{䜞0xG̹gd\Ƹ]L@aePO! JGٌ 1>ݷk{WH[׮:_(9낝$l%}q6Y*OGSpyJ|,Y 4stIOMn5`_=□> 3R{1۞H<~-}C)."J^NT _V0^leٷͣpbrcঢ0csTRpZ2ެ"Fc+7i OX9jڃ=kV~}iT>hg˥ $SWB',Tr`W<z;BQ*2[]ؑY} ;K;"&& /`9b&,xIc=l?}ù v`]ޕIӚƐv4GRC Jfz.v`e _]TsVT6+ F(!eڜzi~ܨ0e-~ZNcz)hbRg)r%|Rp{G.R;$ڈCf Fbss7fk54zyh߉Ju,Py<7#O!LA;{R7UX$p&+f^"^3a76D!K(Sϓm,'!b-qm#O OR]6v͜GY!w[8Ax9EP!GӹYxpW5?mX[^$ œ4Ł#B*u}|%&yt'>x|vcKo]*;%&i 9b.enqxq_{HI<",6]عdA$j݇3װ߻DJXVI0`z->Gy^}Jt"ԗaBj"T>z.~PA+e]WH&vHWW'm-D =WxR7,tXRGs0 xc4>^|-8! [d ρ9'#CԡcQEu%_mZ$ZpwIS,&C'^(Em.užXyz^R|Ll)Oln(6`].1tq ]*e=KP8bY֊mHM$ϾP2I WʫX0➈bB>Κ^|n MVOSCS,2Je6\e.rm8vb'WB#@vk0zz]iaNAsyδ4Y|Yb ZcU ^Gg~"ړ(ې4R@<žڜSTk_"(u!0^CM8[s2u H6H+Ï3² xc^Y Dw|Kp\I[;JE;YsQ|MNnw-f9 ԧSqD%XOVN(nM  i]-|iUv*.wU%nIU{i.>S1qE< 3n,8I](-6w$*hhĎ\V*V[\j?>*N!}HΡSV'bk?>2 ;ܽnBV-ox;2N_ d !8HJ\\f]5^%g?ETn,j? mj}{D_aW(; @@dlb5c [s΄+hE#R^"bFgNT- ]aIVܸe%mnā j F5,v=MN6J[Ŵ6n^(LZ:ӣttޘ|"'OeRBE9,N :GV }x ^`ԞB'_gUtS6FF^~ G>Lg!\{䗢P3w!^lCKj Uʍ8<(Zo.wqBv7 ֶ1RbidanO-*ɌG-%UPf|B=q\kœmxӡ]|Pݤ;T-|[G-/V) >Ot 1~jA>wN.~hSXxħ+&a C Gocl9\) C,ОjƎuABIYk8,ESa~֞E(oh4U]$3_jp7=݌\x(GΛL,׀[hTVRgDRaE1*:DU[+:4;@OIvc-y){ m\1xqDžLYM[s:צ!w 4aH?ŭeܧ!sj;`l1wlP_B3g&3 ፬(.Q2wD~A$,Ub*mNCԤx(bsdl 9M?ܵ# a" 97Β|unAZκSXp1Ɛ^M<4 sT3!9 h)O=ތ? ;k3Wģ $| =6| 4Q<>6m:O8xNs/+4v6ĉ9T_it-`nrf *J+|I7N0kanQK=Ť Nɳ[T:r{HŸiHJ"j˨ʷ7UtL[7H4јn25^:r/x)FaƘNarwqz.>Ɉj&(T8D)hw8 [Zᶋ0^:KͥKd,!GкKVn;@]X5eaWt+sNn]Yz 1k?5fb-f4зCC]qJy-a2W܈O$9Q,7/W5ƛ/0dmHa:t\Ύ¿J:-&gϑ6#K/벞n׶谒JnY]buq? W4nD& bT0_#_,?rāKgSHjk$`pI Iτmԝ56wȐ9aر鹗:ӢnۘQ-oZV7wG8p)]$PԱ6J/)&N/Y72`Cj&p4a~ZdǕC?i#D?BWULdM*n졣`.)kDG{v,*]J:L} ѥM$igA$g+Tx*2T#R(:j/6sBΙm]#HꑉP4Y pR&jRs.zr0 YZks/man/0000755000176200001440000000000013620371402011440 5ustar liggesusersks/man/plot.kda.Rd0000644000176200001440000000412213265741760013457 0ustar liggesusers\name{plot.kda} \alias{plot.kda} \title{Plot for kernel discriminant analysis} \description{ Plot for kernel discriminant analysis for 1- to 3-dimensional data. } \usage{ \method{plot}{kda}(x, y, y.group, ...) } \arguments{ \item{x}{ object of class \code{kda} (output from \code{\link{kda}})} \item{y}{matrix of test data points} \item{y.group}{vector of group labels for test data points} \item{...}{other graphics parameters: \describe{ \item{\code{rugsize}}{height of rug-like plot for partition classes (1-d)} \item{\code{prior.prob}}{vector of prior probabilities} \item{\code{col.part}}{vector of colours for partition classes (1-d, 2-d)} } and those used in \code{\link{plot.kde}} } } \value{ Plots for 1-d and 2-d are sent to graphics window. Plot for 3-d is sent to RGL window. } \details{ For \code{kda} objects, the function headers for the different dimensional data are \preformatted{ ## univariate plot(x, y, y.group, prior.prob=NULL, xlim, ylim, xlab="x", ylab="Weighted density function", drawpoints=FALSE, col, col.part, col.pt, lty, jitter=TRUE, rugsize, ...) ## bivariate plot(x, y, y.group, prior.prob=NULL, cont=c(25,50,75), abs.cont, approx.cont=FALSE, xlim, ylim, xlab, ylab, drawpoints=FALSE, drawlabels=TRUE, col, col.part, col.pt, ...) ## trivariate plot(x, y, y.group, prior.prob=NULL, cont=c(25,50,75), abs.cont, approx.cont=FALSE, colors, alphavec, xlab, ylab, zlab, drawpoints=FALSE, size=3, col.pt="blue", ...) } } \seealso{\code{\link{kda}}, \code{\link{kde}}} \examples{ library(MASS) data(iris) ## univariate example ir <- iris[,1] ir.gr <- iris[,5] kda.fhat <- kda(x=ir, x.group=ir.gr, xmin=3, xmax=9) plot(kda.fhat, xlab="Sepal length") ## bivariate example ir <- iris[,1:2] ir.gr <- iris[,5] kda.fhat <- kda(x=ir, x.group=ir.gr) plot(kda.fhat) \donttest{ ## trivariate example ir <- iris[,1:3] ir.gr <- iris[,5] kda.fhat <- kda(x=ir, x.group=ir.gr) plot(kda.fhat, drawpoints=TRUE, col.pt=c(2,3,4)) ## colour=species, transparency=density heights} } \keyword{hplot} ks/man/kde.local.test.Rd0000644000176200001440000000724313265741624014563 0ustar liggesusers\name{kde.local.test} \alias{kde.local.test} \title{Kernel density based local two-sample comparison test} \description{ Kernel density based local two-sample comparison test for 1- to 6-dimensional data.} \usage{ kde.local.test(x1, x2, H1, H2, h1, h2, fhat1, fhat2, gridsize, binned, bgridsize, verbose=FALSE, supp=3.7, mean.adj=FALSE, signif.level=0.05, min.ESS, xmin, xmax) } \arguments{ \item{x1,x2}{vector/matrix of data values} \item{H1,H2,h1,h2}{bandwidth matrices/scalar bandwidths. If these are missing, \code{Hpi} or \code{hpi} is called by default.} \item{fhat1,fhat2}{objects of class \code{kde}} \item{binned}{flag for binned estimation} \item{gridsize}{vector of grid sizes} \item{bgridsize}{vector of binning grid sizes} \item{verbose}{flag to print out progress information. Default is FALSE.} \item{supp}{effective support for normal kernel} \item{mean.adj}{flag to compute second order correction for mean value of critical sampling distribution. Default is FALSE. Currently implemented for d<=2 only.} \item{signif.level}{significance level. Default is 0.05.} \item{min.ESS}{minimum effective sample size. See below for details.} \item{xmin,xmax}{vector of minimum/maximum values for grid} } \value{ A kernel two-sample local significance is an object of class \code{kde.loctest} which is a list with fields: \item{fhat1,fhat2}{kernel density estimates, objects of class \code{kde}} \item{chisq}{chi squared test statistic} \item{pvalue}{matrix of local p-values at each grid point} \item{fhat.diff}{difference of KDEs} \item{mean.fhat.diff}{mean of the test statistic} \item{var.fhat.diff}{variance of the test statistic} \item{fhat.diff.pos}{binary matrix to indicate locally significant fhat1 > fhat2} \item{fhat.diff.neg}{binary matrix to indicate locally significant fhat1 < fhat2} \item{n1,n2}{sample sizes} \item{H1,H2,h1,h2}{bandwidth matrices/scalar bandwidths} } \details{The null hypothesis is \eqn{H_0(\bold{x}): f_1(\bold{x}) = f_2(\bold{x})}{H_0(x): f_1(x) = f_2(x)} where \eqn{f_1, f_2}{f_1, f_2} are the respective density functions. The measure of discrepancy is \eqn{U(\bold{x}) = [f_1(\bold{x}) - f_2(\bold{x})]^2}{U(x) = [f_1(x) - f_2(x)]^2}. Duong (2013) shows that the test statistic obtained, by substituting the KDEs for the true densities, has a null distribution which is asymptotically chi-squared with 1 d.f. The required input is either \code{x1,x2} and \code{H1,H2}, or \code{fhat1,fhat2}, i.e. the data values and bandwidths or objects of class \code{kde}. In the former case, the \code{kde} objects are created. If the \code{H1,H2} are missing then the default are the plugin selectors \code{Hpi}. Likewise for missing \code{h1,h2}. The \code{mean.adj} flag determines whether the second order correction to the mean value of the test statistic should be computed. \code{min.ESS} is borrowed from Godtliebsen et al. (2002) to reduce spurious significant results in the tails, though by it is usually not required for small to moderate sample sizes. } \references{ Duong, T. (2013) Local significant differences from non-parametric two-sample tests. \emph{Journal of Nonparametric Statistics}, \bold{25}, 635-645. Godtliebsen, F., Marron, J.S. & Chaudhuri, P. (2002) Significance in scale space for bivariate density estimation. \emph{Journal of Computational and Graphical Statistics}, \bold{11}, 1-22. } \seealso{\code{\link{kde.test}}, \code{\link{plot.kde.loctest}}} \examples{ library(MASS) x1 <- crabs[crabs$sp=="B", 4] x2 <- crabs[crabs$sp=="O", 4] loct <- kde.local.test(x1=x1, x2=x2) plot(loct) ## see examples in ? plot.kde.loctest } \keyword{ test } ks/man/vector.Rd0000644000176200001440000000211513265742024013237 0ustar liggesusers\name{vector} \alias{vec} \alias{vech} \alias{invvec} \alias{invvech} \title{Vector and vector half operators} \description{ The vec (vector) operator takes a \eqn{d \times d}{d x d} matrix and stacks the columns into a single vector of length \eqn{d^2}{d^2}. The vech (vector half) operator takes a symmetric \eqn{d \times d}{d x d} matrix and stacks the lower triangular half into a single vector of length \eqn{d(d+1)/2}{d(d+1)/2}. The functions invvec and invvech are the inverses of vec and vech i.e. they form matrices from vectors. } \usage{ vec(x, byrow=FALSE) vech(x) invvec(x, ncol, nrow, byrow=FALSE) invvech(x) } \arguments{ \item{x}{vector or matrix} \item{ncol,nrow}{number of columns and rows for inverse of vech} \item{byrow}{flag for stacking row-wise or column-wise. Default is FALSE.} } \references{ Magnus, J.R. & Neudecker H.M. (1999) \emph{Matrix Differential Calculus with Applications in Statistics and Econometrics (revised edition)}, Wiley & Sons. Chichester. } \examples{ x <- matrix(1:9, nrow=3, ncol=3) vec(x) invvec(vec(x)) } \keyword{algebra} ks/man/unicef.Rd0000644000176200001440000000127413265742016013214 0ustar liggesusers\name{unicef} \docType{data} \alias{unicef} \title{Unicef child mortality - life expectancy data} \description{ This data set contains the number of deaths of children under 5 years of age per 1000 live births and the average life expectancy (in years) at birth for 73 countries with GNI (Gross National Income) less than 1000 US dollars per annum per capita. } \usage{data(unicef)} \format{A matrix with 2 columns and 73 rows. Each row corresponds to a country. The first column is the under 5 mortality rate and the second is the average life expectancy.} \source{ Unicef (2003). \emph{State of the World's Children Report 2003}, Oxford University Press, for Unicef. } \keyword{datasets} ks/man/worldbank.Rd0000644000176200001440000000200413265745334013724 0ustar liggesusers\name{worldbank} \docType{data} \alias{worldbank} \title{Development indicators from the World Bank Group} \description{ This data set contains six development indicators for national entities for the year 2011, which is the latest year for which they are consistently available. } \usage{data(worldbank)} \format{A matrix with 7 columns and 218 rows. Each row corresponds to a country. The first column is the country, the second is the per capita carbon dioxide emissions (thousands Kg), the third is the per capita GDP (thousands of current USD), the fourth is the annual GDP growth rate (\%), the fifth is the annual inflation rate (\%), the sixth is the percentage of internet users in the population (\%), the seventh is the added value agricultural production as a ratio of the total GDP (\%). } \source{ World Bank Group (2016) World development indicators. \url{http://databank.worldbank.org/data/reports.aspx? source=world-development-indicators}. Accessed 2016-10-03. } \keyword{datasets} ks/man/rkde.Rd0000644000176200001440000000323713557403544012675 0ustar liggesusers\name{rkde} \alias{dkde} \alias{pkde} \alias{qkde} \alias{rkde} \title{Derived quantities from kernel density estimates} \description{ Derived quantities from kernel density estimates. } \usage{ dkde(x, fhat) pkde(q, fhat) qkde(p, fhat) rkde(n, fhat, positive=FALSE) } \arguments{ \item{x,q}{vector of quantiles} \item{p}{vector of probabilities} \item{n}{number of observations} \item{positive}{flag to compute KDE on the positive real line. Default is FALSE.} \item{fhat}{kernel density estimate, object of class \code{kde}} } \value{ For the 1-d kernel density estimate \code{fhat}, \code{pkde} computes the cumulative probability for the quantile \code{q}, \code{qkde} computes the quantile corresponding to the probability \code{p}. For any kernel density estimate, \code{dkde} computes the density value at \code{x} (it is an alias for \code{predict.kde}), \code{rkde} computes a random sample of size \code{n}. } \details{ \code{pkde} uses Simpson's rule for the numerical integration. \code{rkde} uses Silverman (1986)'s method to generate a random sample from a KDE. } \references{ Silverman, B. (1986) \emph{Density Estimation for Statistics and Data Analysis}. Chapman & Hall/CRC. London.} \examples{ set.seed(8192) x <- rnorm.mixt(n=10000, mus=0, sigmas=1, props=1) fhat <- kde(x=x, binned=TRUE) p1 <- pkde(fhat=fhat, q=c(-1, 0, 0.5)) qkde(fhat=fhat, p=p1) y <- rkde(fhat=fhat, n=100) x <- rmvnorm.mixt(n=10000, mus=c(0,0), Sigmas=invvech(c(1,0.8,1))) fhat <- kde(x=x, binned=TRUE) y <- rkde(fhat=fhat, n=1000) fhaty <- kde(x=y, binned=TRUE) plot(fhat) plot(fhaty, add=TRUE, col=2) } \keyword{ smooth } ks/man/plot.kcde.Rd0000644000176200001440000000235613117074425013626 0ustar liggesusers\name{plot.kcde} \alias{plot.kcde} \title{Plot for kernel cumulative distribution estimate} \description{ Plot for kernel cumulative distribution estimate 1- to 3-dimensional data. } \usage{ \method{plot}{kcde}(x, ...) } \arguments{ \item{x}{an object of class \code{kcde} (output from \code{\link{kcde}})} \item{...}{other graphics parameters used in \code{\link{plot.kde}}} } \value{ Plots for 1-d and 2-d are sent to graphics window. Plot for 3-d is sent to RGL window (not yet implemented). } \details{ For \code{kcde} objects, the function headers for the different dimensional data are \preformatted{ ## univariate plot(Fhat, xlab, ylab="Distribution function", add=FALSE, drawpoints=FALSE, col.pt="blue", jitter=FALSE, ...) ## bivariate plot(Fhat, display="persp", cont=seq(10,90, by=10), abs.cont, xlab, ylab, zlab="Distribution function", cex=1, pch=1, add=FALSE, drawpoints=FALSE, drawlabels=TRUE, theta=-30, phi=40, d=4, col.pt="blue", col, col.fun, lwd=1, border=NA, thin=1, ...) } } \seealso{\code{\link{plot.kde}}} \examples{ library(MASS) data(iris) Fhat <- kcde(x=iris[,1]) plot(Fhat, xlab="Sepal.Length") Fhat <- kcde(x=iris[,1:2]) plot(Fhat, thin=3) } \keyword{hplot} ks/man/histde.Rd0000644000176200001440000000333613265741431013224 0ustar liggesusers\name{histde} \alias{histde} \alias{predict.histde} \title{Histogram density estimate} \description{ Histogram density estimate for 1- and 2-dimensional data. } \usage{ histde(x, binw, xmin, xmax, adj=0) \method{predict}{histde}(object, ..., x) } \arguments{ \item{x}{matrix of data values} \item{binw}{(vector) of binwidths} \item{xmin,xmax}{vector of minimum/maximum values for grid} \item{adj}{displacement of default anchor point, in percentage of 1 bin} \item{object}{an object of class \code{histde}} \item{...}{other parameters} } \value{ A histogram density estimate is an object of class \code{histde} which is a list with fields: \item{x}{data points - same as input} \item{eval.points}{vector or list of points at which the estimate is evaluated} \item{estimate}{density estimate at \code{eval.points}} \item{binw}{(vector of) bandwidths} \item{nbin}{(vector of) number of bins} \item{names}{variable names} } \details{ If \code{binw} is missing, the default binwidth is \eqn{\hat{b}_i = 2 \cdot 3^{1/(d+2)} \pi^{d/(2d+4)} S_i n^{-1/(d+2)}}{b_i = 2*3^(1/(d+2))*pi^(d/(2d+4))*S_i*n^(-1/(d+2))}, the normal scale selector. If \code{xmin} is missing then it defaults to the data minimum. If \code{xmax} is missing then it defaults to the data maximum. } \seealso{\code{\link{plot.histde}}} \examples{ ## positive data example set.seed(8192) x <- 2^rnorm(100) fhat <- histde(x=x) plot(fhat, col=3) points(c(0.5, 1), predict(fhat, x=c(0.5, 1))) ## large data example on a non-default grid set.seed(8192) x <- rmvnorm.mixt(10000, mus=c(0,0), Sigmas=invvech(c(1,0.8,1))) fhat <- histde(x=x, xmin=c(-5,-5), xmax=c(5,5)) plot(fhat) ## See other examples in ? plot.histde } \keyword{smooth} ks/man/pre.transform.Rd0000644000176200001440000000207712605214556014545 0ustar liggesusers\name{pre.transform} \alias{pre.sphere} \alias{pre.scale} \title{Pre-sphering and pre-scaling} \description{ Pre-sphered or pre-scaled version of data.} \usage{ pre.sphere(x, mean.centred=FALSE) pre.scale(x, mean.centred=FALSE) } \arguments{ \item{x}{matrix of data values} \item{mean.centred}{flag to centre the data values to have zero mean. Default is FALSE.} } \value{Pre-sphered or pre-scaled version of data. These pre-transformations are required for implementing the plug-in \code{\link{Hpi}} selectors and the smoothed cross validation \code{\link{Hscv}} selectors. } \details{ For pre-scaling, the data values are pre-multiplied by \eqn{\mathbf{S}^{-1/2}}{S^(-1/2)} and for pre-scaling, by \eqn{\mathbf{S}_D^{-1/2}}{S_D^(-1/2)} where \eqn{\mathbf{S}}{S} is the sample variance and \eqn{\mathbf{S}_D}{S_D} is \eqn{\mathrm{diag} \, (S_1^2, S_2^2, \dots, S_d^2)}{diag (S_1^2, S_2^2, ..., S_d^2)} where \eqn{S_i^2}{S_i^2} is the i-th marginal sample variance. } \examples{ data(unicef) unicef.sp <- pre.sphere(as.matrix(unicef)) } \keyword{ algebra } ks/man/vkde.Rd0000644000176200001440000000575613265742027012707 0ustar liggesusers\name{vkde} \alias{kde.balloon} \alias{kde.sp} \title{Variable kernel density estimate.} \description{ Variable kernel density estimate for 2-dimensional data. } \usage{ kde.balloon(x, H, h, gridsize, gridtype, xmin, xmax, supp=3.7, eval.points, binned, bgridsize, w, compute.cont=TRUE, approx.cont=TRUE, verbose=FALSE) kde.sp(x, H, h, gridsize, gridtype, xmin, xmax, supp=3.7, eval.points, binned, bgridsize, w, compute.cont=TRUE, approx.cont=TRUE, verbose=FALSE) } \arguments{ \item{x}{matrix of data values} \item{H}{bandwidth matrix. If this missing, \code{Hns} is called by default.} \item{h}{not yet implemented} \item{gridsize}{vector of number of grid points} \item{gridtype}{not yet implemented} \item{xmin,xmax}{vector of minimum/maximum values for grid} \item{supp}{effective support for standard normal} \item{eval.points}{vector or matrix of points at which estimate is evaluated} \item{binned}{flag for binned estimation.} \item{bgridsize}{vector of binning grid sizes} \item{w}{vector of weights. Default is a vector of all ones.} \item{compute.cont}{flag for computing 1\% to 99\% probability contour levels. Default is TRUE.} \item{approx.cont}{flag for computing approximate probability contour levels. Default is TRUE.} \item{verbose}{flag to print out progress information. Default is FALSE.} } \value{ A variable kernel density estimate for bounded data is an object of class \code{kde}. } \details{ The balloon density estimate \code{kde.balloon} employs bandwidths which vary at each estimation point (Loftsgaarden & Quesenberry, 1965). There are as many bandwidths as there are estimation grid points. The default bandwidth is \code{Hns(,deriv.order=2)} and the subsequent bandwidths are derived via a minimal MSE formula. The sample point density estimate \code{kde.sp} employs bandwidths which vary for each data point (Abramson, 1982). There are as many bandwidths as there are data points. The default bandwidth is \code{Hns(,deriv.order=4)} and the subsequent bandwidths are derived via the Abramson formula. } \references{ Abramson, I. S. (1982) On bandwidth variation in kernel estimates - a square root law. \emph{Annals of Statistics}, \bold{10}, 1217-1223. Loftsgaarden, D. O. & Quesenberry, C. P. (1965) A nonparametric estimate of a multivariate density function. \emph{Annals of Mathematical Statistics}, \bold{36}, 1049-1051. } \seealso{\code{\link{kde}}, \code{\link{plot.kde}}} \examples{ \donttest{data(worldbank) wb <- as.matrix(na.omit(worldbank[,4:5])) xmin <- c(-70,-25); xmax <- c(25,70) fhat <- kde(x=wb, xmin=xmin, xmax=xmax) fhat.sp <- kde.sp(x=wb, xmin=xmin, xmax=xmax) plot(fhat, display="persp", box=TRUE, phi=20, zlim=c(0,max(fhat.sp$estimate))) plot(fhat.sp, display="persp", box=TRUE, phi=20, zlim=c(0,max(fhat.sp$estimate)))} \dontrun{ fhat.ball <- kde.balloon(x=wb, xmin=xmin, xmax=xmax) plot(fhat.ball, display="persp", box=TRUE, phi=20, zlim=c(0,max(fhat.sp$estimate)))}} \keyword{smooth} ks/man/kfs.Rd0000644000176200001440000001040213266733004012515 0ustar liggesusers\name{kfs} \alias{kfs} \title{Kernel feature significance } \description{ Kernel feature significance for 1- to 6-dimensional data. } \usage{ kfs(x, H, h, deriv.order=2, gridsize, gridtype, xmin, xmax, supp=3.7, eval.points, binned, bgridsize, positive=FALSE, adj.positive, w, verbose=FALSE, signif.level=0.05) } \arguments{ \item{x}{matrix of data values} \item{H,h}{bandwidth matrix/scalar bandwidth. If these are missing, \code{Hpi} or \code{hpi} is called by default.} \item{deriv.order}{derivative order (scalar)} \item{gridsize}{vector of number of grid points} \item{gridtype}{not yet implemented} \item{xmin,xmax}{vector of minimum/maximum values for grid} \item{supp}{effective support for standard normal} \item{eval.points}{vector or matrix of points at which estimate is evaluated} \item{binned}{flag for binned estimation} \item{bgridsize}{vector of binning grid sizes} \item{positive}{flag if 1-d data are positive. Default is FALSE.} \item{adj.positive}{adjustment applied to positive 1-d data} \item{w}{vector of weights. Default is a vector of all ones.} \item{verbose}{flag to print out progress information. Default is FALSE.} \item{signif.level}{overall level of significance for hypothesis tests. Default is 0.05.} } \value{ A kernel feature significance estimate is an object of class \code{kfs} which is a list with fields \item{x}{data points - same as input} \item{eval.points}{vector or list of points at which the estimate is evaluated} \item{estimate}{binary matrix for significant feature at \code{eval.points}: 0 = not signif., 1 = signif.} \item{h}{scalar bandwidth (1-d only)} \item{H}{bandwidth matrix} \item{gridtype}{"linear"} \item{gridded}{flag for estimation on a grid} \item{binned}{flag for binned estimation} \item{names}{variable names} \item{w}{weights} \item{deriv.order}{derivative order (scalar)} \item{deriv.ind}{each row is a vector of partial derivative indices.} This is the same structure as a \code{kdde} object, except that \code{estimate} is a binary matrix rather than real-valued. } \details{ Feature significance is based on significance testing of the gradient (first derivative) and curvature (second derivative) of a kernel density estimate. Only the latter is currently implemented, and is also known as significant modal regions. The hypothesis test at a grid point \eqn{\bold{x}}{x} is \eqn{H_0(\bold{x}): \mathsf{H} f(\bold{x}) < 0}{H0(x): H f(x) < 0}, i.e. the density Hessian matrix \eqn{\mathsf{H} f(\bold{x})}{H f(x)} is negative definite. The \eqn{p}{p}-values are computed for each \eqn{\bold{x}}{x} using that the test statistic is approximately chi-squared distributed with \eqn{d(d+1)/2}{d(d+1)/2} d.f. We then use a Hochberg-type simultaneous testing procedure, based on the ordered \eqn{p}{p}-values, to control the overall level of significance to be \code{signif.level}. If \eqn{H_0(\bold{x})}{H0(x)} is rejected then \eqn{\bold{x}}{x} belongs to a significant modal region. The computations are based on \code{kdde(x, deriv.order=2)} so \code{kfs} inherits its behaviour from \code{\link{kdde}}. If the bandwidth \code{H} is missing from \code{kfs}, then the default bandwidth is the plug-in selector \code{Hpi(,deriv.order=2)}. Likewise for missing \code{h}. The effective support, binning, grid size, grid range, positive parameters are the same as \code{\link{kde}}. This function is similar to the \code{featureSignif} function in the \pkg{feature} package, except that it accepts unconstrained bandwidth matrices. } \references{ Chaudhuri, P. & Marron, J.S. (1999) SiZer for exploration of structures in curves. \emph{Journal of the American Statistical Association}, \bold{94}, 807-823. Duong, T., Cowling, A., Koch, I. & Wand, M.P. (2008) Feature significance for multivariate kernel density estimation. \emph{Computational Statistics and Data Analysis}, \bold{52}, 4225-4242. Godtliebsen, F., Marron, J.S. & Chaudhuri, P. (2002) Significance in scale space for bivariate density estimation. \emph{Journal of Computational and Graphical Statistics}, \bold{11}, 1-22. } \seealso{\code{\link{kdde}}, \code{\link{plot.kfs}}} \examples{ ## see example is ? plot.kfs } \keyword{smooth} ks/man/plot.kde.part.Rd0000644000176200001440000000613613265741772014442 0ustar liggesusers\name{plot.kde.part} \alias{plot.kde.part} \alias{kms.part} \alias{mvnorm.mixt.part} \title{Partition plot for kernel density clustering} \description{ Plot of partition for kernel density clustering for 2-dimensional data. } \usage{ mvnorm.mixt.part(mus, Sigmas, props=1, xmin, xmax, gridsize, max.iter=100, verbose=FALSE) kms.part(x, H, xmin, xmax, gridsize, verbose=FALSE, ...) \method{plot}{kde.part}(x, display="filled.contour", col, add=FALSE, ...) } \arguments{ \item{mus}{(stacked) matrix of mean vectors} \item{Sigmas}{(stacked) matrix of variance matrices} \item{props}{vector of mixing proportions} \item{xmin,xmax}{vector of minimum/maximum values for grid} \item{gridsize}{vector of number of grid points} \item{max.iter}{maximum number of iterations} \item{verbose}{flag to print out progress information. Default is FALSE.} \item{x}{matrix of data values or an object of class \code{kde.part}} \item{H}{bandwidth matrix. If missing, \code{Hpi(x,deriv,order=1)} is called by default.} \item{display}{type of display, "slice" for contour plot, "persp" for perspective plot, "image" for image plot, "filled.contour" for filled contour plot (1st form), "filled.contour2" (2nd form)} \item{col}{vector of plotting colours} \item{add}{flag to add to current plot. Default is FALSE.} \item{...}{other parameters} } \value{ A kernel partition is an object of class \code{kde.part} which is a list with fields: \item{x}{data points - same as input} \item{eval.points}{vector or list of points at which the estimate is evaluated} \item{estimate}{density estimate at \code{eval.points}} \item{H}{bandwidth matrix} \item{gridtype}{"linear"} \item{gridded}{flag for estimation on a grid} \item{binned}{flag for binned estimation} \item{names}{variable names} \item{w}{weights} \item{cont}{probability contour levels (if \code{compute.cont=TRUE})} \item{end.points}{matrix of final iterates starting from \code{x}} \item{label}{vector of cluster labels} \item{mode}{matrix of cluster modes} \item{nclust}{number of clusters} \item{nclust.table}{frequency table of cluster labels} \item{tol.iter,tol.clust,min.clust.size}{tuning parameter values - same as input} Plot is sent to graphics window. } \details{ For 2-d data, \code{kms.part} and \code{mvnorm.mixt.part} produces a \code{kde.part} object whose values are the class labels, rather than probability density values. } \seealso{\code{\link{plot.kde}}, \code{\link{kms}}} \examples{ \donttest{ ## normal mixture partition mus <- rbind(c(-1,0), c(1, 2/sqrt(3)), c(1,-2/sqrt(3))) Sigmas <- 1/25*rbind(invvech(c(9, 63/10, 49/4)), invvech(c(9,0,49/4)), invvech(c(9,0,49/4))) props <- c(3,3,1)/7 nmixt.part <- mvnorm.mixt.part(mus=mus, Sigmas=Sigmas, props=props) plot(nmixt.part, asp=1, xlim=c(-3,3), ylim=c(-3,3)) } \dontrun{ ## kernel mean shift partition set.seed(81928192) x <- rmvnorm.mixt(n=1000, mus=mus, Sigmas=Sigmas, props=props) msize <- round(151^2*0.05) kms.nmixt.part <- kms.part(x=x, min.clust.size=msize) plot(kms.nmixt.part, asp=1, xlim=c(-3,3), ylim=c(-3,3))}} \keyword{hplot} ks/man/kde.boundary.Rd0000644000176200001440000000557513365063765014350 0ustar liggesusers\name{kde.boundary} \alias{kde.boundary} \title{Kernel density estimate for bounded data} \description{ Kernel density estimate for bounded 1- to 3-dimensional data. } \usage{ kde.boundary(x, H, h, gridsize, gridtype, xmin, xmax, supp=3.7, eval.points, binned=FALSE, bgridsize, w, compute.cont=TRUE, approx.cont=TRUE, boundary.supp, boundary.kernel="beta", verbose=FALSE) } \arguments{ \item{x}{matrix of data values} \item{H,h}{bandwidth matrix/scalar bandwidth. If these are missing, \code{Hpi} or \code{hpi} is called by default.} \item{gridsize}{vector of number of grid points} \item{gridtype}{not yet implemented} \item{xmin,xmax}{vector of minimum/maximum values for grid} \item{supp}{effective support for standard normal} \item{eval.points}{vector or matrix of points at which estimate is evaluated} \item{binned}{flag for binned estimation.} \item{bgridsize}{vector of binning grid sizes} \item{w}{vector of weights. Default is a vector of all ones.} \item{compute.cont}{flag for computing 1\% to 99\% probability contour levels. Default is TRUE.} \item{approx.cont}{flag for computing approximate probability contour levels. Default is TRUE.} \item{boundary.supp}{effective support for boundary region} \item{boundary.kernel}{"beta" = 2nd form of beta boundary kernel, "linear" = linear boundary kernel} \item{verbose}{flag to print out progress information. Default is FALSE.} } \value{ A kernel density estimate for bounded data is an object of class \code{kde}. } \details{ There are two forms of density estimates which are suitable for bounded data, based on the modifying the kernel function. For \code{boundary.kernel="beta"}, the 2nd form of the Beta boundary kernel of Chen (1999) is employed. It is suited for rectangular data boundaries. For \code{boundary.kernel="linear"}, the linear boundary kernel of Hazelton & Marshall (2009) is employed. It is suited for arbitrarily shaped data boundaries, though it is currently only implemented for rectangular boundaries. } \references{ Chen, S. X. (1999) Beta kernel estimators for density functions. \emph{Computational Statistics and Data Analysis}, \bold{31}, 131-145. Hazelton, M. L. & Marshall, J. C. (2009) Linear boundary kernels for bivariate density estimation. \emph{Statistics and Probability Letters}, \bold{79}, 999-1003. } \seealso{\code{\link{kde}}} \examples{ data(worldbank) wb <- as.matrix(na.omit(worldbank[,c("internet", "ag.value")])) fhat <- kde(x=wb) fhat.beta <- kde.boundary(x=wb, xmin=c(0,0), xmax=c(100,100), boundary.kernel="beta") fhat.LB <- kde.boundary(x=wb, xmin=c(0,0), xmax=c(100,100), boundary.kernel="linear") plot(fhat, xlim=c(0,100), ylim=c(0,100)) plot(fhat.beta, add=TRUE, col=2) rect(0,0,100,100, lty=2) plot(fhat, xlim=c(0,100), ylim=c(0,100)) plot(fhat.LB, add=TRUE, col=3) rect(0,0,100,100, lty=2) } \keyword{smooth} ks/man/Hpi.Rd0000644000176200001440000000677613267054215012476 0ustar liggesusers\name{Hpi} \alias{Hpi} \alias{Hpi.diag} \alias{hpi} \title{Plug-in bandwidth selector} \description{ Plug-in bandwidth for for 1- to 6-dimensional data.} \usage{ Hpi(x, nstage=2, pilot, pre="sphere", Hstart, binned, bgridsize, amise=FALSE, deriv.order=0, verbose=FALSE, optim.fun="optim") Hpi.diag(x, nstage=2, pilot, pre="scale", Hstart, binned, bgridsize, amise=FALSE, deriv.order=0, verbose=FALSE, optim.fun="optim") hpi(x, nstage=2, binned=TRUE, bgridsize, deriv.order=0) } \arguments{ \item{x}{vector or matrix of data values} \item{nstage}{number of stages in the plug-in bandwidth selector (1 or 2)} \item{pilot}{"amse" = AMSE pilot bandwidths \cr "samse" = single SAMSE pilot bandwidth \cr "unconstr" = single unconstrained pilot bandwidth \cr "dscalar" = single pilot bandwidth for deriv.order >= 0 \cr "dunconstr" = single unconstrained pilot bandwidth for deriv.order >= 0} \item{pre}{"scale" = \code{\link{pre.scale}}, "sphere" = \code{\link{pre.sphere}}} \item{Hstart}{initial bandwidth matrix, used in numerical optimisation} \item{binned}{flag for binned kernel estimation} \item{bgridsize}{vector of binning grid sizes} \item{amise}{flag to return the minimal scaled PI value} \item{deriv.order}{derivative order} \item{verbose}{flag to print out progress information. Default is FALSE.} \item{optim.fun}{optimiser function: one of \code{nlm} or \code{optim}} } \value{ Plug-in bandwidth. If \code{amise=TRUE} then the minimal scaled PI value is returned too.} \details{\code{hpi(,deriv.order=0)} is the univariate plug-in selector of Wand & Jones (1994), i.e. it is exactly the same as \pkg{KernSmooth}'s \code{dpik}. For deriv.order>0, the formula is taken from Wand & Jones (1995). \code{Hpi} is a multivariate generalisation of this. Use \code{Hpi} for unconstrained bandwidth matrices and \code{Hpi.diag} for diagonal bandwidth matrices. The default pilot is \code{"samse"} for d=2,r=0, and \code{"dscalar"} otherwise. For AMSE pilot bandwidths, see Wand & Jones (1994). For SAMSE pilot bandwidths, see Duong & Hazelton (2003). The latter is a modification of the former, in order to remove any possible problems with non-positive definiteness. Unconstrained and higher order derivative pilot bandwidths are from Chacon & Duong (2010). For d=1, 2, 3, 4 and \code{binned=TRUE}, estimates are computed over a binning grid defined by \code{bgridsize}. Otherwise it's computed exactly. If \code{Hstart} is not given then it defaults to \code{Hns(x)}. From \pkg{ks} 1.11.1 onwards, the default optimisation function is \code{optim.fun="optim"}. To reinstate the previous functionality, use \code{optim.fun="nlm"}. } \references{ Chacon, J.E. & Duong, T. (2010) Multivariate plug-in bandwidth selection with unconstrained pilot matrices. \emph{Test}, \bold{19}, 375-398. Duong, T. & Hazelton, M.L. (2003) Plug-in bandwidth matrices for bivariate kernel density estimation. \emph{Journal of Nonparametric Statistics}, \bold{15}, 17-30. Sheather, S.J. & Jones, M.C. (1991) A reliable data-based bandwidth selection method for kernel density estimation. \emph{Journal of the Royal Statistical Society Series B}, \bold{53}, 683-690. Wand, M.P. & Jones, M.C. (1994) Multivariate plug-in bandwidth selection. \emph{Computational Statistics}, \bold{9}, 97-116. } \seealso{\code{\link{Hbcv}}, \code{\link{Hlscv}}, \code{\link{Hscv}}} \examples{ data(unicef) Hpi(unicef, pilot="dscalar") hpi(unicef[,1]) } \keyword{ smooth } ks/man/hsct.Rd0000644000176200001440000000207113265744162012704 0ustar liggesusers\name{hsct} \docType{data} \alias{hsct} \title{Haematopoietic stem cell transplant} \description{ This data set contains the haematopoietic stem cell transplant (HSCT) measurements obtained a flow cytometer from mouse subjects. A flow cytometer measures the spectra of fluorescent signals from biological cell samples to study their properties. } \usage{data(hsct)} \format{A matrix with 39128 rows and 6 columns. The first column is the FITC-CD45.1 fluorescence (0-1023), the second is the PE-Ly65/Mac1 fluorescence (0-1023), the third is the PI-LiveDead fluorescence (0-1023), the fourth is the APC-CD45.2 fluorescence (0-1023), the fifth is the class label of the cell type (1, 2, 3, 4, 5), the sixth the mouse subject number (5, 6, 9, 12). } \source{ Aghaeepour, N., Finak, G., The FlowCAP Consortium, The DREAM Consortium, Hoos, H., Mosmann, T. R., Brinkman, R., Gottardo, R. & Scheuermann, R. H. (2013) Critical assessment of automated flow cytometry data analysis techniques, \emph{Nature Methods} \bold{10}, 228-238. } \keyword{datasets} ks/man/kdcde.Rd0000644000176200001440000000565713267065474013036 0ustar liggesusers\name{kdcde} \alias{kdcde} \alias{dckde} \title{Deconvolution kernel density derivative estimate} \description{ Deconvolution kernel density derivative estimate for 1- to 6-dimensional data. } \usage{ kdcde(x, H, h, Sigma, sigma, reg, bgridsize, gridsize, binned, verbose=FALSE, ...) dckde(...) } \arguments{ \item{x}{matrix of data values} \item{H,h}{bandwidth matrix/scalar bandwidth. If these are missing, \code{Hpi} or \code{hpi} is called by default.} \item{Sigma,sigma}{error variance matrix} \item{reg}{regularisation parameter} \item{gridsize}{vector of number of grid points} \item{binned}{flag for binned estimation} \item{bgridsize}{vector of binning grid sizes} \item{verbose}{flag to print out progress information. Default is FALSE.} \item{...}{other parameters to \code{\link{kde}}} } \value{ A deconvolution kernel density derivative estimate is an object of class \code{kde} which is a list with fields: \item{x}{data points - same as input} \item{eval.points}{vector or list of points at which the estimate is evaluated} \item{estimate}{density estimate at \code{eval.points}} \item{h}{scalar bandwidth (1-d only)} \item{H}{bandwidth matrix} \item{gridtype}{"linear"} \item{gridded}{flag for estimation on a grid} \item{binned}{flag for binned estimation} \item{names}{variable names} \item{w}{weights} \item{cont}{probability contour levels (if \code{compute.cont=TRUE})} } \details{ A weighted kernel density estimate is utilised to perform the deconvolution. The weights are obtained from from a quadratic programming problem, and then input into \code{kde(,w=)}. This weighted estimate also requires an estimate of the error variance matrix from repeated observations, and of the regularisation parameter. If the latter is missing, it is calculated internally using a 5-fold cross validation method. See Hazelton & Turlach (2009). \code{dckde} is an alias for \code{kdcde}. If the bandwidth \code{H} is missing from \code{kde}, then the default bandwidth is the plug-in selector \code{Hpi}. Likewise for missing \code{h}. The effective support, binning, grid size, grid range, positive parameters are the same as \code{\link{kde}}. } \references{ Hazelton, M. L. & Turlach, B. A. (2009), Nonparametric density deconvolution by weighted kernel density estimators, \emph{Statistics and Computing}, \bold{19}, 217-228. } \seealso{\code{\link{kde}}} \examples{ \donttest{ data(air) air <- air[, c("date", "time", "co2", "pm10")] air2 <- reshape(air, idvar="date", timevar="time", direction="wide") air <- as.matrix(na.omit(air2[,c("co2.20:00", "pm10.20:00")])) Sigma.air <- diag(c(var(air2[,"co2.19:00"] - air2["co2.21:00"], na.rm=TRUE), var(air2[,"pm10.19:00"] - air2[,"pm10.21:00"], na.rm=TRUE))) fhat.air.dec <- kdcde(x=air, Sigma=Sigma.air, reg=0.00021, verbose=TRUE) plot(fhat.air.dec, drawlabels=FALSE, display="filled.contour", lwd=1)} } \keyword{smooth} ks/man/Hns.Rd0000644000176200001440000000212213265741476012475 0ustar liggesusers\name{Hns} \alias{Hns} \alias{Hns.diag} \alias{hns} \alias{Hns.kcde} \alias{hns.kcde} \title{Normal scale bandwidth} \description{ Normal scale bandwidth. } \usage{ Hns(x, deriv.order=0) Hns.diag(x) hns(x, deriv.order=0) Hns.kcde(x) hns.kcde(x) } \arguments{ \item{x}{vector/matrix of data values} \item{deriv.order}{derivative order} } \value{ Normal scale bandwidth. } \details{ \code{Hns} is equal to \code{(4/(n*(d+2*r+2)))^(2/(d+2*r+4))*var(x)}, n = sample size, d = dimension of data, r = derivative order. \code{hns} is the analogue of \code{Hns} for 1-d data. These can be used for density (derivative) estimators \code{\link{kde}}, \code{\link{kdde}}. The equivalents for distribution estimators \code{\link{kcde}} are \code{Hns.kcde} and \code{hns.cde}. } \references{Chacon J.E., Duong, T. & Wand, M.P. (2011). Asymptotics for general multivariate kernel density derivative estimators. \emph{Statistica Sinica}, \bold{21}, 807-840. } \examples{ library(MASS) data(forbes) Hns(forbes, deriv.order=2) hns(forbes$bp, deriv.order=2) } \keyword{smooth} ks/man/plot.kfs.Rd0000644000176200001440000000223013265741774013506 0ustar liggesusers\name{plot.kfs} \alias{plot.kfs} \title{Plot for kernel feature significance} \description{ Plot for kernel significant regions for 1- to 3-dimensional data. } \usage{ \method{plot}{kfs}(x, display="filled.contour", col="orange", colors="orange", abs.cont, alphavec=0.4, add=FALSE, ...) } \arguments{ \item{x}{an object of class \code{kfs} (output from \code{\link{kfs}})} \item{display}{type of display, "slice" for contour plot, "persp" for perspective plot, "image" for image plot, "filled.contour" for filled contour plot (1st form), "filled.contour2" (2nd form) (2-d)} \item{col,colors}{colour for contour region (1-d, 2-d), (3-d)} \item{abs.cont}{absolute contour height. Default is 0.5.} \item{alphavec}{transparency value for contour (3-d)} \item{add}{flag to add to current plot. Default is FALSE.} \item{...}{other graphics parameters used in \code{\link{plot.kde}}} } \value{ Plots for 1-d and 2-d are sent to graphics window. Plot for 3-d is sent to RGL window. } \seealso{\code{\link{plot.kde}}} \examples{ \donttest{library(MASS) data(geyser) geyser.fs <- kfs(geyser, binned=TRUE) plot(geyser.fs) }} \keyword{hplot} ks/man/mixt.Rd0000644000176200001440000000423713317246446012732 0ustar liggesusers\name{mixt} \alias{rnorm.mixt} \alias{dnorm.mixt} \alias{rmvnorm.mixt} \alias{dmvnorm.mixt} \alias{rmvt.mixt} \alias{dmvt.mixt} \alias{mvnorm.mixt.mode} \title{Normal and t-mixture distributions} \description{ Random generation and density values from normal and t-mixture distributions.} \usage{ dnorm.mixt(x, mus=0, sigmas=1, props=1) rnorm.mixt(n=100, mus=0, sigmas=1, props=1, mixt.label=FALSE) dmvnorm.mixt(x, mus, Sigmas, props=1, verbose=FALSE) rmvnorm.mixt(n=100, mus=c(0,0), Sigmas=diag(2), props=1, mixt.label=FALSE) rmvt.mixt(n=100, mus=c(0,0), Sigmas=diag(2), dfs=7, props=1) dmvt.mixt(x, mus, Sigmas, dfs, props) mvnorm.mixt.mode(mus, Sigmas, props=1, verbose=FALSE) } \arguments{ \item{n}{number of random variates} \item{x}{matrix of quantiles} \item{mus}{(stacked) matrix of mean vectors (>1-d) or vector of means (1-d)} \item{Sigmas}{(stacked) matrix of variance matrices (>1-d)} \item{sigmas}{vector of standard deviations (1-d)} \item{props}{vector of mixing proportions} \item{mixt.label}{flag to output numeric label indicating mixture component. Default is FALSE.} \item{verbose}{flag to print out progress information. Default is FALSE.} \item{dfs}{vector of degrees of freedom} } \value{Normal and t-mixture random vectors and density values.} \details{ \code{rmvnorm.mixt} and \code{dmvnorm.mixt} are based on the \code{rmvnorm} and \code{dmvnorm} functions from the \pkg{mvtnorm} package. Likewise for \code{rmvt.mixt} and \code{dmvt.mixt}. For the normal mixture densities, \code{mvnorm.mixt.mode} computes the local modes: these are usually very close but not exactly equal to the component means. } \examples{ ## univariate normal mixture x <- rnorm.mixt(1000, mus=c(-1,1), sigmas=c(0.5, 0.5), props=c(1/2, 1/2)) ## bivariate mixtures mus <- rbind(c(-1,0), c(1, 2/sqrt(3)), c(1,-2/sqrt(3))) Sigmas <- 1/25*rbind(invvech(c(9, 63/10, 49/4)), invvech(c(9,0,49/4)), invvech(c(9,0,49/4))) props <- c(3,3,1)/7 dfs <- c(7,3,2) x <- rmvnorm.mixt(1000, mus=mus, Sigmas=Sigmas, props=props) y <- rmvt.mixt(1000, mus=mus, Sigmas=Sigmas, dfs=dfs, props=props) mvnorm.mixt.mode(mus=mus, Sigmas=Sigmas, props=props) } \keyword{ distribution } ks/man/Hlscv.Rd0000644000176200001440000000544113265741453013026 0ustar liggesusers\name{Hlscv} \alias{Hlscv} \alias{Hlscv.diag} \alias{Hucv} \alias{Hucv.diag} \alias{hlscv} \alias{hucv} \title{Least-squares cross-validation (LSCV) bandwidth matrix selector for multivariate data} \description{ LSCV bandwidth for 1- to 6-dimensional data} \usage{ Hlscv(x, Hstart, binned, bgridsize, amise=FALSE, deriv.order=0, verbose=FALSE, optim.fun="optim", trunc) Hlscv.diag(x, Hstart, binned, bgridsize, amise=FALSE, deriv.order=0, verbose=FALSE, optim.fun="optim", trunc) hlscv(x, binned=TRUE, bgridsize, amise=FALSE, deriv.order=0) Hucv(...) Hucv.diag(...) hucv(...) } \arguments{ \item{x}{vector or matrix of data values} \item{Hstart}{initial bandwidth matrix, used in numerical optimisation} \item{binned}{flag for binned kernel estimation} \item{bgridsize}{vector of binning grid sizes} \item{amise}{flag to return the minimal LSCV value. Default is FALSE.} \item{deriv.order}{derivative order} \item{verbose}{flag to print out progress information. Default is FALSE.} \item{optim.fun}{optimiser function: one of \code{nlm} or \code{optim}} \item{trunc}{parameter to control truncation for numerical optimisation. Default is 4 for density.deriv>0, otherwise no truncation. For details see below.} \item{...}{parameters as above} } \value{ LSCV bandwidth. If \code{amise=TRUE} then the minimal LSCV value is returned too. } \references{ Bowman, A. (1984) An alternative method of cross-validation for the smoothing of kernel density estimates. \emph{Biometrika}, \bold{71}, 353-360. Rudemo, M. (1982) Empirical choice of histograms and kernel density estimators. \emph{Scandinavian Journal of Statistics}, \bold{9}, 65-78. } \details{\code{hlscv} is the univariate LSCV selector of Bowman (1984) and Rudemo (1982). \code{Hlscv} is a multivariate generalisation of this. Use \code{Hlscv} for unconstrained bandwidth matrices and \code{Hlscv.diag} for diagonal bandwidth matrices. \code{Hucv}, \code{Hucv.diag} and \code{hucv} are aliases with UCV (unbiased cross validation) instead of LSCV. Truncation of the parameter space is usually required for the LSCV selector, for r > 0, to find a reasonable solution to the numerical optimisation. If a candidate matrix \code{H} is such that \code{det(H)} is not in \code{[1/trunc, trunc]*det(H0)} or \code{abs(LSCV(H)) > trunc*abs(LSCV0)} then the \code{LSCV(H)} is reset to \code{LSCV0} where \code{H0=Hns(x)} and \code{LSCV0=LSCV(H0)}. From \pkg{ks} 1.11.1 onwards, the default optimisation function is \code{optim.fun="optim"}. For details about the advanced options for \code{binned,Hstart}, see \code{\link{Hpi}}. } \seealso{\code{\link{Hbcv}}, \code{\link{Hpi}}, \code{\link{Hscv}}} \examples{ library(MASS) data(forbes) Hlscv(forbes) hlscv(forbes$bp) } \keyword{ smooth } ks/man/ks-package.Rd0000644000176200001440000003475713470360615013764 0ustar liggesusers\name{ks-package} \alias{ks} \docType{package} \title{ks} \description{ Kernel smoothing for data from 1- to 6-dimensions. } \details{ There are three main types of functions in this package: \itemize{ \item computing kernel estimators - these function names begin with `k' \item computing bandwidth selectors - these begin with `h' (1-d) or `H' (>1-d) \item displaying kernel estimators - these begin with `plot'. } The kernel used throughout is the normal (Gaussian) kernel \eqn{K}{K}. For 1-d data, the bandwidth \eqn{h}{h} is the standard deviation of the normal kernel, whereas for multivariate data, the bandwidth matrix \eqn{\bold{{\rm H}}}{H} is the variance matrix. --For kernel density estimation, \code{\link{kde}} computes \deqn{\hat{f}(\bold{x}) = n^{-1} \sum_{i=1}^n K_{\bold{{\rm H}}} (\bold{x} - \bold{X}_i).}{hat(f)(x) = n^(-1) sum_i K_H (x - X_i).} The bandwidth matrix \eqn{\bold{{\rm H}}}{H} is a matrix of smoothing parameters and its choice is crucial for the performance of kernel estimators. For display, its \code{plot} method calls \code{\link{plot.kde}}. --For kernel density estimation, there are several varieties of bandwidth selectors \itemize{ \item plug-in \code{\link{hpi}} (1-d); \code{\link{Hpi}}, \code{\link{Hpi.diag}} (2- to 6-d) \item least squares (or unbiased) cross validation (LSCV or UCV) \code{\link{hlscv}} (1-d); \code{\link{Hlscv}}, \code{\link{Hlscv.diag}} (2- to 6-d) \item biased cross validation (BCV) \code{\link{Hbcv}}, \code{\link{Hbcv.diag}} (2- to 6-d) \item smoothed cross validation (SCV) \code{\link{hscv}} (1-d); \code{\link{Hscv}}, \code{\link{Hscv.diag}} (2- to 6-d) \item normal scale \code{\link{hns}} (1-d); \code{\link{Hns}} (2- to 6-d). } --For kernel density support estimation, the main function is \code{\link{ksupp}} which is (the convex hull of) \deqn{\{\bold{x}: \hat{f}(\bold{x}) > \tau\}}{\{x: hat(f) > tau\}} for a suitable level \eqn{\tau}{tau}. This is closely related to the \eqn{\tau}{tau}-level set of \eqn{\hat{f}}{hat(f)}. --For truncated kernel density estimation, the main function is \code{\link{kde.truncate}} \deqn{\hat{f} (\bold{x}) \bold{1}\{\bold{x} \in \Omega\} / \int_{\Omega}\hat{f} (\bold{x}) \, d\bold{x}}{hat(f)(x) 1\{x in Omega\}/int hat(f) 1\{x in Omega\}} for a bounded data support \eqn{\Omega}{Omega}. The standard density estimate \eqn{\hat{f}}{hat(f)} is truncated and rescaled to give unit integral over \eqn{\Omega}{Omega}. Its \code{plot} method calls \code{\link{plot.kde}}. --For boundary kernel density estimation where the kernel function is modified explicitly in the boundary region, the main function is \code{\link{kde.boundary}} \deqn{ n^{-1} \sum_{i=1}^n K^*_{\bold{{\rm H}}} (\bold{x} - \bold{X}_i)}{hat(f)(x) = n^(-1) sum_i K*_H (x - X_i)} for a boundary kernel \eqn{K^*}{K*}. Its \code{plot} method calls \code{\link{plot.kde}}. --For variable kernel density estimation where the bandwidth is not a constant matrix, the main functions are \code{\link{kde.balloon}} \deqn{\hat{f}_{\rm ball}(\bold{x}) = n^{-1} \sum_{i=1}^n K_{\bold{{\rm H}}(\bold{x})} (\bold{x} - \bold{X}_i)}{hat(f)_ball(x) = n^(-1) sum_i K_H(x) (x - X_i)} and \code{\link{kde.sp}} \deqn{\hat{f}_{\rm SP}(\bold{x}) = n^{-1} \sum_{i=1}^n K_{\bold{{\rm H}}(\bold{X}_i)} (\bold{x} - \bold{X}_i).}{hat(f)_SP(x) = n^(-1) sum_i K_H(X_i) (x - X_i).} For the balloon estimation \eqn{\hat{f}_{\rm ball}}{hat(f)_ball} the bandwidth varies with the estimation point \eqn{\bold{x}}{x}, whereas for the sample point estimation \eqn{\hat{f}_{\rm SP}}{hat(f)_SP} the bandwidth varies with the data point \eqn{\bold{X}_i, i=1,\dots,n}{X_i, i=1, ..., n}. Their \code{plot} methods call \code{\link{plot.kde}}. The bandwidth selectors for \code{kde.balloon} are based on the normal scale bandwidth \code{Hns(,deriv.order=2)} via the MSE minimal formula, and for \code{kde.SP} on \code{Hns(,deriv.order=4)} via the Abramson formula. --For kernel density derivative estimation, the main function is \code{\link{kdde}} \deqn{{\sf D}^{\otimes r}\hat{f}(\bold{x}) = n^{-1} \sum_{i=1}^n {\sf D}^{\otimes r}K_{\bold{{\rm H}}} (\bold{x} - \bold{X}_i).}{hat(f)^(r)(x) = n^(-1) sum_i D^r K_H (x - X_i).} The bandwidth selectors are a modified subset of those for \code{\link{kde}}, i.e. \code{\link{Hlscv}}, \code{\link{Hns}}, \code{\link{Hpi}}, \code{\link{Hscv}} with \code{deriv.order>0}. Its \code{plot} method is \code{\link{plot.kdde}} for plotting each partial derivative singly. --For kernel summary curvature estimation, the main function is \code{\link{kcurv}} \deqn{\hat{s}(\bold{x})= - \bold{1}\{{\sf D}^2 \hat{f}(\bold{x}) < 0\} \mathrm{abs}(|{\sf D}^2 \hat{f}(\bold{x})|)}{hat(s)(x) = -1\{D^2 hat(f)(x) <0)*abs(det(D^2 hat(f)(x)))\}} where \eqn{{\sf D}^2 \hat{f}(\bold{x})}{D^2 hat(f)(x)} is the kernel Hessian matrix estimate. It has the same structure as a kernel density estimate so its \code{plot} method calls \code{\link{plot.kde}}. --For kernel discriminant analysis, the main function is \code{\link{kda}} which computes density estimates for each the groups in the training data, and the discriminant surface. Its \code{plot} method is \code{\link{plot.kda}}. The wrapper function \code{\link{hkda}}, \code{\link{Hkda}} computes bandwidths for each group in the training data for \code{kde}, e.g. \code{hpi}, \code{Hpi}. --For kernel functional estimation, the main function is \code{kfe} which computes the \eqn{r}{r}-th order integrated density functional \deqn{\hat{{\bold \psi}}_r = n^{-2} \sum_{i=1}^n \sum_{j=1}^n {\sf D}^{\otimes r}K_{\bold{{\rm H}}}(\bold{X}_i-\bold{X}_j).}{hat(psi)_r = n^(-2) sum_i sum_j D^r K_H (X_i - X_j).} The plug-in selectors are \code{\link{hpi.kfe}} (1-d), \code{\link{Hpi.kfe}} (2- to 6-d). Kernel functional estimates are usually not required to computed directly by the user, but only within other functions in the package. --For kernel-based 2-sample testing, the main function is \code{\link{kde.test}} which computes the integrated \eqn{L_2}{L2} distance between the two density estimates as the test statistic, comprising a linear combination of 0-th order kernel functional estimates: \deqn{\hat{T} = \hat{\psi}_{0,1} + \hat{\psi}_{0,2} - (\hat{\psi}_{0,12} + \hat{\psi}_{0,21}),}{hat(T) = hat(psi)_0,1 + hat(psi)_0,2 - (hat(psi)_0,12 + hat(psi)_0,21),} and the corresponding p-value. The \eqn{\psi}{psi} are zero order kernel functional estimates with the subscripts indicating that 1 = sample 1 only, 2 = sample 2 only, and 12, 21 = samples 1 and 2. The bandwidth selectors are \code{\link{hpi.kfe}}, \code{\link{Hpi.kfe}} with \code{deriv.order=0}. --For kernel-based local 2-sample testing, the main function is \code{\link{kde.local.test}} which computes the squared distance between the two density estimates as the test statistic \deqn{\hat{U}(\bold{x}) = [\hat{f}_1(\bold{x}) - \hat{f}_2(\bold{x})]^2}{hat(U)(x) = [hat(f)_1(x) - hat(f)_2(x)]^2} and the corresponding local p-values. The bandwidth selectors are those used with \code{\link{kde}}, e.g. \code{\link{hpi}, \link{Hpi}}. --For kernel cumulative distribution function estimation, the main function is \code{\link{kcde}} \deqn{\hat{F}(\bold{x}) = n^{-1} \sum_{i=1}^n \mathcal{K}_{\bold{{\rm H}}} (\bold{x} - \bold{X}_i)}{hat(F)(x) = n^(-1) sum_i intK_H (x - X_i)} where \eqn{\mathcal{K}}{intK} is the integrated kernel. The bandwidth selectors are \code{\link{hpi.kcde}}, \code{\link{Hpi.kcde}}. Its \code{plot} method is \code{\link{plot.kcde}}. There exist analogous functions for the survival function \eqn{\hat{\bar{F}}}{hat(bar(F))}. --For kernel estimation of a ROC (receiver operating characteristic) curve to compare two samples from \eqn{\hat{F}_1, \hat{F}_2}{hat(F)_1, hat(F)_2}, the main function is \code{\link{kroc}} \deqn{\{\hat{F}_{\hat{Y}_1}(z), \hat{F}_{\hat{Y}_2}(z)\}}{\{hat(F)_hat(Y1))(z), hat(F_hat(Y2))(z)\}} based on the cumulative distribution functions of \eqn{\hat{Y}_j = \hat{\bar{F}}_1(\bold{X}_j), j=1,2}{hat(Yj)=hat(bar(F))_1(X_j), j=1,2}. The bandwidth selectors are those used with \code{\link{kcde}}, e.g. \code{\link{hpi.kcde}, \link{Hpi.kcde}} for \eqn{\hat{F}_{\hat{Y}_j}, \hat{\bar{F}}_1}{hat(F)_hat(Yj), hat(bar(F))_1}. Its \code{plot} method is \code{\link{plot.kroc}}. --For kernel estimation of a copula, the main function is \code{\link{kcopula}} \deqn{\hat{C}(\bold{z}) = \hat{F}(\hat{F}_1^{-1}(z_1), \dots, \hat{F}_d^{-1}(z_d))}{hat(C)(z) = hat(F)(hat(F)_1^(-1)(z_1),..., hat(F)_d^(-1)(z_d))} where \eqn{\hat{F}_j^{-1}(z_j)}{hat(F)_j^(-1)(z_j)} is the \eqn{z_j}{z_j}-th quantile of of the \eqn{j}{j}-th marginal distribution \eqn{\hat{F}_j}{hat(F_j)}. The bandwidth selectors are those used with \code{\link{kcde}} for \eqn{\hat{F}, \hat{F}_j}{hat(F), hat(F)_j}. Its \code{plot} method is \code{\link{plot.kcde}}. %--For kernel estimation of a copula density, the %main function is \code{\link{kcopula.de}} %\deqn{\hat{c}(\bold{z}) = n^{-1} \sum_{i=1}^n %K_{\bold{{\rm H}}} (\bold{z} - \hat{\bold{Z}}_i)}{hat(c)(z) = %hat(f)(z) = n^(-1) sum_i K_H (z - hat(Z)_i)} %where \eqn{\hat{\bold{Z}}_i = (\hat{F}_1(X_{i1}), \dots, % \hat{F}_d(X_{id}))}{hat(Z)_i = (hat(F)_1(X_i1), \dots, hat(F)_d(X_id))}. %The bandwidth selectors are those used with \code{\link{kde}} for %\eqn{\hat{c}}{hat(c)} and \code{\link{kcde}} for \eqn{\hat{F}_j}{hat(F)_j}. %Its \code{plot} method is \code{\link{plot.kde}}. --For kernel mean shift clustering, the main function is \code{\link{kms}}. The mean shift recurrence relation of the candidate point \eqn{{\bold x}}{x} \deqn{{\bold x}_{j+1} = {\bold x}_j + \bold{{\rm H}} {\sf D} \hat{f}({\bold x}_j)/\hat{f}({\bold x}_j),}{x_j+1 = x_j + H D hat(f)(x_j)/hat(f)(x_j),} where \eqn{j\geq 0}{j>=0} and \eqn{{\bold x}_0 = {\bold x}}{x_0 = x}, is iterated until \eqn{{\bold x}}{x} converges to its local mode in the density estimate \eqn{\hat{f}}{hat(f)} by following the density gradient ascent paths. This mode determines the cluster label for \eqn{\bold{x}}{x}. The bandwidth selectors are those used with \code{\link{kdde}(,deriv.order=1)}. --For kernel density ridge estimation, the main function is \code{\link{kdr}}. The kernel density ridge recurrence relation of the candidate point \eqn{{\bold x}}{x} \deqn{{\bold x}_{j+1} = {\bold x}_j + \bold{{\rm U}}_{(d-1)}({\bold x}_j)\bold{{\rm U}}_{(d-1)}({\bold x}_j)^T \bold{{\rm H}} {\sf D} \hat{f}({\bold x}_j)/\hat{f}({\bold x}_j),}{x_j+1 = x_j + U_(d-1)(x_j) U_(d-1)(x_j)^T H D hat(f)(x_j)/hat(f)(x_j),} where \eqn{j\geq 0}{j>=0}, \eqn{{\bold x}_0 = {\bold x}}{x_0 = x} and \eqn{\bold{{\rm U}}_{(d-1)}}{U_(d-1)} is the 1-dimensional projected density gradient, is iterated until \eqn{{\bold x}}{x} converges to the ridge in the density estimate. The bandwidth selectors are those used with \code{\link{kdde}(,deriv.order=2)}. -- For kernel feature significance, the main function \code{\link{kfs}}. The hypothesis test at a point \eqn{\bold{x}}{x} is \eqn{H_0(\bold{x}): \mathsf{H} f(\bold{x}) < 0}{H0(x): H f(x) < 0}, i.e. the density Hessian matrix \eqn{\mathsf{H} f(\bold{x})}{H f(x)} is negative definite. The test statistic is \deqn{W(\bold{x}) = \Vert \mathbf{S}(\bold{x})^{-1/2} \mathrm{vech} \ \mathsf{H} \hat{f} (\bold{x})\Vert ^2}{% W(x) = ||S(x)^(-1/2) vech H hat{f}(x)||^2} where \eqn{{\sf H}\hat{f}}{H hat{f}} is the Hessian estimate, vech is the vector-half operator, and \eqn{\mathbf{S}}{S} is an estimate of the null variance. \eqn{W(\bold{x})}{W(x)} is approximately \eqn{\chi^2}{chi-squared} distributed with \eqn{d(d+1)/2}{d(d+1)/2} degrees of freedom. If \eqn{H_0(\bold{x})}{H0(x)} is rejected, then \eqn{\bold{x}}{x} belongs to a significant modal region. The bandwidth selectors are those used with \code{\link{kdde}(,deriv.order=2)}. Its \code{plot} method is \code{\link{plot.kfs}}. --For deconvolution density estimation, the main function is \code{\link{kdcde}}. A weighted kernel density estimation with the contaminated data \eqn{{\bold W}_1, \dots, {\bold W}_n}{W_1, ..., W_n}, \deqn{\hat{f}_w({\bold x}) = n^{-1} \sum_{i=1}^n \alpha_i K_{\bold{{\rm H}}}({\bold x} - {\bold W}_i),}{hat(f)(x) = n^(-1) sum_i alpha_i K_H (x - W_i),} is utilised, where the weights \eqn{\alpha_1, \dots, \alpha_n}{alpha_1, ..., alpha_n} are chosen via a quadratic optimisation involving the error variance and the regularisation parameter. The bandwidth selectors are those used with \code{\link{kde}}. --Binned kernel estimation is an approximation to the exact kernel estimation and is available for d=1, 2, 3, 4. This makes kernel estimators feasible for large samples. --For an overview of this package with 2-d density estimation, see \code{vignette("kde")}. --For \pkg{ks} \eqn{\geq}{>=} 1.11.1, the \pkg{misc3d} and and \pkg{rgl} (3-d plot), \pkg{OceanView} (quiver plot), \pkg{oz} (Australian map) packages have been moved from Depends to Suggests. This was done to allow \pkg{ks} to be installed on systems where these latter graphical-based packages can't be installed. } \author{ Tarn Duong for most of the package. M. P. Wand for the binned estimation, univariate plug-in selector and univariate density derivative estimator code. J. E. Chacon for the unconstrained pilot functional estimation and fast implementation of derivative-based estimation code. A. and J. Gramacki for the binned estimation for unconstrained bandwidth matrices. } \references{ Bowman, A. & Azzalini, A. (1997) \emph{Applied Smoothing Techniques for Data Analysis}. Oxford University Press, Oxford. Chacon, J.E. & Duong, T. (2018) \emph{Multivariate Kernel Smoothing and Its Applications}. Chapman & Hall/CRC. To appear. Duong, T. (2004) \emph{Bandwidth Matrices for Multivariate Kernel Density Estimation.} Ph.D. Thesis, University of Western Australia. Scott, D.W. (1992) \emph{Multivariate Density Estimation: Theory, Practice, and Visualization}. John Wiley & Sons, New York. Silverman, B. (1986) \emph{Density Estimation for Statistics and Data Analysis}. Chapman & Hall/CRC, London. Simonoff, J. S. (1996) \emph{Smoothing Methods in Statistics}. Springer-Verlag, New York. Wand, M.P. & Jones, M.C. (1995) \emph{Kernel Smoothing}. Chapman & Hall/CRC, London. } \keyword{package} \seealso{\pkg{feature}, \pkg{sm}, \pkg{KernSmooth} } ks/man/kdde.Rd0000644000176200001440000000723613265741573012665 0ustar liggesusers\name{kdde} \alias{kdde} \alias{predict.kdde} \alias{kcurv} \title{Kernel density derivative estimate} \description{ Kernel density derivative estimate for 1- to 6-dimensional data. } \usage{ kdde(x, H, h, deriv.order=0, gridsize, gridtype, xmin, xmax, supp=3.7, eval.points, binned, bgridsize, positive=FALSE, adj.positive, w, deriv.vec=TRUE, verbose=FALSE) kcurv(fhat, compute.cont=TRUE) \method{predict}{kdde}(object, ..., x) } \arguments{ \item{x}{matrix of data values} \item{H,h}{bandwidth matrix/scalar bandwidth. If these are missing, \code{Hpi} or \code{hpi} is called by default.} \item{deriv.order}{derivative order (scalar)} \item{gridsize}{vector of number of grid points} \item{gridtype}{not yet implemented} \item{xmin,xmax}{vector of minimum/maximum values for grid} \item{supp}{effective support for standard normal} \item{eval.points}{vector or matrix of points at which estimate is evaluated} \item{binned}{flag for binned estimation} \item{bgridsize}{vector of binning grid sizes} \item{positive}{flag if data are positive (1-d, 2-d). Default is FALSE.} \item{adj.positive}{adjustment applied to positive 1-d data} \item{w}{vector of weights. Default is a vector of all ones.} \item{deriv.vec}{flag to compute all derivatives in vectorised derivative. Default is TRUE. If FALSE then only the unique derivatives are computed.} \item{verbose}{flag to print out progress information. Default is FALSE.} \item{compute.cont}{flag for computing 1\% to 99\% probability contour levels. Default is TRUE.} \item{fhat}{object of class \code{kdde} with \code{deriv.order=2}} \item{object}{object of class \code{kdde}} \item{...}{other parameters} } \value{ A kernel density derivative estimate is an object of class \code{kdde} which is a list with fields: \item{x}{data points - same as input} \item{eval.points}{vector or list of points at which the estimate is evaluated} \item{estimate}{density derivative estimate at \code{eval.points}} \item{h}{scalar bandwidth (1-d only)} \item{H}{bandwidth matrix} \item{gridtype}{"linear"} \item{gridded}{flag for estimation on a grid} \item{binned}{flag for binned estimation} \item{names}{variable names} \item{w}{weights} \item{deriv.order}{derivative order (scalar)} \item{deriv.ind}{each row is a vector of partial derivative indices} } \details{ For each partial derivative, for grid estimation, the estimate is a list whose elements correspond to the partial derivative indices in the rows of \code{deriv.ind}. For points estimation, the estimate is a matrix whose columns correspond to rows of \code{deriv.ind}. If the bandwidth \code{H} is missing from \code{kdde}, then the default bandwidth is the plug-in selector \code{Hpi}. Likewise for missing \code{h}. The effective support, binning, grid size, grid range, positive parameters are the same as \code{\link{kde}}. The summary curvature is computed by \code{kcurv}, i.e. \deqn{\hat{s}(\bold{x})= - \bold{1}\{\mathsf{D}^2 \hat{f}(\bold{x}) < 0\} \mathrm{abs}(|\mathsf{D}^2 \hat{f}(\bold{x})|)}{hat(s)(x) = -1(D^2 hat(f)(x) <0)*abs(det(D^2 hat(f)(x)))} where \eqn{\mathsf{D}^2 \hat{f}(\bold{x})}{D^2 hat(f)(x)} is the kernel Hessian matrix estimate. So \eqn{\hat{s}}{hat{s}} calculates the absolute value of the determinant of the Hessian matrix and whose sign is the opposite of the negative definiteness indicator. } \seealso{\code{\link{kde}}} \examples{ set.seed(8192) x <- rmvnorm.mixt(1000, mus=c(0,0), Sigmas=invvech(c(1,0.8,1))) fhat <- kdde(x=x, deriv.order=1) ## gradient [df/dx, df/dy] predict(fhat, x=x[1:5,]) ## See other examples in ? plot.kdde } \keyword{smooth} ks/man/kcopula.Rd0000644000176200001440000000701513265741554013406 0ustar liggesusers\name{kcopula} \alias{kcopula} \alias{kcopula.de} \title{Kernel copula (density) estimate} \description{ Kernel copula and copula density estimator for 2-dimensional data. } \usage{ kcopula(x, H, hs, gridsize, gridtype, xmin, xmax, supp=3.7, eval.points, binned, bgridsize, w, verbose=FALSE, marginal="kernel") kcopula.de(x, H, gridsize, gridtype, xmin, xmax, supp=3.7, eval.points, binned, bgridsize, w, verbose=FALSE, compute.cont=TRUE, approx.cont=TRUE, marginal="kernel", boundary.supp, boundary.kernel="beta") } \arguments{ \item{x}{matrix of data values} \item{H,hs}{bandwidth matrix. If these are missing, \code{Hpi.kcde}/\code{Hpi} or \code{hpi.kcde}/\code{hpi} is called by default.} \item{gridsize}{vector of number of grid points} \item{gridtype}{not yet implemented} \item{xmin,xmax}{vector of minimum/maximum values for grid} \item{supp}{effective support for standard normal} \item{eval.points}{matrix of points at which estimate is evaluated} \item{binned}{flag for binned estimation} \item{bgridsize}{vector of binning grid sizes} \item{w}{vector of weights. Default is a vector of all ones.} \item{verbose}{flag to print out progress information. Default is FALSE.} \item{marginal}{"kernel" = kernel cdf or "empirical" = empirical cdf to calculate pseudo-uniform values. Default is "kernel".} \item{compute.cont}{flag for computing 1\% to 99\% probability contour levels. Default is TRUE.} \item{approx.cont}{flag for computing approximate probability contour levels. Default is TRUE.} \item{boundary.supp}{effective support for boundary region} \item{boundary.kernel}{"beta" = 2nd form of beta boundary kernel, "linear" = linear boundary kernel} } \value{ A kernel copula estimate, output from \code{kcopula}, is an object of class \code{kcopula}. A kernel copula density estimate, output from \code{kcopula.de}, is an object of class \code{kde}. These two classes of objects have the same fields as \code{kcde} and \code{kde} objects respectively, except for \item{x}{pseudo-uniform data points} \item{x.orig}{data points - same as input} \item{marginal}{marginal function used to compute pseudo-uniform data} \item{boundary}{flag for data points in the boundary region (\code{kcopula.de} only)} } \details{ For kernel copula estimates, a transformation approach is used to account for the boundary effects. If \code{H} is missing, the default is \code{Hpi.kcde}; if \code{hs} are missing, the default is \code{hpi.kcde}. For kernel copula density estimates, for those points which are in the interior region, the usual kernel density estimator (\code{\link{kde}}) is used. For those points in the boundary region, a product beta kernel based on the boundary corrected univariate beta kernel of Chen (1999) is used (\code{\link{kde.boundary}}). If \code{H} is missing, the default is \code{Hpi.kcde}; if \code{hs} are missing, the default is \code{hpi}. The effective support, binning, grid size, grid range parameters are the same as for \code{\link{kde}}. } \references{ Duong, T. (2014) Optimal data-based smoothing for non-parametric estimation of copula functions and their densities. Submitted. Chen, S.X. (1999). Beta kernel estimator for density functions. \emph{Computational Statistics & Data Analysis}, \bold{31}, 131--145. } \seealso{\code{\link{kcde}}, \code{\link{kde}}} \examples{ library(MASS) data(fgl) x <- fgl[,c("RI", "Na")] Chat <- kcopula(x=x) plot(Chat, disp="persp", thin=3, col="white", border=1) } \keyword{smooth} ks/man/plot.kde.Rd0000644000176200001440000001210213265741773013464 0ustar liggesusers\name{plot.kde} \alias{plot.kde} \title{Plot for kernel density estimate} \description{ Plot for kernel density estimate for 1- to 3-dimensional data. } \usage{ \method{plot}{kde}(x, ...) } \arguments{ \item{x}{an object of class \code{kde} (output from \code{\link{kde}})} \item{...}{other graphics parameters: \describe{ \item{\code{display}}{type of display, "slice" for contour plot, "persp" for perspective plot, "image" for image plot, "filled.contour" for filled contour plot (1st form), "filled.contour2" (2nd form) (2-d)} \item{\code{cont}}{vector of percentages for contour level curves} \item{\code{abs.cont}}{vector of absolute density estimate heights for contour level curves} \item{\code{approx.cont}}{flag to compute approximate contour levels. Default is FALSE.} \item{\code{col}}{plotting colour for density estimate (1-d, 2-d)} \item{\code{col.cont}}{plotting colour for contours} \item{\code{col.fun}}{plotting colour function for contours} \item{\code{col.pt}}{plotting colour for data points} \item{\code{colors}}{vector of colours for each contour (3-d)} \item{\code{jitter}}{flag to jitter rug plot (1-d). Default is TRUE.} \item{\code{lwd.fc}}{line width for filled contours (2-d)} \item{\code{xlim,ylim,zlim}}{axes limits} \item{\code{xlab,ylab,zlab}}{axes labels} \item{\code{add}}{flag to add to current plot. Default is FALSE.} \item{\code{theta,phi,d,border}}{graphics parameters for perspective plots (2-d)} \item{\code{drawpoints}}{flag to draw data points on density estimate. Default is FALSE.} \item{\code{drawlabels}}{flag to draw contour labels (2-d). Default is TRUE.} \item{\code{alpha}}{transparency value of plotting symbol (3-d)} \item{\code{alphavec}}{vector of transparency values for contours (3-d)} \item{\code{size}}{size of plotting symbol (3-d).} } } } \value{ Plots for 1-d and 2-d are sent to graphics window. Plot for 3-d is sent to RGL window. } \details{ For \code{kde} objects, the function headers for the different dimensional data are \preformatted{ ## univariate plot(fhat, xlab, ylab="Density function", add=FALSE, drawpoints=FALSE, col.pt="blue", col.cont=1, cont.lwd=1, jitter=FALSE, cont, abs.cont, approx.cont=TRUE, ...) ## bivariate plot(fhat, display="slice", cont=c(25,50,75), abs.cont, approx.cont=TRUE, xlab, ylab, zlab="Density function", cex=1, pch=1, add=FALSE, drawpoints=FALSE, drawlabels=TRUE, theta=-30, phi=40, d=4, col.pt="blue", col, col.fun, lwd=1, border=1, thin=3, lwd.fc=5, ...) ## trivariate plot(fhat, cont=c(25,50,75), abs.cont, approx.cont=FALSE, colors, add=FALSE, drawpoints=FALSE, alpha, alphavec, xlab, ylab, zlab, size=3, col.pt="blue", ...) } The 1-d plot is a standard plot of a 1-d curve. If \code{drawpoints=TRUE} then a rug plot is added. If \code{cont} is specified, the horizontal line on the x-axis indicates the \code{cont}\% highest density level set. There are different types of plotting displays for 2-d data available, controlled by the \code{display} parameter. (a) If \code{display="slice"} then a slice/contour plot is generated using \code{contour}. (b) If \code{display} is \code{"filled.contour"} or \code{"filled.contour2"} then a filled contour plot is generated. The default contours are at 25\%, 50\%, 75\% or \code{cont=c(25,50,75)} which are upper percentages of highest density regions. (c) If \code{display="persp"} then a perspective/wire-frame plot is generated. The default z-axis limits \code{zlim} are the default from the usual \code{persp} command. (d) If \code{display="image"} then an image plot is generated. Default colours are the default from the usual \code{image} command. For 3-dimensional data, the interactive plot is a series of nested 3-d contours. The default contours are \code{cont=c(25,50,75)}. The default \code{colors} are \code{heat.colors} and the default opacity \code{alphavec} ranges from 0.1 to 0.5. To specify contours, either one of \code{cont} or \code{abs.cont} is required. \code{cont} specifies upper percentages which correspond to probability contour regions. If \code{abs.cont} is set to particular values, then contours at these levels are drawn. This second option is useful for plotting multiple density estimates with common contour levels. See \code{\link{contourLevels}} for details on computing contour levels. If \code{approx=FALSE}, then the exact KDE is computed. Otherwise it is interpolated from an existing KDE grid. This can dramatically reduce computation time for large data sets. } \examples{ library(MASS) data(iris) ## univariate example fhat <- kde(x=iris[,2]) plot(fhat, cont=50, col.cont="blue", cont.lwd=2, xlab="Sepal length") ## bivariate example fhat <- kde(x=iris[,2:3]) plot(fhat, display="filled.contour", cont=seq(10,90,by=10)) plot(fhat, display="persp", thin=3, border=1, col="white") \donttest{ ## trivariate example fhat <- kde(x=iris[,2:4]) plot(fhat, drawpoints=TRUE) }} \keyword{hplot} ks/man/kfe.Rd0000644000176200001440000000501113265741653012507 0ustar liggesusers\name{kfe} \alias{kfe} \alias{Hpi.kfe} \alias{Hpi.diag.kfe} \alias{hpi.kfe} \title{Kernel functional estimate} \description{ Kernel functional estimate for 1- to 6-dimensional data.} \usage{ kfe(x, G, deriv.order, inc=1, binned, bin.par, bgridsize, deriv.vec=TRUE, add.index=TRUE, verbose=FALSE) Hpi.kfe(x, nstage=2, pilot, pre="sphere", Hstart, binned=FALSE, bgridsize, amise=FALSE, deriv.order=0, verbose=FALSE, optim.fun="optim") Hpi.diag.kfe(x, nstage=2, pilot, pre="scale", Hstart, binned=FALSE, bgridsize, amise=FALSE, deriv.order=0, verbose=FALSE, optim.fun="optim") hpi.kfe(x, nstage=2, binned=FALSE, bgridsize, amise=FALSE, deriv.order=0) } \arguments{ \item{x}{vector/matrix of data values} \item{nstage}{number of stages in the plug-in bandwidth selector (1 or 2)} \item{pilot}{"dscalar" = single pilot bandwidth (default) \cr "dunconstr" = single unconstrained pilot bandwidth} \item{pre}{"scale" = \code{\link{pre.scale}}, "sphere" = \code{\link{pre.sphere}}} \item{Hstart}{initial bandwidth matrix, used in numerical optimisation} \item{binned}{flag for binned estimation} \item{bgridsize}{vector of binning grid sizes} \item{amise}{flag to return the minimal scaled PI value} \item{deriv.order}{derivative order} \item{verbose}{flag to print out progress information. Default is FALSE.} \item{optim.fun}{optimiser function: one of \code{nlm} or \code{optim}} \item{G}{pilot bandwidth matrix} \item{inc}{0=exclude diagonal, 1=include diagonal terms in kfe calculation} \item{bin.par}{binning parameters - output from \code{\link{binning}}} \item{deriv.vec}{flag to compute duplicated partial derivatives in the vectorised form. Default is FALSE.} \item{add.index}{flag to output derivative indices matrix. Default is true.} } \value{ Plug-in bandwidth matrix for \eqn{r}{r}-th order kernel functional estimator. } \details{ \code{Hpi.kfe} is the optimal plug-in bandwidth for \eqn{r}{r}-th order kernel functional estimator based on the unconstrained pilot selectors of Chacon & Duong (2010). \code{hpi.kfe} is the 1-d equivalent, using the formulas from Wand & Jones (1995, p.70). \code{kfe} does not usually need to be called explicitly by the user. } \references{ Chacon, J.E. & Duong, T. (2010) Multivariate plug-in bandwidth selection with unconstrained pilot matrices. \emph{Test}, \bold{19}, 375-398. Wand, M.P. & Jones, M.C. (1995) \emph{Kernel Smoothing}. Chapman & Hall/CRC, London. } \seealso{\code{\link{kde.test}}} \keyword{ smooth } ks/man/kms.Rd0000644000176200001440000000775713265741667012564 0ustar liggesusers\name{kms} \alias{kms} \alias{summary.kms} \title{Kernel mean shift clustering} \description{ Kernel mean shift clustering for 2- to 6-dimensional data. } \usage{ kms(x, y, H, max.iter=400, tol.iter, tol.clust, min.clust.size, merge=TRUE, keep.path=FALSE, verbose=FALSE) \method{summary}{kms}(object, ...) } \arguments{ \item{x}{matrix of data values} \item{y}{matrix of candidate data values for which the mean shift will estimate their cluster labels. If missing, \code{y=x}.} \item{H}{bandwidth matrix/scalar bandwidth. If missing, \code{Hpi(x,deriv,order=1)} is called by default.} \item{max.iter}{maximum number of iterations. Default is 400.} \item{tol.iter}{distance under which two successive iterations are considered convergent. Default is 0.001*min marginal IQR of \code{x}.} \item{tol.clust}{distance under which two cluster modes are considered to form one cluster. Default is 0.01*max marginal IQR of \code{x}.} \item{min.clust.size}{minimum cluster size (cardinality). Default is \code{0.01*nrow(y)}.} \item{merge}{flag to merge clusters which are smaller than \code{min.clust.size}. Default is TRUE.} \item{keep.path}{flag to store the density gradient ascent paths. Default is FALSE.} \item{verbose}{flag to print out progress information. Default is FALSE.} \item{object}{object of class \code{kms}} \item{...}{other parameters} } \value{ A kernel mean shift clusters set is an object of class \code{kms} which is a list with fields: \item{x,y}{data points - same as input} \item{end.points}{matrix of final iterates starting from \code{y}} \item{H}{bandwidth matrix} \item{label}{vector of cluster labels} \item{nclust}{number of clusters} \item{nclust.table}{frequency table of cluster labels} \item{mode}{matrix of cluster modes} \item{names}{variable names} \item{tol.iter,tol.clust,min.clust.size}{tuning parameter values - same as input} \item{path}{list of density gradient ascent paths where \code{path[[i]]} is the path of \code{y[i,]} (only if \code{keep.path=TRUE})} } \details{ Mean shift clustering belongs to the class of modal or density-based clustering methods. The mean shift recurrence of the candidate point \eqn{{\bold x}}{x} is \eqn{{\bold x}_{j+1} = {\bold x}_j + \bold{{\rm H}} {\sf D} \hat{f}({\bold x}_j)/\hat{f}({\bold x}_j)}{x_j+1 = x_j + H D hat(f)(x_j)/hat(f)(x_j)} where \eqn{j\geq 0}{j>=0} and \eqn{{\bold x}_0 = {\bold x}}{x_0 = x}. The sequence \eqn{\{{\bold x}_0, {\bold x}_1, \dots \}}{x_0, x_1, ...} follows the density gradient ascent paths to converge to a local mode of the density estimate \eqn{\hat{f}}{hat(f)}. Hence \eqn{{\bold x}}{x} is iterated until it converges to its local mode, and this determines its cluster label. The mean shift recurrence is terminated if successive iterations are less than \code{tol.iter} or the maximum number of iterations \code{max.iter} is reached. Final iterates which are less than \code{tol.clust} distance apart are considered to form a single cluster. If \code{merge=TRUE} then the clusters whose cardinality is less than \code{min.clust.size} are iteratively merged with their nearest cluster. If the bandwidth \code{H} is missing, then the default bandwidth is the plug-in selector for the density gradient \code{Hpi(x,deriv.order=1)}. Any bandwidth that is suitable for the density gradient is also suitable for the mean shift. } \references{ Chacon, J.E. & Duong, T. (2013) Data-driven density estimation, with applications to nonparametric clustering and bump hunting. \emph{Electronic Journal of Statistics}, \bold{7}, 499-532. Comaniciu, D. & Meer, P. (2002). Mean shift: a robust approach toward feature space analysis. \emph{ IEEE Transactions on Pattern Analysis and Machine Intelligence}, \bold{24}, 603-619. } \seealso{\code{\link{kde}}} \examples{ library(MASS) data(crabs) kms.crabs <- kms(x=crabs[,c("FL", "CW")]) plot(kms.crabs$x, col=kms.crabs$label) summary(kms.crabs) } \keyword{cluster} ks/man/grevillea.Rd0000644000176200001440000000175113265743417013723 0ustar liggesusers\name{grevillea} \docType{data} \alias{grevillea} \title{Geographical locations of grevillea plants} \description{ This data set contains the geographical locations of the specimens of \emph{Grevillea uncinulata}, more commonly known as the Hook leaf grevillea, which is an endemic floral species to south Western Australia. This region is one of the 25 `biodiversity hotspots' which are `areas featuring exceptional concentrations of endemic species and experiencing exceptional loss of habitat'. } \usage{data(grevillea)} \format{A matrix with 222 rows and 2 columns. Each row corresponds to a observed plant. The first column is the longitude (decimal degrees), the second is the latitude (decimal degrees). } \source{ CSIRO (2016) Atlas of Living Australia: \emph{Grevillea uncinulata Diels}, \url{http://bie.ala.org.au/species/urn:lsid:biodiversity.org.au:apni.taxon:249319}. Commonwealth Scientific and Industrial Research Organisation. Accessed 2016-03-11. } \keyword{datasets} ks/man/contour.Rd0000644000176200001440000000456513557650023013442 0ustar liggesusers\name{contour} \alias{contourLevels} \alias{contourLevels.kde} \alias{contourLevels.kda} \alias{contourSizes} \title{Contours functions} \description{ Contour levels and sizes. } \usage{ contourLevels(x, ...) \method{contourLevels}{kde}(x, prob, cont, nlevels=5, approx=TRUE, ...) \method{contourLevels}{kda}(x, prob, cont, nlevels=5, approx=TRUE, ...) contourSizes(x, abs.cont, cont=c(25,50,75), approx=TRUE) } \arguments{ \item{x}{an object of class \code{kde} or \code{kda}} \item{prob}{vector of probabilities corresponding to highest density regions} \item{cont}{vector of percentages which correspond to the complement of \code{prob}} \item{abs.cont}{vector of absolute contour levels} \item{nlevels}{number of pretty contour levels} \item{approx}{flag to compute approximate contour levels. Default is TRUE.} \item{...}{other parameters} } \value{ --For \code{contourLevels}, for \code{kde} objects, returns vector of heights. For \code{kda} objects, returns a list of vectors, one for each training group. --For \code{contourSizes}, an approximation of the Lebesgue measure of level set, i.e. length (d=1), area (d=2), volume (d=3), hyper-volume (d>4). } \details{ --For \code{contourLevels}, the most straightforward is to specify \code{prob}. Heights of the corresponding highest density region with probability \code{prob} are computed. The \command{cont} parameter here is consistent with \command{cont} parameter from \command{plot.kde} and \command{plot.kda} i.e. \code{cont=(1-prob)*100}\%. If both \code{prob} and \code{cont} are missing then a pretty set of \code{nlevels} contours are computed. --For \code{contourSizes}, the length, area, volume etc. are approximated by Riemann sums. These are rough approximations and depend highly on the estimation grid, and so should be interpreted carefully. If \code{approx=FALSE}, then the exact KDE is computed. Otherwise it is interpolated from an existing KDE grid. This can dramatically reduce computation time for large data sets. } \seealso{\code{\link{contour}}, \code{\link{contourLines}}} \examples{ set.seed(8192) x <- rmvnorm.mixt(n=1000, mus=c(0,0), Sigmas=diag(2), props=1) fhat <- kde(x=x, binned=TRUE) contourLevels(fhat, cont=c(75, 50, 25)) contourSizes(fhat, cont=25, approx=TRUE) ## compare to approx circle of radius=0.75 with area=1.77 } \keyword{hplot} ks/man/plot.kde.loctest.Rd0000644000176200001440000000352113265741767015150 0ustar liggesusers\name{plot.kde.loctest} \alias{plot.kde.loctest} \title{Plot for kernel local significant difference regions} \description{ Plot for kernel local significant difference regions for 1- to 3-dimensional data. } \usage{ \method{plot}{kde.loctest}(x, ...) } \arguments{ \item{x}{an object of class \code{kde.loctest} (output from \code{\link{kde.local.test}})} \item{...}{other graphics parameters: \describe{ \item{\code{lcol}}{colour for KDE curve (1-d)} \item{\code{col}}{vector of 2 colours. Default is c("purple", "darkgreen"). First colour: sample 1>sample 2, second colour: sample 1\bold{x})}{P(X>x)}. For d>1, \eqn{\mathrm{Pr}(\bold{X}\leq\bold{x}) \neq 1 - \mathrm{Pr}(\bold{X}>\bold{x})}{Pr(X<=x) != 1-Pr(X>x)}. If the bandwidth \code{H} is missing in \code{kcde}, then the default bandwidth is the plug-in selector \code{Hpi.kcde}. Likewise for missing \code{h}. No pre-scaling/pre-sphering is used since the \code{Hpi.kcde} is not invariant to translation/dilation. From \pkg{ks} 1.11.1 onwards, the default optimisation function is \code{optim.fun="optim"}. The effective support, binning, grid size, grid range, positive parameters are the same as \code{\link{kde}}. } \references{ Duong, T. (2016) Non-parametric smoothed estimation of multivariate cumulative distribution and survival functions, and receiver operating characteristic curves. \emph{Journal of the Korean Statistical Society}, \bold{45}, 33-50. } \seealso{\code{\link{kde}}, \code{\link{plot.kcde}}} \examples{ library(MASS) data(iris) Fhat <- kcde(iris[,1:2]) predict(Fhat, x=as.matrix(iris[,1:2])) ## See other examples in ? plot.kcde } \keyword{smooth} ks/man/tempb.Rd0000644000176200001440000000161713265745072013060 0ustar liggesusers\name{tempb} \docType{data} \alias{tempb} \title{Daily temperature} \description{ This data set contains the daily minimum and maximum temperatures from the weather station in Badajoz, Spain, from 1 January 1955 to 31 December 2015. } \usage{data(hsct)} \format{A matrix with 21908 rows and 5 columns. Each row corresponds to a daily measurement. The first column is the year (yyyy), the second is the month (mm), the third is the day (dd), the fourth is the minimum temperature (degrees Celsius), the fifth is the maximum temperature (degrees Celsius). } \source{ Menne, M. J., Durre, I., Vose, R. S., Gleason, B. E. & Houston, T. (2012) An overview of the global historical climatology network-daily database, \emph{Journal of Atmospheric and Oceanic Technology} \bold{429}, 897 - 910. https://climexp.knmi.nl/selectdailyseries.cgi. Accessed 2016-10-20. } \keyword{datasets} ks/man/plotmixt.Rd0000644000176200001440000000327213265741777013640 0ustar liggesusers\name{plotmixt} \alias{plotmixt} \title{Plot for 1- to 3-dimensional normal and t-mixture density functions} \description{ Plot for 1- to 3-dimensional normal and t-mixture density functions. } \usage{ plotmixt(mus, sigmas, Sigmas, props, dfs, dist="normal", draw=TRUE, deriv.order=0, which.deriv.ind=1, binned=TRUE, ...) } \arguments{ \item{mus}{(stacked) matrix of mean vectors} \item{sigmas}{vector of standard deviations (1-d)} \item{Sigmas}{(stacked) matrix of variance matrices (2-d, 3-d)} \item{props}{vector of mixing proportions} \item{dfs}{vector of degrees of freedom} \item{dist}{"normal" - normal mixture, "t" - t-mixture} \item{draw}{flag to draw plot. Default is TRUE.} \item{deriv.order}{derivative order} \item{which.deriv.ind}{index of which partial derivative to plot} \item{binned}{flag for binned estimation of contour levels. Default is TRUE.} \item{...}{other graphics parameters, see \code{\link{plot.kde}}} } \value{ If \code{draw=TRUE}, the 1-d, 2-d plot is sent to graphics window, 3-d plot to RGL window. If \code{draw=FALSE}, then a \code{kdde}-like object is returned. } %\details{ % See the graphics parameter options in \code{?plot.kde}. %} \examples{ ## bivariate mus <- rbind(c(0,0), c(-1,1)) Sigma <- matrix(c(1, 0.7, 0.7, 1), nr=2, nc=2) Sigmas <- rbind(Sigma, Sigma) props <- c(1/2, 1/2) plotmixt(mus=mus, Sigmas=Sigmas, props=props, display="filled.contour") \donttest{ ## trivariate mus <- rbind(c(0,0,0), c(-1,0.5,1.5)) Sigma <- matrix(c(1, 0.7, 0.7, 0.7, 1, 0.7, 0.7, 0.7, 1), nr=3, nc=3) Sigmas <- rbind(Sigma, Sigma) props <- c(1/2, 1/2) plotmixt(mus=mus, Sigmas=Sigmas, props=props, dfs=c(11,8), dist="t") }} \keyword{ hplot} ks/man/cardio.Rd0000644000176200001440000000134613265743134013206 0ustar liggesusers\name{cardio} \docType{data} \alias{cardio} \title{Foetal cardiotocograms} \description{ This data set contains the cardiotocographic measurements from healthy, suspect and pathological foetuses. } \usage{data(cardio)} \format{A matrix with 2126 rows and 8 columns. Each row corresponds to a foetal cardiotocogram. The class label for the foetal state is the last column: N = normal, S = suspect, P = pathological. Details for all variables are found in the link below. } \source{ Lichman, M. (2013) UCI machine learning repository, \url{http://archive.ics.uci.edu/ml/datasets/Cardiotocography}. University of California, Irvine, School of Information and Computer Sciences. Accessed 2017-05-18. } \keyword{datasets} ks/man/kde.test.Rd0000644000176200001440000000602513265741644013471 0ustar liggesusers\name{kde.test} \alias{kde.test} \title{Kernel density based global two-sample comparison test} \description{ Kernel density based global two-sample comparison test for 1- to 6-dimensional data.} \usage{ kde.test(x1, x2, H1, H2, h1, h2, psi1, psi2, var.fhat1, var.fhat2, binned=FALSE, bgridsize, verbose=FALSE) } \arguments{ \item{x1,x2}{vector/matrix of data values} \item{H1,H2,h1,h2}{bandwidth matrices/scalar bandwidths. If these are missing, \code{Hpi.kfe}, \code{hpi.kfe} is called by default.} \item{psi1,psi2}{zero-th order kernel functional estimates} \item{var.fhat1,var.fhat2}{sample variance of KDE estimates evaluated at x1, x2} \item{binned}{flag for binned estimation. Default is FALSE.} \item{bgridsize}{vector of binning grid sizes} \item{verbose}{flag to print out progress information. Default is FALSE.} } \value{ A kernel two-sample global significance test is a list with fields: \item{Tstat}{T statistic} \item{zstat}{z statistic - normalised version of Tstat} \item{pvalue}{p-value of the double sided test} \item{mean,var}{mean and variance of null distribution} \item{var.fhat1,var.fhat2}{sample variances of KDE values evaluated at data points} \item{n1,n2}{sample sizes} \item{H1,H2}{bandwidth matrices} \item{psi1,psi12,psi21,psi2}{kernel functional estimates} } \details{The null hypothesis is \eqn{H_0: f_1 \equiv f_2}{H_0: f_1 = f_2} where \eqn{f_1, f_2}{f_1, f_2} are the respective density functions. The measure of discrepancy is the integrated squared error (ISE) \eqn{T = \int [f_1(\bold{x}) - f_2(\bold{x})]^2 \, d \bold{x}}{int [ f_1(x) - f_2(x)]^2 dx}. If we rewrite this as \eqn{T = \psi_{0,1} - \psi_{0,12} - \psi_{0,21} + \psi_{0,2}}{T = psi_0,1 - psi_0,12 - psi_0,21 + psi_0,2} where \eqn{\psi_{0,uv} = \int f_u (\bold{x}) f_v (\bold{x}) \, d \bold{x}}{psi_0,uv = int f_u(x) f_v(x) dx}, then we can use kernel functional estimators. This test statistic has a null distribution which is asymptotically normal, so no bootstrap resampling is required to compute an approximate p-value. If \code{H1,H2} are missing then the plug-in selector \code{\link{Hpi.kfe}} is automatically called by \code{kde.test} to estimate the functionals with \code{kfe(, deriv.order=0)}. Likewise for missing \code{h1,h2}. As of \pkg{ks} 1.8.8, \code{kde.test(,binned=TRUE)} invokes binned estimation for the computation of the bandwidth selectors, and not the test statistic and p-value. } \references{ Duong, T., Goud, B. & Schauer, K. (2012) Closed-form density-based framework for automatic detection of cellular morphology changes. \emph{PNAS}, \bold{109}, 8382-8387. } \seealso{\code{\link{kde.local.test}}} \examples{ set.seed(8192) samp <- 1000 x <- rnorm.mixt(n=samp, mus=0, sigmas=1, props=1) y <- rnorm.mixt(n=samp, mus=0, sigmas=1, props=1) kde.test(x1=x, x2=y)$pvalue ## accept H0: f1=f2 library(MASS) data(crabs) x1 <- crabs[crabs$sp=="B", c(4,6)] x2 <- crabs[crabs$sp=="O", c(4,6)] kde.test(x1=x1, x2=x2)$pvalue ## reject H0: f1=f2 } \keyword{ test } ks/man/Hbcv.Rd0000644000176200001440000000342713265741424012631 0ustar liggesusers\name{Hbcv} \alias{Hbcv} \alias{Hbcv.diag} \title{Biased cross-validation (BCV) bandwidth matrix selector for bivariate data} \description{ BCV bandwidth matrix for bivariate data.} \usage{ Hbcv(x, whichbcv=1, Hstart, binned=FALSE, amise=FALSE, verbose=FALSE) Hbcv.diag(x, whichbcv=1, Hstart, binned=FALSE, amise=FALSE, verbose=FALSE) } \arguments{ \item{x}{matrix of data values} \item{whichbcv}{1 = BCV1, 2 = BCV2. See details below.} \item{Hstart}{initial bandwidth matrix, used in numerical optimisation} \item{binned}{flag for binned kernel estimation. Default is FALSE.} \item{amise}{flag to return the minimal BCV value. Default is FALSE.} \item{verbose}{flag to print out progress information. Default is FALSE.} } \value{ BCV bandwidth matrix. If \code{amise=TRUE} then the minimal BCV value is returned too. } \references{Sain, S.R, Baggerly, K.A. & Scott, D.W. (1994) Cross-validation of multivariate densities. \emph{Journal of the American Statistical Association}, \bold{82}, 1131-1146. } \details{ Use \code{Hbcv} for unconstrained bandwidth matrices and \code{Hbcv.diag} for diagonal bandwidth matrices. These selectors are only available for bivariate data. Two types of BCV criteria are considered here. They are known as BCV1 and BCV2, from Sain, Baggerly & Scott (1994) and only differ slightly. These BCV surfaces can have multiple minima and so it can be quite difficult to locate the most appropriate minimum. Some times, there can be no local minimum at all so there may be no finite BCV selector. For details about the advanced options for \code{binned}, \code{Hstart}, see \code{\link{Hpi}}. } \seealso{\code{\link{Hlscv}}, \code{\link{Hpi}}, \code{\link{Hscv}}} \examples{ data(unicef) Hbcv(unicef) Hbcv.diag(unicef) } \keyword{ smooth } ks/man/air.Rd0000644000176200001440000000220713265742361012516 0ustar liggesusers\name{air} \docType{data} \alias{air} \title{Air quality measurements in an underground train station} \description{ This data set contains the hourly mean air quality measurements from 01 January 2013 to 31 December 2016 in the Chatelet underground train station in the Paris metro. } \usage{data(air)} \format{A matrix with 35039 rows and 8 columns. Each row corresponds to an hourly measurement. The first column is the date (yyyy-mm-dd), the second is the time (hh:mm), the third is the nitric oxide NO concentration (g/m3), the fourth is the nitrogen dioxide NO2 concentration (g/m3), the fifth is the concentration of particulate matter less than 10 microns PM10 (ppm), the sixth is the carbon dioxide concentration CO2 (g/m3), the seventh is the temperature (degrees Celsius), the eighth is the relative humidity (percentage). } \source{ RATP (2016) Qualite de l'air mesuree dans la station Chatelet, \url{https://data.iledefrance.fr/explore/dataset/qualite-de-lair-mesuree-dans-la-station-chatelet}. Regie autonome des transports parisiens - Departement Developpement, Innovation et Territoires. Accessed 2017-09-27. } \keyword{datasets} ks/man/quake.Rd0000644000176200001440000000276113557404440013053 0ustar liggesusers\name{quake} \docType{data} \alias{quake} \alias{plate} \title{Geographical locations of earthquakes} \description{ The \code{quake} data set contains the geographical locations of severe earthquakes in the years 100 and 2016 inclusive. The \code{plate} data set contains the geographical locations of the tectonic plate boundaries. } \usage{data(quake) data(plate)} \format{--For \code{quake}, a matrix with 5871 rows and 5 columns. Each row corresponds to an earthquake. The first column is the year (negative years indicate B.C.E.), the second is the longitude (decimal degrees), the third is the latitude (decimal degrees), the fourth is the depth beneath the Earth's surface (km), the fifth is a flag for the location inside the circum-Pacific belt (aka Pacific Ring of Fire). --For \code{plate}, a matrix with 3 columns and 6276 rows. Each row corresponds to an location of the tectonic plate boundaries. The first is the longitude, the second is the latitude, the third is the label of the tectonic plate.} \source{ Bird, P. (2003) An updated digital model of plate boundaries, \emph{Geochemistry, Geophysics, Geosystems} \bold{4(3)}, 1-52. 1027. %Data set accessed 2016-03-24 from %\url{http://peterbird.name/publications/2003_PB2002/2003_PB2002.htm}. NGDC/WDS (2017) Global significant earthquake database, National Geophysical Data Center, NOAA, doi:10.7289/V5TD9V7K. National Geophysical Data Center/World Data Service. Accessed 2017-03-30. } \keyword{datasets} ks/man/plot.kroc.Rd0000644000176200001440000000214113265741775013663 0ustar liggesusers\name{plot.kroc} \alias{plot.kroc} \title{Plot for kernel receiver operating characteristic curve (ROC) estimate} \description{ Plot for kernel receiver operating characteristic curve (ROC) estimate 1- to 3-dimensional data. } \usage{ \method{plot}{kroc}(x, add=FALSE, add.roc.ref=FALSE, ylab, xlab, ...) } \arguments{ \item{x}{an object of class \code{kroc} (output from \code{\link{kroc}})} \item{add}{flag to add to current plot. Default is FALSE.} \item{add.roc.ref}{flag to add reference ROC curve. Default is FALSE.} \item{xlab}{x-axis label. Default is "False positive rate (bar(specificity))".} \item{ylab}{y-axis label. Default is "True positive rate (sensitivity)".} \item{...}{other graphics parameters used in \code{\link{plot.kde}}.} } \value{ Plots for 1-d and 2-d are sent to graphics window. Plot for 3-d is sent to RGL window. } \seealso{\code{\link{plot.kde}}} \examples{ library(MASS) data(fgl) x1 <- fgl[fgl[,"type"]=="WinF",c("RI", "Na")] x2 <- fgl[fgl[,"type"]=="Head",c("RI", "Na")] Rhat <- kroc(x1=x1, x2=x2) plot(Rhat, add.roc.ref=TRUE) } \keyword{hplot} ks/man/plot.kdde.Rd0000644000176200001440000000373613470624435013636 0ustar liggesusers\name{plot.kdde} \alias{plot.kdde} \title{Plot for kernel density derivative estimate} \description{ Plot for kernel density derivative estimate for 1- to 3-dimensional data. } \usage{ \method{plot}{kdde}(x, ...) } \arguments{ \item{x}{an object of class \code{kdde} (output from \code{\link{kdde}})} \item{...}{other graphics parameters: \describe{ \item{\code{which.deriv.ind}}{index of the partial derivative to be plotted (>1-d)} } and those used in \code{\link{plot.kde}}} } \value{ Plots for 1-d and 2-d are sent to graphics window. Plot for 3-d is sent to RGL window. In addition to the display options inherited from \code{plot.kde}, the first derivative has \code{display="quiver"}. This is a quiver plot where the size and direction of the arrow indicates the magnitude/direction of the density gradient. See \code{quiver2D} from the \pkg{OceanView} package for more details. } \details{ For \code{kdde} objects, the function headers for the different dimensional data are \preformatted{ ## univariate plot(fhat, ylab="Density derivative function", ...) ## bivariate plot(fhat, which.deriv.ind=1, cont=c(25,50,75), abs.cont, display="slice", zlab="Density derivative function", ...) } } \seealso{\code{\link{plot.kde}}} \examples{ ## univariate example data(tempb) fhat1 <- kdde(x=tempb[,"tmin"], deriv.order=1) ## gradient [df/dx, df/dy] plot(fhat1, xlab="Min. temp.") ## df/dx points(20,predict(fhat1, x=20)) ## bivariate example fhat1 <- kdde(x=tempb[,c("tmin", "tmax")], deriv.order=1) \donttest{plot(fhat1, display="quiver") ## gradient [df/dx, df/dy] fhat2 <- kdde(x=tempb[,c("tmin", "tmax")], deriv.order=2) plot(fhat2, which.deriv.ind=2, display="persp", phi=15) plot(fhat2, which.deriv.ind=2, display="filled.contour", col.fun=topo.colors) ## d^2 f/(dx dy): purple=-ve, green=zero, beige=+ve s2 <- kcurv(fhat2) plot(s2, display="filled.contour") ## summary curvature }} \keyword{hplot} ks/man/kroc.Rd0000644000176200001440000000746513265741676012724 0ustar liggesusers\name{kroc} \alias{kroc} \alias{predict.kroc} \alias{summary.kroc} \title{Kernel receiver operating characteristic (ROC) curve} \description{ Kernel receiver operating characteristic (ROC) curve for 1- to 3-dimensional data.} \usage{ kroc(x1, x2, H1, h1, hy, gridsize, gridtype, xmin, xmax, supp=3.7, eval.points, binned, bgridsize, positive=FALSE, adj.positive, w, verbose=FALSE) \method{predict}{kroc}(object, ..., x) \method{summary}{kroc}(object, ...) } \arguments{ \item{x,x1,x2}{vector/matrix of data values} \item{H1,h1,hy}{bandwidth matrix/scalar bandwidths. If these are missing, \code{Hpi.kcde}, \code{hpi.kcde} is called by default.} \item{gridsize}{vector of number of grid points} \item{gridtype}{not yet implemented} \item{xmin,xmax}{vector of minimum/maximum values for grid} \item{supp}{effective support for standard normal} \item{eval.points}{not yet implemented} \item{binned}{flag for binned estimation} \item{bgridsize}{vector of binning grid sizes} \item{positive}{flag if 1-d data are positive. Default is FALSE.} \item{adj.positive}{adjustment applied to positive 1-d data} \item{w}{vector of weights. Default is a vector of all ones.} \item{verbose}{flag to print out progress information. Default is FALSE.} \item{object}{object of class \code{kroc}, output from \code{kroc}} \item{...}{other parameters} } \value{ A kernel ROC curve is an object of class \code{kroc} which is a list with fields: \item{x}{list of data values \code{x1, x2} - same as input} \item{eval.points}{vector or list of points at which the estimate is evaluated} \item{estimate}{ROC curve estimate at \code{eval.points}} \item{gridtype}{"linear"} \item{gridded}{flag for estimation on a grid} \item{binned}{flag for binned estimation} \item{names}{variable names} \item{w}{weights} \item{tail}{"lower.tail"} \item{h1}{scalar bandwidth for first sample (1-d only)} \item{H1}{bandwidth matrix for first sample} \item{hy}{scalar bandwidth for ROC curve} \item{indices}{summary indices of ROC curve.} } \details{ In this set-up, the values in the first sample \code{x1} should be larger in general that those in the second sample \code{x2}. The usual method for computing 1-d ROC curves is not valid for multivariate data. Duong (2014), based on Lloyd (1998), develops an alternative formulation \eqn{(F_{Y_1}(z), F_{Y_2}(z))}{(F_Y1(z), F_Y2(z))} based on the cumulative distribution functions of \eqn{Y_j = \bar{F}_1(\bold{X}_j), j=1,2}{Yj=bar(F)_1(Xj), j=1,2}. If the bandwidth \code{H1} is missing from \code{kroc}, then the default bandwidth is the plug-in selector \code{Hpi.kcde}. Likewise for missing \code{h1,hy}. A bandwidth matrix \code{H1} is required for \code{x1} for d>1, but the second bandwidth \code{hy} is always a scalar since \eqn{Y_j}{Yj} are 1-d variables. The effective support, binning, grid size, grid range, positive parameters are the same as \code{\link{kde}}. --The \code{summary} method for \code{kroc} objects prints out the summary indices of the ROC curve, as contained in the \code{indices} field, namely the AUC (area under the curve) and Youden index. } \references{ Duong, T. (2016) Non-parametric smoothed estimation of multivariate cumulative distribution and survival functions, and receiver operating characteristic curves. \emph{Journal of the Korean Statistical Society}, \bold{45}, 33-50. Lloyd, C. (1998) Using smoothed receiver operating curves to summarize and compare diagnostic systems. \emph{Journal of the American Statistical Association}, \bold{93}, 1356-1364. } \seealso{\code{\link{kcde}}} \examples{ samp <- 1000 x <- rnorm.mixt(n=samp, mus=0, sigmas=1, props=1) y <- rnorm.mixt(n=samp, mus=0.5, sigmas=1, props=1) Rhat <- kroc(x1=x, x2=y) summary(Rhat) predict(Rhat, x=0.5) } \keyword{ smooth } ks/man/kdr.Rd0000644000176200001440000000720413620355366012525 0ustar liggesusers\name{kdr} \alias{kdr} \title{Kernel density ridge estimation} \description{ Kernel density ridge estimation for 2- to 3-dimensional data. } \usage{ kdr(x, y, H, p=1, max.iter=400, tol.iter, tol.seg, min.seg.size, keep.path=FALSE, gridsize, xmin, xmax, binned, bgridsize, w, fhat, density.cutoff, verbose=FALSE) } \arguments{ \item{x}{matrix of data values} \item{y}{matrix of initial values} \item{p}{dimension of density ridge} \item{H}{bandwidth matrix/scalar bandwidth. If missing, \code{Hpi(x,deriv,order=2)} is called by default.} \item{max.iter}{maximum number of iterations. Default is 400.} \item{tol.iter}{distance under which two successive iterations are considered convergent. Default is 0.001*min marginal IQR of \code{x}.} \item{tol.seg}{distance under which two segments are considered to form one segment. Default is 0.01*max marginal IQR of \code{x}.} \item{min.seg.size}{minimum length of a segment of a density ridge. Default is \code{round(0.001*nrow(y),0)}.} \item{keep.path}{flag to store the density gradient ascent paths. Default is FALSE.} \item{gridsize}{vector of number of grid points} \item{xmin,xmax}{vector of minimum/maximum values for grid} \item{binned}{flag for binned estimation.} \item{bgridsize}{vector of binning grid sizes} \item{w}{vector of weights. Default is a vector of all ones.} \item{fhat}{kde of \code{x}. If missing \code{kde(x=x,w=w)} is executed.} \item{density.cutoff}{density threshold under which the \code{y} are excluded from the density ridge estimation. Default is \code{contourLevels(fhat, cont=99)}.} \item{verbose}{flag to print out progress information. Default is FALSE.} } \value{ A kernel density ridge set is an object of class \code{kdr} which is a list with fields: \item{x,y}{data points - same as input} \item{end.points}{matrix of final iterates starting from \code{y}} \item{H}{bandwidth matrix} \item{names}{variable names} \item{tol.iter,tol.clust,min.seg.size}{tuning parameter values - same as input} \item{binned}{flag for binned estimation} \item{names}{variable names} \item{w}{weights} \item{path}{list of density gradient ascent paths where \code{path[[i]]} is the path of \code{y[i,]} (only if \code{keep.path=TRUE})} } \details{ Kernel density ridge estimation is based on reduced dimension kernel mean shift. *** To do. *** See Ozertem & Erdogmus (2011). If \code{y} is missing, then it defaults to the grid of size \code{gridsize} spanning from \code{xmin} to \code{xmax}. If the bandwidth \code{H} is missing, then the default bandwidth is the plug-in selector for the density gradient \code{Hpi(x,deriv.order=2)}. Any bandwidth that is suitable for the density Hessian is also suitable for the kernel density ridge. } \references{ Ozertem, U. & Erdogmus, D. (2011), Locally defined principal curves and surfaces, \emph{Journal of Machine Learning Research}, \bold{12}, 1249-1286. } \seealso{\code{\link{kde}}} \examples{ \donttest{ library(maps) data(quake) quake <- quake[quake$prof==1,] ## Pacific Ring of Fire quake$long[quake$long<0] <- quake$long[quake$long<0] + 360 quake <- quake[, c("long", "lat")] data(plate) ## tectonic plate boundaries plate <- plate[plate$long < -20 | plate$long > 20,] plate$long[plate$long<0 & !is.na(plate$long)] <- plate$long[plate$long<0 & !is.na(plate$long)] + 360 dr.quake <- kdr(x=quake, xmin=c(70,-70), xmax=c(310, 80)) map("world2", xlim=c(85, 305), ylim=c(-70, 70), mar=c(0,0,0,0), interior=FALSE, lty=2) lines(plate[,1:2], col=3, lwd=2) points(dr.quake$end.points, cex=0.5, pch=16, col=2)} } \keyword{cluster} ks/man/ks-internal.Rd0000644000176200001440000000070313266747063014176 0ustar liggesusers\name{ks-internal} \alias{getRow} \alias{Lpdiff} \alias{matrix.sqrt} \alias{mur} \alias{nur} \alias{nurs} \alias{Qr} \alias{rowKpow} \alias{Sdr} \alias{Sdrv} \alias{symconv.1d} \alias{symconv.nd} % Write Rd help files for these functions \alias{dwsupp} \alias{reg.ucv} \alias{kr} \title{Internal functions in the ks library} \description{ These functions are user-level but which the user is not required to use directly. } \keyword{internal} ks/man/Hnm.Rd0000644000176200001440000000301513620371345012456 0ustar liggesusers\name{Hnm} \alias{Hnm} \alias{hnm} \alias{Hnm.diag} \title{Normal mixture bandwidth} \description{ Normal mixture bandwidth. } \usage{ Hnm(x, deriv.order=0, G=1:9, subset.ind, mise.flag=FALSE, verbose, ...) Hnm.diag(x, deriv.order=0, G=1:9, subset.ind, mise.flag=FALSE, verbose, ...) hnm(x, deriv.order=0, G=1:9, subset.ind, mise.flag=FALSE, verbose, ... ) } \arguments{ \item{x}{vector/matrix of data values} \item{deriv.order}{derivative order} \item{G}{range of number of mixture components} \item{subset.ind}{index vector of subset of \code{x} for fitting} \item{mise.flag}{flag to use MISE or AMISE minimisation. Default is FALSE.} \item{verbose}{flag to print out progress information. Default is FALSE.} \item{...}{other parameters for \code{Mclust}} } \value{ Normal mixture bandwidth. If \code{mise=TRUE} then the minimal MISE value is returned too. } \details{ The normal mixture fit is provided by the \code{Mclust} function in the \pkg{mclust} package. \code{Hnm} is then \code{Hmise.mixt} (if \code{mise.flag=TRUE}) or \code{Hamise.mixt} (if \code{mise.flag=FALSE}) with these fitted normal mixture parameters. Likewise for \code{Hnm.diag}, \code{hnm}. } \seealso{ \link{Hmise.mixt}, \link{Hamise.mixt} } \references{Cwik, J. & Koronacki, J. (1997). A combined adaptive-mixtures/plug-in estimator of multivariate probability densities. \emph{Computational Statistics and Data Analysis}, \bold{26}, 199-218. } \examples{ library(MASS) data(forbes) Hnm(forbes) } \keyword{smooth} ks/man/kda.Rd0000644000176200001440000001413313265741562012505 0ustar liggesusers\name{kda} \alias{Hkda} \alias{Hkda.diag} \alias{kda} \alias{hkda} \alias{predict.kda} \alias{compare} \alias{compare.kda.diag.cv} \alias{compare.kda.cv} \title{Kernel discriminant analysis} \description{ Kernel discriminant analysis for 1- to d-dimensional data. } \usage{ kda(x, x.group, Hs, hs, prior.prob=NULL, gridsize, xmin, xmax, supp=3.7, eval.points, binned, bgridsize, w, compute.cont=TRUE, approx.cont=TRUE, kde.flag=TRUE) Hkda(x, x.group, Hstart, bw="plugin", ...) Hkda.diag(x, x.group, bw="plugin", ...) hkda(x, x.group, bw="plugin", ...) \method{predict}{kda}(object, ..., x) compare(x.group, est.group, by.group=FALSE) compare.kda.cv(x, x.group, bw="plugin", prior.prob=NULL, Hstart, by.group=FALSE, verbose=FALSE, recompute=FALSE, ...) compare.kda.diag.cv(x, x.group, bw="plugin", prior.prob=NULL, by.group=FALSE, verbose=FALSE, recompute=FALSE, ...) } \arguments{ \item{x}{matrix of training data values} \item{x.group}{vector of group labels for training data} \item{Hs,hs}{(stacked) matrix of bandwidth matrices/vector of scalar bandwidths. If these are missing, \code{Hkda} or \code{hkda} is called by default.} \item{prior.prob}{vector of prior probabilities} \item{gridsize}{vector of grid sizes} \item{xmin,xmax}{vector of minimum/maximum values for grid} \item{supp}{effective support for standard normal} \item{eval.points}{vector or matrix of points at which estimate is evaluated} \item{binned}{flag for binned estimation} \item{bgridsize}{vector of binning grid sizes} \item{w}{vector of weights. Not yet implemented.} \item{compute.cont}{flag for computing 1\% to 99\% probability contour levels. Default is TRUE.} \item{approx.cont}{flag for computing approximate probability contour levels. Default is TRUE.} \item{kde.flag}{flag for computing KDE on grid. Default is TRUE.} \item{object}{object of class \code{kda}} \item{bw}{bandwidth: "plugin" = plug-in, "lscv" = LSCV, "scv" = SCV} \item{Hstart}{(stacked) matrix of initial bandwidth matrices, used in numerical optimisation} \item{est.group}{vector of estimated group labels} \item{by.group}{flag to give results also within each group} \item{verbose}{flag for printing progress information. Default is FALSE.} \item{recompute}{flag for recomputing the bandwidth matrix after excluding the i-th data item} \item{...}{other optional parameters for bandwidth selection, see \code{\link{Hpi}}, \code{\link{Hlscv}}, \code{\link{Hscv}}} } \value{ --For \code{kde.flag=TRUE}, a kernel discriminant analysis is an object of class \code{kda} which is a list with fields \item{x}{list of data points, one for each group label} \item{estimate}{list of density estimates at \code{eval.points}, one for each group label} \item{eval.points}{vector or list of points that the estimate is evaluated at, one for each group label} \item{h}{vector of bandwidths (1-d only)} \item{H}{stacked matrix of bandwidth matrices or vector of bandwidths} \item{gridded}{flag for estimation on a grid} \item{binned}{flag for binned estimation} \item{w}{weights} \item{prior.prob}{prior probabilities} \item{x.group}{group labels - same as input} \item{x.group.estimate}{estimated group labels. If the test data \code{eval.points} are given then these are classified. Otherwise the training data \code{x} are classified.} For \code{kde.flag=FALSE}, which is always the case for \eqn{d>3}{d>3}, then only the vector of estimated group labels is returned. --The result from \code{Hkda} and \code{Hkda.diag} is a stacked matrix of bandwidth matrices, one for each training data group. The result from \code{hkda} is a vector of bandwidths, one for each training group. --The \code{compare} functions create a comparison between the true group labels \code{x.group} and the estimated ones. It returns a list with fields \item{cross}{cross-classification table with the rows indicating the true group and the columns the estimated group} \item{error}{misclassification rate (MR)} In the case where the test data is independent of the training data, \code{compare} computes MR = (number of points wrongly classified)/(total number of points). In the case where the test data are not independent e.g. we are classifying the training data set itself, then the cross validated estimate of MR is more appropriate. These are implemented as \code{compare.kda.cv} (unconstrained bandwidth selectors) and \code{compare.kda.diag.cv} (for diagonal bandwidth selectors). These functions are only available for d > 1. If \code{by.group=FALSE} then only the total MR rate is given. If it is set to TRUE, then the MR rates for each class are also given (estimated number in group divided by true number). } \references{ Simonoff, J. S. (1996) \emph{Smoothing Methods in Statistics}. Springer-Verlag. New York } \details{ If the bandwidths \code{Hs} are missing from \code{kda}, then the default bandwidths are the plug-in selectors \code{Hkda(, bw="plugin")}. Likewise for missing \code{hs}. Valid options for \code{bw} are \code{"plugin"}, \code{"lscv"} and \code{"scv"} which in turn call \code{\link{Hpi}}, \code{\link{Hlscv}} and \code{\link{Hscv}}. The effective support, binning, grid size, grid range, positive parameters are the same as \code{\link{kde}}. If prior probabilities are known then set \code{prior.prob} to these. Otherwise \code{prior.prob=NULL} uses the sample proportions as estimates of the prior probabilities. As of \pkg{ks} 1.8.11, \code{kda.kde} has been subsumed into \code{kda}, so all prior calls to \code{kda.kde} can be replaced by \code{kda}. To reproduce the previous behaviour of \code{kda}, the command is \code{kda(, kde.flag=FALSE)}. } \seealso{\code{\link{plot.kda}}} \examples{ set.seed(8192) x <- c(rnorm.mixt(n=100, mus=1), rnorm.mixt(n=100, mus=-1)) x.gr <- rep(c(1,2), times=c(100,100)) y <- c(rnorm.mixt(n=100, mus=1), rnorm.mixt(n=100, mus=-1)) y.gr <- rep(c(1,2), times=c(100,100)) kda.gr <- kda(x, x.gr) y.gr.est <- predict(kda.gr, x=y) compare(y.gr, y.gr.est) ## See other examples in ? plot.kda } \keyword{ smooth } ks/man/Hscv.Rd0000644000176200001440000000637213265741540012653 0ustar liggesusers\name{Hscv} \alias{Hscv} \alias{Hscv.diag} \alias{hscv} \title{Smoothed cross-validation (SCV) bandwidth selector} \description{ SCV bandwidth for 1- to 6-dimensional data.} \usage{ Hscv(x, nstage=2, pre="sphere", pilot, Hstart, binned, bgridsize, amise=FALSE, deriv.order=0, verbose=FALSE, optim.fun="optim") Hscv.diag(x, nstage=2, pre="scale", pilot, Hstart, binned, bgridsize, amise=FALSE, deriv.order=0, verbose=FALSE, optim.fun="optim") hscv(x, nstage=2, binned=TRUE, bgridsize, plot=FALSE) } \arguments{ \item{x}{vector or matrix of data values} \item{pre}{"scale" = \code{\link{pre.scale}}, "sphere" = \code{\link{pre.sphere}}} \item{pilot}{"amse" = AMSE pilot bandwidths \cr "samse" = single SAMSE pilot bandwidth \cr "unconstr" = single unconstrained pilot bandwidth \cr "dscalar" = single pilot bandwidth for deriv.order>0 \cr "dunconstr" = single unconstrained pilot bandwidth for deriv.order>0} \item{Hstart}{initial bandwidth matrix, used in numerical optimisation} \item{binned}{flag for binned kernel estimation} \item{bgridsize}{vector of binning grid sizes} \item{amise}{flag to return the minimal scaled SCV value. Default is FALSE.} \item{deriv.order}{derivative order} \item{verbose}{flag to print out progress information. Default is FALSE.} \item{optim.fun}{optimiser function: one of \code{nlm} or \code{optim}} \item{nstage}{number of stages in the SCV bandwidth selector (1 or 2)} \item{plot}{flag to display plot of SCV(h) vs h (1-d only). Default is FALSE.} } \value{ SCV bandwidth. If \code{amise=TRUE} then the minimal scaled SCV value is returned too. } \details{ \code{hscv} is the univariate SCV selector of Jones, Marron & Park (1991). \code{Hscv} is a multivariate generalisation of this, see Duong & Hazelton (2005). Use \code{Hscv} for unconstrained bandwidth matrices and \code{Hscv.diag} for diagonal bandwidth matrices. The default pilot is \code{"samse"} for d=2, r=0, and \code{"dscalar"} otherwise. For SAMSE pilot bandwidths, see Duong & Hazelton (2005). Unconstrained and higher order derivative pilot bandwidths are from Chacon & Duong (2011). For d=1, the selector \code{hscv} is not always stable for large sample sizes with binning. Examine the plot from \code{hscv(, plot=TRUE)} to determine the appropriate smoothness of the SCV function. Any non-smoothness is due to the discretised nature of binned estimation. From \pkg{ks} 1.11.1 onwards, the default optimisation function is \code{optim.fun="optim"}. For details about the advanced options for \code{binned, Hstart}, see \code{\link{Hpi}}. } \references{ Chacon, J.E. & Duong, T. (2011) Unconstrained pilot selectors for smoothed cross validation. \emph{Australian & New Zealand Journal of Statistics}, \bold{53}, 331-351. Duong, T. & Hazelton, M.L. (2005) Cross-validation bandwidth matrices for multivariate kernel density estimation. \emph{Scandinavian Journal of Statistics}, \bold{32}, 485-506. Jones, M.C., Marron, J.S. & Park, B.U. (1991) A simple root n bandwidth selector. \emph{Annals of Statistics}, \bold{19}, 1919-1932. } \seealso{\code{\link{Hbcv}}, \code{\link{Hlscv}}, \code{\link{Hpi}}} \examples{ data(unicef) Hscv(unicef) hscv(unicef[,1]) } \keyword{ smooth } ks/man/binning.Rd0000644000176200001440000000263613265742545013401 0ustar liggesusers\name{binning} \alias{binning} \title{Linear binning for multivariate data} \description{ Linear binning for 1- to 4-dimensional data. } \usage{ binning(x, H, h, bgridsize, xmin, xmax, supp=3.7, w, gridtype="linear") } \arguments{ \item{x}{matrix of data values} \item{H,h}{bandwidth matrix, scalar bandwidth} \item{xmin,xmax}{vector of minimum/maximum values for grid} \item{supp}{effective support for standard normal is [-supp,supp]} \item{bgridsize}{vector of binning grid sizes} \item{w}{vector of weights. Default is a vector of all ones.} \item{gridtype}{not yet implemented} } \value{ Returns a list with 2 fields \item{counts}{linear binning counts} \item{eval.points}{vector (d=1) or list (d>=2) of grid points in each dimension } } \details{ As of \pkg{ks} 1.10.0, binning is available for unconstrained (non-diagonal) bandwidth matrices. Code is used courtesy of A. & J. Gramacki, and M.P. Wand. Default \code{bgridsize} are d=1: 401; d=2: rep(151, 2); d=3: rep(51, 3); d=4: rep(21, 4). } \references{ Gramacki, A. & Gramacki, J. (2016) FFT-based fast computation of multivariate kernel estimators with unconstrained bandwidth matrices. \emph{Journal of Computational & Graphical Statistics}, \bold{26}, 459-462. Wand, M.P. & Jones, M.C. (1995) \emph{Kernel Smoothing}. Chapman & Hall. London. } \examples{ data(unicef) ubinned <- binning(x=unicef) } \keyword{algebra} ks/man/kde.Rd0000644000176200001440000001264413317247031012504 0ustar liggesusers\name{kde} \alias{kde} \alias{predict.kde} \title{Kernel density estimate} \description{ Kernel density estimate for 1- to 6-dimensional data. } \usage{ kde(x, H, h, gridsize, gridtype, xmin, xmax, supp=3.7, eval.points, binned, bgridsize, positive=FALSE, adj.positive, w, compute.cont=TRUE, approx.cont=TRUE, unit.interval=FALSE, verbose=FALSE) \method{predict}{kde}(object, ..., x, zero.flag=TRUE) } \arguments{ \item{x}{matrix of data values} \item{H,h}{bandwidth matrix/scalar bandwidth. If these are missing, \code{Hpi} or \code{hpi} is called by default.} \item{gridsize}{vector of number of grid points} \item{gridtype}{not yet implemented} \item{xmin,xmax}{vector of minimum/maximum values for grid} \item{supp}{effective support for standard normal} \item{eval.points}{vector or matrix of points at which estimate is evaluated} \item{binned}{flag for binned estimation.} \item{bgridsize}{vector of binning grid sizes} \item{positive}{flag if data are positive (1-d, 2-d). Default is FALSE.} \item{adj.positive}{adjustment applied to positive 1-d data} \item{w}{vector of weights. Default is a vector of all ones.} \item{compute.cont}{flag for computing 1\% to 99\% probability contour levels. Default is TRUE.} \item{approx.cont}{flag for computing approximate probability contour levels. Default is TRUE.} \item{unit.interval}{flag if 1-d data are bounded on unit interval [0,1]. Default is FALSE.} \item{verbose}{flag to print out progress information. Default is FALSE.} \item{object}{object of class \code{kde}} \item{zero.flag}{interpolated values \code{object$estimate} of when \code{x} outside of \code{object$eval.points}=0 (if \code{TRUE}), = nearest \code{object$estimate} (if \code{FALSE})} \item{...}{other parameters} } \value{ A kernel density estimate is an object of class \code{kde} which is a list with fields: \item{x}{data points - same as input} \item{eval.points}{vector or list of points at which the estimate is evaluated} \item{estimate}{density estimate at \code{eval.points}} \item{h}{scalar bandwidth (1-d only)} \item{H}{bandwidth matrix} \item{gridtype}{"linear"} \item{gridded}{flag for estimation on a grid} \item{binned}{flag for binned estimation} \item{names}{variable names} \item{w}{weights} \item{cont}{probability contour levels (if \code{compute.cont=TRUE})} } \details{ For d=1, if \code{h} is missing, the default bandwidth is \code{hpi}. For d>1, if \code{H} is missing, the default is \code{Hpi}. For d=1, if \code{positive=TRUE} then \code{x} is transformed to \code{log(x+adj.positive)} where the default \code{adj.positive} is the minimum of \code{x}. This is known as a log transformation density estimate. For d=1, 2, 3, and if \code{eval.points} is not specified, then the density estimate is computed over a grid defined by \code{gridsize} (if \code{binned=FALSE}) or by \code{bgridsize} (if \code{binned=TRUE}). This form is suitable for visualisation in conjunction with the \code{plot} method. For d=4, 5, 6, and if \code{eval.points} is not specified, then the density estimate is computed over a grid defined by \code{gridsize}. --If \code{eval.points} is specified, as a vector (d=1) or as a matrix (d=2, 3, 4), then the density estimate is computed at \code{eval.points}. This form is suitable for numerical summaries (e.g. maximum likelihood), and is not compatible with the \code{plot} method. Despite that the density estimate is returned only at \code{eval.points}, by default, a binned gridded estimate is calculated first and then the density estimate at \code{eval.points} is computed using the \code{predict} method. If this default intermediate binned grid estimate is not required, then set \code{binned=FALSE} to compute directly the exact density estimate at \code{eval.points}. %--For d>4, computing the kernel %density estimate over a grid is not feasible, and so it is computed exactly %and \code{eval.points} (as a matrix) must be specified. Binned kernel estimation is an approximation to the exact kernel estimation and is available for d=1, 2, 3, 4. This makes kernel estimators feasible for large samples. The default value of the binning flag \code{binned} is n>1 (d=1), n>500 (d=2), n>1000 (d>=3). The default \code{bgridsize,gridsize} are 401 (d=1), rep(151, 2) (d=2), rep(51, 3) (d=3), rep(21,4) (d=4). The effective support for a normal kernel is where all values outside \code{[-supp,supp]^d} are zero. The default \code{xmin} is \code{min(x)-Hmax*supp} and \code{xmax} is \code{max(x)+Hmax*supp} where \code{Hmax} is the maximum of the diagonal elements of \code{H}. The grid produced is the outer product of \code{c(xmin[1], xmax[1])}, ..., \code{c(xmin[d], xmax[d])}. } \seealso{\code{\link{plot.kde}}} \examples{ ## positive data example data(worldbank) wb <- as.matrix(na.omit(worldbank[,2:3])) wb[,2] <- wb[,2]/1000 fhat <- kde(x=wb) fhat.trans <- kde(x=wb, adj.positive=c(0,0), positive=TRUE) plot(fhat, xlim=c(0,20), ylim=c(0,80)) plot(fhat.trans, add=TRUE, col=2) rect(0,0,100,100, lty=2) ## large data example on non-default grid ## 151 x 151 grid = [-5,-4.933,..,5] x [-5,-4.933,..,5] set.seed(8192) x <- rmvnorm.mixt(10000, mus=c(0,0), Sigmas=invvech(c(1,0.8,1))) fhat <- kde(x=x, compute.cont=TRUE, xmin=c(-5,-5), xmax=c(5,5), bgridsize=c(151,151)) plot(fhat) ## See other examples in ? plot.kde } \keyword{smooth} ks/man/plot.histde.Rd0000644000176200001440000000506613265741754014213 0ustar liggesusers\name{plot.histde} \alias{plot.histde} \title{Plot for histogram density estimate} \description{ Plot for histogram density estimate for 1- and 2-dimensional data. } \usage{ \method{plot}{histde}(x, ...) } \arguments{ \item{x}{an object of class \code{histde} (output from \code{\link{histde}})} \item{...}{other graphics parameters: \describe{ \item{\code{col}}{plotting colour for density estimate} \item{\code{col.fun}}{plotting colour function for levels} \item{\code{col.pt}}{plotting colour for data points} \item{\code{jitter}}{flag to jitter rug plot (1-d). Default is TRUE.} \item{\code{xlim,ylim}}{axes limits} \item{\code{xlab,ylab}}{axes labels} \item{\code{add}}{flag to add to current plot. Default is FALSE.} \item{\code{drawpoints}}{flag to draw data points on density estimate. Default is FALSE.} \item{\code{breaks}}{vector of break values of density estimate. Default is an \code{nbreaks} equilinear sequence over the data range.} \item{\code{nbreaks}}{number of breaks in \code{breaks} sequence} \item{\code{lty.rect},\code{lwd.rect}}{line type/width for histogram box lines (2-d)} \item{\code{border}}{colour of histogram box lines (2-d)} \item{\code{col.rect}}{colour of histogram bars (1-d)} \item{\code{add.grid}}{flag to add histogram grid (2-d). Default is TRUE.} } } } \value{ Plots for 1-d and 2-d are sent to graphics window. } \details{ For \code{histde} objects, the function headers for the different dimensional data are \preformatted{ ## univariate plot(fhat, xlab, ylab="Density function", add=FALSE, drawpoints=FALSE, col.pt="blue", jitter=FALSE, border=1, ...) ## bivariate plot(fhat, breaks, nbreaks=11, xlab, ylab, zlab="Density function", cex=1, pch=1, add=FALSE, drawpoints=FALSE, col, col.fun, col.pt="blue", lty.rect=2, cex.text=1, border, lwd.rect=1, col.rect="transparent", add.grid=TRUE, ...) } The 1-d plot is a standard plot of a histogram generated by \code{hist}. If \code{drawpoints=TRUE} then a rug plot is added. The 2-d plot is similar to the \code{display="filled.contour"} option from \code{\link{plot.kde}} with the default \code{nbreaks=11} contour levels. Default colours are the default from the \code{image} command. } \seealso{\code{\link{plot.kde}}} \examples{ library(MASS) data(iris) ## univariate example fhat <- histde(x=iris[,2]) plot(fhat, border=3, xlab="Sepal length") ## bivariate example fhat <- histde(x=iris[,2:3]) plot(fhat, drawpoints=TRUE) box() } \keyword{hplot} ks/man/kde.truncate.Rd0000644000176200001440000000263713620355224014332 0ustar liggesusers\name{kde.truncate} \alias{kde.truncate} \alias{kdde.truncate} \title{Truncated kernel density derivative estimate} \description{ Truncated kernel density derivative estimate for 2-dimensional data. } \usage{ kde.truncate(fhat, boundary) kdde.truncate(fhat, boundary) } \arguments{ \item{fhat}{object of class \code{kde} or \code{kdde}} \item{boundary}{two column matrix delimiting the boundary for truncation} } \value{ A truncated kernel density (derivative) estimate inherits the same object class as the input estimate. } \details{ A simple truncation is performed on the kernel estimator. All the points in the estimation grid which are outside of the regions delimited by \code{boundary} are set to 0, and their probability mass is distributed proportionally to the density (derivative) value. %The \code{boundary} is typically obtained as the output from %\code{polypath} from the \pkg{mgcv} package which determines %automatically the interior/exterior of a set of polygon paths. } \seealso{\code{\link{kde}}, \code{\link{kdde}}} \examples{ library(oz) data(grevillea) wa.coast <- ozRegion(section=1) wa.polygon <- cbind(wa.coast$lines[[1]]$x, wa.coast$lines[[1]]$y) fhat <- kde(x=grevillea) fhat <- kde.truncate(fhat, wa.polygon) oz(section=1, xlim=c(114.75, 121.5), ylim=c(-33, -31.5)) plot(fhat, add=TRUE, cont=seq(10,90,by=10), col=2, drawlabels=FALSE, drawpoints=TRUE) } \keyword{smooth} ks/man/ise.mixt.Rd0000644000176200001440000000471213265741545013511 0ustar liggesusers\name{ise.mixt} \alias{Hmise.mixt} \alias{Hamise.mixt} \alias{Hmise.mixt.diag} \alias{Hamise.mixt.diag} \alias{hmise.mixt} \alias{hamise.mixt} \alias{ise.mixt} \alias{amise.mixt} \alias{mise.mixt} \title{Squared error bandwidth matrix selectors for normal mixture densities} \description{ The global errors ISE (Integrated Squared Error), MISE (Mean Integrated Squared Error) and the AMISE (Asymptotic Mean Integrated Squared Error) for 1- to 6-dimensional data. Normal mixture densities have closed form expressions for the MISE and AMISE. So in these cases, we can numerically minimise these criteria to find MISE- and AMISE-optimal matrices. } \usage{ Hamise.mixt(mus, Sigmas, props, samp, Hstart, deriv.order=0) Hmise.mixt(mus, Sigmas, props, samp, Hstart, deriv.order=0) Hamise.mixt.diag(mus, Sigmas, props, samp, Hstart, deriv.order=0) Hmise.mixt.diag(mus, Sigmas, props, samp, Hstart, deriv.order=0) hamise.mixt(mus, sigmas, props, samp, hstart, deriv.order=0) hmise.mixt(mus, sigmas, props, samp, hstart, deriv.order=0) amise.mixt(H, mus, Sigmas, props, samp, h, sigmas, deriv.order=0) ise.mixt(x, H, mus, Sigmas, props, h, sigmas, deriv.order=0, binned=FALSE, bgridsize) mise.mixt(H, mus, Sigmas, props, samp, h, sigmas, deriv.order=0) } \arguments{ \item{mus}{(stacked) matrix of mean vectors (>1-d), vector of means (1-d)} \item{Sigmas,sigmas}{(stacked) matrix of variance matrices (>1-d), vector of standard deviations (1-d)} \item{props}{vector of mixing proportions} \item{samp}{sample size} \item{Hstart,hstart}{initial bandwidth (matrix), used in numerical optimisation} \item{deriv.order}{derivative order} \item{x}{matrix of data values} \item{H,h}{bandwidth (matrix)} \item{binned}{flag for binned kernel estimation. Default is FALSE.} \item{bgridsize}{vector of binning grid sizes} } \value{ Unconstrained MISE- or AMISE-optimal bandwidth matrix. ISE, MISE or AMISE value. } \details{ ISE is a random variable that depends on the data \code{x}. MISE and AMISE are non-random and don't depend on the data. For normal mixture densities, ISE, MISE and AMISE have exact formulas for all dimensions. } \references{Chacon J.E., Duong, T. & Wand, M.P. (2011). Asymptotics for general multivariate kernel density derivative estimators. \emph{Statistica Sinica}, \bold{21}, 807-840. } \examples{ x <- rmvnorm.mixt(100) Hamise.mixt(samp=nrow(x), mus=rep(0,2), Sigmas=var(x), props=1, deriv.order=1) } \keyword{smooth} ks/man/ksupp.Rd0000644000176200001440000000234513221505031013067 0ustar liggesusers\name{ksupp} \alias{ksupp} \title{Kernel support estimate} \description{ Kernel support estimate for 2-dimensional data. } \usage{ ksupp(fhat, cont=95, abs.cont, convex.hull=FALSE) } \arguments{ \item{fhat}{object of class \code{kde}} \item{cont}{percentage for contour level curve. Default is 95.} \item{abs.cont}{absolute density estimate height for contour level curve} \item{convex.hull}{flag to compute convex hull of contour level curve. Default is FALSE.} } \value{ A kernel support estimate is a 2-column matrix which delimits the (convex hull of the) level set of the density estimate \code{fhat}. } \details{ The kernel support estimate is the level set of the density estimate that exceeds the \code{cont} percent contour level. If this level set is a simply connected region, then this can suffice to be a conservative estimate of the density support. Otherwise, the convex hull of the level set is advised. } \seealso{\code{\link{kde}}} \examples{ library(oz) data(grevillea) fhat <- kde(x=grevillea) fhat.supp <- ksupp(fhat, convex.hull=TRUE) plot(fhat, display="filled.contour", cont=seq(10,90,by=10), drawlabels=FALSE) plot(fhat, cont=95, add=TRUE) polygon(fhat.supp, lty=2) } \keyword{smooth} ks/DESCRIPTION0000644000176200001440000000231113620451512012371 0ustar liggesusersPackage: ks Version: 1.11.7 Date: 2020-02-11 Title: Kernel Smoothing Authors@R: c(person("Tarn", "Duong", role=c("aut","cre"), email="tarn.duong@gmail.com"), person("Matt", "Wand", role="ctb", email="Matt.Wand@uts.edu.au"), person("Jose", "Chacon", role="ctb", email="jechacon@unex.es"), person("Artur", "Gramacki", role="ctb", email="a.gramacki@issi.uz.zgora.pl")) Maintainer: Tarn Duong Depends: R (>= 2.10.0) Imports: FNN (>= 1.1), kernlab, KernSmooth (>= 2.22), Matrix, mclust, mgcv, multicool, mvtnorm (>= 1.0-0) Suggests: maps, MASS, misc3d (>= 0.4-0), OceanView, oz, rgl (>= 0.66) Description: Kernel smoothers for univariate and multivariate data, including densities, density derivatives, cumulative distributions, clustering, classification, density ridges, significant modal regions, and two-sample hypothesis tests. Chacon & Duong (2018) . License: GPL-2 | GPL-3 URL: http://www.mvstat.net/mvksa NeedsCompilation: yes Packaged: 2020-02-11 00:19:14 UTC; tduong Author: Tarn Duong [aut, cre], Matt Wand [ctb], Jose Chacon [ctb], Artur Gramacki [ctb] Repository: CRAN Date/Publication: 2020-02-11 07:10:02 UTC ks/build/0000755000176200001440000000000013620371402011764 5ustar liggesusersks/build/vignette.rds0000644000176200001440000000026613620371402014327 0ustar liggesusersb```b`@YH394{vJ^P^903Pʂ44aV@+I `aBVZnKjAj^ HvѴpxVaaqIY0AAn0Ez0?Ht&${+%$Q/nqzИks/src/0000755000176200001440000000000013620371402011454 5ustar liggesusersks/src/ks.c0000644000176200001440000006347613227237517012270 0ustar liggesusers#include #include #include #include #ifdef HAVE_CONFIG_H #include #endif #include #include #include #include /* Multivariate linear binning functions translated from the Fortran code of M. Wand & T.Duong in ks < 1.8.0 adapted from 1-d massdist.c in stats package */ /* Headers */ void massdist1d(double *x1, int *n, double *a1, double *b1, int *M1, double *weight, double *est); void massdist2d(double *x1, double *x2, int *n, double *a1, double *a2, double *b1, double *b2, int *M1, int *M2, double *weight, double *est); void massdist3d(double *x1, double *x2, double *x3, int *n, double *a1, double *a2, double *a3, double *b1, double *b2, double *b3, int *M1, int *M2, int *M3, double *weight, double *est); void massdist4d(double *x1, double *x2, double *x3, double *x4, int *n, double *a1, double *a2, double *a3, double *a4, double *b1, double *b2, double *b3, double *b4, int *M1, int *M2, int *M3, int *M4, double *weight, double *est); void interp1d(double *x1, int *n, double *a1, double *b1, int *M1, double *fun, double *est); void interp2d(double *x1, double *x2, int *n, double *a1, double *a2, double *b1, double *b2, int *M1, int *M2, double *fun, double *est); void interp3d(double *x1, double *x2, double *x3, int *n, double *a1, double *a2, double *a3, double *b1, double *b2, double *b3, int *M1, int *M2, int *M3, double *fun, double *est); /* Code */ void massdist1d(double *x1, int *n, double *a1, double *b1, int *M1, double *weight, double *est) { double fx1, wi, xdelta1, xpos1; int i, ix1, ixmax1, ixmin1, MM1; MM1 = M1[0]; ixmin1 = 0; ixmax1 = MM1 - 2; xdelta1 = (b1[0] - a1[0]) / (MM1 - 1); // set all est = 0 for (i=0; i < MM1; i++) est[i] = 0.0; // assign linear binning weights for (i=0; i < n[0]; i++) { if(R_FINITE(x1[i])) { xpos1 = (x1[i] - a1[0]) / xdelta1; ix1 = floor(xpos1); fx1 = xpos1 - ix1; wi = weight[i]; if(ixmin1 <= ix1 && ix1 <= ixmax1) { est[ix1] += wi*(1-fx1); est[ix1 + 1] += wi*fx1; } else if(ix1 == -1) { est[0] += wi*fx1; } else if(ix1 == ixmax1 + 1) { est[ix1] += wi*(1-fx1); } } } } void massdist2d(double *x1, double *x2, int *n, double *a1, double *a2, double *b1, double *b2, int *M1, int *M2, double *weight, double *est) { double fx1, fx2, wi, xdelta1, xdelta2, xpos1, xpos2; int i, ix1, ix2, ixmax1, ixmin1, ixmax2, ixmin2, MM1, MM2; MM1 = M1[0]; MM2 = M2[0]; ixmin1 = 0; ixmax1 = MM1 - 2; ixmin2 = 0; ixmax2 = MM2 - 2; xdelta1 = (b1[0] - a1[0]) / (MM1 - 1); xdelta2 = (b2[0] - a2[0]) / (MM2 - 1); // set all est = 0 for (i=0; i < MM1*MM2; i++) est[i] = 0.0; // assign linear binning weights for (i=0; i < n[0]; i++) { if(R_FINITE(x1[i]) && R_FINITE(x2[i])) { xpos1 = (x1[i] - a1[0]) / xdelta1; xpos2 = (x2[i] - a2[0]) / xdelta2; ix1 = floor(xpos1); ix2 = floor(xpos2); fx1 = xpos1 - ix1; fx2 = xpos2 - ix2; wi = weight[i]; if(ixmin1 <= ix1 && ixmin2 <= ix2 && ix2 <= ixmax2) { est[ix2*MM1 + ix1] += wi*(1-fx1)*(1-fx2); est[ix2*MM1 + ix1 + 1] += wi*fx1*(1-fx2); est[(ix2+1)*MM1 + ix1] += wi*(1-fx1)*fx2; est[(ix2+1)*MM1 + ix1 + 1] += wi*fx1*fx2; } else if(ix1 == ixmax1 + 1 && ixmin2 <= ix2 && ix2 <= ixmax2) { est[ix2*MM1 + ix1] += wi*(1-fx1)*(1-fx2); est[(ix2+1)*MM1 + ix1] += wi*(1-fx1)*fx2; } else if (ixmin1 <= ix1 && ix1 <= ixmax1 && ix2 == ixmax2 + 1) { est[ix2*MM1 + ix1] += wi*(1-fx1)*(1-fx2); est[ix2*MM1 + ix1 + 1] += wi*fx1*(1-fx2); } else if (ix1 == ixmax1 + 1 && ix2 == ixmax2 + 1) { est[ix2*MM1 + ix1] += wi*(1-fx1)*(1-fx2); } } } } void massdist3d(double *x1, double *x2, double *x3, int *n, double *a1, double *a2, double *a3, double *b1, double *b2, double *b3, int *M1, int *M2, int *M3, double *weight, double *est) { double fx1, fx2, fx3, xdelta1, xdelta2, xdelta3, xpos1, xpos2, xpos3, wi; int i, ix1, ix2, ix3, ixmax1, ixmin1, ixmax2, ixmax3, ixmin2, ixmin3, MM1, MM2, MM3; MM1 = M1[0]; MM2 = M2[0]; MM3 = M3[0]; ixmin1 = 0; ixmax1 = MM1 - 2; ixmin2 = 0; ixmax2 = MM2 - 2; ixmin3 = 0; ixmax3 = MM3 - 2; xdelta1 = (b1[0] - a1[0]) / (MM1 - 1); xdelta2 = (b2[0] - a2[0]) / (MM2 - 1); xdelta3 = (b3[0] - a3[0]) / (MM3 - 1); // set all est = 0 for (i=0; i < MM1*MM2*MM3; i++) est[i] = 0.0; // assign linear binning weights for (i=0; i < n[0]; i++) { if(R_FINITE(x1[i]) && R_FINITE(x2[i]) && R_FINITE(x3[i])) { xpos1 = (x1[i] - a1[0]) / xdelta1; xpos2 = (x2[i] - a2[0]) / xdelta2; xpos3 = (x3[i] - a3[0]) / xdelta3; ix1 = floor(xpos1); ix2 = floor(xpos2); ix3 = floor(xpos3); fx1 = xpos1 - ix1; fx2 = xpos2 - ix2; fx3 = xpos3 - ix3; wi = weight[i]; if(ixmin1 <= ix1 && ix1 <= ixmax1 && ixmin2 <= ix2 && ix2 <= ixmax2 && ixmin3 <= ix3 && ix3 <= ixmax3) { est[ix3*MM1*MM2 + ix2*MM1 + ix1] += wi*(1-fx1)*(1-fx2)*(1-fx3); est[ix3*MM1*MM2 + ix2*MM1 + ix1 + 1] += wi*fx1*(1-fx2)*(1-fx3); est[ix3*MM1*MM2 + (ix2+1)*MM1 + ix1] += wi*(1-fx1)*fx2*(1-fx3); est[ix3*MM1*MM2 + (ix2+1)*MM1 + ix1 + 1] += wi*fx1*fx2*(1-fx3); est[(ix3+1)*MM1*MM2 + ix2*MM1 + ix1] += wi*(1-fx1)*(1-fx2)*fx3; est[(ix3+1)*MM1*MM2 + ix2*MM1 + ix1 + 1] += wi*fx1*(1-fx2)*fx3; est[(ix3+1)*MM1*MM2 + (ix2+1)*MM1 + ix1] += wi*(1-fx1)*fx2*fx3; est[(ix3+1)*MM1*MM2 + (ix2+1)*MM1 + ix1 + 1] += wi*fx1*fx2*fx3; } else if(ix1 == ixmax1 + 1 && ixmin2 <= ix2 && ix2 <= ixmax2 && ixmin3 <= ix3 && ix3 <= ixmax3) { est[ix3*MM1*MM2 + ix2*MM1 + ix1] += wi*(1-fx1)*(1-fx2)*(1-fx3); est[ix3*MM1*MM2 + (ix2+1)*MM1 + ix1] += wi*(1-fx1)*fx2*(1-fx3); est[(ix3+1)*MM1*MM2 + ix2*MM1 + ix1] += wi*(1-fx1)*(1-fx2)*fx3; est[(ix3+1)*MM1*MM2 + (ix2+1)*MM1 + ix1] += wi*(1-fx1)*fx2*fx3; } else if(ixmin1 <= ix1 && ix1 <= ixmax1 && ix2 == ixmax2 + 1 && ixmin3 <= ix3 && ix3 <= ixmax3) { est[ix3*MM1*MM2 + ix2*MM1 + ix1] += wi*(1-fx1)*(1-fx2)*(1-fx3); est[ix3*MM1*MM2 + ix2*MM1 + ix1 + 1] += wi*fx1*(1-fx2)*(1-fx3); est[(ix3+1)*MM1*MM2 + ix2*MM1 + ix1] += wi*(1-fx1)*(1-fx2)*fx3; est[(ix3+1)*MM1*MM2 + ix2*MM1 + ix1 + 1] += wi*fx1*(1-fx2)*fx3; } else if(ixmin1 <= ix1 && ix1 <= ixmax1 && ixmin2 <= ix2 && ix2 <= ixmax2 && ix3 == ixmax3 + 1) { est[ix3*MM1*MM2 + ix2*MM1 + ix1] += wi*(1-fx1)*(1-fx2)*(1-fx3); est[ix3*MM1*MM2 + ix2*MM1 + ix1 + 1] += wi*fx1*(1-fx2)*(1-fx3); est[ix3*MM1*MM2 + (ix2+1)*MM1 + ix1] += wi*(1-fx1)*fx2*(1-fx3); est[ix3*MM1*MM2 + (ix2+1)*MM1 + ix1 + 1] += wi*fx1*fx2*(1-fx3); } else if(ix1 == ixmax1 + 1 && ix2 == ixmax2 + 1 && ixmin3 <= ix3 && ix3 <= ixmax3) { est[ix3*MM1*MM2 + ix2*MM1 + ix1] += wi*(1-fx1)*(1-fx2)*(1-fx3); est[(ix3+1)*MM1*MM2 + ix2*MM1 + ix1] += wi*(1-fx1)*(1-fx2)*fx3; } else if(ix1 == ixmax1 + 1 && ixmin2 <= ix2 && ix2 <= ixmax2 && ix3 == ixmax3 + 1) { est[ix3*MM1*MM2 + ix2*MM1 + ix1] += wi*(1-fx1)*(1-fx2)*(1-fx3); est[ix3*MM1*MM2 + (ix2+1)*MM1 + ix1] += wi*(1-fx1)*fx2*(1-fx3); } else if(ixmin1 <= ix1 && ix1 <= ixmax1 && ix2 == ixmax2 + 1 && ix3 == ixmax3 + 1) { est[ix3*MM1*MM2 + ix2*MM1 + ix1] += wi*(1-fx1)*(1-fx2)*(1-fx3); est[ix3*MM1*MM2 + ix2*MM1 + ix1 + 1] += wi*fx1*(1-fx2)*(1-fx3); } else if(ix1 == ixmax1 + 1 && ix2 == ixmax2 + 1 && ix3 == ixmax3 + 1) { est[ix3*MM1*MM2 + ix2*MM1 + ix1] += wi*(1-fx1)*(1-fx2)*(1-fx3); } } } } void massdist4d(double *x1, double *x2, double *x3, double *x4, int *n, double *a1, double *a2, double *a3, double *a4, double *b1, double *b2, double *b3, double *b4, int *M1, int *M2, int *M3, int *M4, double *weight, double *est) { double fx1, fx2, fx3, fx4, xdelta1, xdelta2, xdelta3, xdelta4, xpos1, xpos2, xpos3, xpos4, wi; int i, ix1, ix2, ix3, ix4, ixmax1, ixmin1, ixmax2, ixmax3, ixmax4, ixmin2, ixmin3, ixmin4, MM1, MM2, MM3, MM4; MM1 = M1[0]; MM2 = M2[0]; MM3 = M3[0]; MM4 = M4[0]; ixmin1 = 0; ixmax1 = MM1 - 2; ixmin2 = 0; ixmax2 = MM2 - 2; ixmin3 = 0; ixmax3 = MM3 - 2; ixmin4 = 0; ixmax4 = MM4 - 2; xdelta1 = (b1[0] - a1[0]) / (MM1 - 1); xdelta2 = (b2[0] - a2[0]) / (MM2 - 1); xdelta3 = (b3[0] - a3[0]) / (MM3 - 1); xdelta4 = (b4[0] - a4[0]) / (MM4 - 1); // set all est = 0 for (i=0; i < MM1*MM2*MM3*MM4; i++) est[i] = 0.0; // assign linear binning weights for (i=0; i < n[0]; i++) { if(R_FINITE(x1[i]) && R_FINITE(x2[i]) && R_FINITE(x3[i]) && R_FINITE(x4[i])) { xpos1 = (x1[i] - a1[0]) / xdelta1; xpos2 = (x2[i] - a2[0]) / xdelta2; xpos3 = (x3[i] - a3[0]) / xdelta3; xpos4 = (x4[i] - a4[0]) / xdelta4; ix1 = floor(xpos1); ix2 = floor(xpos2); ix3 = floor(xpos3); ix4 = floor(xpos4); fx1 = xpos1 - ix1; fx2 = xpos2 - ix2; fx3 = xpos3 - ix3; fx4 = xpos4 - ix4; wi = weight[i]; if(ixmin1 <= ix1 && ix1 <= ixmax1 && ixmin2 <= ix2 && ix2 <= ixmax2 && ixmin3 <= ix3 && ix3 <= ixmax3 && ixmin4 <= ix4 && ix4 <= ixmax4) { est[ix4*MM1*MM2*MM3 + ix3*MM1*MM2 + ix2*MM1 + ix1] += wi*(1-fx1)*(1-fx2)*(1-fx3)*(1-fx4); est[ix4*MM1*MM2*MM3 + ix3*MM1*MM2 + ix2*MM1 + ix1 + 1] += wi*fx1*(1-fx2)*(1-fx3)*(1-fx4); est[ix4*MM1*MM2*MM3 + ix3*MM1*MM2 + (ix2+1)*MM1 + ix1] += wi*(1-fx1)*fx2*(1-fx3)*(1-fx4); est[ix4*MM1*MM2*MM3 + ix3*MM1*MM2 + (ix2+1)*MM1 + ix1 + 1] += wi*fx1*fx2*(1-fx3)*(1-fx4); est[ix4*MM1*MM2*MM3 + (ix3+1)*MM1*MM2 + ix2*MM1 + ix1] += wi*(1-fx1)*(1-fx2)*fx3*(1-fx4); est[ix4*MM1*MM2*MM3 + (ix3+1)*MM1*MM2 + ix2*MM1 + ix1 + 1] += wi*fx1*(1-fx2)*fx3*(1-fx4); est[ix4*MM1*MM2*MM3 + (ix3+1)*MM1*MM2 + (ix2+1)*MM1 + ix1] += wi*(1-fx1)*fx2*fx3*(1-fx4); est[ix4*MM1*MM2*MM3 + (ix3+1)*MM1*MM2 + (ix2+1)*MM1 + ix1 + 1] += wi*fx1*fx2*fx3*(1-fx4); est[(ix4+1)*MM1*MM2*MM3 + ix3*MM1*MM2 + ix2*MM1 + ix1] += wi*(1-fx1)*(1-fx2)*(1-fx3)*fx4; est[(ix4+1)*MM1*MM2*MM3 + ix3*MM1*MM2 + ix2*MM1 + ix1 + 1] += wi*fx1*(1-fx2)*(1-fx3)*fx4; est[(ix4+1)*MM1*MM2*MM3 + ix3*MM1*MM2 + (ix2+1)*MM1 + ix1] += wi*(1-fx1)*fx2*(1-fx3)*fx4; est[(ix4+1)*MM1*MM2*MM3 + ix3*MM1*MM2 + (ix2+1)*MM1 + ix1 + 1] += wi*fx1*fx2*(1-fx3)*fx4; est[(ix4+1)*MM1*MM2*MM3 + (ix3+1)*MM1*MM2 + ix2*MM1 + ix1] += wi*(1-fx1)*(1-fx2)*fx3*fx4; est[(ix4+1)*MM1*MM2*MM3 + (ix3+1)*MM1*MM2 + ix2*MM1 + ix1 + 1] += wi*fx1*(1-fx2)*fx3*fx4; est[(ix4+1)*MM1*MM2*MM3 + (ix3+1)*MM1*MM2 + (ix2+1)*MM1 + ix1] += wi*(1-fx1)*fx2*fx3*fx4; est[(ix4+1)*MM1*MM2*MM3 + (ix3+1)*MM1*MM2 + (ix2+1)*MM1 + ix1 + 1] += wi*fx1*fx2*fx3*fx4; } else if(ix1 == ixmax1 + 1 && ixmin2 <= ix2 && ix2 <= ixmax2 && ixmin3 <= ix3 && ix3 <= ixmax3 && ixmin4 <= ix4 && ix4 <= ixmax4) { est[ix4*MM1*MM2*MM3 + ix3*MM1*MM2 + ix2*MM1 + ix1] += wi*(1-fx1)*(1-fx2)*(1-fx3)*(1-fx4); est[ix4*MM1*MM2*MM3 + ix3*MM1*MM2 + (ix2+1)*MM1 + ix1] += wi*(1-fx1)*fx2*(1-fx3)*(1-fx4); est[ix4*MM1*MM2*MM3 + (ix3+1)*MM1*MM2 + ix2*MM1 + ix1] += wi*(1-fx1)*(1-fx2)*fx3*(1-fx4); est[ix4*MM1*MM2*MM3 + (ix3+1)*MM1*MM2 + (ix2+1)*MM1 + ix1] += wi*(1-fx1)*fx2*fx3*(1-fx4); est[(ix4+1)*MM1*MM2*MM3 + ix3*MM1*MM2 + ix2*MM1 + ix1] += wi*(1-fx1)*(1-fx2)*(1-fx3)*fx4; est[(ix4+1)*MM1*MM2*MM3 + ix3*MM1*MM2 + (ix2+1)*MM1 + ix1] += wi*(1-fx1)*fx2*(1-fx3)*fx4; est[(ix4+1)*MM1*MM2*MM3 + (ix3+1)*MM1*MM2 + ix2*MM1 + ix1] += wi*(1-fx1)*(1-fx2)*fx3*fx4; est[(ix4+1)*MM1*MM2*MM3 + (ix3+1)*MM1*MM2 + (ix2+1)*MM1 + ix1] += wi*(1-fx1)*fx2*fx3*fx4; } else if(ixmin1 <= ix1 && ix1 <= ixmax1 && ix2 == ixmax2 + 1 && ixmin3 <= ix3 && ix3 <= ixmax3 && ixmin4 <= ix4 && ix4 <= ixmax4) { est[ix4*MM1*MM2*MM3 + ix3*MM1*MM2 + ix2*MM1 + ix1] += wi*(1-fx1)*(1-fx2)*(1-fx3)*(1-fx4); est[ix4*MM1*MM2*MM3 + ix3*MM1*MM2 + ix2*MM1 + ix1 + 1] += wi*fx1*(1-fx2)*(1-fx3)*(1-fx4); est[ix4*MM1*MM2*MM3 + (ix3+1)*MM1*MM2 + ix2*MM1 + ix1] += wi*(1-fx1)*(1-fx2)*fx3*(1-fx4); est[ix4*MM1*MM2*MM3 + (ix3+1)*MM1*MM2 + ix2*MM1 + ix1 + 1] += wi*fx1*(1-fx2)*fx3*(1-fx4); est[(ix4+1)*MM1*MM2*MM3 + ix3*MM1*MM2 + ix2*MM1 + ix1] += wi*(1-fx1)*(1-fx2)*(1-fx3)*fx4; est[(ix4+1)*MM1*MM2*MM3 + ix3*MM1*MM2 + ix2*MM1 + ix1 + 1] += wi*fx1*(1-fx2)*(1-fx3)*fx4; est[(ix4+1)*MM1*MM2*MM3 + (ix3+1)*MM1*MM2 + ix2*MM1 + ix1] += wi*(1-fx1)*(1-fx2)*fx3*fx4; est[(ix4+1)*MM1*MM2*MM3 + (ix3+1)*MM1*MM2 + ix2*MM1 + ix1 + 1] += wi*fx1*(1-fx2)*fx3*fx4; } else if(ixmin1 <= ix1 && ix1 <= ixmax1 && ixmin2 <= ix2 && ix2 <= ixmax2 && ix3 == ixmax3 + 1 && ixmin4 <= ix4 && ix4 <= ixmax4) { est[ix4*MM1*MM2*MM3 + ix3*MM1*MM2 + ix2*MM1 + ix1] += wi*(1-fx1)*(1-fx2)*(1-fx3)*(1-fx4); est[ix4*MM1*MM2*MM3 + ix3*MM1*MM2 + ix2*MM1 + ix1 + 1] += wi*fx1*(1-fx2)*(1-fx3)*(1-fx4); est[ix4*MM1*MM2*MM3 + ix3*MM1*MM2 + (ix2+1)*MM1 + ix1] += wi*(1-fx1)*fx2*(1-fx3)*(1-fx4); est[ix4*MM1*MM2*MM3 + ix3*MM1*MM2 + (ix2+1)*MM1 + ix1 + 1] += wi*fx1*fx2*(1-fx3)*(1-fx4); est[(ix4+1)*MM1*MM2*MM3 + ix3*MM1*MM2 + ix2*MM1 + ix1] += wi*(1-fx1)*(1-fx2)*(1-fx3)*fx4; est[(ix4+1)*MM1*MM2*MM3 + ix3*MM1*MM2 + ix2*MM1 + ix1 + 1] += wi*fx1*(1-fx2)*(1-fx3)*fx4; est[(ix4+1)*MM1*MM2*MM3 + ix3*MM1*MM2 + (ix2+1)*MM1 + ix1] += wi*(1-fx1)*fx2*(1-fx3)*fx4; est[(ix4+1)*MM1*MM2*MM3 + ix3*MM1*MM2 + (ix2+1)*MM1 + ix1 + 1] += wi*fx1*fx2*(1-fx3)*fx4; } else if(ixmin1 <= ix1 && ix1 <= ixmax1 && ixmin2 <= ix2 && ix2 <= ixmax2 && ixmin3 <= ix3 && ix3 <= ixmax3 && ix4 == ixmax4 + 1) { est[ix4*MM1*MM2*MM3 + ix3*MM1*MM2 + ix2*MM1 + ix1] += wi*(1-fx1)*(1-fx2)*(1-fx3)*(1-fx4); est[ix4*MM1*MM2*MM3 + ix3*MM1*MM2 + ix2*MM1 + ix1 + 1] += wi*fx1*(1-fx2)*(1-fx3)*(1-fx4); est[ix4*MM1*MM2*MM3 + ix3*MM1*MM2 + (ix2+1)*MM1 + ix1] += wi*(1-fx1)*fx2*(1-fx3)*(1-fx4); est[ix4*MM1*MM2*MM3 + ix3*MM1*MM2 + (ix2+1)*MM1 + ix1 + 1] += wi*fx1*fx2*(1-fx3)*(1-fx4); est[ix4*MM1*MM2*MM3 + (ix3+1)*MM1*MM2 + ix2*MM1 + ix1] += wi*(1-fx1)*(1-fx2)*fx3*(1-fx4); est[ix4*MM1*MM2*MM3 + (ix3+1)*MM1*MM2 + ix2*MM1 + ix1 + 1] += wi*fx1*(1-fx2)*fx3*(1-fx4); est[ix4*MM1*MM2*MM3 + (ix3+1)*MM1*MM2 + (ix2+1)*MM1 + ix1] += wi*(1-fx1)*fx2*fx3*(1-fx4); est[ix4*MM1*MM2*MM3 + (ix3+1)*MM1*MM2 + (ix2+1)*MM1 + ix1 + 1] += wi*fx1*fx2*fx3*(1-fx4); } else if(ix1 == ixmax1 + 1 && ix2 == ixmax2 + 1 && ixmin3 <= ix3 && ix3 <= ixmax3 && ixmin4 <= ix4 && ix4 <= ixmax4) { est[ix4*MM1*MM2*MM3 + ix3*MM1*MM2 + ix2*MM1 + ix1] += wi*(1-fx1)*(1-fx2)*(1-fx3)*(1-fx4); est[ix4*MM1*MM2*MM3 + (ix3+1)*MM1*MM2 + ix2*MM1 + ix1] += wi*(1-fx1)*(1-fx2)*fx3*(1-fx4); est[(ix4+1)*MM1*MM2*MM3 + ix3*MM1*MM2 + ix2*MM1 + ix1] += wi*(1-fx1)*(1-fx2)*(1-fx3)*fx4; est[(ix4+1)*MM1*MM2*MM3 + (ix3+1)*MM1*MM2 + ix2*MM1 + ix1] += wi*(1-fx1)*(1-fx2)*fx3*fx4; } else if(ix1 == ixmax1 + 1 && ixmin2 <= ix2 && ix2 <= ixmax2 && ix3 == ixmax3 + 1 && ixmin4 <= ix4 && ix4 <= ixmax4) { est[ix4*MM1*MM2*MM3 + ix3*MM1*MM2 + ix2*MM1 + ix1] += wi*(1-fx1)*(1-fx2)*(1-fx3)*(1-fx4); est[ix4*MM1*MM2*MM3 + ix3*MM1*MM2 + (ix2+1)*MM1 + ix1] += wi*(1-fx1)*fx2*(1-fx3)*(1-fx4); est[(ix4+1)*MM1*MM2*MM3 + ix3*MM1*MM2 + ix2*MM1 + ix1] += wi*(1-fx1)*(1-fx2)*(1-fx3)*fx4; est[(ix4+1)*MM1*MM2*MM3 + ix3*MM1*MM2 + (ix2+1)*MM1 + ix1] += wi*(1-fx1)*fx2*(1-fx3)*fx4; } else if(ix1 == ixmax1 + 1 && ixmin2 <= ix2 && ix2 <= ixmax2 && ixmin3 <= ix3 && ix3 <= ixmax3 && ix4 == ixmax4 + 1) { est[ix4*MM1*MM2*MM3 + ix3*MM1*MM2 + ix2*MM1 + ix1] += wi*(1-fx1)*(1-fx2)*(1-fx3)*(1-fx4); est[ix4*MM1*MM2*MM3 + ix3*MM1*MM2 + (ix2+1)*MM1 + ix1] += wi*(1-fx1)*fx2*(1-fx3)*(1-fx4); est[ix4*MM1*MM2*MM3 + (ix3+1)*MM1*MM2 + ix2*MM1 + ix1] += wi*(1-fx1)*(1-fx2)*fx3*(1-fx4); est[ix4*MM1*MM2*MM3 + (ix3+1)*MM1*MM2 + (ix2+1)*MM1 + ix1] += wi*(1-fx1)*fx2*fx3*(1-fx4); } else if(ixmin1 <= ix1 && ix1 <= ixmax1 && ix2 == ixmax2 + 1 && ix3 == ixmax3 + 1 && ixmin4 <= ix4 && ix4 <= ixmax4) { est[ix4*MM1*MM2*MM3 + ix3*MM1*MM2 + ix2*MM1 + ix1] += wi*(1-fx1)*(1-fx2)*(1-fx3)*(1-fx4); est[ix4*MM1*MM2*MM3 + ix3*MM1*MM2 + ix2*MM1 + ix1 + 1] += wi*fx1*(1-fx2)*(1-fx3)*(1-fx4); est[(ix4+1)*MM1*MM2*MM3 + ix3*MM1*MM2 + ix2*MM1 + ix1] += wi*(1-fx1)*(1-fx2)*(1-fx3)*fx4; est[(ix4+1)*MM1*MM2*MM3 + ix3*MM1*MM2 + ix2*MM1 + ix1 + 1] += wi*fx1*(1-fx2)*(1-fx3)*fx4; } else if(ixmin1 <= ix1 && ix1 <= ixmax1 && ix2 == ixmax2 + 1 && ixmin3 <= ix3 && ix3 <= ixmax3 && ix4 == ixmax4 + 1) { est[ix4*MM1*MM2*MM3 + ix3*MM1*MM2 + ix2*MM1 + ix1] += wi*(1-fx1)*(1-fx2)*(1-fx3)*(1-fx4); est[ix4*MM1*MM2*MM3 + ix3*MM1*MM2 + ix2*MM1 + ix1 + 1] += wi*fx1*(1-fx2)*(1-fx3)*(1-fx4); est[ix4*MM1*MM2*MM3 + (ix3+1)*MM1*MM2 + ix2*MM1 + ix1] += wi*(1-fx1)*(1-fx2)*fx3*(1-fx4); est[ix4*MM1*MM2*MM3 + (ix3+1)*MM1*MM2 + ix2*MM1 + ix1 + 1] += wi*fx1*(1-fx2)*fx3*(1-fx4); } else if(ixmin1 <= ix1 && ix1 <= ixmax1 && ixmin2 <= ix2 && ix2 <= ixmax2 && ix3 == ixmax3 + 1 && ix4 == ixmax4 + 1) { est[ix4*MM1*MM2*MM3 + ix3*MM1*MM2 + ix2*MM1 + ix1] += wi*(1-fx1)*(1-fx2)*(1-fx3)*(1-fx4); est[ix4*MM1*MM2*MM3 + ix3*MM1*MM2 + ix2*MM1 + ix1 + 1] += wi*fx1*(1-fx2)*(1-fx3)*(1-fx4); est[ix4*MM1*MM2*MM3 + ix3*MM1*MM2 + (ix2+1)*MM1 + ix1] += wi*(1-fx1)*fx2*(1-fx3)*(1-fx4); est[ix4*MM1*MM2*MM3 + ix3*MM1*MM2 + (ix2+1)*MM1 + ix1 + 1] += wi*fx1*fx2*(1-fx3)*(1-fx4); } else if(ix1 == ixmax1 + 1 && ix2 == ixmax2 + 1 && ix3 == ixmax3 + 1 && ixmin4 <= ix4 && ix4 <= ixmax4) { est[ix4*MM1*MM2*MM3 + ix3*MM1*MM2 + ix2*MM1 + ix1] += wi*(1-fx1)*(1-fx2)*(1-fx3)*(1-fx4); est[(ix4+1)*MM1*MM2*MM3 + ix3*MM1*MM2 + ix2*MM1 + ix1] += wi*(1-fx1)*(1-fx2)*(1-fx3)*fx4; } else if(ix1 == ixmax1 + 1 && ix2 == ixmax2 + 1 && ixmin3 <= ix3 && ix3 <= ixmax3 && ix4 == ixmax4 + 1) { est[ix4*MM1*MM2*MM3 + ix3*MM1*MM2 + ix2*MM1 + ix1] += wi*(1-fx1)*(1-fx2)*(1-fx3)*(1-fx4); est[ix4*MM1*MM2*MM3 + (ix3+1)*MM1*MM2 + ix2*MM1 + ix1] += wi*(1-fx1)*(1-fx2)*fx3*(1-fx4); } else if(ix1 == ixmax1 + 1 && ixmin2 <= ix2 && ix2 <= ixmax2 && ix3 == ixmax3 + 1 && ix4 == ixmax4 + 1) { est[ix4*MM1*MM2*MM3 + ix3*MM1*MM2 + ix2*MM1 + ix1] += wi*(1-fx1)*(1-fx2)*(1-fx3)*(1-fx4); est[ix4*MM1*MM2*MM3 + ix3*MM1*MM2 + (ix2+1)*MM1 + ix1] += wi*(1-fx1)*fx2*(1-fx3)*(1-fx4); } else if(ixmin1 <= ix1 && ix1 <= ixmax1 && ix2 == ixmax2 + 1 && ix3 == ixmax3 + 1 && ix4 == ixmax4 + 1) { est[ix4*MM1*MM2*MM3 + ix3*MM1*MM2 + ix2*MM1 + ix1] += wi*(1-fx1)*(1-fx2)*(1-fx3)*(1-fx4); est[ix4*MM1*MM2*MM3 + ix3*MM1*MM2 + ix2*MM1 + ix1 + 1] += wi*fx1*(1-fx2)*(1-fx3)*(1-fx4); } else if(ix1 == ixmax1 + 1 && ix2 == ixmax2 + 1 && ix3 == ixmax3 + 1 && ix4 == ixmax4 + 1) { est[ix4*MM1*MM2*MM3 + ix3*MM1*MM2 + ix2*MM1 + ix1] += wi*(1-fx1)*(1-fx2)*(1-fx3)*(1-fx4); } } } } void interp1d(double *x1, int *n, double *a1, double *b1, int *M1, double *fun, double *est) { double fx1, xdelta1, xpos1; int i, ix1, ixmax1, ixmin1, MM1; MM1 = M1[0]; ixmin1 = 0; ixmax1 = MM1 - 2; xdelta1 = (b1[0] - a1[0]) / (MM1 - 1); // set all est = 0 for (i=0; i < n[0]; i++) est[i] = 0.0; // assign linear binning weights for (i=0; i < n[0]; i++) { if(R_FINITE(x1[i])) { xpos1 = (x1[i] - a1[0]) / xdelta1; ix1 = floor(xpos1); fx1 = xpos1 - ix1; if(ixmin1 <= ix1 && ix1 <= ixmax1) { est[i] = fun[ix1]*(1-fx1) + fun[ix1 + 1]*fx1; } else if(ix1 <= -1) { est[i] = fun[0]; } else if(ix1 >= ixmax1 + 1) { est[i] = fun[ixmax1 + 1]; } } } } void interp2d(double *x1, double *x2, int *n, double *a1, double *a2, double *b1, double *b2, int *M1, int *M2, double *fun, double *est) { double fx1, fx2, xdelta1, xdelta2, xpos1, xpos2; int i, ix1, ix2, ixmax1, ixmin1, ixmax2, ixmin2, MM1, MM2; MM1 = M1[0]; MM2 = M2[0]; ixmin1 = 0; ixmax1 = MM1 - 2; ixmin2 = 0; ixmax2 = MM2 - 2; xdelta1 = (b1[0] - a1[0]) / (MM1 - 1); xdelta2 = (b2[0] - a2[0]) / (MM2 - 1); // set all est = 0 for (i=0; i < n[0]; i++) est[i] = 0.0; // assign linear binning weights for (i=0; i < n[0]; i++) { if(R_FINITE(x1[i]) && R_FINITE(x2[i])) { xpos1 = (x1[i] - a1[0]) / xdelta1; xpos2 = (x2[i] - a2[0]) / xdelta2; ix1 = floor(xpos1); ix2 = floor(xpos2); fx1 = xpos1 - ix1; fx2 = xpos2 - ix2; if(ixmin1 <= ix1 && ix1 <= ixmax1 && ixmin2 <= ix2 && ix2 <= ixmax2) { est[i] = fun[ix2*MM1 + ix1]*(1-fx1)*(1-fx2) \ + fun[ix2*MM1 + ix1 + 1]*fx1*(1-fx2) \ + fun[(ix2+1)*MM1 + ix1]*(1-fx1)*fx2 \ + fun[(ix2+1)*MM1 + ix1 + 1]*fx1*fx2; } else if(ix1 == ixmax1 + 1 && ixmin2 <= ix2 && ix2 <= ixmax2) { est[i] = fun[ix2*MM1 + ix1]*(1-fx1)*(1-fx2) \ + fun[(ix2+1)*MM1 + ix1]*(1-fx1)*fx2; } else if (ixmin1 <= ix1 && ix1 <= ixmax1 && ix2 == ixmax2 + 1) { est[i] = fun[ix2*MM1 + ix1]*(1-fx1)*(1-fx2) \ + fun[ix2*MM1 + ix1 + 1]*fx1*(1-fx2); } else if (ix1 == ixmax1 + 1 && ix2 == ixmax2 + 1) { est[i] = fun[ix2*MM1 + ix1]*(1-fx1)*(1-fx2); } } } } void interp3d(double *x1, double *x2, double *x3, int *n, double *a1, double *a2, double *a3, double *b1, double *b2, double *b3, int *M1, int *M2, int *M3, double *fun, double *est) { double fx1, fx2, fx3, xdelta1, xdelta2, xdelta3, xpos1, xpos2, xpos3; int i, ix1, ix2, ix3, ixmax1, ixmin1, ixmax2, ixmax3, ixmin2, ixmin3, MM1, MM2, MM3; MM1 = M1[0]; MM2 = M2[0]; MM3 = M3[0]; ixmin1 = 0; ixmax1 = MM1 - 2; ixmin2 = 0; ixmax2 = MM2 - 2; ixmin3 = 0; ixmax3 = MM3 - 2; xdelta1 = (b1[0] - a1[0]) / (MM1 - 1); xdelta2 = (b2[0] - a2[0]) / (MM2 - 1); xdelta3 = (b3[0] - a3[0]) / (MM3 - 1); // set all est = 0 for (i=0; i < n[0]; i++) est[i] = 0.0; // assign linear binning weights for (i=0; i < n[0]; i++) { if(R_FINITE(x1[i]) && R_FINITE(x2[i]) && R_FINITE(x3[i])) { xpos1 = (x1[i] - a1[0]) / xdelta1; xpos2 = (x2[i] - a2[0]) / xdelta2; xpos3 = (x3[i] - a3[0]) / xdelta3; ix1 = floor(xpos1); ix2 = floor(xpos2); ix3 = floor(xpos3); fx1 = xpos1 - ix1; fx2 = xpos2 - ix2; fx3 = xpos3 - ix3; if(ixmin1 <= ix1 && ix1 <= ixmax1 && ixmin2 <= ix2 && ix2 <= ixmax2 && ixmin3 <= ix3 && ix3 <= ixmax3) { est[i] = fun[ix3*MM1*MM2 + ix2*MM1 + ix1]*(1-fx1)*(1-fx2)*(1-fx3) \ + fun[ix3*MM1*MM2 + ix2*MM1 + ix1 + 1]*fx1*(1-fx2)*(1-fx3) \ + fun[ix3*MM1*MM2 + (ix2+1)*MM1 + ix1]*(1-fx1)*fx2*(1-fx3) \ + fun[ix3*MM1*MM2 + (ix2+1)*MM1 + ix1 + 1]*fx1*fx2*(1-fx3) \ + fun[(ix3+1)*MM1*MM2 + ix2*MM1 + ix1]*(1-fx1)*(1-fx2)*fx3 \ + fun[(ix3+1)*MM1*MM2 + ix2*MM1 + ix1 + 1]*fx1*(1-fx2)*fx3 \ + fun[(ix3+1)*MM1*MM2 + (ix2+1)*MM1 + ix1]*(1-fx1)*fx2*fx3 \ + fun[(ix3+1)*MM1*MM2 + (ix2+1)*MM1 + ix1 + 1]*fx1*fx2*fx3; } else if(ix1 == ixmax1 + 1 && ixmin2 <= ix2 && ix2 <= ixmax2 && ixmin3 <= ix3 && ix3 <= ixmax3) { est[i] = fun[ix3*MM1*MM2 + ix2*MM1 + ix1]*(1-fx1)*(1-fx2)*(1-fx3) \ + fun[ix3*MM1*MM2 + (ix2+1)*MM1 + ix1]*(1-fx1)*fx2*(1-fx3) \ + fun[(ix3+1)*MM1*MM2 + ix2*MM1 + ix1]*(1-fx1)*(1-fx2)*fx3 \ + fun[(ix3+1)*MM1*MM2 + (ix2+1)*MM1 + ix1]*(1-fx1)*fx2*fx3; } else if(ixmin1 <= ix1 && ix1 <= ixmax1 && ix2 == ixmax2 + 1 && ixmin3 <= ix3 && ix3 <= ixmax3) { est[i] = fun[ix3*MM1*MM2 + ix2*MM1 + ix1]*(1-fx1)*(1-fx2)*(1-fx3) \ + fun[ix3*MM1*MM2 + ix2*MM1 + ix1 + 1]*fx1*(1-fx2)*(1-fx3) \ + fun[(ix3+1)*MM1*MM2 + ix2*MM1 + ix1]*(1-fx1)*(1-fx2)*fx3 \ + fun[(ix3+1)*MM1*MM2 + ix2*MM1 + ix1 + 1]*fx1*(1-fx2)*fx3; } else if(ixmin1 <= ix1 && ix1 <= ixmax1 && ixmin2 <= ix2 && ix2 <= ixmax2 && ix3 == ixmax3 + 1) { est[i] = fun[ix3*MM1*MM2 + ix2*MM1 + ix1]*(1-fx1)*(1-fx2)*(1-fx3) \ + fun[ix3*MM1*MM2 + ix2*MM1 + ix1 + 1]*fx1*(1-fx2)*(1-fx3) \ + fun[ix3*MM1*MM2 + (ix2+1)*MM1 + ix1]*(1-fx1)*fx2*(1-fx3) \ + fun[ix3*MM1*MM2 + (ix2+1)*MM1 + ix1 + 1]*fx1*fx2*(1-fx3); } else if(ix1 == ixmax1 + 1 && ix2 == ixmax2 + 1 && ixmin3 <= ix3 && ix3 <= ixmax3) { est[i] = fun[ix3*MM1*MM2 + ix2*MM1 + ix1]*(1-fx1)*(1-fx2)*(1-fx3) \ + fun[(ix3+1)*MM1*MM2 + ix2*MM1 + ix1]*(1-fx1)*(1-fx2)*fx3; } else if(ix1 == ixmax1 + 1 && ixmin2 <= ix2 && ix2 <= ixmax2 && ix3 == ixmax3 + 1) { est[i] = fun[ix3*MM1*MM2 + ix2*MM1 + ix1]*(1-fx1)*(1-fx2)*(1-fx3) \ + fun[ix3*MM1*MM2 + (ix2+1)*MM1 + ix1]*(1-fx1)*fx2*(1-fx3); } else if(ixmin1 <= ix1 && ix1 <= ixmax1 && ix2 == ixmax2 + 1 && ix3 == ixmax3 + 1) { est[i] = fun[ix3*MM1*MM2 + ix2*MM1 + ix1]*(1-fx1)*(1-fx2)*(1-fx3) \ + fun[ix3*MM1*MM2 + ix2*MM1 + ix1 + 1]*fx1*(1-fx2)*(1-fx3); } else if(ix1 == ixmax1 + 1 && ix2 == ixmax2 + 1 && ix3 == ixmax3 + 1) { est[i] = fun[ix3*MM1*MM2 + ix2*MM1 + ix1]*(1-fx1)*(1-fx2)*(1-fx3); } } } } /* Registration of native routines added 17/03/2017 */ static R_NativePrimitiveArgType md1_t[] = { REALSXP, INTSXP, REALSXP, REALSXP, INTSXP, REALSXP, REALSXP }; static R_NativePrimitiveArgType md2_t[] = { REALSXP, REALSXP, INTSXP, REALSXP, REALSXP, REALSXP, REALSXP, INTSXP, INTSXP, REALSXP, REALSXP }; static R_NativePrimitiveArgType md3_t[] = { REALSXP, REALSXP, REALSXP, INTSXP, REALSXP, REALSXP, REALSXP, REALSXP, REALSXP, REALSXP, INTSXP, INTSXP, INTSXP, REALSXP, REALSXP }; static R_NativePrimitiveArgType md4_t[] = { REALSXP, REALSXP, REALSXP, REALSXP, INTSXP, REALSXP, REALSXP, REALSXP, REALSXP, REALSXP, REALSXP, REALSXP, REALSXP, INTSXP, INTSXP, INTSXP, INTSXP, REALSXP, REALSXP }; const static R_CMethodDef cMethods[] = { {"massdist1d", (DL_FUNC) &massdist1d, 7, md1_t}, {"massdist2d", (DL_FUNC) &massdist2d, 11, md2_t}, {"massdist3d", (DL_FUNC) &massdist3d, 15, md3_t}, {"massdist4d", (DL_FUNC) &massdist4d, 19, md4_t}, {"interp1d", (DL_FUNC) &interp1d, 7, md1_t}, {"interp2d", (DL_FUNC) &interp2d, 11, md2_t}, {"interp3d", (DL_FUNC) &interp3d, 15, md3_t}, {NULL, NULL, 0} }; void attribute_visible R_init_ks(DllInfo *info) { R_registerRoutines(info, cMethods, NULL, NULL, NULL); R_useDynamicSymbols(info, FALSE); R_forceSymbols(info, TRUE); } ks/vignettes/0000755000176200001440000000000013620371402012675 5ustar liggesusersks/vignettes/kde.Rnw0000644000176200001440000001746513216261074014151 0ustar liggesusers\documentclass[a4paper,11pt]{article} %\usepackage{amsmath,amssymb,amsthm,amsopn,natbib} \usepackage{amsmath,amssymb,amsopn,natbib} \usepackage[left=2.5cm,top=2.5cm,right=2.5cm,bottom=2.5cm]{geometry} \renewcommand{\today}{\begingroup \number \day\space \ifcase \month \or January\or February\or March\or April\or May\or June\or July\or August\or September\or October\or November\or December\fi \space \number \year \endgroup} \renewcommand{\vec}[1]{\boldsymbol{#1}} \newcommand{\mat}[1]{\mathbf{#1}} \def\bH{\mat{H}} \def\vecx{\vec{x}} \def\vecX{\vec{X}} \DeclareMathOperator{\E}{\boldsymbol{\mathbb{E}}} %\DeclareMathOperator{\Var}{Var} \let\code=\texttt \let\proglang=\texttt \let\pkg=\texttt %\VignetteIndexEntry{kde} %\SweaveOpts{eps=FALSE} \title{ks: Kernel density estimation for bivariate data} \author{Tarn Duong} \begin{document} \maketitle \noindent Kernel density estimation is a popular tool for visualising the distribution of data. See \citet*{simonoff1996}, for example, for an overview. When multivariate kernel density estimation is considered it is usually in the constrained context with diagonal bandwidth matrices, e.g. in the \proglang{R} packages \pkg{sm} \citep*{sm} and \pkg{KernSmooth} \citep*{KernSmooth}. We introduce a new \proglang{R} package \pkg{ks} which implements diagonal and unconstrained data-driven bandwidth matrices for kernel density estimation, which can also be used for multivariate kernel discriminant analysis. The \pkg{ks} package implements selectors for 1- to 6-dimensional data. This vignette contains only a brief introduction to using \pkg{ks} for kernel density estimation for 2-dimensional data. See \citet*{duong2007c} for a more detailed account. For a bivariate random sample $\vecX_1, \vecX_2, \ldots, \vecX_n$ drawn from a density $f$, the kernel density estimate is defined by $$ \hat{f} (\vecx; \bH) = n^{-1}\sum_{i=1}^n K_{\bH} ( \vecx - \vec{X}_i) $$ where $\vecx = (x_1, x_2)^T$ and $\vec{X}_i = (X_{i1}, X_{i2})^T, i = 1, 2, \ldots, n$. Here $K(\vecx)$ is the kernel which is a symmetric probability density function, $\bH$ is the bandwidth matrix which is symmetric and positive-definite, and $K_{\bH}(\vecx) = |\bH|^{-1/2} K( \bH^{-1/2} \vecx)$. The choice of $K$ is not crucial: we take $K(\vecx) = (2\pi)^{-1} \exp(-\tfrac{1}{2} \vecx^T \vecx)$ the standard normal throughout. In contrast, the choice of $\bH$ is crucial in determining the performance of $\hat f$. The most common parameterisations of the bandwidth matrix are the diagonal and the general or unconstrained which has no restrictions on $\bH$ provided that $\bH$ remains positive definite and symmetric, that is $$ \bH = \begin{bmatrix}h_1^2 & 0 \\0 & h_2^2 \end{bmatrix} \ \mathrm{or} \ \bH = \begin{bmatrix}h_1^2 & h_{12} \\ h_{12} & h_2^2 \end{bmatrix}. $$ This latter parameterisation allows kernels to have an arbitrary orientation whereas the former only allows kernels which are oriented to the co-ordinate axes. For our target density, we use the `dumbbell' density, given by the normal mixture $$ \frac{4}{11} N \bigg( \begin{bmatrix}-2 \\ 2\end{bmatrix}, \begin{bmatrix}1 & 0 \\ 0 & 1 \end{bmatrix} \bigg)+ \frac{3}{11} N \bigg( \begin{bmatrix}0 \\ 0\end{bmatrix}, \begin{bmatrix}0.8 & -0.72 \\ -0.72 & 0.8\end{bmatrix} \bigg)+ \frac{4}{11} N \bigg( \begin{bmatrix}2 \\ -2\end{bmatrix}, \begin{bmatrix}1 & 0 \\ 0 & 1 \end{bmatrix} \bigg), $$ displayed on the left in Figure \ref{fig:dens-db}. This density is unimodal. On the right is a sample of 200 data points. <>= library(ks) set.seed(8192) samp <- 200 mus <- rbind(c(-2,2), c(0,0), c(2,-2)) Sigmas <- rbind(diag(2), matrix(c(0.8, -0.72, -0.72, 0.8), nrow=2), diag(2)) cwt <- 3/11 props <- c((1-cwt)/2, cwt, (1-cwt)/2) x <- rmvnorm.mixt(n=samp, mus=mus, Sigmas=Sigmas, props=props) @ \setkeys{Gin}{width=0.45\textwidth} \begin{figure}[!ht] \begin{center} <>= plotmixt(mus=mus, Sigmas=Sigmas, props=props, xlim=c(-4,4), ylim=c(-4,4)) @ <>= plot(x, xlim=c(-4,4), ylim=c(-4,4), xlab="x", ylab="y") @ \end{center} \caption{Target `dumbbell' density. (Left) contour plot. (Right) Scatter plot.} \label{fig:dens-db} \end{figure} We use \code{Hpi} for unconstrained plug-in selectors and \code{Hpi.diag} for diagonal plug-in selectors. <>= Hpi1 <- Hpi(x=x) Hpi2 <- Hpi.diag(x=x) @ To compute a kernel density estimate, the command is \code{kde}, which creates a \code{kde} class object <<>>= fhat.pi1 <- kde(x=x, H=Hpi1) fhat.pi2 <- kde(x=x, H=Hpi2) @ We use the \code{plot} method for \code{kde} objects to display these kernel density estimates. The default is a contour plot with the upper 25\%, 50\% and 75\% contours of the (sample) highest density regions. %, as %defined in \citet*{bowman1993} and \citet*{hyndman1996}. These regions are also plotted by the \pkg{sm} library. <>= plot(fhat.pi1) plot(fhat.pi2) @ The respective kernel density estimates are produced in Figure \ref{fig:pi}. The diagonal bandwidth matrix constrains the smoothing to be performed in directions parallel to the co-ordinate axes, so it is not able to apply accurate levels of smoothing to the obliquely oriented central portion. The result is a multimodal density estimate. The unconstrained bandwidth matrix correctly produces a unimodal density estimate. \begin{figure}[!ht] \centering <>= plot(fhat.pi1, main="Plug-in", cex.main=1.4) @ <>= plot(fhat.pi2, main="Plug-in diagonal", cex.main=1.4) @ \caption{Kernel density estimates with plug-in selectors} \label{fig:pi} \end{figure} %The commands %\code{Hlscv} and \code{Hlscv.diag} are the unconstrained and diagonal %LSCV (Least Squares Cross Validation) selectors. The unconstrained SCV (Smoothed Cross Validation) selector is \code{Hscv} and its diagonal version is \code{Hscv.diag}. In Figure \ref{fig:cv}, the most reasonable density estimate is from the unconstrained SCV selector. <>= Hscv1 <- Hscv(x=x) Hscv2 <- Hscv.diag(x=x) @ \begin{figure}[!ht] \centering <>= fhat.cv1 <- kde(x=x, H=Hscv1) fhat.cv2 <- kde(x=x, H=Hscv2) @ <>= plot(fhat.cv1, main="SCV", cex.main=1.4) @ <>= plot(fhat.cv2, main="SCV diagonal", cex.main=1.4) @ \caption{Kernel density estimates with cross validation selectors} \label{fig:cv} \end{figure} The unconstrained bandwidth selectors will be better than their diagonal counterparts when the data have large mass oriented obliquely to the co-ordinate axes, like for the dumbbell data. The unconstrained plug-in and the SCV selectors can be viewed as generally recommended selectors. \bibliographystyle{apalike} \begin{thebibliography}{} \bibitem[Bowman and Azzalini, 2007]{sm} Bowman, A. W. and Azzalini, A. (2007). \newblock {\em sm: kernel smoothing methods: Bowman and Azzalini (1997)}. \newblock R package version 2.2. \bibitem[Duong, 2007]{duong2007c} Duong, T. (2007). \newblock ks: {K}ernel density estimation and kernel discriminant analysis for multivariate data in {R}. \newblock {\em Journal of Statistical Software}. \textbf{21 (7)}, URL \texttt{http://www.jstatsoft.org/v21/i07}. \bibitem[Simonoff, 1996]{simonoff1996} Simonoff, J. S. (1996). \newblock {\em Smoothing Methods in Statistics}. \newblock Springer-Verlag, New York. \bibitem[Wand, 2006]{KernSmooth} Wand, M. P. (2006). \newblock {\em KernSmooth: Functions for kernel smoothing for Wand \& Jones (1995)}. \newblock R package version 2.22-19. R port by Brian Ripley. \end{thebibliography} \end{document} ks/CHANGELOG0000644000176200001440000004122413620362541012106 0ustar liggesusersChange log file for ks 1.11.7 -Fixed small bug in help files to comply with R 3.6.3 CMD check. 1.11.6 -Changed dkde() to be an alias for predict.kde(). -Updated default.bgridsize() for d=4 to rep(15,4). -Fixed bug in kdde.binned.nd() to force when keval is a vector to be 1-row matrix. 1.11.5 -Fixed bugs in kde.1d() passing eval.points parameter and which didn't allow unequal class proportions. 1.11.4 -Fixed error report in kde() incorrectly asserting to set "binned=TRUE" for exact estimation. -Fixed bug in line colour in plot.kcde(). -Fixed bug in kde.grid.nd() not passing verbose argument. 1.11.3 -Fixed bug to kda() which set prior.prob values to default sample proportion even when set explicitly differently. -Fixed bug in partition plot for 2D plot.kda(). 1.11.2 -Fixed error in predict.kda() incorrectly assigning class labels. -Replaced dnorm.deriv() by version from J.E.C to compute arbitrary derivatives. -Added verbose option to kde.points(). 1.11.1 -Fixed missing passing of h, H parameters in kde.positive.1d() and kde.positive.2d(). -Fixed bug in kdecopula.de(). -Fixed bug in partition colours in 2D plot.kda(). -Changed default optim.fun="nlm" to optim.fun="optim" everywhere. -Moved rgl, misc3d, OceanView from Imports to Suggests, so ks can run in environments which can't install these visual functionalities. -Fixed inconsistencies in gridsize and bgridsize default values in ks.defaults(). -Added varying.grid.interp.*d() in predict method for non-uniform grids. -Fixed bug in 1D predict.kde() with non-uniform grid (i.e. output from kde(, positive=TRUE)). -Extended limits of grid plotting for in plot.histde(). -Fixed bug in creating factor levels for estimated labels in kda(). -Added air, cardio, hsct, plate, quake, tempb datasets. 1.11.0 -Added multivariate version of rkde(). -Added histogram estimators histde(). -Simplified calculation of default values in kde(), etc. -Changed default flag binned=FALSE to binned=default.bflag. -Fixed estimated group labels calculation in kda(). -Fixed interpolation for d>3 in grid.interp() and predict.kde(). -Added histogram density estimate histde(). -Added kernel density estimate for bounded data kde.boundary(). -Added truncated kernel density estimate kde.truncate(). -Added kernel support estimate ksupp(). -Added kernel partition plot plot.kde.part(). -Added variable kernel density estimates vkde(). -Added quiver plot to plot.kdde() for deriv.order=1. -Added kernel summary curvature kcurv() for deriv.order=2. -Added World Bank data data(worldbank). -Added any dim KDE in kde.grid.nd(). -Changed display="filled.contour" for 2D plots to not give adjacent colour scale bar. -Fixed bug in 1d kde.test() p-value to return scalar. -Fixed bug in interp1d in ks.C which had assigned values outside of estimation array. 1.10.7 -Changed mvtnorm from `Depends' to `Imports' in DESCRIPTION. -Implemented per-block calculation for large sample sizes in kdde(, binned=TRUE). -Fixed small bug in col.fun for plot.kcde(, display="filled.contour2") -Swapped order of computation of CDFs in kroc to prevent possible segmentation faults. -Fixed bug in default bandwidth for kcde(). -Fixed bug in default estimation grid limits for kda.nd(). -Corrected formulas for scalar pilots in gdscalar() to match those in book. -Added feature significance function kfs(). 1.10.6 -Registered native C routines in src/ks.c. -Added kernel mean shift kms(). -Fixed bug in predict.kdde() for vector x for d>2. 1.10.5 -Fixed bug in invisible return values for plot.kda(), plot.kcde(), plot.kdde(), plot.kde(). -Added more detail about eval.points in kde.Rd. -Changed default approx.cont=TRUE in plot methods. -Changed default to compute.cont=TRUE in estimation functions and corresponding plot methods. -Fixed bug in contour plot colours in plot.kdde() for 2D. -Fixed bug in calculation of scalar pilot in gdscalar(). -Fixed bug in calculation of unconstrained SCV pilot in Gunconstr.scv(). 1.10.4 -Fixed bug in plot.kde(,display="slice",abs.cont=) not plotting contours correctly. -Fixed bug in predict.kde(object, ..., x) by adding zero.flag which controls behaviour when x is outside interpolation grid object$eval.points: TRUE = 0, FALSE = object$estimate corr to nearest grid point. 1.10.3 -Fixed bugs in col specification in plot.kde(,disp="persp") and disp="image". -Approx computation in contourLevels(,approx=TRUE) is now default. -Boundary adjustments in binning() moved to C functions linbin*d.ks(). -Grid interpolation functions renamed from find.nearest.gridpts() to grid.interp() and coded in C to increase speed. -Reduced time complexity of loess smoother in kcopula(). 1.10.2 -Improved speed for kde.points(), kdde.points(). -Improved speed for compare(). -Fixed missing xlab, ylab in plot.kde() for 2D KDE. 1.10.1 -Fixed small bug in find.nearest.gridpts when treating edge points. -Modified pre.scale, pre.sphere to use sweep(). -Fixed lower edge interpolation in find.nearest.gridpts.1d(). -Fixed incorrect derivative order in kfe calculation in gdscalar(,binned=TRUE). 1.10.0 -Implemented binned estimation via symconv.1d(), symconv.nd() with unconstrained b/w for kde(), kdde(), kfe(), dmvnorm.deriv.sum(), Hlscv() Hscv(). -Added aliases Hucv(), Hcv.diag(), hucv() for Hlscv(), Hlscv.diag(), h.lscv(). -Added predict method for kda objects. -Fixed inconsistency in plot.kde1d(,col=). -Added 3d exact estimation and 3d plot for kdde(). -Adjusted calls to symconv.1d(), symconv.nd() in drvkde for feature library. -Included calls to RGL plots in help file examples in \donttest{}. -Moved dfltCounts(), drvkde() to feature library. 1.9.5 -Changed DESCRIPTION to comply with CRAN checks (e.g. imports etc.) -Fixed inconsistencies in graphical parameters in plot() functions (e.g. ptcol, cont.col, ...) -Added raster graphics if available for display="image" and "filled.contour2" plots. 1.9.4 -Removed explicit prior calculation of permutation derivative indices in dmvnorm.deriv.sum(). -Fixed small bug in contourLevels.kdde() to make explicit call to predict.kde(). 1.9.3 -Removed copula.grid() and hence dependence on copula package. -Fixed bug in displaying 2D contour level labels for plot.kde() and sorting in contourSizes(). -Added amise=TRUE option to hpi.kcde(). -Modified kroc() to be line with updated mathematical definition. 1.9.2 -Changed binning=FALSE to binned=binned for Hpi(,pilot="dscalar"), Hpi.diag(,pilot="dscalar"). -Fixed bug in binning behaviour in gdscalar(). 1.9.1 -Fixed typos in help files -Added new classes "kcopula" and "kcopula.de" for output from kcopula and kcopula.de to distinguish them from "kcde" and "kde" objects. -Exported matrix.sqrt(). -Added "exp" option for make.grid.ks(). 1.9.0 -Added efficient recursive versions for dmvnorm.deriv(), Sdr(), Sdrv(), nur(), nurs(), mur(), Qr() from Chacon & Duong (2014) Statist Comput. -Fixed bug in Hscv(,binned=TRUE), Hscv.diag(,binned=TRUE) which was still computing unbinned estimators. -Fixed bug in 1-d KDA plot. -Added sensitivity, specificity as output to compare(). -Made small changes to default selectors to be more consistent across selectors. -Fixed bug in point colour in rug plot for plotkda.1d(). -Added Hpi.diag.kcde(). -Added Lpdiff() (Lp distance for two functions) and copula.grid (true copula evaluated on a grid). -Fixed small bug in plotmixt(,draw=FALSE) to actually not draw plots. -Added predict method for kde objects to replace kde.approx(). -Added option to compute 1-d KDE supported on [0,1] kde(,unit.interval=TRUE) which calls kde.unit.interval(). -Changed default axes limits when plotkde.3d(, drawpoints=FALSE) from data range to mean of KDE evaluation range. -Fixed bug in default pilot selector for d>3 data in kda(). -Changed ad hoc argument matching to match.arg(). -Fixed bug in last line of lscv.mat(). -Added binned estimation to Hbcv(), Hbcv.diag(). -Added default binning flag function default.flag(). 1.8.13 -Added boundary density estimator kde.boundary() for compactly supported data. -Added kernel density of copula nd copula density, i.e. kcopula() and kcopula.de(). -Fixed small bug in plot.kcde(disp="slice", abs.cont=!missing), and Hpi.kcde(). -Changed smoothing spline in kroc() to be evaluated on equally spaced grid. -Added thinning option for persp plots plot.kde(thin=), plot.kcde(thin=). 1.8.12 -Added kernel estimators for CDF kcde() and ROC curves kroc(). -Added default plug-in bandwidths to kda(), kcde(), kde(), kdde(), kde.local.test(), kroc(), kde.test(). -Added warning when using non-diagonal bandwidths for binned estimation. -Added plot and contourLevel methods for kdde objects. -Modified plotmixt() to include derivatives. -Added 1-d plug-in selectors hpi(,deriv.order>0). -Merged kda() and kda.kde() into single kda() function. -Changed "kda.kde" object class name to "kda". 1.8.11 -Added progress bars to compare.kda.cv(), compare.kda.diag.cv(). -Corrected critical df from d to 1 in kde.local.test(). 1.8.10 -Fixed small bug in call to contourLevels(approx=) inside kde(). 1.8.9 -Added kde.local.test() for local 2-sample test. -Replaced foreign call to .C("massdist", package="stats") requested by B. Ripley by call to .C("massdist1d", package="ks"). -Changed rug plot in plot.kda.kde() to rug-like plot, similar that in plot.kde.loctest(). 1.8.8 -Changed function header of Hpi.kfe() to be more consistent with Hpi(). -Added option Hpi.kfe(, pilot="dscalar") to ensure scale invariance in p-values. This becomes the default over the previous pilot="unconstr". -Added 1-d option in kde.test() and its required bandwidth hpi.kfe(). -Modified binned=TRUE option in kde.test() so that it is applied only to bandwidth selection, and not the test statistic and its p-value. -Removed default truncation in Hlscv(), Hlscv.diag() for deriv.order=0. 1.8.7 -Further improved speed of kfe(,Sdr.flag=FALSE) by computing unique partial derivatives. -Removed unused function dkde.weights() to compute optimal deconvolution weights, and hence dependence on the kernlab library. -Changed output from kfe(binned=TRUE) to be vector not 1-row matrix. 1.8.6 -Implemented calculation of Lebesgue measure of level sets of contours, contourSizes(). -Implemented probability contour plot for 1-d KDE plot, i.e. analogue to existing 2-d, 3-d contour plot(,disp="slice"). -Added recursive computations kfe(,Sdr.flag=FALSE) which don't compute symmetriser matrices explicitly. These are then called in Hpi(,Sdr.flag=TRUE) and Hscv(,Sdr.flag=FALSE). -Changed pilot="dunconstr" to direct computation rather than indirect eta form. This means that Hpi(,pilot="dunconstr", deriv.order=0) and Hpi(,pilot="unconstr") now give the same result. -Remove pilot="dsamse" option as this was more computation than pilot="dscalar" but with little difference in the result. 1.8.5 -Fully unconstrained pilot selectors pilot="dunconstr" for Hscv(), Hpi() for density derivative estimation. -Unconstrained Hlscv() selector for density derivative estimation. 1.8.4 -Reinstated psi.ns code (more efficient than eta.kfe.y) and SAMSE pilot estimators Hpi(, pilot="samse"). -Edited help manual. 1.8.3 -Added computationally efficient density derivative b/w selectors Hpi(deriv.order=), Hscv(deriv.order=), and their diagonal counterparts Hpi.diag(), Hlscv.diag(). -Added computationally efficient kernel functional estimators in eta.kfe.y() used in kde.test(). -New pilot selectors for density derivatives. -Added abs.cont capability to plot(, disp="filled.contour"). -Removed explicit expressions in psins() for d>2, replaced by eta.kfe() evaluations. -Removed psins() and Theta6() evaluations in gsamse and gamse.scv. -Removed kfold arguments. 1.8.2 -Fixed bug in kde.points.sum() to avoid allocating large matrices for unbalanced sample sizes for x and eval.points. -Fixed bug in dmvnorm.deriv.sum() which had excluded last partition class for double.loop=FALSE. -Added binned options to kde.test(). -Fixed bug for exact estimation in kfe(). -Added plotting colours as function of z-value in plot.kde(, disp="persp"). -Added decoupled calculation for Hlscv(). -Added optim.fun option to select optimiser function in Hpi, Hpi.diag, Hlscv, Hlscv.diag, Hscv, Hscv.diag(). 1.8.1 -Modified p-value calculation for large -ve Z-statistics. -Fixed bug for binned estimation for unconstrained bandwidths for kde(). 1.8.0 -Added density derivative selectors Hpi(,deriv.order=r), Hlscv(,deriv.order=r) for r>0 from J.E. Chacon. -Changed vech(H) terms to vec(H) in AMISE estimators. -Changed default binning gridsize for 3-d data from rep(51,3) to rep(31,3). -Added verbose option to b/w selectors (in double sum) for tracking progress. -Changed LSCV, SCV selectors optimisation from Nelder-Mead to BFGS. -Changed Fortran linear binning code to C (and fixed bugs in Fortran code). -Added modification to linear binning for boundary points. -Removed explicit derivatives in BCV selector optimisation. 1.7.4 -Fixed small bug in partitioning method for kde.points.sum(). 1.7.3 -Changed partitioning method for dmvnorm.deriv.sum() and kde.points.sum(). 1.7.2 -Changed p-value calculation for kde.test(). 1.7.1 -Reinstated single partial derivative of mv normal for scalar variance matrix dmvnorm.deriv.scalar.sum() for use in AMSE pilot plug-in selectors. -More efficient form of kdde(). 1.7.0 -Added KDE-based 2-sample test kde.test(). -Modified output of plotmixt(). -Added "double.loop" option to kfe() for large samples - increases running time, reduces memory. -Modified dmvnorm.deriv.sum() to improve memory memory management for large samples. -Cleaned up code for plug-in bandwidth selectors and kernel functional estimators. -Cleaned up help files. -Disabled kfold b/w selectors. 1.6.13 -Added flag to automatically compute probability contour levels in kde(). 1.6.11 -Added own version of filled contours as option disp="filled.contour2" and different colours for disp="slice" contours. 1.6.10 -Added k-fold b/w selectors. 1.6.9 -Added approximate option in contourLevels(). -Added kdde() kernel density derivative estimators. 1.6.8 -Added 1-d LSCV selector hlscv(). 1.6.7 -Corrected ISE for normal mixtures, from J.E. Chacon. 1.6.6 -Added MISE, AMISE, ISE functions for normal mixtures derivatives. -Changed internal double sum calculations from J.E. Chacon. 1.6.x -1-d binned KDE fix from M.P. Wand. -Streamlined code sharing with feature package (all binning code now contained only in ks). -Reorganised and renamed internal bandwidth selection functions, mostly double sums of normal densities . 1.5.11 -Fixed small bugs in drvkde, vech, Hpi(, pilot="unconstr") 1.5.10 -Added drvkde (kernel density derivative estimator 1-d) from feature using M.P. Wand's code. 1.5.x -Added normal mixture (A)MISE-optimal selectors: hamise.mixt, hmise.mixt, Hamise.mixt, Hmise.mixt. -Added distribution functions for 1-d KDEs: dkde, pdke, qkde, rkde. -Added plug-in selectors for 1-d data (exactly the code for dpik from KernSmooth). For KDE, this is hpi, for KDA, this is hkda(, bw="plugin"). -Made changes to specifying line colour (col rather than lcol) in plot.kde, plot.kda.kde and partition class colour (partcol) in plot.kda.kde. -Added plot3d() capabilities from rgl to 3-d plot - removing own axes drawing functions. -New functions to compute pilot functional estimators hat{psi}_r(g). These are exact, and are more efficient than binned estimators for small samples (~100), and are available in d > 4. 1.4.x -Vignette illustrating 2-d KDE added -Binned estimation implemented for KDE with diagonal selectors and pilot functional estimation with diagonal selectors. -Filled contour plots added as disp=filled option in plot.kde(). -compare.kda.cv() and compare.cv() modified to improve speed. -Hscv.diag() and Hbcv.diag() added for completeness. 1.3.5 -Fixed small bug in compare.kda.cv() and compare.kda.diag.cv(). 1.3.4 -RGL-type plots added for 3-d data. Specification of 3-d contour levels now same order as 2-d contours. 1.3.x -Multivariate (for 3 to 6 dimensions inclusive) bandwidth selectors added for Hpi(), Hpi.diag(), Hlscv(), Hlscv.diag() and Hscv(). NB: because Hbcv() and Hbcv.diag() performed poorly for 2-d, these weren't implemented in higher dimensions. 1.2.x -Package checked by CRAN testers and accepted on the CRAN website. To pass all the necessary checks involved some internal programming changes but has not affected the user interface. -The child mortality data set unicef is used in the examples. 1.1.x -S3 type objects have been introduced. The output from kde() are `kde' objects. The output from kda.kde() and pda.pde() are `dade' objects. Corresponding plot functions are called automatically by invoking `plot'. -Kernel discriminant analysers are now available. Parametric (linear and quadratic) discriminant analysers are accessed using `pda'. -adapt library is no longer required. This was formerly used on the functions for integrated squared error computations ise.mixt() and iset.mixt(). ks/R/0000755000176200001440000000000013620371402011066 5ustar liggesusersks/R/kde-boundary.R0000644000176200001440000006516213216566053013620 0ustar liggesusers ###################################################################### ## Boundary KDE ###################################################################### kde.boundary <- function(x, H, h, gridsize, gridtype, xmin, xmax, supp=3.7, eval.points, binned=FALSE, bgridsize, w, compute.cont=TRUE, approx.cont=TRUE, boundary.supp, boundary.kernel="beta", verbose=FALSE) { bk <- match.arg(boundary.kernel, c("beta", "linear")) if (bk=="beta") { if (missing(boundary.supp)) boundary.supp <- 10 fhat <- kde.beta.boundary(x=x, H=H, h=h, gridsize=gridsize, gridtype=gridtype, xmin=xmin, xmax=xmax, supp=supp, eval.points=eval.points, binned=binned, bgridsize=bgridsize, w=w, compute.cont=compute.cont, approx.cont=approx.cont, boundary.supp=boundary.supp, verbose=verbose) } else if (bk=="linear") { if (missing(boundary.supp)) boundary.supp <- 2 fhat <- kde.linear.boundary(x=x, H=H, h=h, gridsize=gridsize, gridtype=gridtype, xmin=xmin, xmax=xmax, supp=supp, eval.points=eval.points, binned=binned, bgridsize=bgridsize, w=w, compute.cont=compute.cont, approx.cont=approx.cont, boundary.supp=boundary.supp, verbose=verbose) } return(fhat) } ###################################################################### ## Linear boundary KDE ###################################################################### kde.linear.boundary <- function(x, H, h, gridsize, gridtype, xmin, xmax, supp=3.7, eval.points, binned=FALSE, bgridsize, w, compute.cont=TRUE, approx.cont=TRUE, boundary.supp=2, verbose=FALSE) { ## default values ksd <- ks.defaults(x=x, w=w, binned=binned, bgridsize=bgridsize, gridsize=gridsize) d <- ksd$d; n <- ksd$n; w <- ksd$w if (missing(binned)) binned <- ksd$binned if (missing(gridsize)) gridsize <- ksd$gridsize if (missing(bgridsize)) bgridsize <- gridsize if (d==1) { if (missing(h)) h <- hpi(x=x, binned=default.bflag(d=d,n=n), bgridsize=bgridsize) } if (missing(H) & d>1) H <- Hpi(x=x, binned=default.bflag(d=d,n=n), bgridsize=bgridsize) ## compute exact (non-binned) estimator ## 1-dimensional if (d==1) { stop("Not yet implemented.") } ## multi-dimensional else { if (is.data.frame(x)) x <- as.matrix(x) if (missing(eval.points)) { if (d==2) fhat <- kde.LB.grid.2d(x=x, H=H, gridsize=gridsize, supp=supp, xmin=xmin, xmax=xmax, gridtype=gridtype, w=w, boundary.supp=boundary.supp, binned=binned, verbose=verbose) else stop("Not yet implemented.") ##stop("Need to specify eval.points for more than 3 dimensions") } else stop("Not yet implemented.") } fhat$binned <- binned fhat$names <- parse.name(x) ## add variable names fhat$w <- w class(fhat) <- "kde" ## compute prob contour levels if (compute.cont & missing(eval.points)) fhat$cont <- contourLevels(fhat, cont=1:99, approx=approx.cont) return(fhat) } ###################################################################### ## Bivariate linear boundary KDE ###################################################################### kde.LB.grid.2d <- function(x, H, gridsize, bgridsize, supp, gridx=NULL, grid.pts=NULL, xmin, xmax, gridtype, w, boundary.supp=10, binned=FALSE, verbose=FALSE) { n <- nrow(x) d <- ncol(x) if (missing(xmin)) xmin <- apply(x, 2, min) if (missing(xmax)) xmax <- apply(x, 2, max) if (missing(gridtype)) gridtype <- rep("linear", d) h <- sqrt(diag(H)) ## initialise grid if (is.null(gridx)) gridx <- make.grid.ks(x, matrix.sqrt(H), tol=supp, gridsize=gridsize, xmin=xmin, xmax=xmax, gridtype=gridtype) suppx <- make.supp(x, matrix.sqrt(H), tol=supp) if (is.null(grid.pts)) grid.pts <- find.gridpts(gridx, suppx) fhat.grid <- matrix(0, nrow=length(gridx[[1]]), ncol=length(gridx[[2]])) ## indicator for closeness to boundary bound.ind <- boundary.ind(x=x, h=h, boundary.supp=boundary.supp) n1 <- sum(!bound.ind) if (verbose) pb <- txtProgressBar() if (binned) { ## interior points - use normal kernel fhat.grid <- n1*kde(x=x[!bound.ind,], H=H, xmin=xmin, xmax=xmax, binned=binned, bgridsize=bgridsize)$estimate for (i in 1:n) { if (verbose) setTxtProgressBar(pb, i/n) if (bound.ind[i]) { ## compute evaluation points eval.x <- gridx[[1]][grid.pts$xmin[i,1]:grid.pts$xmax[i,1]] eval.y <- gridx[[2]][grid.pts$xmin[i,2]:grid.pts$xmax[i,2]] eval.x.ind <- c(grid.pts$xmin[i,1]:grid.pts$xmax[i,1]) eval.y.ind <- c(grid.pts$xmin[i,2]:grid.pts$xmax[i,2]) eval.x.len <- length(eval.x) ## use linear boundary kernel for boundary points fhat <- dmvnorm.LB(x=expand.grid(eval.x, eval.y), mu=x[i,], Sigma=H) ## place vector of density estimate values `fhat' onto grid 'fhat.grid' for (j in 1:length(eval.y)) fhat.grid[eval.x.ind, eval.y.ind[j]] <- fhat.grid[eval.x.ind, eval.y.ind[j]] + w[i]*fhat[((j-1) * eval.x.len + 1):(j * eval.x.len)] } } } else { for (i in 1:n) { if (verbose) setTxtProgressBar(pb, i/n) ## compute evaluation points eval.x <- gridx[[1]][grid.pts$xmin[i,1]:grid.pts$xmax[i,1]] eval.y <- gridx[[2]][grid.pts$xmin[i,2]:grid.pts$xmax[i,2]] eval.x.ind <- c(grid.pts$xmin[i,1]:grid.pts$xmax[i,1]) eval.y.ind <- c(grid.pts$xmin[i,2]:grid.pts$xmax[i,2]) eval.x.len <- length(eval.x) ## interior points - use normal kernel if (!bound.ind[i]) { eval.pts <- expand.grid(list(eval.x, eval.y)) fhat <- dmvnorm.mixt(x=eval.pts, mus=x[i,], Sigmas=H, props=1) } else { ## use linear boundary kernel for boundary points fhat <- dmvnorm.LB(x=expand.grid(eval.x, eval.y), mu=x[i,], Sigma=H) } ## place vector of density estimate values `fhat' onto grid 'fhat.grid' for (j in 1:length(eval.y)) fhat.grid[eval.x.ind, eval.y.ind[j]] <- fhat.grid[eval.x.ind, eval.y.ind[j]] + w[i]*fhat[((j-1) * eval.x.len + 1):(j * eval.x.len)] } } fhat.grid <- fhat.grid/n gridx1 <- list(gridx[[1]], gridx[[2]]) fhat.grid <- fhat.grid/sum(fhat.grid*prod(sapply(gridx1,diff)[1,])) if (verbose) close(pb) fhat.list <- list(x=x, eval.points=gridx1, estimate=fhat.grid, H=H, gridtype=gridx$gridtype, gridded=TRUE, boundary=bound.ind) return(fhat.list) } ## Bivariate linear boundary normal kernel dmvnorm.LB.kernel.2d <- function(x, H, xmin=c(0,0), xmax=c(1,1), ...) { x1 <- seq(xmin[1], xmax[1], length=151) x2 <- seq(xmin[2], xmax[2], length=151) eval.points <- list(x1, x2) fhat <- list() fhat$eval.points <- eval.points fhat$estimate <- array(dmvnorm.LB(x=expand.grid(eval.points), mu=x, Sigma=H), dim=c(length(x1), length(x2))) x <- rmvnorm.mixt(n=1000, mus=x, Sigmas=H, props=1) fhat$x <- x fhat$H <- H fhat$gridtype <- "linear" fhat$gridded <- TRUE fhat$binned <- FALSE fhat$names <- parse.name(x) fhat$w <- rep(1, nrow(x)) class(fhat) <- "kde" return(fhat) } dmvnorm.LB <- function(x, mu, Sigma, a0, a1) { if (!is.matrix(x)) x <- as.matrix(x) if (missing(a0) | missing(a1)) { ev <- -sweep(x, 2, mu, FUN="-") %*% diag(sqrt(1/diag(Sigma))) ev.list <- list(unique(ev[,1]), unique(ev[,2])) delta <- prod(unlist(lapply(lapply(ev.list, diff), getElement, 1))) d <- ncol(Sigma) evalK <- dmvnorm.mixt(x=ev, mus=rep(0,d), Sigmas=diag(d), props=1) m0 <- sum(evalK*delta) m1 <- apply(evalK*delta*ev, 2, sum) m2 <- apply(evalK*delta*rowKpow(ev, ev), 2, sum) M2 <- invvec(m2) M2inv <- chol2inv(chol(M2)) a0 <- 1/drop(m0 - t(m1) %*% M2inv%*%m1) a1 <- -a0*M2inv%*%m1 } evalK.LB <- (a0 - drop(ev %*% a1))*dmvnorm.mixt(x=x, mus=mu, Sigmas=Sigma, props=1) return(evalK.LB) } ############################################################################# ## Boundary KDE ############################################################################# ## boundary kernel estimator using beta bounday kernels (2nd form) kde.beta.boundary <- function(x, H, h, gridsize, gridtype, xmin, xmax, supp=3.7, eval.points, binned=FALSE, bgridsize, w, compute.cont=TRUE, approx.cont=TRUE, boundary.supp=1, verbose=FALSE) { if (is.vector(x)) { if (missing(H)) {d <- 1; n <- length(x)} else { if (is.vector(H)) { d <- 1; n <- length(x)} else {x <- matrix(x, nrow=1); d <- ncol(x); n <- nrow(x)} } } else {d <- ncol(x); n <- nrow(x)} if (!missing(w)) if (!(identical(all.equal(sum(w), n), TRUE))) { warning("Weights don't sum to sample size - they have been scaled accordingly\n") w <- w*n/sum(w) } if (missing(w)) w <- rep(1,n) if (d==1) { if (missing(h)) h <- hpi(x=x, binned=default.bflag(d=d,n=n), bgridsize=bgridsize) } if (missing(H) & d>1) H <- Hpi(x=x, binned=default.bflag(d=d,n=n), bgridsize=bgridsize) ## compute exact (non-binned) estimator if (missing(gridsize)) gridsize <- default.gridsize(d) ## 1-dimensional if (d==1) { if (missing(eval.points)) { fhat <- kde.boundary.grid.1d(x=x, h=h, gridsize=gridsize, supp=supp, xmin=xmin, xmax=xmax, gridtype=gridtype, w=w, boundary.supp=boundary.supp, binned=binned) } else stop("Not yet implemented.") ##fhat <- kde.points.1d(x=x, h=h, eval.points=eval.points, positive=positive, adj.positive=adj.positive, w=w) } ## multi-dimensional else { if (is.data.frame(x)) x <- as.matrix(x) if (missing(eval.points)) { if (d==2) fhat <- kde.boundary.grid.2d(x=x, H=H, gridsize=gridsize, supp=supp, xmin=xmin, xmax=xmax, gridtype=gridtype, w=w, boundary.supp=boundary.supp, binned=binned, verbose=verbose) else if (d == 3) fhat <- kde.boundary.grid.3d(x=x, H=H, gridsize=gridsize, supp=supp, xmin=xmin, xmax=xmax, gridtype=gridtype, w=w, boundary.supp=boundary.supp, binned=binned, verbose=verbose) else stop("Need to specify eval.points for more than 3 dimensions") } else stop("Not yet implemented.") ##fhat <- kde.points(x=x, H=H, eval.points=eval.points, w=w) } fhat$binned <- binned fhat$names <- parse.name(x) ## add variable names fhat$w <- w class(fhat) <- "kde" ## compute prob contour levels if (compute.cont & missing(eval.points)) fhat$cont <- contourLevels(fhat, cont=1:99, approx=approx.cont) return(fhat) } kde.boundary.grid.1d <- function(x, h,gridsize, supp=3.7, xmin, xmax, gridtype, w, boundary.supp=0.5, binned=FALSE) { if (missing(xmin)) xmin <- min(x) if (missing(xmax)) xmax <- max(x) if (missing(gridtype)) gridtype <- "linear" ## transform x into [0,1] x.star <- (x-xmin)/(xmax-xmin) h.star <- h/(xmax-xmin) n <- length(x) gridtype1 <- match.arg(gridtype, c("linear", "sqrt")) if (gridtype1=="linear") eval.x <- seq(0, 1, length=gridsize) else if (gridtype1=="sqrt") { eval.x.temp <- seq(0, 1, length=gridsize) eval.x <- sign(eval.x.temp) * eval.x.temp^2 } gridtype.vec <- gridtype1 ## indicator for closeness to boundary of [0,1] bound.ind <- boundary.ind(x=x.star, h=h.star, boundary.supp=boundary.supp) n1 <- sum(!bound.ind) ## interior points - use normal kernel ## binned estimation only in the interior fhat.grid <- rep(0,length=gridsize) if (n1>0) { if (binned) { fhat.grid <- n1*kde(x=x.star[!bound.ind], h=h.star, xmin=0, xmax=1, binned=TRUE, bgridsize=gridsize)$estimate } else { fhat.grid <- n1*dnorm.mixt(x=eval.x, mus=x.star[!bound.ind], sigmas=rep(h.star, n1), props=w[!bound.ind]/n1) } } ## boundary points - use adjusted beta kernel hb.star <- 2*h.star for (i in 1:(n-n1)) fhat.grid <- fhat.grid + dbeta.kernel2(x=x.star[bound.ind][i], eval.x=eval.x, h=hb.star)*w[bound.ind][i] fhat.grid <- fhat.grid/n ## backtransform eval.points <- (xmax-xmin)*eval.x + xmin fhat.grid <- fhat.grid/(xmax-xmin) fhat <- list(x=x, eval.points=eval.points, estimate=fhat.grid, h=h, H=h^2, gridtype=gridtype.vec, gridded=TRUE) class(fhat) <- "kde" return(fhat) } kde.boundary.grid.2d <- function(x, H, gridsize, supp, gridx=NULL, grid.pts=NULL, xmin, xmax, gridtype, w, boundary.supp=1, binned=FALSE, verbose=FALSE) { n <- nrow(x) d <- ncol(x) if (missing(xmin)) xmin <- apply(x, 2, min) ##- h*supp if (missing(xmax)) xmax <- apply(x, 2, max) ## + h*supp if (missing(gridtype)) gridtype <- rep("linear", d) ## transform x into [0,1]^d x.star <- x for (j in 1:d) x.star[,j] <- (x[,j]-xmin[j])/(xmax[j]-xmin[j]) H.star <- diag(1/(xmax-xmin)) %*% H %*% diag(1/(xmax-xmin)) h.star <- sqrt(diag(H.star)) ## initialise grid if (is.null(gridx)) gridx <- make.grid.ks(x.star, matrix.sqrt(H.star), tol=supp, gridsize=gridsize, xmin=rep(0,d), xmax=rep(1,d), gridtype=gridtype) suppx <- make.supp(x.star, matrix.sqrt(H.star), tol=supp) if (is.null(grid.pts)) grid.pts <- find.gridpts(gridx, suppx) fhat.grid <- matrix(0, nrow=length(gridx[[1]]), ncol=length(gridx[[2]])) ## indicator for closeness to boundary of [0,1]^d bound.ind <- boundary.ind(x=x.star, h=h.star, boundary.supp=boundary.supp) n1 <- sum(!bound.ind) if (verbose) pb <- txtProgressBar() if (binned) { ## interior points - use normal kernel fhat.grid <- n1*kde(x=x.star[!bound.ind,], H=H.star, xmin=rep(0,d), xmax=rep(1,d), binned=TRUE, bgridsize=gridsize)$estimate for (i in 1:n) { if (verbose) setTxtProgressBar(pb, i/n) if (bound.ind[i]) { ## compute evaluation points eval.x <- gridx[[1]][grid.pts$xmin[i,1]:grid.pts$xmax[i,1]] eval.y <- gridx[[2]][grid.pts$xmin[i,2]:grid.pts$xmax[i,2]] eval.x.ind <- c(grid.pts$xmin[i,1]:grid.pts$xmax[i,1]) eval.y.ind <- c(grid.pts$xmin[i,2]:grid.pts$xmax[i,2]) eval.x.len <- length(eval.x) ## convert bandwidth from normal kernel to beta kernel scale ## for boundary points hb.star <- 2*h.star fhat <- dmvbeta.prod.kernel2(x=x.star[i,], eval.x=list(eval.x, eval.y), hs=hb.star) ## place vector of density estimate values `fhat' onto grid 'fhat.grid' for (j in 1:length(eval.y)) fhat.grid[eval.x.ind, eval.y.ind[j]] <- fhat.grid[eval.x.ind, eval.y.ind[j]] + w[i]*fhat[((j-1) * eval.x.len + 1):(j * eval.x.len)] } } } else { for (i in 1:n) { if (verbose) setTxtProgressBar(pb, i/n) ## compute evaluation points eval.x <- gridx[[1]][grid.pts$xmin[i,1]:grid.pts$xmax[i,1]] eval.y <- gridx[[2]][grid.pts$xmin[i,2]:grid.pts$xmax[i,2]] eval.x.ind <- c(grid.pts$xmin[i,1]:grid.pts$xmax[i,1]) eval.y.ind <- c(grid.pts$xmin[i,2]:grid.pts$xmax[i,2]) eval.x.len <- length(eval.x) ## interior points - use normal kernel if (!bound.ind[i]) { eval.pts <- expand.grid(eval.x, eval.y) fhat <- dmvnorm(eval.pts, x.star[i,], H.star) } else { ## convert bandwidth from normal kernel to beta kernel scale ## for boundary points hb.star <- 2*h.star fhat <- dmvbeta.prod.kernel2(x=x.star[i,], eval.x=list(eval.x, eval.y), hs=hb.star) ##fhat <- dmvbeta.symm.kernel2(x=x.star[i,], eval.x=expand.grid(eval.x, eval.y), H=2*H.star) } ## place vector of density estimate values `fhat' onto grid 'fhat.grid' for (j in 1:length(eval.y)) fhat.grid[eval.x.ind, eval.y.ind[j]] <- fhat.grid[eval.x.ind, eval.y.ind[j]] + w[i]*fhat[((j-1) * eval.x.len + 1):(j * eval.x.len)] } } fhat.grid <- fhat.grid/n if (verbose) close(pb) ## back-transform gridx1 <- list((xmax[1]-xmin[1])*gridx[[1]] + xmin[1], (xmax[2]-xmin[2])*gridx[[2]] + xmin[2]) fhat.grid <- fhat.grid/prod(xmax-xmin) fhat.list <- list(x=x, eval.points=gridx1, estimate=fhat.grid, H=H, gridtype=gridx$gridtype, gridded=TRUE, boundary=bound.ind) return(fhat.list) } kde.boundary.grid.3d <- function(x, H, gridsize, supp, gridx=NULL, grid.pts=NULL, xmin, xmax, gridtype, w, boundary.supp=0.5, verbose=FALSE, binned=FALSE) { n <- nrow(x) d <- ncol(x) if (missing(xmin)) xmin <- apply(x, 2, min) if (missing(xmax)) xmax <- apply(x, 2, max) if (missing(gridtype)) gridtype <- rep("linear", d) ## transform x into [0,1]^d x.star <- x for (j in 1:d) x.star[,j] <- (x[,j]-xmin[j])/(xmax[j]-xmin[j]) H.star <- diag(1/(xmax-xmin)) %*% H %*% diag(1/(xmax-xmin)) h.star <- sqrt(diag(H.star)) ## initialise grid if (is.null(gridx)) gridx <- make.grid.ks(x.star, matrix.sqrt(H.star), tol=supp, gridsize=gridsize, xmin=rep(0,d), xmax=rep(1,d), gridtype=gridtype) suppx <- make.supp(x.star, matrix.sqrt(H.star), tol=supp) if (is.null(grid.pts)) grid.pts <- find.gridpts(gridx, suppx) fhat.grid <- array(0, dim=c(length(gridx[[1]]), length(gridx[[2]]), length(gridx[[3]]))) ## indicator for closeness to boundary of [0,1]^d bound.ind <- boundary.ind(x=x.star, h=h.star, boundary.supp=boundary.supp) n1 <- sum(!bound.ind) if (verbose) pb <- txtProgressBar() if (binned) { ## interior points - use normal kernel fhat.grid <- n1*kde(x=x.star[!bound.ind,], H=H.star, xmin=rep(0,d), xmax=rep(1,d), binned=TRUE, bgridsize=gridsize)$estimate for (i in 1:n) { if (verbose) setTxtProgressBar(pb, i/n) if (bound.ind[i]) { ## compute evaluation points eval.x <- gridx[[1]][grid.pts$xmin[i,1]:grid.pts$xmax[i,1]] eval.y <- gridx[[2]][grid.pts$xmin[i,2]:grid.pts$xmax[i,2]] eval.z <- gridx[[3]][grid.pts$xmin[i,3]:grid.pts$xmax[i,3]] eval.x.ind <- c(grid.pts$xmin[i,1]:grid.pts$xmax[i,1]) eval.y.ind <- c(grid.pts$xmin[i,2]:grid.pts$xmax[i,2]) eval.z.ind <- c(grid.pts$xmin[i,3]:grid.pts$xmax[i,3]) eval.x.len <- length(eval.x) eval.pts <- expand.grid(eval.x, eval.y) ## convert bandwidth from normal kernel to beta kernel scale ## for boundary points hb.star <- 2*h.star fhat.xy <- dmvbeta.prod.kernel2(x=x.star[i,], eval.x=list(eval.x, eval.y), hs=hb.star[1:2]) ## place vector of density estimate values `fhat' onto grid 'fhat.grid' for (k in 1:length(eval.z)) { fhat <- w[i]*cbind(fhat.xy, dbeta.kernel2(x=x.star[i,3], eval.x=eval.z[k], h=hb.star[3])) for (j in 1:length(eval.y)) fhat.grid[eval.x.ind,eval.y.ind[j], eval.z.ind[k]] <- fhat.grid[eval.x.ind, eval.y.ind[j], eval.z.ind[k]] + fhat[((j-1) * eval.x.len + 1):(j * eval.x.len)] } } } } else { for (i in 1:n) { if (verbose) setTxtProgressBar(pb, i/n) ## compute evaluation points eval.x <- gridx[[1]][grid.pts$xmin[i,1]:grid.pts$xmax[i,1]] eval.y <- gridx[[2]][grid.pts$xmin[i,2]:grid.pts$xmax[i,2]] eval.z <- gridx[[3]][grid.pts$xmin[i,3]:grid.pts$xmax[i,3]] eval.x.ind <- c(grid.pts$xmin[i,1]:grid.pts$xmax[i,1]) eval.y.ind <- c(grid.pts$xmin[i,2]:grid.pts$xmax[i,2]) eval.z.ind <- c(grid.pts$xmin[i,3]:grid.pts$xmax[i,3]) eval.x.len <- length(eval.x) eval.pts <- expand.grid(eval.x, eval.y) ## interior points - use normal kernel if (!bound.ind[i]) { ## place vector of density estimate values `fhat' onto grid 'fhat.grid' for (k in 1:length(eval.z)) { fhat <- w[i]*dmvnorm(cbind(eval.pts, eval.z[k]), x[i,], H) for (j in 1:length(eval.y)) fhat.grid[eval.x.ind,eval.y.ind[j], eval.z.ind[k]] <- fhat.grid[eval.x.ind, eval.y.ind[j], eval.z.ind[k]] + fhat[((j-1) * eval.x.len + 1):(j * eval.x.len)] } } else { ## convert bandwidth from normal kernel to beta kernel scale hb.star <- 2*h.star fhat.xy <- dmvbeta.prod.kernel2(x=x.star[i,], eval.x=list(eval.x, eval.y), hs=hb.star[1:2]) for (k in 1:length(eval.z)) { fhat <- w[i]*cbind(fhat.xy, dbeta.kernel2(x=x.star[i,3], eval.x=eval.z[k], h=hb.star[3])) for (j in 1:length(eval.y)) fhat.grid[eval.x.ind,eval.y.ind[j], eval.z.ind[k]] <- fhat.grid[eval.x.ind, eval.y.ind[j], eval.z.ind[k]] + fhat[((j-1) * eval.x.len + 1):(j * eval.x.len)] } } } } fhat.grid <- fhat.grid/n if (verbose) close(pb) ## back-transform gridx1 <- list((xmax[1]-xmin[1])*gridx[[1]] + xmin[1], (xmax[2]-xmin[2])*gridx[[2]] + xmin[2], (xmax[3]-xmin[3])*gridx[[3]] + xmin[3]) fhat.grid <- fhat.grid/prod(xmax-xmin) fhat.list <- list(x=x, eval.points=gridx1, estimate=fhat.grid, H=H, gridtype=gridx$gridtype, gridded=TRUE, boundary=bound.ind) return(fhat.list) } ## indicator function for boundary region of [0,1] i.e. [0,h] + [1-h, h] boundary.ind <- function(x, h, xmin, xmax, boundary.supp=1) { if (is.vector(x)){ x <- matrix(x, ncol=1) } n <- nrow(x) d <- ncol(x) ## indicator for closeness to boundary of [0,1]^d bound.ind <- matrix(NA, nrow=n, ncol=d) for (j in 1:d) bound.ind[,j] <- (abs(x[,j]) <= boundary.supp*h[j]) | (abs(1-x[,j]) <= boundary.supp*h[j]) bound.ind <- apply(bound.ind, 1, any) return(bound.ind) } ###################################################################### ## Bivariate beta boundary KDE ###################################################################### ## Modified boundary beta kernel - first form (Chen, 1999) dbeta.kernel <- function(x, eval.x, h) { return (dbeta(x=eval.x, shape1=x/h^2+1, shape2=(1-x)/h^2+1)) } ## Modified boundary beta kernel - second form (Chen, 1999) dbeta.kernel2 <- function(x, eval.x, h) { rhox <- function(y, hy) {if (y==0) return (1) else return(2*hy^4 + 5/2 - sqrt(4*hy^8 + 6*hy^4 + 9/4 - y^2 -y/hy^2))} ind <- cut(x, c(0, 2*h^2, 1-2*h^2, 1), labels=FALSE, include.lowest=TRUE) dbk <- rep(0, length(eval.x)) if (ind==1) {shape1 <- rhox(x,hy=h); shape2 <- (1-x)/h^2} else if (ind==2) {shape1 <- x/h^2; shape2 <- (1-x)/h^2} else if (ind==3) {shape1 <- x/h^2; shape2 <- rhox(1-x, hy=h)} return(dbeta(eval.x, shape1=shape1, shape2=shape2)) } ## Modified multivariate boundary beta product kernel dmvbeta.prod.kernel2 <- function(x, eval.x, hs) { d <- length(hs) db <- vector("list", d) for (i in 1:d) db[[i]] <- 0 for (i in 1:d) db[[i]] <- dbeta.kernel2(x=x[i], eval.x=eval.x[[i]], h=hs[i]) db <- expand.grid(db) db <- apply(db, 1, prod) return(db) } ## Modified multivariate boundary beta spherically symmetric kernel dmvbeta.symm.kernel2 <- function(x, eval.x, H) { d <- ncol(H) eval.y <- sqrt(apply(eval.x^2, 1, sum))/sqrt(d) y <- sqrt(sum(x^2))/sqrt(d) return(dbeta.kernel2(x=y, eval.x=eval.y, h=sqrt(tr(H)))/d) } rbeta.kernel2 <- function(x, n, h) { rhox <- function(y, hy) {if (y==0) return (1) else return(2*hy^4 + 5/2 - sqrt(4*hy^8 + 6*hy^4 + 9/4 - y^2 -y/hy^2))} ind <- cut(x, c(0, 2*h^2, 1-2*h^2, 1), labels=FALSE, include.lowest=TRUE) if (ind==1) {shape1 <- rhox(x,hy=h); shape2 <- (1-x)/h^2} else if (ind==2) {shape1 <- x/h^2; shape2 <- (1-x)/h^2} else if (ind==3) {shape1 <- x/h^2; shape2 <- rhox(1-x, hy=h)} return(rbeta(n=n, shape1=shape1, shape2=shape2)) } dmvbeta.prod.kernel2.2d <- function(x, hs, xmin=c(0,0), xmax=c(1,1), ...) { x.star <- (x - xmin)/(xmax - xmin) hs.star <- hs/(xmax - xmin) x1 <- seq(0,1, length=151) x1[1] <- 1e-9; x1[151] <- 1-1e-9 eval.points <- list(x1, x1) fhat <- list() x <- cbind(rbeta.kernel2(x=x.star[1], n=1000, h=hs.star[1]), rbeta.kernel2(x=x.star[2], n=1000, h=hs.star[2])) fhat$eval.points <- list(seq(0,1, length=151), seq(0,1, length=151)) fhat$estimate <- matrix(dmvbeta.prod.kernel2(x=x.star, eval.x=eval.points, hs=hs.star, ...), nrow=length(eval.points[[1]])) fhat$x <- sweep(sweep(x, 2, xmin, FUN="+"), 2, xmax-xmin, FUN="*") fhat$eval.points[[1]] <- xmin[1] + fhat$eval.points[[1]]*(xmax[1]-xmin[1]) fhat$eval.points[[2]] <- xmin[2] + fhat$eval.points[[2]]*(xmax[2]-xmin[2]) fhat$H <- diag(2) fhat$gridtype <- "linear" fhat$gridded <- TRUE fhat$binned <- FALSE fhat$names <- parse.name(x) fhat$w <- rep(1, nrow(x)) class(fhat) <- "kde" return(fhat) } ########################################################################## ## Truncate unbounded KDE to polygon boundary ########################################################################## kde.truncate <- function(fhat, boundary) { ##if (class(x) %in% "kde") fhat <- x ##else fhat <- kde(x=x, ...) ## reallocate any probability mass outside of map boundary regions ## to interior regions truncate.ind <- array(mgcv::in.out(boundary, as.matrix(expand.grid(fhat$eval.points[[1]], fhat$eval.points[[2]]))), dim=dim(fhat$estimate)) fhat.trunc <- fhat fhat.trunc$estimate <- fhat.trunc$estimate*truncate.ind fhat.sum <- sum(fhat$estimate*head(apply(sapply(fhat$eval.points, diff), 1, prod), n=1)) fhat.trunc.sum <- sum(fhat.trunc$estimate*head(apply(sapply(fhat.trunc$eval.points, diff), 1, prod), n=1)) fhat.trunc$estimate <- fhat.trunc$estimate*fhat.sum/fhat.trunc.sum if (length(fhat.trunc$cont)>0) fhat.trunc$cont <- contourLevels(fhat.trunc, cont=1:99, approx=TRUE) return(fhat.trunc) } ########################################################################## ## Truncate unbounded KDDE to polygon boundary ########################################################################## kdde.truncate <- function(fhat, boundary) { ##if (class(x) %in% "kdde") fhat <- x ##else fhat <- kdde(x=x, ...) ## reallocate any probability mass outside of map boundary regions ## to interior regions fhat.trunc <- fhat for (i in 1:length(fhat$estimate)) { truncate.ind <- array(mgcv::in.out(boundary, as.matrix(expand.grid(fhat$eval.points[[1]], fhat$eval.points[[2]]))), dim=dim(fhat$estimate[[i]])) fhat.trunc$estimate[[i]] <- fhat.trunc$estimate[[i]]*truncate.ind fhat.sum <- abs(sum(fhat$estimate[[i]]*head(apply(sapply(fhat$eval.points, diff), 1, prod), n=1))) fhat.trunc.sum <- abs(sum(fhat.trunc$estimate[[i]]*head(apply(sapply(fhat.trunc$eval.points, diff), 1, prod), n=1))) fhat.trunc$estimate[[i]] <- fhat.trunc$estimate[[i]]*fhat.sum/fhat.trunc.sum } if (length(fhat.trunc$cont)>0) fhat.trunc$cont <- contourLevels(fhat.trunc, cont=1:99, approx=TRUE) return(fhat.trunc) } ks/R/kfs.R0000644000176200001440000001526513257005563012015 0ustar liggesusers############################################################################### ### Feature significance for ultivariate kernel density stimate ############################################################################### kfs <- function(x, H, h, deriv.order=2, gridsize, gridtype, xmin, xmax, supp=3.7, eval.points, binned, bgridsize, positive=FALSE, adj.positive, w, verbose=FALSE, signif.level=0.05) { r <- deriv.order ## default values ksd <- ks.defaults(x=x, w=w, binned=binned, bgridsize=bgridsize, gridsize=gridsize) d <- ksd$d; n <- ksd$n; w <- ksd$w binned <- ksd$binned bgridsize <- ksd$bgridsize gridsize <- ksd$gridsize if (missing(h) & d==1) h <- hpi(x=x, nstage=2, binned=default.bflag(d=d, n=n), deriv.order=r) if (missing(H) & d>1) H <- Hpi(x=x, nstage=2-(d>2), binned=default.bflag(d=d, n=n), deriv.order=r, verbose=verbose) if (d==1) { fhatr <- kdde(x=x, h=h, deriv.order=r, gridsize=gridsize, gridtype=gridtype, xmin=xmin, xmax=xmax, supp=supp, eval.points=eval.points, binned=binned, bgridsize=bgridsize, w=w, deriv.vec=FALSE, verbose=verbose) fhat <- kde(x=x, h=h, gridsize=gridsize, gridtype=gridtype, xmin=min(fhatr$eval.points), xmax=max(fhatr$eval.points), binned=binned, bgridsize=bgridsize, positive=positive, adj.positive=adj.positive, w=w) fhat.est <- as.vector(fhat$estimate) fhatr.est <- as.vector(fhatr$estimate) RDrK <- (-1)^r*psins.1d(r=2*r, sigma=1) fhatr.Sigma <- n^(-1)* h^(-2*r-1)*RDrK fhatr.Sigma12 <- sqrt(fhatr.Sigma) fhatr.est <- fhatr.est/fhatr.Sigma12 local.mode <- fhatr.est <= 0 fhatr.wald <- fhatr.est^2 gs <- length(fhat$estimate) } else if (d>1) { ## KDE fhat <- kde(x=x, H=H, gridsize=gridsize, gridtype=gridtype, xmin=xmin, xmax=xmax, supp=supp, eval.points=eval.points, binned=binned, bgridsize=bgridsize, w=w, verbose=verbose) ## KDDE for r=2 fhatr <- kdde(x=x, H=H, deriv.order=r, gridsize=gridsize, gridtype=gridtype, xmin=xmin, xmax=xmax, supp=supp, eval.points=eval.points, binned=binned, bgridsize=bgridsize, w=w, deriv.vec=FALSE, verbose=verbose) fhat.est <- as.vector(fhat$estimate) fhatr.est <- sapply(fhatr$estimate, as.vector) ## convert from vec to vech because vec'ed derivative ## contains repeated columns so its variance isn't invertible Hinv <- chol2inv(chol(H)) Hinv12 <- matrix.sqrt(Hinv) RDrK <- (-1)^r*invvec(psins(r=2*r, Sigma=diag(d))) dupld <- dupl(d)$d dupld.MPinv <- chol2inv(chol(t(dupld)%*% dupld)) %*% t(dupld) fhatr.Sigma.const <- n^(-1)*det(H)^(-1/2)* Kpow(Hinv12,r) %*% RDrK %*% Kpow(Hinv12,2) fhatr.Sigma.const <- dupld.MPinv %*% fhatr.Sigma.const %*% t(dupld.MPinv) fhatr.Sigma.const12inv <- chol2inv(chol(matrix.sqrt(fhatr.Sigma.const))) fhatr.est <- fhatr.est %*% fhatr.Sigma.const12inv ## all eigenvalues < 0 => local mode fhatr.eigen <- lapply(lapply(seq(1,nrow(fhatr.est)), function(i) {invvech(fhatr.est[i,])}), eigen, only.values=TRUE) fhatr.eigen <- t(sapply(fhatr.eigen, getElement, "values")) local.mode <- apply(fhatr.eigen <= 0, 1, all) fhatr.wald <- apply(fhatr.est^2, 1, sum)/fhat.est gs <- dim(fhat$estimate) } ## Hochberg adjustment for sequential tests pval.wald <- 1 - pchisq(fhatr.wald, d*(d+1)/2) pval.wald[fhat.est<=contourLevels(fhat, cont=100)] <- NA pval.wald.ord <- pval.wald[order(pval.wald)] num.test <- sum(!is.na(pval.wald.ord)) if (num.test>=1) num.test.seq <- c(1:num.test, rep(NA, prod(gs) - num.test)) else num.test.seq <- rep(NA, prod(gs)) reject.nonzero <- ((pval.wald.ord <= signif.level/(num.test + 1 - num.test.seq)) &(pval.wald.ord > 0)) reject.nonzero.ind <- which(reject.nonzero) signif.wald <- array(FALSE, dim=gs) ## p-value == 0 => reject null hypotheses automatically signif.wald[which(pval.wald==0, arr.ind=TRUE)] <- TRUE ## p-value > 0 then reject null hypotheses indicated in reject.nonzero.ind for (i in reject.nonzero.ind) signif.wald[which(pval.wald==pval.wald.ord[i], arr.ind=TRUE)] <- TRUE ## ESS = effective sample size ##ess <- n*fhat$estimate*dmvnorm.mixt(x=rep(0,d), mu=rep(0,d), Sigma=H, props=1) ##signif.ess <- ess >= 5 signif.wald <- signif.wald & array(local.mode, dim=gs) & array(fhat.est>contourLevels(fhat, cont=99), dim=gs) fhatr$estimate <- signif.wald+0 ##fhatr$dens.estimate <- fhat.est class(fhatr) <- "kfs" return(fhatr) } plot.kfs <- function(x, display="filled.contour", col="orange", colors="orange", abs.cont, alphavec=0.4, add=FALSE, ...) { fhatr <- x fhatr$deriv.order <- NULL class(fhatr) <- "kde" if (is.vector(fhatr$H)) d <- 1 else d <- ncol(fhatr$H) if (d==1) { fhat <- kde(x=fhatr$x) plot(fhat, col="grey", add=add, ...) gridsize <- length(fhatr$estimate) sc.ind <- which(fhatr$estimate==1) sc.len <- length(sc.ind) sc.ind.diff <- diff(sc.ind) jump.ind <- which(sc.ind.diff!=1) jump.num <- length(jump.ind) if (jump.num==0) lines(fhat$eval.points[sc.ind], fhat$estimate[sc.ind],col=col, ...) if (jump.num > 0) { curr.ind <- sc.ind[1:jump.ind[1]] lines(fhat$eval.points[curr.ind], fhat$estimate[curr.ind], col=col, ...) if (jump.num > 1) { for (j in 2:length(jump.num)) { curr.ind <- sc.ind[(jump.ind[j-1]+1):jump.ind[j]] lines(fhat$eval.points[curr.ind], fhat$estimate[curr.ind], col=col, ...) } } curr.ind <- sc.ind[(max(jump.ind)+1):sc.len] lines(fhat$eval.points[curr.ind], fhat$estimate[curr.ind], col=col, ...) } } else if (d==2) { if (missing(abs.cont)) abs.cont <- 0.5 disp1 <- match.arg(display, c("slice", "persp", "image", "filled.contour", "filled.contour2")) if (disp1=="filled.contour2") col <- c("transparent", col) if (disp1=="filled.contour") { col.fun <- function(n){return(c("transparent", rep("orange",n)))} plot(fhatr, abs.cont=abs.cont, drawlabels=FALSE, col.fun=col.fun, add=add, display=display, ...) } else plot(fhatr, abs.cont=abs.cont, drawlabels=FALSE, col=col, add=add, display=display, ...) } else if (d==3) { if (missing(abs.cont)) abs.cont <- 0.25 plot(fhatr, abs.cont=abs.cont, colors=colors, alphavec=alphavec, add=add, ...) } invisible() } ks/R/deconv-kde.R0000644000176200001440000000566113267061670013252 0ustar liggesusers###################################################################### ## Deconvolution KDE ###################################################################### dckde <- function(...) {return (kdcde(...)) } kdcde <- function(x, H, h, Sigma, sigma, reg, bgridsize, gridsize, binned, verbose=FALSE, ...) { ## default values ksd <- ks.defaults(x=x, binned=binned, bgridsize=bgridsize, gridsize=gridsize) d <- ksd$d; n <- ksd$n ##if (missing(binned)) binned <- ksd$binned ##if (missing(bgridsize)) bgridsize <- ksd$bgridsize ##if (missing(gridsize)) gridsize <- ksd$gridsize binned <- ksd$binned gridsize <- ksd$gridsize bgridsize <- ksd$bgridsize x <- as.matrix(x) if (d==1 & missing(h)) h <- hpi(x=x, nstage=2, binned=default.bflag(d=d, n=n), deriv.order=0) if (d>1 & missing(H)) H <- Hpi(x=x, nstage=2, binned=default.bflag(d=d, n=n), deriv.order=0) if (d==1) stop("d=1 not yet implemented for dckde.") if (missing(reg)) reg <- reg.ucv(x=x, H=H, h=h, Sigma=Sigma, sigma=sigma, k=5, d=d, binned=binned, verbose=verbose) ## Deconvolution KDE is weighted KDE with non-uniform weights w <- dckde.weights(x=x, H=H, Sigma=Sigma, reg=reg) fhat <- kde(x=x, H=H, w=w, binned=binned, bgridsize=bgridsize, gridsize=gridsize) fhat$reg <- reg return(fhat) } ## Weights for deconvolution KDE ## Code adapted from DeconWK 0.6-5 ## Author B. Turlach ## R-forge website: https://r-forge.r-project.org/R/?group_id=630 dckde.weights <- function(x, Sigma, H, reg) { n <- nrow(x) d <- ncol(x) Qmat <- matrix(0, ncol=n, nrow=n) bvec <- rep(0, n) for (j in 1:n) { Qmat[j,] <- dmvnorm.mixt(x, mus=x[j,], Sigmas=2*H + 2*Sigma, props=1) bvec[j] <- sum(dmvnorm.mixt(x, mus=x[j,], Sigmas=2*H + Sigma, props=1)) } if(!missing(reg)) diag(Qmat) <- diag(Qmat) + reg/n bvec <- bvec/n val <- kernlab::ipop(c=-bvec, H=Qmat, A=rep(1,n), b=1, r=0, l=rep(0,n), u=rep(1, n)) w <- kernlab::primal(val) w <- w/sum(w)*n return(w) } ## Unbiased k-fold cross validation choice of regularisation penalty (gamma) reg.ucv <- function(x, H, h, Sigma, sigma, k=5, d, binned=FALSE, verbose=FALSE) { if (d>1) gamma.ucv.temp <- function(gamma) { return(-reg.ucv.val(x=x, H=H, Sigma=Sigma, k=k, reg=gamma^2, binned=binned)) } gamma.val <- nlm(f=gamma.ucv.temp, p=0.1, print.level=2*as.numeric(verbose))$estimate^2 return(gamma.val) } ## k-fold UCV value for regularisation penalty reg.ucv.val <- function(x, Sigma, H, reg, k=5, binned=FALSE) { n <- nrow(x) n.seq <- block.indices(n, n, npergroup=round(n/k)) cv.val <- 0 for (j in 1:(length(n.seq)-1)) { iind <- n.seq[j]:(n.seq[j+1]-1) w <- dckde.weights(x=x[-iind,], H=H, Sigma=Sigma, reg=reg) fhat <- kde(x=x[-iind,], H=H+Sigma, w=w, binned=binned) cv.val <- cv.val + sum(predict(fhat, x=x[iind,])) } return(cv.val) } ks/R/kcde.R0000644000176200001440000005636213353244063012140 0ustar liggesusers##################################################################### ## Kernel estimators of the multivariate cdf (cumulative distribution function) ##################################################################### kcde <- function(x, H, h, gridsize, gridtype, xmin, xmax, supp=3.7, eval.points, binned, bgridsize, positive=FALSE, adj.positive, w, verbose=FALSE, tail.flag="lower.tail") { ## default values ksd <- ks.defaults(x=x, w=w, binned=binned, bgridsize=bgridsize, gridsize=gridsize) d <- ksd$d; n <- ksd$n; w <- ksd$w binned <- ksd$binned gridsize <- ksd$gridsize bgridsize <- ksd$bgridsize tail.flag1 <- match.arg(tail.flag, c("lower.tail", "upper.tail")) ## KCDE is computed as cumulative Riemann sum of KDE on a grid if (d==1) { if (missing(h) & !positive) h <- hpi.kcde(x=x, binned=default.bflag(d=d, n=n)) Fhat <- kde(x=x, h=h, gridsize=gridsize, gridtype=gridtype, xmin=xmin, xmax=xmax, supp=supp, binned=binned, bgridsize=bgridsize, positive=positive, adj.positive=adj.positive, w=w) diffe <- abs(diff(Fhat$eval.points)) if (tail.flag1=="lower.tail") Fhat$estimate <- c(0, diffe) * cumsum(Fhat$estimate) else Fhat$estimate <- c(diffe[1], diffe) * (sum(Fhat$estimate) - cumsum(Fhat$estimate)) } else if (d==2) { if (missing(H) & !positive) H <- Hpi.kcde(x=x, binned=default.bflag(d=d, n=n), bgridsize=bgridsize, verbose=FALSE) Fhat <- kde(x=x, H=H, gridsize=gridsize, gridtype=gridtype, xmin=xmin, xmax=xmax, supp=supp, binned=binned, bgridsize=bgridsize, w=w, verbose=verbose) diffe1 <- abs(diff(Fhat$eval.points[[1]])) diffe2 <- abs(diff(Fhat$eval.points[[2]])) if (tail.flag1=="lower.tail") { Fhat$estimate <- apply(Fhat$estimate, 1, cumsum)*c(0,diffe1) Fhat$estimate <- apply(t(Fhat$estimate), 2, cumsum)*c(0,diffe2) } else { Fhatsum <- matrix(apply(Fhat$estimate, 1, sum), ncol=ncol(Fhat$estimate), nrow=nrow(Fhat$estimate), byrow=TRUE) Fhat$estimate <- (Fhatsum-apply(Fhat$estimate, 1, cumsum))*c(diffe1[1], diffe1) Fhatsum <- matrix(apply(Fhat$estimate, 1, sum), ncol=ncol(Fhat$estimate), nrow=nrow(Fhat$estimate), byrow=TRUE) Fhat$estimate <- (Fhatsum-apply(t(Fhat$estimate), 2, cumsum))*c(diffe2[1], diffe2) } } else if (d==3) { if (missing(H) & !positive) H <- Hpi.kcde(x=x, binned=default.bflag(d=d, n=n), bgridsize=bgridsize, verbose=FALSE) Fhat <- kde(x=x, H=H, gridsize=gridsize, gridtype=gridtype, xmin=xmin, xmax=xmax, supp=supp, binned=binned, bgridsize=bgridsize, w=w, verbose=verbose) Fhat.temp <- Fhat$estimate diffe1 <- abs(diff(Fhat$eval.points[[1]])) diffe2 <- abs(diff(Fhat$eval.points[[2]])) diffe3 <- abs(diff(Fhat$eval.points[[3]])) if (tail.flag1=="lower.tail") { for (i in 1:dim(Fhat$estimate)[3]) { Fhat.temp[,,i] <- apply(Fhat.temp[,,i], 1, cumsum)*c(0,diffe1) Fhat.temp[,,i] <- apply(t(Fhat.temp[,,i]), 2, cumsum)*c(0,diffe2) } for (i in 1:dim(Fhat$estimate)[1]) for (j in 1:dim(Fhat$estimate)[2]) Fhat.temp[i,j,] <- cumsum(Fhat.temp[i,j,])*c(0,diffe3) Fhat$estimate <- Fhat.temp } else { for (i in 1:dim(Fhat$estimate)[3]) { Fhatsum <- matrix(apply(Fhat.temp[,,i], 1, sum), ncol=ncol(Fhat.temp), nrow=nrow(Fhat.temp), byrow=TRUE) Fhat.temp[,,i] <- (Fhatsum-apply(Fhat.temp[,,i], 1, cumsum))*c(diffe1[1], diffe1) Fhatsum <- matrix(apply(Fhat.temp[,,i], 1, sum), ncol=ncol(Fhat.temp), nrow=nrow(Fhat.temp), byrow=TRUE) Fhat.temp[,,i] <- (Fhatsum-apply(t(Fhat.temp[,,i]), 2, cumsum))*c(diffe2[1],diffe2) } for (i in 1:dim(Fhat$estimate)[1]) for (j in 1:dim(Fhat$estimate)[2]) { Fhatsum <- sum(Fhat.temp[i,j,]) Fhat.temp[i,j,] <- (Fhatsum-cumsum(Fhat.temp[i,j,]))*c(diffe3[1],diffe3) } Fhat$estimate <- Fhat.temp } } ## normalise max CDF estimate equal to 1 Fhat$estimate <- Fhat$estimate/max(Fhat$estimate) if (!missing(eval.points)) { if (d<=3) { Fhat$estimate <- predict(Fhat, x=eval.points) Fhat$eval.points <- eval.points } else { Fhat <- kcde.points(x=x, H=H, eval.points=eval.points, w=w, verbose=verbose, tail.flag=tail.flag1) } } Fhat$tail <- tail.flag1 class(Fhat) <- "kcde" return(Fhat) } ## KCDE is computed at specified estimation points kcde.points <- function(x, H, eval.points, w, verbose=FALSE, tail.flag="lower.tail") { n <- nrow(x) if (verbose) pb <- txtProgressBar() Fhat <- rep(0, nrow(eval.points)) pmvnorm.temp <- function(x, ...) { return(pmvnorm(mean=x, ...)) } for (i in 1:nrow(eval.points)) { if (verbose) setTxtProgressBar(pb, i/(nrow(eval.points)-1)) if (tail.flag=="lower.tail") Fhat[i] <- sum(apply(x, 1, pmvnorm.temp, upper=eval.points[i,], sigma=H)) else Fhat[i] <- sum(apply(x, 1, pmvnorm.temp, lower=eval.points[i,], sigma=H)) } Fhat <- Fhat/n if (verbose) close(pb) return(list(x=x, eval.points=eval.points, estimate=Fhat, H=H, gridded=FALSE, binned=FALSE, names=NULL, w=w)) } ##################################################################### ## Plotting functions for 1-d to 3-d KCDE ##################################################################### plot.kcde <- function(x, ...) { Fhat <- x if (is.vector(Fhat$x)) plotkcde.1d(Fhat, ...) else { d <- ncol(Fhat$x) if (d==2) { opr <- options()$preferRaster; if (!is.null(opr)) if (!opr) options("preferRaster"=TRUE) plotret <- plotkcde.2d(Fhat, ...) if (!is.null(opr)) options("preferRaster"=opr) invisible(plotret) } else if (d==3) { plotkcde.3d(Fhat, ...) invisible() } else stop ("kde.plot function only available for 1, 2 or 3-d data") } } plotkcde.1d <- function(Fhat, xlab, ylab="Distribution function", add=FALSE, drawpoints=FALSE, col=1, col.pt="blue", jitter=FALSE, ...) { if (missing(xlab)) xlab <- Fhat$names if (Fhat$tail=="upper.tail") zlab <- "Survival function" if (add) lines(Fhat$eval.points, Fhat$estimate, xlab=xlab, ylab=ylab, col=col, ...) else plot(Fhat$eval.points, Fhat$estimate, type="l", xlab=xlab, ylab=ylab, col=col, ...) if (drawpoints) if (jitter) rug(jitter(Fhat$x), col=col.pt) else rug(Fhat$x, col=col.pt) } plotkcde.2d <- function(Fhat, display="persp", cont=seq(10,90, by=10), abs.cont, xlab, ylab, zlab="Distribution function", cex=1, pch=1, add=FALSE, drawpoints=FALSE, drawlabels=TRUE, theta=-30, phi=40, d=4, col.pt="blue", col, col.fun, lwd=1, border=NA, thin=1, ...) { disp1 <- match.arg(display, c("slice", "persp", "image", "filled.contour", "filled.contour2")) if (!is.list(Fhat$eval.points)) stop("Needs a grid of density estimates") if (missing(xlab)) xlab <- Fhat$names[1] if (missing(ylab)) ylab <- Fhat$names[2] if (Fhat$tail=="upper.tail") zlab <- "Survival function" ## perspective/wireframe plot if (disp1=="persp") { hts <- seq(0, 1.1*max(Fhat$estimate), length=500) if (missing(col)) col <- grey(seq(0,0.9, length=length(hts)+1)) ## rev(heat.colors(length(hts)+1)) # #if (length(col)<100) col <- rep(col, length=100) if (missing(col)) col <- topo.colors(length(hts)+1) if (!missing(col.fun)) col <- col.fun(length(hts)+1) if (length(col)0) contour(Fhat$eval.points[[1]], Fhat$eval.points[[2]], Fhat$estimate*scale, level=hts[i]*scale, add=TRUE, drawlabels=drawlabels, col=col[i], lwd=lwd, ...) } ## add points if (drawpoints) points(Fhat$x[,1], Fhat$x[,2], col=col.pt, cex=cex, pch=pch) } ## image plot else if (disp1=="image") { if (missing(col)) col <- rev(heat.colors(100)) image(Fhat$eval.points[[1]], Fhat$eval.points[[2]], Fhat$estimate, xlab=xlab, ylab=ylab, add=add, col=col, ...) box() } else if (disp1=="filled.contour" | disp1=="filled.contour2") { hts <- cont/100 if (!missing(col.fun)) col <- col.fun(length(hts)+1) if (missing(col)) col <- c("transparent", rev(heat.colors(length(hts)))) clev <- c(-0.01*max(abs(Fhat$estimate)), hts, max(c(Fhat$estimate, hts)) + 0.01*max(abs(Fhat$estimate))) if (disp1=="filled.contour2") { image(Fhat$eval.points[[1]], Fhat$eval.points[[2]], Fhat$estimate, xlab=xlab, ylab=ylab, add=add, col=col[1:(length(hts)+1)], breaks=clev, ...) ## draw contours for (i in 1:length(hts)) contour(Fhat$eval.points[[1]], Fhat$eval.points[[2]], Fhat$estimate, level=hts[i], add=TRUE, drawlabels=FALSE, col=col[i+1], lwd=7) if (!missing(lwd)) { for (i in 1:length(hts)) { if (missing(abs.cont)) scale <- cont[i]/hts[i] else scale <- 1 if (lwd >=1) contour(Fhat$eval.points[[1]], Fhat$eval.points[[2]], Fhat$estimate*scale, level=hts[i]*scale, add=TRUE, drawlabels=drawlabels, col=1, lwd=lwd, ...) } } ## add points if (drawpoints) points(Fhat$x[,1], Fhat$x[,2], col=col.pt, cex=cex, pch=pch) } else { if (tail(hts, n=1) < max(Fhat$estimate)) hts <- c(hts, max(Fhat$estimate)) filled.contour(Fhat$eval.points[[1]], Fhat$eval.points[[2]], Fhat$estimate, xlab=xlab, ylab=ylab, levels=hts, ...) } } if (disp1=="persp") invisible(plotret) else invisible() } plotkcde.3d <- function(Fhat, cont=c(25,50,75), colors, alphavec, size=3, col.pt="blue", add=FALSE, xlab, ylab, zlab, drawpoints=FALSE, alpha=1, box=TRUE, axes=TRUE, ...) { ## suggestions from Viktor Petukhov 08/03/2018 if (!requireNamespace("rgl", quietly=TRUE)) stop("Install the rgl package as it is required.", call.=FALSE) if (!requireNamespace("misc3d", quietly=TRUE)) stop("Install the misc3d package as it is required.", call.=FALSE) hts <- sort(cont/100) nc <- length(hts) if (missing(colors)) colors <- rev(heat.colors(nc)) if (missing(xlab)) xlab <- Fhat$names[1] if (missing(ylab)) ylab <- Fhat$names[2] if (missing(zlab)) zlab <- Fhat$names[3] if (missing(alphavec)) alphavec <- seq(0.5,0.1,length=nc) if (drawpoints) rgl::plot3d(Fhat$x[,1],Fhat$x[,2],Fhat$x[,3], size=size, col=col.pt, alpha=alpha, xlab=xlab, ylab=ylab, zlab=zlab, add=add, box=FALSE, axes=FALSE, ...) else rgl::plot3d(Fhat$x[,1],Fhat$x[,2],Fhat$x[,3], type="n", xlab=xlab, ylab=ylab, zlab=zlab, add=add, box=FALSE, axes=FALSE, ...) rgl::bg3d(col="white") for (i in 1:nc) if (hts[nc-i+1] < max(Fhat$estimate)) misc3d::contour3d(Fhat$estimate, level=hts[nc-i+1], x=Fhat$eval.points[[1]], y=Fhat$eval.points[[2]], z=Fhat$eval.points[[3]], add=TRUE, color=colors[i], alpha=alphavec[i], box=FALSE, axes=FALSE, ...) if (box) rgl::box3d() if (axes) rgl::axes3d() } ##################################################################### ## Bandwidth selectors for KCDE ##################################################################### ### Normal scale bandwidth selectors hns.kcde <- function(x) { d <- 1 n <- length(x) #m1 <- 0.2820948 sigma <- sd(x) hns <- 4^(1/3)*sigma*n^(-1/3) return(hns) } Hns.kcde <- function(x) { if (is.vector(x)) {return(hns.kcde(x)^2)} d <- ncol(x) n <- nrow(x) m1 <- (4*pi)^(-1/2) Jd <- matrix(1, ncol=d, nrow=d) Sigma <- var(x) Hns <- (4*det(Sigma)^(1/2)*tr(matrix.sqrt(Sigma))/tr(Sigma))^(2/3)*Sigma*n^(-2/3) return(Hns) } ## Plug-in bandwidth selector hpi.kcde <- function(x, nstage=2, binned, amise=FALSE) { n <- length(x) d <- 1 if (missing(binned)) binned <- default.bflag(d,n) K2 <- dnorm.deriv(x=0, mu=0, sigma=1, deriv.order=2) K4 <- dnorm.deriv(x=0, mu=0, sigma=1, deriv.order=4) m2 <- 1 m1 <- (4*pi)^(-1/2) ## formula for bias annihliating bandwidths from Wand & Jones (1995, p.70) if (nstage==2) { psi6.hat <- psins.1d(r=6, sigma=sd(x)) gamse4 <- (2*K4/(-m2*psi6.hat*n))^(1/(4+3)) psi4.hat <- kfe.1d(x=x, g=gamse4, deriv.order=4, inc=1, binned=binned) gamse2 <- (2*K2/(-m2*psi4.hat*n))^(1/(2+3)) psi2.hat <- kfe.1d(x=x, g=gamse2, deriv.order=2, inc=1, binned=binned) } else { psi4.hat <- psins.1d(r=4, sigma=sd(x)) gamse2 <- (2*K2/(-m2*psi4.hat*n))^(1/(2+3)) psi2.hat <- kfe.1d(x=x, g=gamse2, deriv.order=2, inc=1, binned=binned) } ## formula form Polansky & Baker (2000) h <- (2*m1/(-m2^2*psi2.hat*n))^(1/3) if (amise) PI <- -2*n^(-1)*m1*h - 1/4*psi2.hat*h^4 if (!amise) return(h) else return(list(h=h, PI=PI)) } Hpi.kcde <- function(x, nstage=2, pilot, Hstart, binned, bgridsize, amise=FALSE, verbose=FALSE, optim.fun="optim") { n <- nrow(x) d <- ncol(x) m1 <- (4*pi)^(-1/2) Jd <- matrix(1, ncol=d, nrow=d) if (missing(binned)) binned <- default.bflag(d,n) if(!is.matrix(x)) x <- as.matrix(x) if (missing(pilot)) pilot <- "dunconstr" pilot1 <- match.arg(pilot, c("dunconstr", "dscalar")) if (pilot1=="dscalar") stop("Use dunconstr pilot for Hpi.kcde since pre-scaling approaches are not valid") D2K0 <- t(dmvnorm.deriv(x=rep(0,d), mu=rep(0,d), Sigma=diag(d), deriv.order=2)) if (nstage==2) { ## stage 1 psi4.ns <- psins(r=4, Sigma=var(x), deriv.vec=TRUE) amse2.temp <- function(vechH) { H <- invvech(vechH) %*% invvech(vechH) Hinv <- chol2inv(chol(H)) Hinv12 <- matrix.sqrt(Hinv) amse2.val <- 1/(det(H)^(1/2)*n)*((Hinv12 %x% Hinv12) %*% D2K0) + 1/2* t(vec(H) %x% diag(d^2)) %*% psi4.ns return(sum(amse2.val^2)) } Hstart2 <- matrix.sqrt(Gns(r=2, n=n, Sigma=var(x))) optim.fun1 <- match.arg(optim.fun, c("nlm", "optim")) if (optim.fun1=="nlm") { result <- nlm(p=vech(Hstart2), f=amse2.temp, print.level=2*as.numeric(verbose)) H2 <- invvech(result$estimate) %*% invvech(result$estimate) } else { result <- optim(vech(Hstart2), amse2.temp, method="BFGS", control=list(trace=as.numeric(verbose))) H2 <- invvech(result$par) %*% invvech(result$par) } psi2.hat <- kfe(x=x, G=H2, deriv.order=2, add.index=FALSE, binned=binned, bgridsize=bgridsize, verbose=verbose) } else { psi2.hat <- psins(r=2, Sigma=var(x), deriv.vec=TRUE) H2 <- Gns(r=2, n=n, Sigma=var(x)) } if (missing(Hstart)) Hstart <- Hns.kcde(x=x) ##Fhat.pilot <- kcde(x=x, H2) ##VF <- sum(Fhat.pilot$estimate*(1-Fhat.pilot$estimate)*prod(sapply(Fhat.pilot$eval, diff)[1,])) ## stage 2 amise.temp <- function(vechH) { H <- invvech(vechH) %*% invvech(vechH) H12 <- matrix.sqrt(H) amise.val <- -2*n^(-1)*m1*tr(H12) - 1/4*t(vec(H %*% H)) %*% psi2.hat ##amise.val <- -2*n^(-1)*m1*sum(vech(H12)) - 1/4*t(vec(H %*% H)) %*% psi2.hat return(drop(amise.val)) } Hstart <- matrix.sqrt(Hstart) optim.fun1 <- match.arg(optim.fun, c("optim", "nlm")) if (optim.fun1=="nlm") { result <- nlm(p=vech(Hstart), f=amise.temp, print.level=2*as.numeric(verbose)) H <- invvech(result$estimate) %*% invvech(result$estimate) amise.star <- result$minimum } else { result <- optim(vech(Hstart), amise.temp, method="BFGS", control=list(trace=as.numeric(verbose))) H <- invvech(result$par) %*% invvech(result$par) amise.star <- result$value } if (!amise) return(H) else return(list(H=H, PI=amise.star)) } Hpi.diag.kcde <- function(x, nstage=2, pilot, Hstart, binned=FALSE, bgridsize, amise=FALSE, verbose=FALSE, optim.fun="optim") { n <- nrow(x) d <- ncol(x) m1 <- (4*pi)^(-1/2) Jd <- matrix(1, ncol=d, nrow=d) if (missing(binned)) binned <- default.bflag(d,n) if(!is.matrix(x)) x <- as.matrix(x) if (missing(pilot)) pilot <- "dscalar" pilot1 <- match.arg(pilot, c("dunconstr", "dscalar")) if (pilot1=="dunconstr") stop("Use dscalar pilot for Hpi.diag.kcde since pre-sphering approaches are not valid") D2K0 <- t(dmvnorm.deriv(x=rep(0,d), mu=rep(0,d), Sigma=diag(d), deriv.order=2)) if (nstage==2) { ## stage 1 psi4.ns <- psins(r=4, Sigma=var(x), deriv.vec=TRUE) amse2.temp <- function(diagH) { H <- diag(diagH) %*% diag(diagH) Hinv <- chol2inv(chol(H)) Hinv12 <- matrix.sqrt(Hinv) amse2.val <- 1/(det(H)^(1/2)*n)*((Hinv12 %x% Hinv12) %*% D2K0) + 1/2* t(vec(H) %x% diag(d^2)) %*% psi4.ns return(sum(amse2.val^2)) } Hstart2 <- matrix.sqrt(Gns(r=2, n=n, Sigma=var(x))) optim.fun1 <- match.arg(optim.fun, c("optim", "nlm")) if (optim.fun1=="nlm") { result <- nlm(p=diag(Hstart2), f=amse2.temp, print.level=2*as.numeric(verbose)) H2 <- diag(result$estimate) %*% diag(result$estimate) } else { result <- optim(diag(Hstart2), amse2.temp, method="BFGS", control=list(trace=as.numeric(verbose))) H2 <- diag(result$par) %*% diag(result$par) } psi2.hat <- kfe(x=x, G=H2, deriv.order=2, add.index=FALSE, binned=binned, bgridsize=bgridsize, verbose=verbose) } else psi2.hat <- psins(r=2, Sigma=var(x), deriv.vec=TRUE) if (missing(Hstart)) Hstart <- Hns.kcde(x=x) ## stage 2 amise.temp <- function(diagH) { H <- diag(diagH) %*% diag(diagH) H12 <- matrix.sqrt(H) amise.val <- -2*n^(-1)*m1*tr(H12) - 1/4*t(vec(H %*% H)) %*% psi2.hat return(drop(amise.val)) } Hstart <- matrix.sqrt(Hstart) optim.fun1 <- match.arg(optim.fun, c("optim", "nlm")) if (optim.fun1=="nlm") { result <- nlm(p=diag(Hstart), f=amise.temp, print.level=2*as.numeric(verbose)) H <- diag(result$estimate) %*% diag(result$estimate) amise.star <- result$minimum } else { result <- optim(diag(Hstart), amise.temp, method="BFGS", control=list(trace=as.numeric(verbose))) H <- diag(result$par) %*% diag(result$par) amise.star <- result$value } if (!amise) return(H) else return(list(H=H, PI=amise.star)) } ##################################################################### ## Multivariate kernel ROC estimators ##################################################################### kroc <- function(x1, x2, H1, h1, hy, gridsize, gridtype, xmin, xmax, supp=3.7, eval.points, binned, bgridsize, positive=FALSE, adj.positive, w, verbose=FALSE) { if (is.vector(x1)) {d <- 1; n1 <- length(x1)} else {d <- ncol(x1); n1 <- nrow(x1); x1 <- as.matrix(x1); x2 <- as.matrix(x2)} if (!missing(eval.points)) stop("eval.points in kroc not yet implemented") if (d==1) { if (missing(h1)) h1 <- hpi.kcde(x=x1, binned=default.bflag(d=d, n=n1)) Fhatx1 <- kcde(x=x1, h=h1, gridsize=gridsize, gridtype=gridtype, xmin=xmin, xmax=xmax, supp=supp, binned=binned, bgridsize=bgridsize, positive=positive, adj.positive=adj.positive, w=w, tail.flag="upper.tail") } else { if (missing(H1)) H1 <- Hpi.kcde(x=x1, binned=default.bflag(d=d, n=n1), verbose=verbose) Fhatx1 <- kcde(x=x1, H=H1, gridsize=gridsize, gridtype=gridtype, xmin=xmin, xmax=xmax, supp=supp, binned=binned, bgridsize=bgridsize, w=w, tail.flag="upper.tail", verbose=verbose) } ## transform from [0,1] to reals y1 <- predict(Fhatx1, x=x1) y2 <- predict(Fhatx1, x=x2) y1 <- qnorm(y1[y1>0]) y2 <- qnorm(y2[y2>0]) if (missing(hy)) hy <- hpi.kcde(y2, binned=default.bflag(d=1, n=n1)) Fhaty2 <- kcde(x=y2, h=hy, binned=TRUE, xmin=min(y1,y2)-3.7*hy, xmax=max(y1,y2)+3.7*hy) Fhaty1 <- kcde(x=y1, h=hy, binned=TRUE, xmin=min(y1,y2)-3.7*hy, xmax=max(y1,y2)+3.7*hy) Fhaty1$eval.points <- pnorm(Fhaty1$eval.points) Fhaty2$eval.points <- pnorm(Fhaty2$eval.points) Rhat <- Fhaty1 Rhat$eval.points <- Fhaty1$estimate Rhat$estimate <- Fhaty2$estimate if (d==1) {Rhat$h1 <- h1; Rhat$H1 <- h1^2; Rhat$hy <- hy} else {Rhat$H1 <- H1; Rhat$hy <- hy} ## Use spline to smooth out transformed ROC curve Rhat.smoothed <- smooth.spline(Rhat$eval.points, Rhat$estimate, spar=0.5) Rhat.smoothed <- predict(Rhat.smoothed, x=seq(0,1,length=length(Rhat$eval.points))) Rhat$eval.points <- Rhat.smoothed$x Rhat$estimate <- Rhat.smoothed$y ## add (0,0) and (1,1) as endpoints if (head(Rhat$eval.points, n=1)!=0) Rhat$eval.points[1] <- 0 if (head(Rhat$estimate, n=1)!=0) Rhat$estimate[1] <- 0 if (tail(Rhat$eval.points, n=1)!=1) Rhat$eval.points[length(Rhat$eval.points)] <- 1 if (tail(Rhat$estimate, n=1)!=1) Rhat$estimate[length(Rhat$estimate)] <- 1 Rhat$estimate[Rhat$estimate>1] <- 1 Rhat$estimate[Rhat$estimate<0] <- 0 Rhat$indices <- indices.kroc(Rhat) Rhat <- Rhat[-c(4,5)] class(Rhat) <- "kroc" return(Rhat) } ### summary measure of ROC curves indices.kroc <- function(Rhat) { auc <- sum(abs((head(Rhat$estimate, n=-1) - tail(Rhat$estimate, n=-1)))*abs(diff(Rhat$eval.points))/2 + head(Rhat$estimate, n=-1)*abs(diff(Rhat$eval.points))) youden.val <- Rhat$estimate - Rhat$eval.points if (max(youden.val)>0.001) { youden.ind <- which.max(youden.val) youden <- youden.val[youden.ind] LR <- list(minus=(1-Rhat$estimate[youden.ind])/(1-Rhat$eval.points[youden.ind]), plus=Rhat$estimate[youden.ind]/Rhat$eval.points[youden.ind]) } else LR <- list(minus=1, plus=1) return(list(auc=auc, youden=max(youden.val), LR=LR)) } ## plot method plot.kroc <- function(x, add=FALSE, add.roc.ref=FALSE, ylab="True positive rate (sensitivity)", xlab= expression("False positive rate"~~group("(", list(bar(specificity)), ")")), ...) { Rhat <- x if (add) lines(Rhat$eval.points, Rhat$estimate, ...) else plot(Rhat$eval.points, Rhat$estimate, type="l", ylab=ylab, xlab=xlab, ...) if (is.vector(Rhat$x[[1]])) d <- 1 else d <- ncol(Rhat$x[[1]]) if (add.roc.ref) { z <- seq(0,1, length=401) kind <- 0:(d-1) roc.indep <- 0 for (k in kind) roc.indep <- roc.indep + z*(-log(z))^k/factorial(k) lines(z, roc.indep, lty=2, col="grey") } } ############################################################################# ## summary method ############################################################################# summary.kroc <- function(object, ...) { cat("Summary measures for ROC curve\nAUC =", signif(object$indices$auc, ...), "\n") cat("Youden index =", signif(object$indices$youden, ...), "\n") cat(paste("(LR-, LR+) = (", signif(object$indices$LR$minus, ...), ", ", signif(object$indices$LR$plus, ...),")\n\n",sep="")) } ############################################################################# ## predict methods ############################################################################# predict.kcde <- function(object, ..., x) { return(predict.kde(object=object, ..., x=x, zero.flag=FALSE)) } predict.kroc <- function(object, ..., x) { return(predict.kde(object=object, ..., x=x, zero.flag=FALSE)) } ks/R/vkde.R0000644000176200001440000001635713237347067012174 0ustar liggesusers###################################################################### ## Balloon variable KDE ###################################################################### kde.balloon <- function(x, H, h, gridsize, gridtype, xmin, xmax, supp=3.7, eval.points, binned, bgridsize, w, compute.cont=TRUE, approx.cont=TRUE, verbose=FALSE) { if (is.vector(x)) { if (missing(H)) {d <- 1; n <- length(x)} else { if (is.vector(H)) { d <- 1; n <- length(x)} else {x <- matrix(x, nrow=1); d <- ncol(x); n <- nrow(x)} } } else {d <- ncol(x); n <- nrow(x)} if (!missing(w)) if (!(identical(all.equal(sum(w), n), TRUE))) { warning("Weights don't sum to sample size - they have been scaled accordingly\n") w <- w*n/sum(w) } if (missing(w)) w <- rep(1,n) if (d==1) { if (missing(h)) h <- hns(x=x, deriv.order=2) } if (missing(H) & d>1) { H <- Hns(x=x, deriv.order=2) ##Hpi(x=x, binned=default.bflag(d=d, n=n), bgridsize=bgridsize, verbose=verbose, deriv.order=2) } if (d==2) fhat <- kde.balloon.2d(x=x, H=H, gridsize=gridsize, gridtype=gridtype, xmin=xmin, xmax=xmax, supp=supp, eval.points=eval.points, binned=binned, bgridsize=bgridsize, w=w, compute.cont=compute.cont, approx.cont=approx.cont, verbose=verbose) else stop("d!=1 not yet implemented.") if (compute.cont) fhat$cont <- contourLevels(fhat, cont=1:99, approx=approx.cont) return(fhat) } ###################################################################### ## Bivariate balloon variable KDE ###################################################################### kde.balloon.2d <- function(x, H, gridsize, gridtype, xmin, xmax, supp=3.7, eval.points, binned, bgridsize, w, compute.cont=TRUE, approx.cont=TRUE, verbose=FALSE) { d <- ncol(x) n <- nrow(x) fhat <- kde(x=x, H=H, gridsize=gridsize, gridtype=gridtype, xmin=xmin, xmax=xmax, supp=supp, eval.points=eval.points, binned=binned, bgridsize=bgridsize, w=w, compute.cont=compute.cont, approx.cont=approx.cont) fhat.ep <- expand.grid(fhat$eval.points) fhat.pilot <- fhat fhat2.pilot <- kdde(x=x, deriv.order=2, H=H, gridsize=gridsize, gridtype=gridtype, xmin=xmin, xmax=xmax, supp=supp, eval.points=eval.points, binned=binned, bgridsize=bgridsize, w=w) h.pi <- (d*predict(fhat.pilot, x=fhat.ep)/drop((4*pi)^(d/2)*predict(fhat2.pilot, x=fhat.ep) %*% vec(diag(d)))^2)^(1/(d+4))*n^(-1/(d+4)) h.pi <- array(h.pi, dim=dim(fhat$estimate)) gs <- dim(fhat$estimate) if (verbose) { pb <- txtProgressBar(max=prod(gs)); k <- 0 } fhat$estimate <- array(0, dim=dim(fhat$estimate)) for (i in 1:gs[2]) for (j in 1:gs[1]) { if (!is.na(h.pi[i,j]) & !is.infinite(h.pi[i,j])) if (h.pi[i,j]>0) fhat$estimate[i,j] <- kde(x=x, w=w, H=h.pi[i,j]^2*diag(d), eval.points=fhat.ep[i+(j-1)*gs[1],])$estimate if (verbose) { k <- k+1; setTxtProgressBar(pb,k) } } if (verbose) close(pb) delta.int <- prod(sapply(fhat$eval.points, diff)[1,]) riemann.sum <- sum(fhat$estimate*delta.int) fhat.estimate <- fhat$estimate/riemann.sum fhat$H <- h.pi^2 return(fhat) } ###################################################################### ## Sample point variable KDE ###################################################################### kde.sp <- function(x, H, h, gridsize, gridtype, xmin, xmax, supp=3.7, eval.points, binned, bgridsize, w, compute.cont=TRUE, approx.cont=TRUE, verbose=FALSE) { if (is.vector(x)) { if (missing(H)) {d <- 1; n <- length(x)} else { if (is.vector(H)) { d <- 1; n <- length(x)} else {x <- matrix(x, nrow=1); d <- ncol(x); n <- nrow(x)} } } else {d <- ncol(x); n <- nrow(x)} if (!missing(w)) if (!(identical(all.equal(sum(w), n), TRUE))) { warning("Weights don't sum to sample size - they have been scaled accordingly\n") w <- w*n/sum(w) } if (missing(w)) w <- rep(1,n) if (d==1) { if (missing(h)) h <- hns(x=x, deriv.order=4) } if (missing(H) & d>1) { H <- Hns(x=x, deriv.order=4) } if (d==2) fhat <- kde.sp.2d(x=x, H=H, gridsize=gridsize, gridtype=gridtype, xmin=xmin, xmax=xmax, supp=supp, eval.points=eval.points, binned=binned, bgridsize=bgridsize, w=w, compute.cont=compute.cont, approx.cont=approx.cont, verbose=verbose) else stop("d!=2 not yet implemented.") if (compute.cont) fhat$cont <- contourLevels(fhat, cont=1:99, approx=approx.cont) return(fhat) } ###################################################################### ## Bivariate sample point variable KDE ###################################################################### kde.sp.2d <- function(x, H, gridsize, gridtype, xmin, xmax, supp=3.7, eval.points, binned, bgridsize, w, compute.cont=TRUE, approx.cont=TRUE, verbose=FALSE) { d <- 2 n <- nrow(x) fhat <- kde(x=x, H=H, gridsize=gridsize, gridtype=gridtype, xmin=xmin, xmax=xmax, supp=supp, eval.points=eval.points, binned=binned, bgridsize=bgridsize, w=w, compute.cont=compute.cont, approx.cont=approx.cont) fhat.pilot <- fhat fhat1.pilot <- kdde(x=x, deriv.order=1, H=H, gridsize=gridsize, gridtype=gridtype, xmin=xmin, xmax=xmax, supp=supp, eval.points=eval.points, binned=binned, bgridsize=bgridsize, w=w) fhat2.pilot <- kdde(x=x, deriv.order=2, H=H, gridsize=gridsize, gridtype=gridtype, xmin=xmin, xmax=xmax, supp=supp, eval.points=eval.points, binned=binned, bgridsize=bgridsize, w=w) fhat3.pilot <- kdde(x=x, deriv.order=3, H=H, gridsize=gridsize, gridtype=gridtype, xmin=xmin, xmax=xmax, supp=supp, eval.points=eval.points, binned=binned, bgridsize=bgridsize, w=w) fhat4.pilot <- kdde(x=x, deriv.order=4, H=H, gridsize=gridsize, gridtype=gridtype, xmin=xmin, xmax=xmax, supp=supp, eval.points=eval.points, binned=binned, bgridsize=bgridsize, w=w) fhat.pilot <- predict(fhat.pilot, x=x) fhat1.pilot <- predict(fhat1.pilot, x=x) fhat2.pilot <- predict(fhat2.pilot, x=x) fhat3.pilot <- predict(fhat3.pilot, x=x) fhat4.pilot <- predict(fhat4.pilot, x=x) lambda1 <- 1/fhat.pilot^5*rowKpow(fhat1.pilot, r=4) lambda2 <- 1/fhat.pilot^4*rowKpow(fhat2.pilot, fhat1.pilot, r=1, s=2) lambda3 <- 1/fhat.pilot^3*rowKpow(fhat2.pilot, r=2) lambda4 <- 1/fhat.pilot^3*rowKpow(fhat3.pilot, fhat1.pilot, r=1, s=1) lambda5 <- 1/fhat.pilot^2*fhat4.pilot lambda <- drop((24*lambda1 - 36*lambda2 + 6*lambda3 + 8*lambda4 - 2*lambda5) %*% Sdr(d,r=4) %*% (vec(diag(d)) %x% vec(diag(d)))) RK <- (4*pi)^(-d/2) h.Ab <- (8*d*RK*fhat.pilot^(1+d/2)/lambda^2)^(-1/(d+8))*n^(-1/(d+8)) fhat$estimate <- array(0, dim=dim(fhat$estimate)) xmin <- sapply(fhat$eval.points, min) xmax <- sapply(fhat$eval.points, max) if (verbose) { pb <- txtProgressBar(max=n) } for (i in 1:n) { if (verbose) setTxtProgressBar(pb, n) fhat$estimate <- fhat$estimate + kde(x=matrix(x[i,], nrow=1), H=h.Ab[i]^2*diag(d), xmin=xmin, xmax=xmax, binned=binned, gridsize=dim(fhat$estimate), bgridsize=dim(fhat$estimate))$estimate } if (verbose) close(pb) fhat$estimate <- fhat$estimate/n fhat$H <- h.Ab^2 return(fhat) } ks/R/kfe.R0000644000176200001440000002222713254556071011775 0ustar liggesusers ############################################################################# ## Kernel functional estimation ############################################################################# kfe <- function(x, G, deriv.order, inc=1, binned, bin.par, bgridsize, deriv.vec=TRUE, add.index=TRUE, verbose=FALSE) { r <- deriv.order d <- ncol(x) n <- nrow(x) if (missing(binned)) binned <- default.bflag(d, n) psir <- dmvnorm.deriv.sum(x=x, Sigma=G, deriv.order=r, inc=inc, binned=binned, bin.par=bin.par, bgridsize=bgridsize, deriv.vec=deriv.vec, verbose=verbose, kfe=TRUE, add.index=FALSE) if (add.index) { ind.mat <- dmvnorm.deriv(x=rep(0,d), mu=rep(0,d), Sigma=diag(d), deriv.order=r, only.index=TRUE) if (deriv.vec) return(list(psir=psir, deriv.ind=ind.mat)) else return(list(psir=psir, deriv.ind=unique(ind.mat))) } else return(psir=psir) } kfe.1d <- function(x, g, deriv.order, inc=1, binned=TRUE, bin.par) { r <- deriv.order n <- length(x) psir <- dnorm.deriv.sum(x=x, sigma=g, deriv.order=r, inc=1, binned=binned, bin.par=bin.par, kfe=TRUE) if (inc==0) psir <- (n^2*psir - n*dnorm.deriv(0, mu=0, sigma=g, deriv.order=r))/(n*(n-1)) return(psir) } kfe.scalar <- function(x, g, deriv.order, inc=1, binned=TRUE, bin.par, verbose=FALSE) { r <- deriv.order d <- ncol(x) psir <- dmvnorm.deriv.scalar.sum(x=x, sigma=g, deriv.order=r, inc=inc, kfe=TRUE, binned=binned, bin.par=bin.par, verbose=verbose) return(psir) } ############################################################################### ## Plug-in unconstrained bandwidth for KFE ## ## Returns ## Plug-in bandwidth ############################################################################### hpi.kfe <- function(x, nstage=2, binned=FALSE, bgridsize, amise=FALSE, deriv.order=0) { n <- length(x) d <- 1 r <- deriv.order k <- 2 ## kernel order Kr0 <- dnorm.deriv(x=0, mu=0, sigma=1, deriv.order=r) mu2K <- 1 if (nstage==2) { psi4.hat <- psins.1d(r=r+k+2, sigma=sd(x)) gamse2 <- (factorial(r+2)*Kr0/(mu2K*psi4.hat*n))^(1/(r+k+3)) psi2.hat <- kfe.1d(x=x, g=gamse2, deriv.order=r+k, inc=1, binned=binned) } else { psi2.hat <- psins.1d(r=r+k, sigma=sd(x)) } ## formula for bias annihliating bandwidths from Wand & Jones (1995, p.70) gamse <- (factorial(r)*Kr0/(-mu2K*psi2.hat*n))^(1/(r+k+1)) return(gamse) } Hpi.kfe <- function(x, nstage=2, pilot, pre="sphere", Hstart, binned=FALSE, bgridsize, amise=FALSE, deriv.order=0, verbose=FALSE, optim.fun="optim") { if (deriv.order!=0) stop("Currently only deriv.order=0 is implemented") n <- nrow(x) d <- ncol(x) r <- deriv.order if (missing(pilot)) pilot <- "dscalar" if(!is.matrix(x)) x <- as.matrix(x) pilot1 <- match.arg(pilot, c("dunconstr", "dscalar")) pre1 <- match.arg(pre, c("scale", "sphere")) optim.fun1 <- match.arg(optim.fun, c("nlm", "optim")) if (pre1=="scale") { x.star <- pre.scale(x) S12 <- diag(sqrt(diag(var(x)))) Sinv12 <- chol2inv(chol(S12)) } else if (pre1=="sphere") { x.star <- pre.sphere(x) S12 <- matrix.sqrt(var(x)) Sinv12 <- chol2inv(chol(S12)) } D2K0 <- t(dmvnorm.deriv(x=rep(0,d), mu=rep(0,d), Sigma=diag(d), deriv.order=2)) K0 <- dmvnorm.deriv(x=rep(0,d), mu=rep(0,d), Sigma=diag(d), deriv.order=0) if (nstage==2) { ## stage 1 if (pilot1=="dscalar") { psi4.ns <- psins(r=r+4, Sigma=var(x.star), deriv.vec=TRUE) ##h2 <- gdscalar(x=x.star, d=d, r=r-2, n=n, verbose=verbose, nstage=nstage, scv=FALSE) ## gdscalar not used because it's an implicit computation without ## symmetriser matrices and is slower than direct computation with ## symmetriser matrices. A1 <- drop(t(D2K0) %*% D2K0) A2 <- drop(t(D2K0) %*% t(vec(diag(d)) %x% diag(d^2)) %*% psi4.ns) A3 <- drop(t(psi4.ns) %*% (vec(diag(d)) %*% t(vec(diag(d))) %x% diag(d^2)) %*% psi4.ns) ## Special case from Chacon & Duong (2009): bias minimisation ##h2 <- ((4*d+8)*A1/(-d*A2 + sqrt(d^2*A2^2 + (8*d+16)*A1*A3)))^(1/(d+4))*n^(-1/(d+4)) ## Special from Chacon & Duong (2009): bias annihilation h2 <- (-A1/(2*A2*n))^(1/(d+4)) H2 <- h2^2*diag(d) psi2.hat <- kfe(x=x.star, G=H2, deriv.order=r+2, add.index=FALSE, binned=binned, bgridsize=bgridsize, verbose=verbose) } else if (pilot1=="dunconstr") { psi4.ns <- psins(r=r+4, Sigma=var(x), deriv.vec=TRUE) amse2.temp <- function(vechH) { H <- invvech(vechH) %*% invvech(vechH) Hinv <- chol2inv(chol(H)) Hinv12 <- matrix.sqrt(Hinv) amse2.temp <- 1/(det(H)^(1/2)*n)*((Hinv12 %x% Hinv12) %*% D2K0) + 1/2* t(vec(H) %x% diag(d^2)) %*% psi4.ns return(sum((amse2.temp)^2)) } Hstart2 <- matrix.sqrt(Gns(r=r+2, n=n, Sigma=var(x))) if (optim.fun1=="nlm") { result <- nlm(p=vech(Hstart2), f=amse2.temp, print.level=2*as.numeric(verbose)) H2 <- invvech(result$estimate) %*% invvech(result$estimate) } else if (optim.fun1=="optim") { result <- optim(vech(Hstart2), amse2.temp, method="BFGS", control=list(trace=as.numeric(verbose))) H2 <- invvech(result$par) %*% invvech(result$par) } psi2.hat <- kfe(x=x, G=H2, deriv.order=r+2, add.index=FALSE, binned=binned, bgridsize=bgridsize, verbose=verbose) } } else { if (pilot1=="dscalar") psi2.hat <- psins(r=r+2, Sigma=var(x.star), deriv.vec=TRUE) else if (pilot1=="dunconstr") psi2.hat <- psins(r=r+2, Sigma=var(x), deriv.vec=TRUE) } if (pilot1=="dscalar") {if (missing(Hstart)) Hstart <- Gns(r=r, n=n, Sigma=var(x.star))} else if (pilot1=="dunconstr") {if (missing(Hstart)) Hstart <- Gns(r=r, n=n, Sigma=var(x))} ## stage 2 amse.temp <- function(vechH) { H <- invvech(vechH) %*% invvech(vechH) amse.val <- 1/(det(H)^(1/2)*n)*K0 + 1/2* t(vec(H)) %*% psi2.hat return(sum((amse.val^2))) } Hstart <- matrix.sqrt(Hstart) if (optim.fun1=="nlm") { result <- nlm(p=vech(Hstart), f=amse.temp, print.level=2*as.numeric(verbose)) H <- invvech(result$estimate) %*% invvech(result$estimate) amise.star <- result$minimum } else if (optim.fun1=="optim") { result <- optim(vech(Hstart), amse.temp, method="BFGS", control=list(trace=as.numeric(verbose))) H <- invvech(result$par) %*% invvech(result$par) amise.star <- result$value } ## back-transform if (pilot1=="dscalar") H <- S12 %*% H %*% S12 if (!amise) return(H) else return(list(H=H, PI=amise.star)) } ############################################################################### ## Plug-in diagonal bandwidth for KFE ## ## Returns ## Plug-in bandwidth ############################################################################### Hpi.diag.kfe <- function(x, nstage=2, pilot, pre="scale", Hstart, binned=FALSE, bgridsize, amise=FALSE, deriv.order=0, verbose=FALSE, optim.fun="optim") { if (deriv.order!=0) stop("Currently only dervi.order=0 is implemented") n <- nrow(x) d <- ncol(x) r <- deriv.order D2K0 <- t(dmvnorm.deriv(x=rep(0,d), mu=rep(0,d), Sigma=diag(d), deriv.order=2)) K0 <- dmvnorm.deriv(x=rep(0,d), mu=rep(0,d), Sigma=diag(d), deriv.order=0) if (missing(pilot)) pilot <- "dscalar" pilot1 <- match.arg(pilot, c("dunconstr", "dscalar")) pre1 <- match.arg(pre, c("scale", "sphere")) optim.fun1 <- match.arg(optim.fun, c("nlm", "optim")) if (pre1=="sphere") stop("Using pre-sphering won't give diagonal bandwidth matrix") if (pilot1=="dunconstr") stop("Unconstrained pilot selectors are not suitable for Hpi.diag.kfe") if (pre1=="scale") { x.star <- pre.scale(x) S12 <- diag(sqrt(diag(var(x)))) Sinv12 <- chol2inv(chol(S12)) } if (nstage==2) { ## stage 1 psi4.ns <- psins(r=r+4, Sigma=var(x.star), deriv.vec=TRUE) if (pilot1=="dscalar") { ## h2 is on pre-transformed data scale A1 <- drop(t(D2K0) %*% D2K0) A2 <- drop(t(D2K0) %*% t(vec(diag(d)) %x% diag(d^2)) %*% psi4.ns) A3 <- drop(t(psi4.ns) %*% (vec(diag(d)) %*% t(vec(diag(d))) %x% diag(d^2)) %*% psi4.ns) h2 <- ((4*d+8)*A1/(-d*A2 + sqrt(d^2*A2^2 + (8*d+16)*A1*A3)))^(1/(d+4))*n^(-1/(d+4)) H2 <- h2^2*diag(d) } psi2.hat <- kfe(x=x.star, G=H2, deriv.order=r+2, add.index=FALSE, binned=binned, bgridsize=bgridsize, verbose=verbose) } else psi2.hat <- psins(r=r+2, Sigma=var(x.star), deriv.vec=TRUE) ## stage 2 amse.temp <- function(diagH) { H <- diag(diagH) %*% diag(diagH) amse.val <- 1/(det(H)^(1/2)*n)*K0 + 1/2* t(vec(H)) %*% psi2.hat return(sum((amse.val^2))) } if (missing(Hstart)) Hstart <- Hns(x=x.star, deriv.order=r) Hstart <- matrix.sqrt(Hstart) if (optim.fun1=="nlm") { result <- nlm(p=diag(Hstart), f=amse.temp, print.level=2*as.numeric(verbose)) H <- diag(result$estimate) %*% diag(result$estimate) amise.star <- result$minimum } else if (optim.fun1=="optim") { result <- optim(diag(Hstart), amse.temp, method="BFGS", control=list(trace=as.numeric(verbose))) H <- diag(result$par) %*% diag(result$par) amise.star <- result$value } ## back-transform if (pilot1=="dscalar") H <- S12 %*% H %*% S12 if (!amise) return(H) else return(list(H=H, PI=amise.star)) } ks/R/prelim.R0000644000176200001440000005417413257006055012521 0ustar liggesusers############################################################################## ## Parse variable name ############################################################################ parse.name <-function(x) { if (is.vector(x)) { d <- 1 x.names <- deparse(substitute(x)) } else { d <- ncol(x) x.names <- colnames(x) if (is.null(x.names)) { x.names <- strsplit(deparse(substitute(x)), "\\[")[[1]][1] x.names <- paste(x.names, "[, ", 1:d,"]",sep="") } } return(x.names) } ############################################################################# ## Basic vectors and matrices and their operations ############################################################################# ## Vec operator vec <- function(x, byrow=FALSE) { if (is.vector(x)) return (x) if (byrow) x <- t(x) d <- ncol(x) vecx <- vector() for (j in 1:d) vecx <- c(vecx, x[,j]) return(vecx) } ## Vech operator vech <- function(x) { if (is.vector(x)) { if (length(x)==1) return (x) else stop("vech undefined for vectors") } else if (is.matrix(x)) { d <- ncol(x) if (d!=nrow(x)) ##if (!isSymmetric(x)) stop("vech only defined for square matrices") vechx <- vector() for (j in 1:d) vechx <- c(vechx, x[j:d,j]) return(vechx) } } ## Inverse vec operator invvec <- function(x, ncol, nrow, byrow=FALSE) { if (length(x)==1) return(x) d <- sqrt(length(x)) if (missing(ncol) | missing(nrow)) { ncol <- d; nrow <- d if (round(d) != d) stop("Need to specify nrow and ncol for non-square matrices") } invvecx <- matrix(0, nrow = nrow, ncol = ncol) if (byrow) for (j in 1:nrow) invvecx[j,] <- x[c(1:ncol) + (j-1)*ncol] else for (j in 1:ncol) invvecx[,j] <- x[c(1:nrow) + (j-1)*nrow] return(invvecx) } ## Inverse vech operator invvech <- function(x) { if (length(x)==1) return(x) d <- (-1 + sqrt(8*length(x) + 1))/2 if (round(d) != d) stop("Number of elements in x will not form a square matrix") invvechx <- matrix(0, nrow=d, ncol=d) for (j in 1:d) invvechx[j:d,j] <- x[1:(d-j+1)+ (j-1)*(d - 1/2*(j-2))] invvechx <- invvechx + t(invvechx) - diag(diag(invvechx)) return(invvechx) } ## Trace of matrix tr <- function(A) { count <- 0 if (is.vector(A)) return (A[1]) if (nrow(A)!=ncol(A)) stop("Not square matrix") else for (i in 1:nrow(A)) count <- count + A[i,i] return(count) } ## Elementary vector elem <- function(i, d) { elem.vec <- rep(0, d) elem.vec[i] <- 1 return(elem.vec) } ## Commutation matrix (taken from MCMCglmmm library) comm <- function(m,n){ K<-matrix(0,m*n, m*n) H<-matrix(0,m,n) for(i in 1:m){ for(j in 1:n){ H[i,j]<-1 K<-K+kronecker(H,t(H)) H[i,j]<-0 } } return(K) } ############################################################################### ## Duplication matrix ## Taken from Felipe Osorio http://www.ime.usp.br/~osorio/files/dupl.q ############################################################################### dupl <- function(order, ret.q = FALSE) { ## call cl <- match.call() time1 <- proc.time() if (!is.integer(order)) order <- as.integer(order) n <- order - 1 ## initial duplication matrix d1 <- matrix(0, nrow = 1, ncol = 1) d1[1,1] <- 1 if (!is.integer(d1)) storage.mode(d1) <- "integer" ## recursive formula if (n > 0){ for (k in 1:n){ drow <- 2*k + 1 + nrow(d1) dcol <- k + 1 + ncol(d1) d2 <- matrix(0, nrow = drow, ncol=dcol) storage.mode(d2) <- "integer" d2[1,1] <- 1 d2[2:(k+1),2:(k+1)] <- diag(k) d2[(k+2):(2*k+1),2:(k+1)] <- diag(k) d2[(2*k+2):drow,(k+2):dcol] <- d1 ## permutation matrix q <- permute.mat(k) ## new duplication matrix d2 <- q %*% d2 storage.mode(d2) <- "integer" d1 <- d2 } } else { d2 <- q <- d1 } ## results obj <- list(call=cl, order=order, d=d2) if (ret.q) obj$q <- q obj$time <- proc.time() - time1 obj } ############################################################################### ## Pre-scaling ## Parameters ## x - data points ## ## Returns ## Pre-scaled x values ############################################################################### pre.scale <- function(x, mean.centred=FALSE) { S <- diag(diag(var(x))) Sinv12 <- matrix.sqrt(chol2inv(chol(S))) if (mean.centred) x.scaled <- sweep(x, 2, apply(x, 2, mean)) else x.scaled <- x x.scaled <- x.scaled %*% Sinv12 return (x.scaled) } ############################################################################### ## Pre-sphering ## Parameters ## x - data points ## ## Returns ## Pre-sphered x values ############################################################################### pre.sphere <- function(x, mean.centred=FALSE) { S <- var(x) Sinv12 <- matrix.sqrt(chol2inv(chol(S))) if (mean.centred) x.sphered <- sweep(x, 2, apply(x, 2, mean)) else x.sphered <- x x.sphered <- x.sphered %*% Sinv12 return (x.sphered) } ############################################################################## ## Boolean functions ############################################################################### is.even <- function(x) { y <- x[x>0] %%2 return(identical(y, rep(0, length(y)))) } is.diagonal <- function(x) { return(identical(diag(diag(x)),x)) } ############################################################################### ## Finds row index matrix ## Parameters ## x - data points ## ## Returns ## i - if r==mat[i,] ## NA - otherwise ############################################################################### which.mat <- function(r, mat) { ind <- numeric() for (i in 1:nrow(mat)) if (identical(r, mat[i,])) ind <- c(ind,i) return(ind) } ################################################################### ## Permutation functions ################################################################### #################################################################### ## Exactly the same function as combinat:::permn #################################################################### permn.ks <- function (x, fun = NULL, ...) { if (is.numeric(x) && length(x) == 1 && x > 0 && trunc(x) == x) x <- seq(x) n <- length(x) nofun <- is.null(fun) out <- vector("list", gamma(n + 1)) p <- ip <- seqn <- 1:n d <- rep(-1, n) d[1] <- 0 m <- n + 1 p <- c(m, p, m) i <- 1 use <- -c(1, n + 2) while (m != 1) { out[[i]] <- if (nofun) x[p[use]] else fun(x[p[use]], ...) i <- i + 1 m <- n chk <- (p[ip + d + 1] > seqn) m <- max(seqn[!chk]) if (m < n) d[(m + 1):n] <- -d[(m + 1):n] index1 <- ip[m] + 1 index2 <- p[index1] <- p[index1 + d[m]] p[index1 + d[m]] <- m tmp <- ip[index2] ip[index2] <- ip[m] ip[m] <- tmp } out } ########################################################################## ## Permutations with repetitions of the first d naturals (1:d) taking ## k elements at a time. There are d^k of them, each having length k ## => We arrange them into a matrix of order d^k times k ## Each row represents one permutation ## Second version: filling in the matrix comlumn-wise (slightly faster) ########################################################################## perm.rep<-function(d,r) { if(r==0){PM<-1} if(r>0){ PM<-matrix(nrow=d^r,ncol=r) for(pow in 0:(r-1)){ t2<-d^pow p1<-1 while(p1<=d^r){ for(al in 1:d){for(p2 in 1:t2){ PM[p1,r-pow]<-al p1<-p1+1}}}} } return(PM) } ############################################################################### ## Permute a list of values ## ## Same function as EXPAND.GRID (base package), modified to take ## list as an argument and returns a matrix ############################################################################### permute <- function (args) { nargs <- length(args) if (!nargs) return(as.data.frame(list())) if (nargs == 1 && is.list(a1 <- args[[1]])) nargs <- length(args <- a1) if (nargs <= 1) return(as.data.frame(if (nargs == 0 || is.null(args[[1]])) list() else args, optional = TRUE)) cargs <- args rep.fac <- 1 orep <- prod(sapply(args, length)) for (i in 1:nargs) { x <- args[[i]] nx <- length(x) orep <- orep/nx cargs[[i]] <- rep(rep(x, rep(rep.fac, nx)), orep) rep.fac <- rep.fac * nx } do.call("cbind", cargs) } permute.mat <- function(order) { m <- as.integer(order) m <- m + 1 eye <- diag(m) u1 <- eye[1:m,1] u2 <- eye[1:m,2:m] q1 <- kronecker(eye, u1) q2 <- kronecker(eye, u2) q <- matrix(c(q1, q2), nrow = nrow(q2), ncol = ncol(q1) + ncol(q2)) if (!is.integer(q)) storage.mode(q) <- "integer" q } ########################################################################## ### pinv.all generates all the permutations PR_{d,r} as described in ### Appendix B of Chacon and Duong (2014) ########################################################################## pinv.all<-function(d,r){ i<-1:d^r n<-i-1 dpow<-d^(0:r) n.mat<-matrix(rep(n,r+1),byrow=FALSE,nrow=d^r,ncol=r+1) dpow.mat<-matrix(rep(dpow,d^r),byrow=TRUE,nrow=d^r,ncol=r+1) ndf.mat<-floor(n.mat/dpow.mat) ans<-ndf.mat[,r:1]-d*ndf.mat[,(r+1):2] return(ans+1) } ############################################################################## ## Block indices for double sums ############################################################################## block.indices <- function(nx, ny, d, r=0, diff=FALSE, block.limit=1e6, npergroup) { if (missing(npergroup)) { if (diff) npergroup <- max(c(block.limit %/% (nx*d^r), 1)) else npergroup <- max(c(block.limit %/% nx,1)) } nseq <- seq(1, ny, by=npergroup) if (tail(nseq,n=1) <= ny) nseq <- c(nseq, ny+1) if (length(nseq)==1) nseq <- c(1, ny+1) return(nseq) } block.indices2 <- function(nx, ny, block.limit=1e6, npergroup) { if (missing(npergroup)) npergroup <- max(c(block.limit %/% nx,1)) nseq <- seq(1, ny, by=npergroup) if (tail(nseq,n=1) <= ny) nseq <- c(nseq, ny+1) if (length(nseq)==1) nseq <- c(1, ny+1) return(nseq) } #################################################################### ## Differences for double sums calculations #################################################################### differences <- function(x, y, upper=FALSE, ff=FALSE, Kpow=0) { if (missing(y)) y <- x if (is.vector(x)) x <- t(as.matrix(x)) if (is.vector(y)) y <- t(as.matrix(y)) nx <- nrow(x) ny <- nrow(y) d <- ncol(x) if (ff) difs <- ff(init=0, dim=c(nx*ny,d)) else difs <- matrix(ncol=d,nrow=nx*ny) for (j in 1:d) { difs[,j] <- rep(x[,j], times=ny) - rep(y[1:ny,j], each=nx) ## jth column of difs contains all the differences X_{ij}-Y_{kj} } if (upper) { ind.remove <- numeric() for (j in 1:(nx-1)) ind.remove <- c(ind.remove, (j*nx+1):(j*nx+j)) return(difs[-ind.remove,]) } else return(difs) } ##### Odd factorial OF<-function(m){factorial(m)/(2^(m/2)*factorial(m/2))} ############################################################################### ## Matrix square root - taken from Stephen Lake ## http://www5.biostat.wustl.edu/s-news/s-news-archive/200109/msg00067.html ############################################################################### matrix.sqrt <- function(A) { if (length(A)==1) return(sqrt(A)) sva <- svd(A) if (min(sva$d)>=0) Asqrt <- sva$u %*% diag(sqrt(sva$d)) %*% t(sva$v) else stop("Matrix square root is not defined") return(Asqrt) } ############################################################################### ## Matrix power ############################################################################### matrix.pow <- function(A, n) { if (nrow(A)!=ncol(A)) stop("A must be a square matrix") if (floor(n)!=n) stop("n must be an integer") if (n==0) return(diag(ncol(A))) if (n < 0) return(matrix.pow(A=chol2inv(chol(A)), n=-n)) # trap non-integer n and return an error if (n == 1) return(A) result <- diag(1, ncol(A)) while (n > 0) { if (n %% 2 != 0) { result <- result %*% A n <- n - 1 } A <- A %*% A n <- n / 2 } return(result) } ########################################################################## ### Kmat computes the commutation matrix of orders m,n ########################################################################## Kmat<-function(m,n){ K<-matrix(0,ncol=m*n,nrow=m*n) i<-1:m;j<-1:n rows<-rowSums(expand.grid((i-1)*n,j)) cols<-rowSums(expand.grid(i,(j-1)*m)) positions<-cbind(rows,cols) K[positions]<-1 return(K) } ########################################################################## ### mat.Kprod computes row-wise Kronecker products of matrices ########################################################################## mat.Kprod<-function(U,V){ #### Returns a matrix with rows U[i,]%x%V[i,] n1<-nrow(U) n2<-nrow(V) if(n1!=n2)stop("U and V must have the same number of vectors") p<-ncol(U) q<-ncol(V) onep<-rep(1,p) oneq<-rep(1,q) P<-(U%x%t(oneq))*(t(onep)%x%V) return(P) } ########################################################################## ## Kpow computes the Kronecker power of a matrix A ########################################################################## Kpow<-function(A,pow){ if(floor(pow)!=pow)stop("pow must be an integer") Apow<-A if(pow==0){Apow<-1} if(pow>1){ for(i in 2:pow) Apow<-Apow%x%A } return(Apow) } #### Kronecker sum Ksum <- function(A,B) { AB <- numeric() for (i in 1:nrow(A)) for (j in 1:nrow(B)) AB <- rbind(AB, A[i,] + B[j,]) return(AB) } ############################################################################# ## Row-wise Kronecker product ############################################################################# rowKpow <- function(A,B,r=1,s=1) { A <- as.matrix(A) if (missing(B)) { res <- t(apply(t(A), 2, Kpow, r)) } else { B <- as.matrix(B) if (nrow(A)!=nrow(B)) stop("A and B must have same number of rows") res <- numeric() Ar <- t(apply(t(A), 2, Kpow, r)) Bs <- t(apply(t(B), 2, Kpow, s)) for (i in 1:ncol(Ar)) res <- cbind(res, apply(Bs, 2, FUN="*", Ar[,i])) } return(drop(res)) } getRow <- function(object, n) {return(object[n,])} #### Returns a matrix with the pow-th Kronecker power of A[i,] in the i-th row mat.Kpow<-function(A,pow){ Apow<-A if(pow==0){Apow<-matrix(1,nrow=nrow(A), ncol=1)} if(pow>1){ for(i in 2:pow) Apow<-mat.Kprod(Apow,A) } return(Apow) } #### Vector of all r-th partial derivatives of the normal density at x=0, i.e., D^{\otimes r)\phi(0) DrL0 <- function(d,r) { v <- as.vector(Kpow(A=vec(diag(d)),pow=r/2)) DL0<-(-1)^(r/2)*(2*pi)^(-d/2)*OF(r)*matrix(Sdrv(d=d, r=r, v=v), ncol=1) return(DL0) } ######################################################################### ### Wrapper functions for Chacon & Duong (2014) ########################################################################## Sdr<-function(d, r, type="recursive"){ type1 <- match.arg(type, c("recursive", "direct")) Sdr.mat <- do.call(paste("Sdr", type1, sep="."), list(d=d, r=r)) return(Sdr.mat) } Sdrv<-function(d, r, v, type="recursive"){ type1 <- match.arg(type, c("recursive", "direct")) v <- as.vector(v) Sdrvec <- do.call(paste("Sdrv", type1, sep="."), list(d=d, r=r, v=v)) return(Sdrvec) } ########################################################################## ## Symmetriser matrix ########################################################################## ############################################################################ ### Sdr.direct computes the symmetrizer matrix S_{d,r} based on Equation (4) ### as described in Section 3 of Chacon and Duong (2014) ############################################################################ Sdr.direct<-function(d,r){ S<-matrix(0,ncol=d^r,nrow=d^r) per<-permn.ks(r) per.rep<-pinv.all(d,r) nper<-factorial(r) nper.rep<-d^r per<-matrix(unlist(per), byrow=TRUE, ncol=r, nrow=nper) pow<-0:(r-1) dpow<-d^pow if(nper.rep<=nper){ dpow.mat<-matrix(rep(dpow,nper),byrow=TRUE,ncol=r,nrow=nper) for(i in 1:nper.rep){ ## Loop over no. perms with reps (d^r) pinvi<-per.rep[i,] sigpinvi<-matrix(pinvi[per],byrow=FALSE,nrow=nrow(per),ncol=ncol(per)) psigpinvi<-drop(1+rowSums((sigpinvi-1)*dpow.mat)) S[i,]<-tabulate(psigpinvi,nbins=d^r) }} if(nper=2){ Id<-diag(d) T<-Id A<-Kmat(d,d) for(j in 2:r){ T<-((j-1)/j)*(A%*%(T%x%Id)%*%A)+A/j S<-(S%x%Id)%*%T if(j1) { delta <- sapply(f.diff$eval.points, diff) delta <- rbind(head(delta, n=1), delta) if (d==2) riemann.sum <- sum(outer(delta[,1], delta[,2]) * f.diff$estimate) else if (d==3) riemann.sum <- sum(outer(outer(delta[,1], delta[,2]), delta[,3]) * f.diff$estimate) } return(riemann.sum) } ks.defaults <- function(x, w, binned, bgridsize, gridsize) { ## dimensions of x if (is.vector(x)) {d <- 1; n <- length(x)} else {d <- ncol(x); n <- nrow(x)} ## default uniform weights if (missing(w)) w <- rep(1,n) else if (!missing(w)) if (!(identical(all.equal(sum(w), n), TRUE))) { warning("Weights don't sum to sample size - they have been scaled accordingly\n") w <- w*n/sum(w) } ## default binning flag if (missing(binned)) binned <- default.bflag(d=d, n=n) ## default grid sizes if (missing(bgridsize)) { if (missing(gridsize)) bgridsize <- default.bgridsize(d) else bgridsize <- gridsize } if (missing(gridsize)) gridsize <- default.gridsize(d) if (length(gridsize)==1) gridsize <- rep(gridsize, d) if (length(bgridsize)==1) bgridsize <- rep(bgridsize, d) return(list(d=d, n=n, w=w, binned=binned, bgridsize=bgridsize, gridsize=gridsize)) } ks/R/kr.R0000644000176200001440000001533013267727431011645 0ustar liggesusers############################################################################### ## Multivariate kernel regression ############################################################################### kr <- function(x, y, H, h, gridsize, gridtype, xmin, xmax, supp=3.7, eval.points, binned, bgridsize, w, compute.cont=TRUE, approx.cont=TRUE, verbose=FALSE, xsupp.truncate=TRUE, reg.order=1) { ## default values ksd <- ks.defaults(x=x, w=w, binned=binned, bgridsize=bgridsize, gridsize=gridsize) d <- ksd$d; n <- ksd$n; w <- ksd$w binned <- ksd$binned bgridsize <- ksd$bgridsize gridsize <- ksd$gridsize if (is.data.frame(x)) x <- as.matrix(x) p <- reg.order if (d==1 & missing(h)) h <- hpi(x=x, binned=default.bflag(d=d, n=n)) if (d>1 & missing(H) & d>1) H <- Hpi(x=x, binned=default.bflag(d=d, n=n)) ## compute binned estimator if (binned) { stop("Binning not yet available.") } else { ## compute exact (non-binned) estimator ## 1-dimensional if (d==1) { ##if (missing(eval.points)) ##{ ## if (unit.interval) ## { ## mhat <- kr.unit.interval.1d(x=x, y=y, h=h, binned=FALSE, reg.order=p) ## } ## else ## mhat <- kr.grid.1d(x=x, y=y, h=h, gridsize=gridsize, supp=supp, positive=positive, xmin=xmin, xmax=xmax, adj.positive=adj.positive, gridtype=gridtype, w=w, reg.order=p) ## } ## else ## mhat <- kr.points.1d(x=x, y=y, h=h, eval.points=eval.points, positive=positive, adj.positive=adj.positive, w=w, reg.order=p) } ## multi-dimensional else { if (missing(eval.points)) { if (d==2) mhat <- kr.grid.2d(x=x, y=y, H=H, gridsize=gridsize, supp=supp, xmin=xmin, xmax=xmax, gridtype=gridtype, w=w, verbose=verbose, xsupp.truncate=xsupp.truncate, reg.order=p) ##else if (d == 3) ## mhat <- kr.grid.3d(x=x, y=y, H=H, gridsize=gridsize, supp=supp, xmin=xmin, xmax=xmax, gridtype=gridtype, w=w, verbose=verbose, reg.order=p) else stop("Need to specify eval.points for more than 3 dimensions") } ##else ## mhat <- kr.points(x=x, y=y, H=H, eval.points=eval.points, w=w, reg.order=p) } } mhat$binned <- binned mhat$names <- parse.name(x) ## add variable names mhat$w <- w class(mhat) <- "kr" ## compute prob contour levels if (compute.cont & missing(eval.points)) { mhat.temp <- mhat mhat.temp$estimate[is.na(mhat.temp$estimate)] <- -1e10 mhat$cont <- contourLevels(mhat.temp, cont=1:99, approx=approx.cont) } return(mhat) } kr.1d <- function(x, y, h, eval.points, reg.order=1) { n <- length(x) nsumy <- sum(y)/n wy <- y/nsumy if (missing(eval.points)) s0 <- kde(x=x, h=h) else s0 <- kde(x=x, h=h, eval.points=eval.points) fhat.wy <- kde(x=x, h=h, w=wy, eval.points=s0$eval.points) fhat.wy$estimate <- fhat.wy$estimate * nsumy mhat <- fhat.wy if (reg.order==0) { mhat$estimate <- mhat$estimate/s0$estimate } if (reg.order==1) { fhat1.wy <- kdde(x=x, h=h, w=wy, eval.points=s0$eval.points, deriv.order=1) fhat1.wy$estimate <- fhat1.wy$estimate * nsumy*h s1 <- -kdde(x=x, h=h, deriv.order=1, eval.points=s0$eval.points)$estimate*h s2 <- kdde(x=x, h=h, deriv.order=2, eval.points=s0$eval.points)$estimate*h^2 - s0$estimate mhat$estimate <- s2/(s2*s0$estimate-s1^2) * fhat.wy$estimate + s1/(s2*s0$estimate-s1^2) * fhat1.wy$estimate } return(mhat) } kr.grid.2d <- function(x, y, H, gridsize, supp, gridx=NULL, grid.pts=NULL, xmin, xmax, gridtype, w, verbose=FALSE, xsupp.truncate=FALSE, tol.zero=1e-3, reg.order=1) { p <- reg.order ## initialise grid n <- nrow(x) if (is.null(gridx)) gridx <- make.grid.ks(x, matrix.sqrt(H), tol=supp, gridsize=gridsize, xmin=xmin, xmax=xmax, gridtype=gridtype) mhat.grid <- matrix(0, nrow=length(gridx[[1]]), ncol=length(gridx[[2]])) if (verbose) pb <- txtProgressBar() eval.pts <- expand.grid(gridx[[1]], gridx[[2]]) eval.len <- nrow(eval.pts) if (xsupp.truncate) { fhat <- kde(x=x, binned=TRUE) fhat.cont <- contourLevels(fhat, cont=99, approx=TRUE) fhat.eval <- predict(fhat, x=eval.pts) } else { fhat.cont <- 0 fhat.eval <- rep(1, eval.len) } beta.hat <- rep(NA, length=eval.len) for (i in 1:eval.len) { if (fhat.eval[i]>fhat.cont) { eval.ptsi <- unlist(eval.pts[i,]) if (p==0) design.x <- rep(1, n) else if (p==1) design.x <- cbind(Inter=rep(1,n), sweep(x, 2, eval.ptsi)) W.x <- dmvnorm(x=x, mean=eval.ptsi, sigma=H) A <- t(design.x * W.x) b <- A %*% y A <- A %*% design.x detA <- det(A) if (!(is.infinite(detA) | is.na(detA))) if (detA > tol.zero) beta.hat[i] <- solve(A,b)[1] } if (verbose) setTxtProgressBar(pb, i/eval.len) } mhat.grid <- array(beta.hat, dim=gridsize) if (verbose) close(pb) gridx1 <- list(gridx[[1]], gridx[[2]]) mhat.list <- list(x=x, y=y, eval.points=gridx1, estimate=mhat.grid, H=H, gridtype=gridx$gridtype, gridded=TRUE, reg.order=p) return(mhat.list) } plot.kr <- function(x, display="rgl", col, col.fun, xlab, ylab, ...) { if (display!="rgl") plot.kdde(x=x, col=col, col.fun=col.fun, display=display, xlab=xlab, ylab=ylab, ...) else { ## suggestions from Viktor Petukhov 08/03/2018 if (!requireNamespace("rgl", quietly=TRUE)) stop("Install the rgl package as it is required.", call.=FALSE) if (missing(col.fun)) col.fun <- terrain.colors if (missing(col)) col <- terrain.colors(5)[2] col.table <- col.fun(round(diff(range(x$estimate, na.rm=TRUE)) + 1,0)) col <- col.table[x$estimate - min(x$estimate, na.rm=TRUE) + 1] if (missing(xlab)) xlab <- x$names[1] if (missing(ylab)) ylab <- x$names[2] rgl::persp3d(x$eval.points[[1]], x$eval.points[[2]], x$estimate, col=col, xlab=xlab, ylab=ylab, ...) } } contourLevels.kr <- function(x, ...) { mhat <- x mhat$estimate[is.na(mhat$estimate)] <- 0 mhat$deriv.order <- 1 mhat$deriv.ind <- matrix(1, ncol=1, nrow=1) mhat$estimate <- list(mhat$estimate) return(contourLevels.kdde(x=mhat,...)) } predict.kr <- function(object, ..., x) { mhat <- object mhat$estimate[is.na(mhat$estimate)] <- 0 return(predict.kde(object=mhat, ..., x=x)) } ks/R/kcopula.R0000644000176200001440000002150613265470004012656 0ustar liggesusers############################################################################# ## Kernel copula and copula density estimators ############################################################################# ## empirical pseudo-uniform transformation ## taken from pobs() function in copula package pseudo.unif.empirical <- function (x, y) ##, na.last="keep", ties.method="average") { if (missing(y)) y <- x if (is.vector(y)) y <- matrix(y, nrow=1) d <- ncol(x) u <- matrix(0, ncol=d, nrow=nrow(x)) for (i in 1:d) { ecdf.fun <- ecdf(x=x[,i]) u[,i] <- ecdf.fun(y[,i]) } return(u) ##return(apply(x, 2, rank, na.last=na.last, ties.method=ties.method)/(nrow(x) + 1)) } ## kernel pseudo-uniform transformation pseudo.unif.kernel <- function(x, y, hs, binned=TRUE) { if (missing(y)) y <- x if (is.vector(y)) y <- matrix(y, nrow=1) d <- ncol(x) u <- list() ##u.eval.points <- list() for (i in 1:d) { u[[i]] <- kcde(x=x[,i], h=hs[i], eval.points=y[,i], binned=binned) } u2 <- sapply(u, getElement, "estimate") return(u2) } ############################################################################# ## Kernel copula estimator ############################################################################# kcopula <- function(x, H, hs, gridsize, gridtype, xmin, xmax, supp=3.7, eval.points, binned, bgridsize, w, verbose=FALSE, marginal="kernel") { ksd <- ks.defaults(x=x, w=w, binned=binned, bgridsize=bgridsize, gridsize=gridsize) d <- ksd$d; n <- ksd$n; w <- ksd$w binned <- ksd$binned gridsize <- ksd$gridsize bgridsize <- ksd$bgridsize if (missing(H)) H <- Hpi.kcde(x=x, binned=default.bflag(d=d,n=n)) Fhat <- kcde(x=x, H=H, gridsize=gridsize, binned=binned, bgridsize=bgridsize, xmin=xmin, xmax=xmax, supp=supp, eval.points=eval.points, w=w, verbose=verbose, tail.flag="lower.tail") xlims <- sapply(Fhat$eval.points, range) xlims[1,] <- xlims[1,] - 0.1*abs(apply(xlims, 2, diff)) xlims[2,] <- xlims[2,] + 0.1*abs(apply(xlims, 2, diff)) ## generate pseudo-uniform values marginal1 <- match.arg(marginal, c("kernel", "empirical")) if (missing(hs)) { hs <- rep(0, d) for (i in 1:d) hs[i] <- hpi.kcde(x=x[,i], binned=TRUE) } if (marginal1=="kernel") { ## kernel pseudo-uniform u <- list() u.eval.points <- list() for (i in 1:d) { u.eval.points[[i]] <- kcde(x=x[,i], h=hs[i], eval.points=Fhat$eval.points[[i]], xmin=xlims[1,i], xmax=xlims[2,i], binned=TRUE) } y <- pseudo.unif.kernel(x=x, y=x, hs=hs, binned=TRUE) ep <- lapply(u.eval.points, getElement, "estimate") } else if (marginal1=="empirical") { ## empirical pseudo-uniform y <- pseudo.unif.empirical(x=x, y=x) ep <- numeric() for (i in 1:d) { f <- ecdf(x=x[,i]) ep <- c(ep, list(f(Fhat$eval.points[[i]]))) } } Chat <- Fhat Chat$x <- y ## sapply(u, getElement, "estimate") Chat$x.orig <- x Chat$eval.points <- ep ##lapply(u.eval.points, getElement, "estimate") Chat$hs <- hs ## loess smoothing on a uniform grid if (d==2) { ## select smaller grid for d==2 for memory usage reasons subselect <- round(cbind(seq(1,length(Chat$eval.points[[1]]), length=101), seq(1,length(Chat$eval.points[[2]]), length=101)),0) eval.points.df <- data.frame(expand.grid(Chat$eval.points[[1]][subselect[,1]], Chat$eval.points[[2]][subselect[,2]])) names(eval.points.df) <- paste("x", 1:ncol(eval.points.df), sep="") eval.points.df <- data.frame(estimate=as.numeric(Chat$estimate[subselect[,1], subselect[,2]]), eval.points.df) } else if (d==3) { ## select smaller grid for d==3 for memory usage reasons subselect <- round(cbind(seq(1,length(Chat$eval.points[[1]]), length=21), seq(1,length(Chat$eval.points[[2]]), length=21), seq(1,length(Chat$eval.points[[3]]), length=21)),0) eval.points.df <- data.frame(expand.grid(Chat$eval.points[[1]][subselect[,1]], Chat$eval.points[[2]][subselect[,2]], Chat$eval.points[[3]][subselect[,3]])) names(eval.points.df) <- paste("x", 1:ncol(eval.points.df), sep="") eval.points.df <- data.frame(estimate=as.numeric(Chat$estimate[subselect[,1], subselect[,2], subselect[,3]]), eval.points.df) } if (d==2) Chat.loess <- loess(estimate ~ x1+x2, data=eval.points.df, span=0.1) else if (d==3) Chat.loess <- loess(estimate ~ x1+x2+x3, data=eval.points.df, span=0.1) u.eval.points.regular <- list() for (i in 1:d) u.eval.points.regular[[i]] <- seq(0,1,length=length(Chat$eval.points[[i]])) u.eval.points.regular.df <- data.frame(expand.grid(u.eval.points.regular)) names(u.eval.points.regular.df) <- paste("x", 1:ncol(u.eval.points.regular.df), sep="") Chat.smoothed <- Chat Chat.smoothed$eval.points <- u.eval.points.regular Chat.smoothed$estimate <- array(predict(Chat.loess, newdata=u.eval.points.regular.df), dim=dim(Chat$estimate)) ## interpolate NA boundary values from loess smoothing gsdim <- dim(Chat$estimate) if (d==2) { Chat.smoothed$estimate[1,] <- 0 Chat.smoothed$estimate[gsdim[1],] <- Chat.smoothed$estimate[gsdim[1]-1,]*1.001 Chat.smoothed$estimate[,1] <-0 Chat.smoothed$estimate[,gsdim[2]] <- Chat.smoothed$estimate[,gsdim[2]-1]*1.001 Chat.smoothed$estimate[gsdim[1],gsdim[2]] <- 1 Chat.smoothed$estimate[Chat.smoothed$estimate>1] <- 1 } else if (d==3) { Chat.smoothed$estimate[,,1] <- 0 for (k in 2:(gsdim[3]-1)) { Chat.smoothed$estimate[,,k][1,] <- 0 Chat.smoothed$estimate[,,k][gsdim[1],] <- Chat.smoothed$estimate[,,k][gsdim[1]-1,]*1.001 Chat.smoothed$estimate[,,k][,1] <-0 Chat.smoothed$estimate[,,k][,gsdim[2]] <- Chat.smoothed$estimate[,,k][,gsdim[2]-1]*1.001 } Chat.smoothed$estimate[,,gsdim[3]] <- Chat.smoothed$estimate[,,gsdim[3]-1]*1.001 Chat.smoothed$estimate[gsdim[1],gsdim[2],gsdim[3]] <- 1 Chat.smoothed$estimate[Chat.smoothed$estimate>1] <- 1 } Chat <- Chat.smoothed Chat$marginal <- marginal1 class(Chat) <- "kcopula" return(Chat) } ############################################################################# ## Kernel copula density estimator ############################################################################# kcopula.de <- function(x, H, gridsize, gridtype, xmin, xmax, supp=3.7, eval.points, binned, bgridsize, w, verbose=FALSE, compute.cont=TRUE, approx.cont=TRUE, marginal="kernel", boundary.supp, boundary.kernel="beta") { ##warning("Use kcopula.de with care as it can be less accurate than kdecop in the kdecopula package.") ksd <- ks.defaults(x=x, w=w, binned=binned, bgridsize=bgridsize, gridsize=gridsize) d <- ksd$d; n <- ksd$n; w <- ksd$w if (missing(binned)) binned <- ksd$binned if (missing(bgridsize)) bgridsize <- ksd$bgridsize if (missing(gridsize)) gridsize <- ksd$gridsize hs <- rep(0, d) for (i in 1:d) hs[i] <- hpi.kcde(x=x[,i], binned=TRUE) ## generate pseudo-uniform values marginal1 <- match.arg(marginal, c("kernel", "empirical")) if (marginal1=="kernel") { ## kernel pseudo-uniform y <- pseudo.unif.kernel(x=x, y=x, hs=hs, binned=TRUE) } else if (marginal1=="empirical") { ## empirical pseudo-uniform y <- pseudo.unif.empirical(x=x, y=x) } colnames(y) <- colnames(x) if (missing(H)) H <- Hns(y) ## H <- do.call(Hfun, list(x=y, binned=default.bflag(d=d, n=nrow(y)), bgridsize=bgridsize, pilot=Hfun.pilot, verbose=verbose)) ## kernel copula density is boundary kernel estimator if (d==2 | d==3) chat <- kde.boundary(x=y, H=H, gridsize=gridsize, supp=supp, xmin=rep(0,d), xmax=rep(1,d), gridtype=gridtype, w=w, boundary.supp=boundary.supp, binned=FALSE, verbose=verbose, boundary.kernel=boundary.kernel) else stop("kcopula.de requires 2-d or 3-d data.") ## normalise KDE to integrate to 1 chat$estimate <- chat$estimate/sum(chat$estimate*apply(sapply(chat$eval.points, diff), 1, prod)[1]) chat$names <- parse.name(x) chat$x.orig <- x chat$hs <- hs ## compute prob contour levels if (compute.cont & missing(eval.points)) chat$cont <- contourLevels(chat, cont=1:99, approx=approx.cont) chat$marginal <- marginal1 class(chat) <- "kcopula.de" return(chat) } plot.kcopula <- function(x, ...) { plot.kcde(x, ...) } plot.kcopula.de <- function(x, ...) { plot.kde(x, ...) } ############################################################################# ## predict methods ############################################################################# predict.kcopula <- function(object, ..., x, u) { if (missing(u)) {if (object$marginal=="kernel") u <- pseudo.unif.kernel(x=object$x.orig, y=x, hs=object$hs)} return(predict.kde(object, ..., x=u)) } predict.kcopula.de <- function(object, ..., x, u) { if (missing(u)) {if (object$marginal=="kernel") u <- pseudo.unif.kernel(x=object$x.orig, y=x, hs=object$hs)} return(predict.kde(object, ..., x=u)) } contourLevels.kcopula.de <- function(x, ...) { x1 <- x; class(x1) <- "kde" return(contourLevels(x=x1, ...)) } ks/R/kdde.R0000644000176200001440000006366113557654225012154 0ustar liggesusers############################################################################### ### Multivariate kernel density derivative estimate ############################################################################### kdde <- function(x, H, h, deriv.order=0, gridsize, gridtype, xmin, xmax, supp=3.7, eval.points, binned, bgridsize, positive=FALSE, adj.positive, w, deriv.vec=TRUE, verbose=FALSE) { ## default values r <- deriv.order ksd <- ks.defaults(x=x, w=w, binned=binned, bgridsize=bgridsize, gridsize=gridsize) d <- ksd$d; n <- ksd$n; w <- ksd$w binned <- ksd$binned gridsize <- ksd$gridsize bgridsize <- ksd$bgridsize if (d==1 & missing(h) & !positive) h <- hpi(x=x, nstage=2, binned=default.bflag(d=d, n=n), deriv.order=r) if (d>1 & missing(H) & !positive) { if ((r>0) & (d>2)) nstage <- 1 else nstage <- 2 H <- Hpi(x=x, nstage=nstage, binned=default.bflag(d=d, n=n), deriv.order=r, verbose=verbose) } ## compute binned estimator if (binned) { if (positive & is.vector(x)) { y <- log(x) fhat <- kdde.binned(x=y, H=H, h=h, deriv.order=r, bgridsize=bgridsize, xmin=xmin, xmax=xmax, w=w) fhat$estimate <- fhat$estimate/exp(fhat$eval.points) fhat$eval.points <- exp(fhat$eval.points) fhat$x <- x } else fhat <- kdde.binned(x=x, H=H, h=h, deriv.order=r, bgridsize=bgridsize, xmin=xmin, xmax=xmax, w=w, deriv.vec=deriv.vec, verbose=verbose) if (!missing(eval.points)) { fhat$estimate <- predict(fhat, x=eval.points) fhat$eval.points <- eval.points } } else { ## compute exact (non-binned) estimator ## 1-dimensional if (d==1) { if (!missing(H) & !missing(h)) stop("Both H and h are both specified") if (missing(h)) h <- sqrt(H) if (missing(eval.points)) fhat <- kdde.grid.1d(x=x, h=h, gridsize=gridsize, supp=supp, xmin=xmin, xmax=xmax, gridtype=gridtype, w=w, deriv.order=r) else fhat <- kdde.points.1d(x=x, h=h, eval.points=eval.points, w=w, deriv.order=r) } ## multi-dimensional else { if (is.data.frame(x)) x <- as.matrix(x) if (missing(eval.points)) { if (d==2) fhat <- kdde.grid.2d(x=x, H=H, gridsize=gridsize, supp=supp, xmin=xmin, xmax=xmax, gridtype=gridtype, w=w, deriv.order=r, deriv.vec=deriv.vec, verbose=verbose) else if (d==3) fhat <- kdde.grid.3d(x=x, H=H, gridsize=gridsize, supp=supp, xmin=xmin, xmax=xmax, gridtype=gridtype, w=w, deriv.order=r, deriv.vec=deriv.vec, verbose=verbose) else stop("Need to specify eval.points for more than 3 dimensions") } else fhat <- kdde.points(x=x, H=H, eval.points=eval.points, w=w, deriv.order=r, deriv.vec=deriv.vec) } } fhat$binned <- binned fhat$names <- parse.name(x) class(fhat) <- "kdde" return(fhat) } ############################################################################### ## Multivariate binned kernel density derivative estimate ############################################################################### kdde.binned <- function(x, H, h, deriv.order, bgridsize, xmin, xmax, bin.par, w, deriv.vec=TRUE, deriv.index, verbose=FALSE) { r <- deriv.order if (length(r)>1) stop("deriv.order should be a non-negative integer") ## linear binning if (missing(bin.par)) { if (is.vector(x)) {d <- 1; n <- length(w)} else {d <- ncol(x); n <- nrow(x)} if (d==1) if (missing(H)) { H <- as.matrix(h^2)} else {h <- sqrt(H); H <- as.matrix(H)} if (d==1) Hd <- H else Hd <- diag(diag(H)) bin.par <- binning(x=x, H=Hd, h=h, bgridsize, xmin, xmax, supp=3.7+max(r), w=w) } else { if (!is.list(bin.par$eval.points)) { d <- 1; bgridsize <- length(bin.par$eval.points)} else { d <- length(bin.par$eval.points); bgridsize <- sapply(bin.par$eval.points, length)} w <- bin.par$w if (d==1) if (missing(H)) H <- as.matrix(h^2) else {h <- sqrt(H); H <- as.matrix(H)} } if (d==1) { fhat <- kdde.binned.1d(h=h, deriv.order=r, bin.par=bin.par) eval.points <- fhat$eval.points est <- fhat$estimate } else { ind.mat <- dmvnorm.deriv(x=rep(0,d), mu=rep(0,d), Sigma=H, deriv.order=r, only.index=TRUE, deriv.vec=deriv.vec) fhat.grid <- kdde.binned.nd(H=H, deriv.order=r, bin.par=bin.par, verbose=verbose, deriv.vec=deriv.vec) } if (missing(x)) x <- NULL if (d==1) { if (r==0) fhat <- list(x=x, eval.points=unlist(eval.points), estimate=est, h=h, H=h^2, gridtype="linear", gridded=TRUE, binned=TRUE, names=NULL, w=w) else fhat <- list(x=x, eval.points=unlist(eval.points), estimate=est, h=h, H=h^2, gridtype="linear", gridded=TRUE, binned=TRUE, names=NULL, w=w, deriv.order=r, deriv.ind=r) } else { if (r==0) fhat <- list(x=x, eval.points=fhat.grid$eval.points, estimate=fhat.grid$estimate[[1]], H=H, gridtype="linear", gridded=TRUE, binned=TRUE, names=NULL, w=w) else fhat <- list(x=x, eval.points=fhat.grid$eval.points, estimate=fhat.grid$estimate, H=H, gridtype="linear", gridded=TRUE, binned=TRUE, names=NULL, w=w, deriv.order=r, deriv.ind=ind.mat) } class(fhat) <- "kdde" return(fhat) } kdde.binned.1d <- function(h, deriv.order, bin.par) { r <- deriv.order n <- sum(bin.par$counts) a <- min(bin.par$eval.points) b <- max(bin.par$eval.points) M <- length(bin.par$eval.points) L <- min(ceiling((4+r)*h*(M-1)/(b-a)), M-1) delta <- (b-a)/(M-1) N <- 2*L-1 grid1 <- seq(-(L-1), L-1) keval <- dnorm.deriv(x=delta*grid1, mu=0, sigma=h, deriv.order=r)/n est <- symconv.1d(keval, bin.par$counts) ##keval <- dnorm.deriv(x=(b-a)*(0:L)/(M-1), mu=0, sigma=h, deriv.order=r)/n ##est <- symconv.ks.old(keval, bin.par$counts, skewflag=(-1)^r) return(list(eval.points=bin.par$eval.points, estimate=est)) } kdde.binned.nd <- function(H, deriv.order, bin.par, verbose=FALSE, deriv.vec=TRUE) { d <- ncol(H) r <- deriv.order n <- sum(bin.par$counts) a <- sapply(bin.par$eval.points, min) b <- sapply(bin.par$eval.points, max) M <- sapply(bin.par$eval.points, length) L <- pmin(ceiling((4+r)*max(sqrt(abs(diag(H))))*(M-1)/(b-a)), M-1) delta <- (b-a)/(M-1) if (min(L)<=0) warning(paste("Binning grid too coarse for current (small) bandwidth: consider increasing grid size for dimensions", toString(which(pmin(L)<=1)))) ##if (all(L==1)) L[head(which(L==1),n=1)] <- 2 N <- 2*L-1 if(d==2) { grid1 <- seq(-(L[1]-1), L[1]-1) grid2 <- seq(-(L[2]-1), L[2]-1) xgrid <- expand.grid(delta[1]*grid1, delta[2]*grid2) } else if (d==3) { grid1 <- seq(-(L[1]-1), L[1]-1) grid2 <- seq(-(L[2]-1), L[2]-1) grid3 <- seq(-(L[3]-1), L[3]-1) xgrid <- expand.grid(delta[1]*grid1, delta[2]*grid2, delta[3]*grid3) } else if (d==4) { grid1 <- seq(-(L[1]-1), L[1]-1) grid2 <- seq(-(L[2]-1), L[2]-1) grid3 <- seq(-(L[3]-1), L[3]-1) grid4 <- seq(-(L[4]-1), L[4]-1) xgrid <- expand.grid(delta[1]*grid1, delta[2]*grid2, delta[3]*grid3, delta[4]*grid4) } deriv.index <- dmvnorm.deriv(x=rep(0,d), mu=rep(0,d), Sigma=H, deriv.order=r, add.index=TRUE, only.index=TRUE, deriv.vec=TRUE) deriv.index.minimal <- dmvnorm.deriv(x=rep(0,d), mu=rep(0,d), Sigma=H, deriv.order=r, add.index=TRUE, only.index=TRUE, deriv.vec=FALSE) if (verbose) pb <- txtProgressBar() if (r==0) { n.seq <- block.indices(1, nrow(xgrid), d=d, r=r, diff=FALSE) est.list <- vector(1, mode="list") est.list[[1]] <- array(0, dim=dim(bin.par$counts)) } else if (r>0) { n.deriv <- nrow(deriv.index) n.deriv.minimal <- nrow(deriv.index.minimal) if (deriv.vec) n.est.list <- n.deriv else n.est.list <- n.deriv.minimal est.list <- vector(n.est.list, mode="list") for (j in 1:n.est.list) est.list[[j]] <- array(0, dim=dim(bin.par$counts)) if (d^r >= 3^7) n.seq <- block.indices(1, nrow(xgrid), d=d, r=r, diff=FALSE, block.limit=1e4) else n.seq <- block.indices(1, nrow(xgrid), d=d, r=r, diff=FALSE, block.limit=1e5) } for (i in 1:(length(n.seq)-1)) { if (verbose) setTxtProgressBar(pb, i/(length(n.seq)-1)) keval <- dmvnorm.deriv(x=xgrid[n.seq[i]:(n.seq[i+1]-1),], mu=rep(0,d), Sigma=H, deriv.order=r, add.index=TRUE, deriv.vec=FALSE)$deriv/n if (r==0) keval <- as.matrix(keval, ncol=1) else if (is.vector(keval)) keval <- as.matrix(t(keval), nrow=1) est <- list() ## loop over only unique partial derivative indices nderiv <- nrow(deriv.index.minimal) if (!(is.null(nderiv))) for (s in 1:nderiv) { if (deriv.vec) deriv.rep.index <- which.mat(deriv.index.minimal[s,], deriv.index) else deriv.rep.index <- s kevals <- array(keval[,s], dim=N) ##if (r==0) sf <- rep(1,d) ##else sf <- (-1)^deriv.index.minimal[s,] est.temp <- symconv.nd(kevals, bin.par$counts, d=d) for (s2 in 1:length(deriv.rep.index)) est[[deriv.rep.index[s2]]] <- est.temp } else { ##for (s in 1:ncol(keval)) ##{ ## kevals <- array(keval[,s], dim=N) ## if (r==0) sf <- rep(1,d) ## else sf <- (-1)^deriv.index[s,] ## est[[s]] <- symconv.nd(kevals, bin.par$counts, d=d) ##} kevals <- lapply(as.data.frame(keval), function(x){array(x, dim=N)}) est <- lapply(kevals, function(x){symconv.nd(x, bin.par$counts, d=d)}) } if (r==0) est.list[[1]] <- est.list[[1]] + est[[1]] else if (r>0) for (j in 1:n.est.list) est.list[[j]] <- est.list[[j]] + est[[j]] } if (verbose) close(pb) return(list(eval.points=bin.par$eval.points, estimate=est.list, deriv.order=r)) } ############################################################################# #### Univariate kernel density derivative estimate on a grid ############################################################################# kdde.grid.1d <- function(x, h, gridsize, supp=3.7, positive=FALSE, adj.positive, xmin, xmax, gridtype, w, deriv.order=0) { r <- deriv.order if (r==0) fhatr <- kde(x=x, h=h, gridsize=gridsize, supp=supp, positive=positive, adj.positive=adj.positive, xmin=xmin, xmax=xmax, gridtype=gridtype, w=w) else { if (missing(xmin)) xmin <- min(x) - h*supp if (missing(xmax)) xmax <- max(x) + h*supp if (missing(gridtype)) gridtype <- "linear" y <- x gridtype1 <- match.arg(gridtype, c("linear", "sqrt")) if (gridtype1=="linear") gridy <- seq(xmin, xmax, length=gridsize) else if (gridtype1=="sqrt") { gridy.temp <- seq(sign(xmin)*sqrt(abs(xmin)), sign(xmax)*sqrt(abs(xmax)), length=gridsize) gridy <- sign(gridy.temp) * gridy.temp^2 } gridtype.vec <- gridtype1 n <- length(y) est <- dnorm.deriv.mixt(x=gridy, mus=y, sigmas=rep(h, n), props=w/n, deriv.order=r) fhatr <- list(x=y, eval.points=gridy, estimate=est, h=h, H=h^2, gridtype=gridtype.vec, gridded=TRUE, binned=FALSE, names=NULL, w=w, deriv.order=r, deriv.ind=deriv.order) class(fhatr) <- "kdde" } return(fhatr) } ############################################################################## ## Bivariate kernel density derivative estimate on a grid ## Computes all mixed partial derivatives for a given deriv.order ############################################################################## kdde.grid.2d <- function(x, H, gridsize, supp, gridx=NULL, grid.pts=NULL, xmin, xmax, gridtype, w, deriv.order=0, deriv.vec=TRUE, verbose=FALSE) { d <- 2 r <- deriv.order if (r==0) fhatr <- kde(x=x, H=H, gridsize=gridsize, supp=supp, xmin=xmin, xmax=xmax, gridtype=gridtype, w=w, verbose=verbose) else { ## initialise grid n <- nrow(x) if (is.null(gridx)) gridx <- make.grid.ks(x, matrix.sqrt(H), tol=supp, gridsize=gridsize, xmin=xmin, xmax=xmax, gridtype=gridtype) suppx <- make.supp(x, matrix.sqrt(H), tol=supp) if (is.null(grid.pts)) grid.pts <- find.gridpts(gridx, suppx) nderiv <- d^r fhat.grid <- list() for (k in 1:nderiv) fhat.grid[[k]] <- matrix(0, nrow=length(gridx[[1]]), ncol=length(gridx[[2]])) if (verbose) pb <- txtProgressBar() for (i in 1:n) { ## compute evaluation points eval.x <- gridx[[1]][grid.pts$xmin[i,1]:grid.pts$xmax[i,1]] eval.y <- gridx[[2]][grid.pts$xmin[i,2]:grid.pts$xmax[i,2]] eval.x.ind <- c(grid.pts$xmin[i,1]:grid.pts$xmax[i,1]) eval.y.ind <- c(grid.pts$xmin[i,2]:grid.pts$xmax[i,2]) eval.x.len <- length(eval.x) eval.pts <- expand.grid(eval.x, eval.y) ## Create list of matrices for different partial derivatives fhat <- dmvnorm.deriv(x=eval.pts, mu=x[i,], Sigma=H, deriv.order=r) ## place vector of density estimate values `fhat' onto grid 'fhat.grid' for (k in 1:nderiv) for (j in 1:length(eval.y)) fhat.grid[[k]][eval.x.ind, eval.y.ind[j]] <- fhat.grid[[k]][eval.x.ind, eval.y.ind[j]] + w[i]*fhat[((j-1) * eval.x.len + 1):(j * eval.x.len),k] if (verbose) setTxtProgressBar(pb, i/n) } if (verbose) close(pb) for (k in 1:nderiv) fhat.grid[[k]] <- fhat.grid[[k]]/n gridx1 <- list(gridx[[1]], gridx[[2]]) ind.mat <- dmvnorm.deriv(x=rep(0,d), mu=rep(0,d), Sigma=H, deriv.order=r, only.index=TRUE) if (!deriv.vec) { fhat.grid.vech <- list() deriv.ind <- unique(ind.mat) for (i in 1:nrow(deriv.ind)) { which.deriv <- which.mat(deriv.ind[i,], ind.mat)[1] fhat.grid.vech[[i]] <- fhat.grid[[which.deriv]] } ind.mat <- deriv.ind fhat.grid <- fhat.grid.vech } fhatr <- list(x=x, eval.points=gridx1, estimate=fhat.grid, H=H, gridtype=gridx$gridtype, gridded=TRUE, binned=FALSE, names=NULL, w=w, deriv.order=deriv.order, deriv.ind=ind.mat) } return(fhatr) } kdde.grid.3d <- function(x, H, gridsize, supp, gridx=NULL, grid.pts=NULL, xmin, xmax, gridtype, w, deriv.order=0, deriv.vec=TRUE, verbose=FALSE) { d <- 3 r <- deriv.order if (r==0) fhatr <- kde(x=x, H=H, gridsize=gridsize, supp=supp, xmin=xmin, xmax=xmax, gridtype=gridtype, w=w, verbose=verbose) else { ## initialise grid n <- nrow(x) if (is.null(gridx)) gridx <- make.grid.ks(x, matrix.sqrt(H), tol=supp, gridsize=gridsize, xmin=xmin, xmax=xmax, gridtype=gridtype) suppx <- make.supp(x, matrix.sqrt(H), tol=supp) if (is.null(grid.pts)) grid.pts <- find.gridpts(gridx, suppx) nderiv <- d^r fhat.grid <- list() for (k in 1:nderiv) fhat.grid[[k]] <- array(0, dim=gridsize) if (verbose) pb <- txtProgressBar() for (i in 1:n) { ## compute evaluation points eval.x <- gridx[[1]][grid.pts$xmin[i,1]:grid.pts$xmax[i,1]] eval.y <- gridx[[2]][grid.pts$xmin[i,2]:grid.pts$xmax[i,2]] eval.z <- gridx[[3]][grid.pts$xmin[i,3]:grid.pts$xmax[i,3]] eval.x.ind <- c(grid.pts$xmin[i,1]:grid.pts$xmax[i,1]) eval.y.ind <- c(grid.pts$xmin[i,2]:grid.pts$xmax[i,2]) eval.z.ind <- c(grid.pts$xmin[i,3]:grid.pts$xmax[i,3]) eval.x.len <- length(eval.x) eval.pts <- expand.grid(eval.x, eval.y) ## Create list of matrices for different partial derivatives ##fhat <- dmvnorm.deriv(x=eval.pts, mu=x[i,], Sigma=H, deriv.order=r) ## place vector of density estimate values `fhat' onto grid 'fhat.grid' for (ell in 1:nderiv) for (k in 1:length(eval.z)) { fhat <- w[i]*dmvnorm.deriv(cbind(eval.pts, eval.z[k]), x[i,], H, deriv.order=r) for (j in 1:length(eval.y)) fhat.grid[[ell]][eval.x.ind,eval.y.ind[j], eval.z.ind[k]] <- fhat.grid[[ell]][eval.x.ind, eval.y.ind[j], eval.z.ind[k]] + fhat[((j-1) * eval.x.len + 1):(j * eval.x.len)] } if (verbose) setTxtProgressBar(pb, i/n) } if (verbose) close(pb) for (k in 1:nderiv) fhat.grid[[k]] <- fhat.grid[[k]]/n ##gridx1 <- list(gridx[[1]], gridx[[2]]) gridx1 <- list(gridx[[1]], gridx[[2]], gridx[[3]]) ind.mat <- dmvnorm.deriv(x=rep(0,d), mu=rep(0,d), Sigma=H, deriv.order=r, only.index=TRUE) if (!deriv.vec) { fhat.grid.vech <- list() deriv.ind <- unique(ind.mat) for (i in 1:nrow(deriv.ind)) { which.deriv <- which.mat(deriv.ind[i,], ind.mat)[1] fhat.grid.vech[[i]] <- fhat.grid[[which.deriv]] } ind.mat <- deriv.ind fhat.grid <- fhat.grid.vech } fhatr <- list(x=x, eval.points=gridx1, estimate=fhat.grid, H=H, gridtype=gridx$gridtype, gridded=TRUE, binned=FALSE, names=NULL, w=w, deriv.order=deriv.order, deriv.ind=ind.mat) } return(fhatr) } ############################################################################# ## Multivariate kernel density estimate using normal kernels, ## evaluated at each sample point ############################################################################# kdde.points.1d <- function(x, h, eval.points, w, deriv.order=0) { r <- deriv.order n <- length(x) fhat <- dnorm.deriv.mixt(x=eval.points, mus=x, sigmas=rep(h,n), props=w/n, deriv.order=r) return(list(x=x, eval.points=eval.points, estimate=fhat, h=h, H=h^2, gridded=FALSE, binned=FALSE, names=NULL, w=w, deriv.order=r, deriv.ind=r)) } kdde.points <- function(x, H, eval.points, w, deriv.order=0, deriv.vec=TRUE) { n <- nrow(x) ##Hs <- numeric(0) ##for (i in 1:n) ## Hs <- rbind(Hs, H) Hs <- replicate(n, H, simplify=FALSE) Hs <- do.call(rbind, Hs) r <- deriv.order fhat <- dmvnorm.deriv.mixt(x=eval.points, mus=x, Sigmas=Hs, props=w/n, deriv.order=r, deriv.vec=deriv.vec, add.index=TRUE) return(list(x=x, eval.points=eval.points, estimate=fhat$deriv, H=H, gridded=FALSE, binned=FALSE, names=NULL, w=w, deriv.order=r, deriv.ind=fhat$deriv.ind)) } ############################################################################# ## Plot method for KDDE ############################################################################# plot.kdde <- function(x, ...) { fhat <- x if (is.null(fhat$deriv.order)) { class(fhat) <- "kde" plot(fhat, ...) } else { if (is.vector(fhat$x)) { plotkdde.1d(fhat, ...) invisible() } else { d <- ncol(fhat$x) if (d==2) { opr <- options()$preferRaster; if (!is.null(opr)) if (!opr) options("preferRaster"=TRUE) plotret <- plotkdde.2d(fhat, ...) if (!is.null(opr)) options("preferRaster"=opr) invisible(plotret) } else if (d==3) { ##stop("plot.kdde not yet implemented for 3-d data") plotkdde.3d(fhat, ...) invisible() } else stop ("Plot function only available for 1, 2 or 3-d data") } } } plotkdde.1d <- function(fhat, ylab="Density derivative function", cont=50, abs.cont, ...) { if (missing(abs.cont)) { abs.cont <- as.matrix(contourLevels(fhat, approx=TRUE, cont=cont), ncol = length(cont)) abs.cont <- c(abs.cont[1, ], rev(abs.cont[2, ])) } class(fhat) <- "kde" plot(fhat, ylab=ylab, abs.cont=abs.cont, ...) } plotkdde.2d <- function(fhat, which.deriv.ind=1, cont=c(25,50,75), abs.cont, display="slice", zlab="Density derivative function", col.fun=topo.colors, kdde.flag=TRUE, thin=5, transf=1/4, neg.grad=FALSE, ...) { disp1 <- match.arg(display, c("persp", "slice", "image", "filled.contour", "filled.contour2", "quiver")) if (disp1=="slice" | disp1=="filled.contour" | disp1=="filled.contour2") { if (missing(abs.cont)) { abs.cont <- as.matrix(contourLevels(fhat, approx=TRUE, cont=cont), ncol=length(cont)) abs.cont <- c(abs.cont[1,], rev(abs.cont[2,])) } } if (disp1=="quiver") { if (fhat$deriv.order==1) plotquiver(fhat=fhat, thin=thin, transf=transf, neg.grad=neg.grad, ...) else warning("Quiver plot requires gradient estimate.") } else { fhat.temp <- fhat fhat.temp$deriv.ind <- fhat.temp$deriv.ind[which.deriv.ind,] fhat.temp$estimate <- fhat.temp$estimate[[which.deriv.ind]] fhat <- fhat.temp class(fhat) <- "kde" plot(fhat, display=display, abs.cont=abs.cont, zlab=zlab, col.fun=col.fun, kdde.flag=kdde.flag, ...) } } plotkdde.3d <- function(fhat, which.deriv.ind=1, cont=c(25,50,75), abs.cont, colors, col.fun=cm.colors, ...) { if (missing(abs.cont)) { abs.cont <- as.matrix(contourLevels(fhat, approx=TRUE, cont=cont), ncol=length(cont)) abs.cont <- c(abs.cont[1,], rev(abs.cont[2,])) } fhat.temp <- fhat fhat.temp$deriv.ind <- fhat.temp$deriv.ind[which.deriv.ind,] fhat.temp$estimate <- fhat.temp$estimate[[which.deriv.ind]] fhat <- fhat.temp class(fhat) <- "kde" if (missing(colors)) { colors <- rev(col.fun(length(abs.cont))) nc <- length(colors) colors[1: (nc/2)] <- rev(colors[1:(nc/2)]) } plot(fhat, abs.cont=abs.cont, colors=colors, ...) } ###################################################################### ## Quiver plot ###################################################################### plotquiver <- function(fhat, thin=5, transf=1/4, neg.grad=FALSE, xlab, ylab, ...) { ## suggestions from Viktor Petukhov 08/03/2018 if (!requireNamespace("OceanView", quietly=TRUE)) stop("Install the OceanView package as it is required.", call.=FALSE) ev <- fhat$eval.points est <- fhat$estimate if (transf!=0){ est[[1]] <- sign(est[[1]])*abs(est[[1]])^(transf) est[[2]] <- sign(est[[2]])*abs(est[[2]])^(transf) } thin1.ind <- seq(1, length(ev[[1]]), by=thin) thin2.ind <- seq(1, length(ev[[2]]), by=thin) fx <- est[[1]][thin1.ind, thin2.ind] fy <- est[[2]][thin1.ind, thin2.ind] if (neg.grad) { fx <- -fx; fy <- -fy } if (missing(xlab)) xlab <- fhat$names[1] if (missing(ylab)) ylab <- fhat$names[2] OceanView::quiver2D(x=ev[[1]][thin1.ind], y=ev[[2]][thin2.ind], u=fx, v=fy, xlab=xlab, ylab=ylab, ...) } ############################################################################# ## ContourLevels method for KDDE ############################################################################# contourLevels.kdde <- function(x, prob, cont, nlevels=5, approx=TRUE, which.deriv.ind=1, ...) { fhat <- x if (is.vector(fhat$x)) { d <- 1; n <- length(fhat$x) if (!is.null(fhat$deriv.order)) { fhat.temp <- fhat fhat.temp$deriv.ind <-fhat.temp$deriv.ind[which.deriv.ind] fhat <- fhat.temp } } else { d <- ncol(fhat$x); n <-nrow(fhat$x) if (!is.matrix(fhat$x)) fhat$x <- as.matrix(fhat$x) if (!is.null(fhat$deriv.order)) { fhat.temp <- fhat fhat.temp$estimate <- fhat.temp$estimate[[which.deriv.ind]] fhat.temp$deriv.ind <-fhat.temp$deriv.ind[which.deriv.ind,] fhat <- fhat.temp } } if (is.null(x$w)) w <- rep(1, n) else w <- x$w if (is.null(fhat$gridded)) { if (d==1) fhat$gridded <- fhat$binned else fhat$gridded <- is.list(fhat$eval.points) } if (missing(prob) & missing(cont)) hts <- pretty(fhat$estimate, n=nlevels) else { if (approx & fhat$gridded) dobs <- predict.kde(fhat, x=fhat$x) else dobs <- kdde(x=fhat$x, H=fhat$H, eval.points=fhat$x, w=w, deriv.order=fhat$deriv.order)$estimate[,which.deriv.ind] if (is.null(fhat$deriv.order)) { if (!missing(prob) & missing(cont)) hts <- quantile(dobs[dobs>=0], prob=prob) if (missing(prob) & !missing(cont)) hts <- quantile(dobs[dobs>=0], prob=(100-cont)/100) } else { if (!missing(prob) & missing(cont)) hts <- rbind(-quantile(abs(dobs[dobs<0]), prob=prob), quantile(dobs[dobs>=0], prob=prob)) if (missing(prob) & !missing(cont)) hts <- rbind(-quantile(abs(dobs[dobs<0]), prob=(100-cont)/100), quantile(dobs[dobs>=0], prob=(100-cont)/100)) } } return(hts) } ############################################################################# ## predict method for KDDE ############################################################################# predict.kdde <- function(object, ..., x) { fhat <- object if (is.vector(fhat$H)) d <- 1 else d <- ncol(fhat$H) if (d==1) n <- length(x) else { if (is.vector(x)) x <- matrix(x, nrow=1) else x <- as.matrix(x) n <- nrow(x) } if (!is.null(fhat$deriv.ind)) { if (is.vector(fhat$deriv.ind)) pk.mat <- predict.kde(fhat, x=x, ...) else { nd <- nrow(fhat$deriv.ind) pk.mat <- matrix(0, ncol=nd, nrow=n) for (i in 1:nd) { fhat.temp <- fhat fhat.temp$estimate <- fhat$estimate[[i]] pk.mat[,i] <- predict.kde(fhat.temp, x=x, ...) } } } else { pk.mat <- predict.kde(fhat, x=x, ...) } return(drop(pk.mat)) } ###################################################################### ## Summary kernel curvature ###################################################################### kcurv <- function(fhat, compute.cont=TRUE) { fhat.curv <- fhat if (is.vector(fhat$H)) d <- 1 else d <- ncol(fhat$H) if (fhat$deriv.order!=2) stop("Requires output from kdde(, deriv.order=2).") if (d==1) { Hessian.det <- fhat$estimate local.mode <- fhat$estimate <0 fhat.curv$estimate <- local.mode*abs(Hessian.det) } else if (d>1) { fhat.est <- sapply(fhat$estimate, as.vector) Hessian.det <- sapply(seq(1,nrow(fhat.est)), function(i) {det(invvec(fhat.est[i,]))}) Hessian.eigen <- lapply(lapply(seq(1,nrow(fhat.est)), function(i) {invvec(fhat.est[i,])}), eigen, only.values=TRUE) Hessian.eigen <- t(sapply(Hessian.eigen, getElement, "values")) local.mode <- apply(Hessian.eigen <= 0, 1, all) fhat.curv$estimate <- local.mode*array(abs(Hessian.det), dim=dim(fhat$estimate[[1]])) } fhat.curv$deriv.order <- NULL fhat.curv$deriv.ind <- NULL if (compute.cont) { fhat.temp <- fhat.curv fhat.temp$x <- fhat.curv$x[predict(fhat.curv, x=fhat.curv$x)>0,] fhat.temp$estimate <- fhat.temp$estimate fhat.curv$cont <- contourLevels(fhat.temp, cont=1:99) } class(fhat.curv) <- "kde" return(fhat.curv) } ks/R/kde.R0000644000176200001440000012151413557621336011775 0ustar liggesusers############################################################################### ## Multivariate kernel density estimators ############################################################################### ############################################################################### ## Generate grid over a set of points ## ## Parameters ## x - data points ## H - bandwidth matrix ## tol - tolerance = extra coverage exceeding the range of x ## gridsize - number of points for each direction ## ## Returns ## gridx - list of intervals, one for each co-ord direction so that ## gridx[[1]] x gridx[[2]] x ... x gridx[[d]] is the grid ## stepsize - vector of step sizes ############################################################################### make.grid.ks <- function(x, H, tol, gridsize, xmin, xmax, gridtype) { d <- ncol(x) tol.H <- tol * diag(H) if (missing(xmin)) xmin <- apply(x, 2, min) - tol.H if (missing(xmax)) xmax <- apply(x, 2, max) + tol.H stepsize <- rep(0, d) gridx <- numeric(0) if (length(gridsize)==1) gridsize <- rep(gridsize, d) if (missing(gridtype)) gridtype <- rep("linear", d) gridtype.vec <- rep("", d) for (i in 1:d) { gridtype1 <- match.arg(gridtype[i], c("linear", "sqrt", "quantile", "exp")) if (gridtype1=="linear") { gridx <- c(gridx, list(seq(xmin[i], xmax[i], length=gridsize[i]))) stepsize[i] <- abs(gridx[[i]][1] - gridx[[i]][2]) } else if (gridtype1=="sqrt") { gridx.temp <- seq(sign(xmin[i])*sqrt(abs(xmin[i])), sign(xmax[i])*sqrt(abs(xmax[i])), length=gridsize[i]) gridx <- c(gridx, list(sign(gridx.temp) * gridx.temp^2)) stepsize[i] <- NA } else if (gridtype1=="quantile") { gridx.temp <- qnorm(seq(1e-2, 1-1e-2, length=gridsize[i])) gridx <- c(gridx, list(xmin[i] + (xmax[i]-xmin[i])*(gridx.temp-min(gridx.temp))/(max(gridx.temp)-min(gridx.temp)))) stepsize[i] <- NA } else if (gridtype1=="exp") { gridx.temp <- seq(exp(xmin[i]), exp(xmax[i]), length=gridsize[i]) gridx <- c(gridx, list(log(gridx.temp))) stepsize[i] <- NA } gridtype.vec[i] <- gridtype1 } gridx <- c(gridx, list(stepsize = stepsize, gridtype=gridtype.vec)) return(gridx) } ############################################################################### ## Generate kernel (rectangular) support at data point ## ## Parameters ## x - data points ## H - bandwidth matrix ## tol - tolerance = extra coverage exceeding the range of x ## ## Returns ## list of min and max points of support (here we parameterise rectangles ## by their min = lower left co-ord and max = upper right coord) ############################################################################### make.supp <- function(x, H, tol) { n <- nrow(x) d <- ncol(x) tol.H <- tol * diag(H) xmin <- matrix(0, nrow=n, ncol=d) xmax <- matrix(0, nrow=n, ncol=d) for (i in 1:n) { xmin[i,] <- x[i,] - tol.H xmax[i,] <- x[i,] + tol.H } return(list(xmin = xmin, xmax = xmax)) } ############################################################################### ## Find the grid points contained in kernel support rectangles ## ## Parameters ## gridx - grid (list of subdivided intervals) ## rectx - rectangles (list of min and max points) ## ## Returns ## list of min and max points of the grid for each rectangle ############################################################################### find.gridpts <- function(gridx, suppx) { xmax <- suppx$xmax xmin <- suppx$xmin d <- ncol(xmax) n <- nrow(xmax) gridpts.min <- matrix(0, ncol=d, nrow=n) gridpts.max <- gridpts.min for (i in 1:n) for (j in 1:d) { ## find index of last element of gridx smaller than min support tsum <- sum(xmin[i,j] >= gridx[[j]]) if (tsum==0) gridpts.min[i,j] <- 1 else gridpts.min[i,j] <- tsum ## find index of first element gridx greater than max support gridpts.max[i,j] <- sum(xmax[i,j] >= gridx[[j]]) } return(list(xmin=gridpts.min, xmax=gridpts.max)) } ############################################################################## ## Interpolate the values of f defined on gridx at new values x ############################################################################## grid.interp <- function(x, gridx, f) { if (!is.list(gridx)) { ## uniform grid if (isTRUE(all.equal(diff(gridx), rep(diff(gridx)[1], length(gridx)-1)))) fx <- grid.interp.1d(x=as.vector(x), gridx=gridx, f=f) ## non-uniform grid else fx <- varying.grid.interp.1d(x=as.vector(x), gridx=gridx, f=f) return(fx) } else { if (is.vector(x)) x <- as.matrix(t(x)) d <- ncol(x) n <- nrow(x) if (d<2) stop("x should be a vector") gridx.diff <- lapply(lapply(gridx,diff), getElement, 1) for (i in 1:length(gridx.diff)) gridx.diff[[i]] <- rep(gridx.diff[[i]], sapply(gridx, length)[i]-1) uniform.grid.flag <- isTRUE(all.equal(lapply(gridx,diff), gridx.diff)) ## uniform grid if (d==2 & uniform.grid.flag) fx <- grid.interp.2d(x=x, gridx=gridx, f=f) else if (d==3 & uniform.grid.flag) fx <- grid.interp.3d(x=x, gridx=gridx, f=f) else ## d >=4 or non-uniform grid { gridsize <- sapply(gridx,length) gind <- matrix(0, nrow=n, ncol=d) for (i in 1:n) for (j in 1:d) { tsum <- sum(x[i,j] >= gridx[[j]]) if (tsum==0) gind[i,j] <- 1 else gind[i,j] <- tsum } for (j in 1:d) gind[gind[,j]>=gridsize[j],j] <- gridsize[j]-1 bperm <- list() for (j in 1:d) bperm[[j]] <- elem(1,2) binary.perm <- as.matrix(expand.grid(bperm)) colnames(binary.perm) <- NULL gind.list <- list() fx <- rep(0, length=n) for (i in 1:n) { gind.list[[i]] <- matrix(gind[i,], nrow=2^d, ncol=d, byrow=TRUE) + binary.perm w <- matrix(0, nrow=2^d, ncol=d) gridw <- matrix(0, nrow=2^d, ncol=d) for (j in 1:d) { gind.list[[i]][,j][gind.list[[i]][,j]>=gridsize[j]] <- gridsize[j] gridw[,j] <- gridx[[j]][gind.list[[i]][,j]] } w <- abs(matrix(as.numeric(x[i,]), nrow=2^d, ncol=d, byrow=TRUE) - gridw) w <- apply(w, 1, prod) ##w <- apply(abs(matrix(as.numeric(x[i,]), nrow=2^d, ncol=d, byrow=TRUE) - gridw), 1, prod) ##w <- 1/apply(abs(sweep(gridw, 2, x[i,])), 1, prod) ##w[w>1e5] <- 1e5 w <- w/sum(w) ##fx[i] <- sum(w*f[gind.list[[i]]]) fx[i] <- sum(w*f[gind.list[[i]][2^d:1,]]) } } } return(fx) } grid.interp.1d <- function(x, gridx, f) { n <- length(x) gpoints1 <- gridx M1 <- length(gpoints1) a1 <- gpoints1[1] b1 <- gpoints1[M1] out <- .C(C_interp1d, x1=as.double(x), n=as.integer(n), a1=as.double(a1), b1=as.double(b1), M1=as.integer(M1), fun=as.double(as.vector(f)), est=double(n)) return(out$est) } grid.interp.2d <- function(x, gridx, f) { n <- nrow(x) gpoints1 <- gridx[[1]] gpoints2 <- gridx[[2]] M1 <- length(gpoints1) M2 <- length(gpoints2) a1 <- gpoints1[1] a2 <- gpoints2[1] b1 <- gpoints1[M1] b2 <- gpoints2[M2] out <- .C(C_interp2d, x1=as.double(x[,1]), x2=as.double(x[,2]), n=as.integer(n), a1=as.double(a1), a2=as.double(a2), b1=as.double(b1), b2=as.double(b2), M1=as.integer(M1), M2=as.integer(M2), fun=as.double(as.vector(f)), est=double(n)) return(out$est) } grid.interp.3d <- function(x, gridx, f) { n <- nrow(x) gpoints1 <- gridx[[1]] gpoints2 <- gridx[[2]] gpoints3 <- gridx[[3]] M1 <- length(gpoints1) M2 <- length(gpoints2) M3 <- length(gpoints3) a1 <- gpoints1[1] a2 <- gpoints2[1] a3 <- gpoints3[1] b1 <- gpoints1[M1] b2 <- gpoints2[M2] b3 <- gpoints3[M3] out <- .C(C_interp3d, x1=as.double(x[,1]), x2=as.double(x[,2]), x3=as.double(x[,3]), n=as.integer(n), a1=as.double(a1), a2=as.double(a2), a3=as.double(a3), b1=as.double(b1), b2=as.double(b2), b3=as.double(b3), M1=as.integer(M1), M2=as.integer(M2), M3=as.integer(M3), fun=as.double(as.vector(f)), est=double(n)) return(out$est) } ############################################################################### ## Linear intepolation based on kernel estimation grid ############################################################################### kde.approx <- function(fhat, x) { return(grid.interp(x=x, gridx=fhat$eval.points, f=fhat$estimate)) } ############################################################################## ## Find the nearest grid points surrounding point x for non-uniform grids ############################################################################## varying.grid.interp <- function(x, gridx, f) { if (!is.list(gridx)) return(varying.grid.interp.1d(x=x, gridx=gridx, f=f)) else { if (is.vector(x)) x <- as.matrix(t(x)) d <- ncol(x) n <- nrow(x) gridsize <- sapply(gridx,length) gind <- matrix(0, nrow=n, ncol=d) for (i in 1:n) for (j in 1:d) { tsum <- sum(x[i,j] >= gridx[[j]]) if (tsum==0) gind[i,j] <- 1 else gind[i,j] <- tsum } } bperm <- list() for (j in 1:d) bperm[[j]] <- elem(1,2) binary.perm <- as.matrix(expand.grid(bperm)) colnames(binary.perm) <- NULL gind.list <- list() fx <- rep(0, length=n) for (i in 1:n) { gind.list[[i]] <- matrix(gind[i,], nrow=2^d, ncol=d, byrow=TRUE) + binary.perm w <- matrix(0, nrow=2^d, ncol=d) gridw <- matrix(0, nrow=2^d, ncol=d) for (j in 1:d) { gind.list[[i]][,j][gind.list[[i]][,j]>=gridsize[j]] <- gridsize[j] gridw[,j] <- gridx[[j]][gind.list[[i]][,j]] } w <- 1/apply((matrix(as.numeric(x[i,]), nrow=2^d, ncol=d, byrow=TRUE) - gridw)^2, 1, sum) w[w>1e5] <- 1e5 w <- w/sum(w) fx[i] <- sum(w*f[gind.list[[i]]]) } return(fx) } varying.grid.interp.1d <- function(x, gridx, f) { n <- length(x) gind <- rep(0, length=n) for (i in 1:length(x)) { tsum <- sum(x[i] >= gridx) if (tsum==0) gind[i] <- 1 else gind[i] <- tsum } gind2 <- gind+1 gind2[gind2>length(gridx)] <- length(gridx) gind2[x<=gridx[1]] <- gind[x<=gridx[1]] gind <- cbind(gind, gind2) colnames(gind) <- NULL fx <- rep(0, n) for (i in 1:n) { w <- 1/(x[i] - gridx[gind[i,]])^2 w[w>1e5] <- 1e5 w <- w/sum(w) fx[i] <- sum(w*f[gind[i,]]) } return(fx) } predict.kde <- function(object, ..., x, zero.flag=TRUE) { fhat <- grid.interp(x=x, gridx=object$eval.points, f=object$estimate) if (!zero.flag) { if (!is.list(object$eval.points)) d <- 1 else d <- length(object$eval.points) if (d==1) { gs <- length(object$eval.points) x.ind <- findInterval(x, object$eval.points, all.inside=FALSE) fhat[x.ind==0] <- object$estimate[1] fhat[x.ind==gs] <- object$estimate[gs] } else { x <- matrix(x, ncol=d) gs <- sapply(object$eval.points, length) x.ind <- matrix(0, nrow=nrow(x), ncol=d) for (i in 1:d) x.ind[,i] <- findInterval(x[,i], object$eval.points[[i]], all.inside=FALSE) x.ind[x.ind==0] <- 1 x.ind.flag <- x.ind==1 for (i in 1:d) x.ind.flag[,i] <- x.ind.flag[,i] | x.ind[,i]==gs[i] fhat[apply(x.ind.flag, 1, any)] <- object$estimate[x.ind[apply(x.ind.flag, 1, any),]] } } return(fhat) } ############################################################################### ## Multivariate kernel density estimate using normal kernels ## ## Parameters ## x - points ## H - bandwidth matrix ## gridsize - number of interval points in grid ## supp - effective support of kernel ## eval.points - compute density estimate at these points (if missing ## and dim(x) = 2, 3 compute density estimate over grid) ## eval.levels - compute 3-D in 2-D slices taken at these level curves ## ## Returns ## list with first d components with the points that the density ## estimate is evaluated at, and values of the density estimate ############################################################################## kde <- function(x, H, h, gridsize, gridtype, xmin, xmax, supp=3.7, eval.points, binned, bgridsize, positive=FALSE, adj.positive, w, compute.cont=TRUE, approx.cont=TRUE, unit.interval=FALSE, verbose=FALSE) { ## default values ksd <- ks.defaults(x=x, w=w, binned=binned, bgridsize=bgridsize, gridsize=gridsize) d <- ksd$d; n <- ksd$n; w <- ksd$w binned <- ksd$binned gridsize <- ksd$gridsize bgridsize <- ksd$bgridsize if (d==1 & missing(h) & !positive) h <- hpi(x=x, nstage=2, binned=default.bflag(d=d, n=n), deriv.order=0) if (d>1 & missing(H) & !positive) H <- Hpi(x=x, nstage=2, binned=default.bflag(d=d, n=n), deriv.order=0) if (binned & d>4) stop("Binned estimation for d>4 not implemented. Set binned=FALSE for exact estimation.") ## compute binned estimator if (binned) { if (positive) { if (d==1) { fhat <- kde.positive.1d(x=x, h=h, bgridsize=bgridsize, xmin=xmin, xmax=xmax, w=w, binned=binned, adj.positive=adj.positive) } else if (d==2) { fhat <- kde.positive.2d(x=x, H=H, bgridsize=bgridsize, xmin=xmin, xmax=xmax, w=w, binned=binned, adj.positive=adj.positive) } ##warning("Using binned estimation for positive data may not be reliable.") } else if (unit.interval) { fhat <- kde.unit.interval.1d(x=x, binned=binned, h=h) } else { fhat <- kdde.binned(x=x, H=H, h=h, bgridsize=bgridsize, xmin=xmin, xmax=xmax, w=w, deriv.order=0, verbose=verbose) } if (!missing(eval.points)) { fhat$estimate <- predict(fhat, x=eval.points) fhat$eval.points <- eval.points } } else { ## compute exact (non-binned) estimator ## 1-dimensional if (d==1) { if (missing(eval.points)) { if (unit.interval) fhat <- kde.unit.interval.1d(x=x, h=h, binned=FALSE) else if (positive) fhat <- kde.positive.1d(x=x, h=h, xmin=xmin, xmax=xmax, w=w, binned=FALSE, adj.positive=adj.positive) else fhat <- kde.grid.1d(x=x, h=h, gridsize=gridsize, supp=supp, positive=positive, xmin=xmin, xmax=xmax, adj.positive=adj.positive, gridtype=gridtype, w=w) } else fhat <- kde.points.1d(x=x, h=h, eval.points=eval.points, positive=positive, adj.positive=adj.positive, w=w) } ## multi-dimensional else { if (is.data.frame(x)) x <- as.matrix(x) if (missing(eval.points)) { if (d==2) { if (positive) fhat <- kde.positive.2d(x=x, H=H, gridsize=gridsize, xmin=xmin, xmax=xmax, w=w, binned=binned, adj.positive=adj.positive) else fhat <- kde.grid.2d(x=x, H=H, gridsize=gridsize, supp=supp, xmin=xmin, xmax=xmax, gridtype=gridtype, w=w, verbose=verbose) } else if (d==3) fhat <- kde.grid.3d(x=x, H=H, gridsize=gridsize, supp=supp, xmin=xmin, xmax=xmax, gridtype=gridtype, w=w, verbose=verbose) else fhat <- kde.grid.nd(x=x, H=H, gridsize=gridsize, supp=supp, xmin=xmin, xmax=xmax, gridtype=gridtype, w=w, verbose=verbose) ##stop("Need to specify eval.points for more than 3 dimensions") } else fhat <- kde.points(x=x, H=H, eval.points=eval.points, w=w, verbose=verbose) } } fhat$binned <- binned fhat$names <- parse.name(x) ## add variable names fhat$w <- w class(fhat) <- "kde" ## compute prob contour levels if (compute.cont & missing(eval.points)) fhat$cont <- contourLevels(fhat, cont=1:99, approx=approx.cont) return(fhat) } ############################################################################### ## Univariate kernel density estimate on a grid ############################################################################### kde.grid.1d <- function(x, h, gridsize, supp=3.7, positive=FALSE, adj.positive, xmin, xmax, gridtype, w) { if (missing(xmin)) xmin <- min(x) - h*supp if (missing(xmax)) xmax <- max(x) + h*supp if (missing(gridtype)) gridtype <- "linear" if (positive) { if (missing(adj.positive)) adj.positive <- abs(min(x)) y <- log(x + adj.positive) ## transform positive data x to real line gridx <- seq(max(0, xmin), xmax, length=gridsize) gridy <- log(gridx + adj.positive) gridtype.vec <- "linear" } else { y <- x gridtype1 <- match.arg(gridtype, c("linear", "sqrt", "quantile", "exp")) if (gridtype1=="linear") { gridy <- seq(xmin, xmax, length=gridsize) } else if (gridtype1=="sqrt") { gridy.temp <- seq(sign(xmin)*sqrt(abs(xmin)), sign(xmax)*sqrt(abs(xmax)), length=gridsize) gridy <- sign(gridy.temp) * gridy.temp^2 } else if (gridtype1=="exp") { gridy.temp <- seq(exp(xmin), exp(xmax), length=gridsize) gridy <- log(gridy.temp) } gridtype.vec <- gridtype1 } n <- length(y) est <- dnorm.mixt(x=gridy, mus=y, sigmas=rep(h, n), props=w/n) fhat <- list(x=y, eval.points=gridy, estimate=est, h=h, H=h^2, gridtype=gridtype.vec, gridded=TRUE) if (positive) { ## compute transformation KDE fhat$estimate <- fhat$estimate/(exp(gridy)) fhat$x <- x fhat$eval.points <- exp(gridy) - adj.positive ##gridx } class(fhat) <- "kde" return(fhat) } kde.positive.1d <- function(x, h, adj.positive, binned=FALSE, xmin, xmax, compute.cont=TRUE, approx.cont=TRUE, ...) { if (missing(adj.positive)) adj.positive <- abs(min(x)) y <- log(x + adj.positive) if (missing(h)) h <- hpi(y, binned=binned) d <- 1 tol <- 3.7 tol.h <- tol*h if (missing(xmin)) xmin <- min(x) - tol.h if (missing(xmax)) xmax <- max(x) + tol.h xmin[xmin<0] <- 0 ymin1 <- log(xmin + adj.positive) ymax1 <- log(xmax + adj.positive) fhaty <- kde(x=y, h=h, xmin=ymin1, xmax=ymax1, gridtype=c("exp"), binned=binned, compute.cont=compute.cont, approx.cont=approx.cont, ...) fhaty$estimate[is.nan(fhaty$estimate)] <- 0 fhatx <- fhaty fhatx$x <- x fhatx$eval.points <- exp(fhaty$eval.points) - adj.positive jacobian <- abs(exp(fhaty$eval.points)) jacobian[jacobian<=0] <- min(fhatx$estimate[fhatx$estimate>0]) fhatx$estimate <- fhaty$estimate/jacobian if (compute.cont) fhatx$cont <- contourLevels(fhatx, cont=1:99, approx=approx.cont) return(fhatx) } kde.unit.interval.1d <- function(x, h, binned=FALSE) { d <-1 y <- qnorm(x) if (missing(h)) h <- hpi(y) xseq <- tail(head(seq(0,1, length=default.gridsize(d)+2),n=-1), n=-1) fhaty <- kde(x=y, h=h, binned=binned) ##fhaty$eval.points <- qnorm(xseq) fhaty$estimate <- predict(fhaty, x=qnorm(xseq)) fhatx <- fhaty fhatx$eval.points <- xseq fhatx$estimate <- fhaty$estimate/dnorm(fhaty$eval.points) ## apply loess smoothing for unsmmooth binned estimates if (binned) { fhatx.loess <- loess(fhatx$estimate ~ fhatx$eval.points) fhatx.smoothed <- fhatx fhatx.smoothed$eval.points <- xseq fhatx.smoothed$estimate <- predict(fhatx.loess, x=xseq) fhatx <- fhatx.smoothed } return(fhatx) } ############################################################################### ## Bivariate kernel density estimate using normal kernels, evaluated over grid ## ## Parameters ## x - data points ## H - bandwidth matrix ## gridsize - number of interval points in grid ## supp - effective support of kernel ## ## Returns ## list with fields ## x - data points ## eval.points - points that KDE is evaluated at ## estimate - KDE evaluated at eval.points ## H - bandwidth matrix ############################################################################### kde.grid.2d <- function(x, H, gridsize, supp, gridx=NULL, grid.pts=NULL, xmin, xmax, gridtype, w, verbose=FALSE) { ## initialise grid n <- nrow(x) if (is.null(gridx)) gridx <- make.grid.ks(x, matrix.sqrt(H), tol=supp, gridsize=gridsize, xmin=xmin, xmax=xmax, gridtype=gridtype) suppx <- make.supp(x, matrix.sqrt(H), tol=supp) if (is.null(grid.pts)) grid.pts <- find.gridpts(gridx, suppx) fhat.grid <- matrix(0, nrow=length(gridx[[1]]), ncol=length(gridx[[2]])) if (verbose) pb <- txtProgressBar() for (i in 1:n) { ## compute evaluation points eval.x <- gridx[[1]][grid.pts$xmin[i,1]:grid.pts$xmax[i,1]] eval.y <- gridx[[2]][grid.pts$xmin[i,2]:grid.pts$xmax[i,2]] eval.x.ind <- c(grid.pts$xmin[i,1]:grid.pts$xmax[i,1]) eval.y.ind <- c(grid.pts$xmin[i,2]:grid.pts$xmax[i,2]) eval.x.len <- length(eval.x) eval.pts <- expand.grid(eval.x, eval.y) fhat <- dmvnorm(eval.pts, x[i,], H) ## place vector of density estimate values `fhat' onto grid 'fhat.grid' for (j in 1:length(eval.y)) fhat.grid[eval.x.ind, eval.y.ind[j]] <- fhat.grid[eval.x.ind, eval.y.ind[j]] + w[i]*fhat[((j-1) * eval.x.len + 1):(j * eval.x.len)] if (verbose) setTxtProgressBar(pb, i/n) } if (verbose) close(pb) fhat.grid <- fhat.grid/n gridx1 <- list(gridx[[1]], gridx[[2]]) fhat.list <- list(x=x, eval.points=gridx1, estimate=fhat.grid, H=H, gridtype=gridx$gridtype, gridded=TRUE) return(fhat.list) } ###################################################################### ## Bivariate KDE for data in positive quadrant ###################################################################### kde.positive.2d <- function(x, H, adj.positive, binned=FALSE, xmin, xmax, compute.cont=TRUE, approx.cont=TRUE, ...) { if (missing(adj.positive)) adj.positive <- abs(apply(x, 2, min)) y <- log(cbind(x[,1] + adj.positive[1],x[,2] + adj.positive[2])) if (missing(H)) H <- Hpi(y, binned=binned) d <- ncol(x) tol <- 3.7 tol.H <- tol * diag(H) if (missing(xmin)) xmin <- apply(x, 2, min) - tol.H if (missing(xmax)) xmax <- apply(x, 2, max) + tol.H xmin[xmin<0] <- 0 ymin1 <- log(pmax(xmin + adj.positive, apply(x, 2, min))) ymax1 <- log(xmax + adj.positive) fhaty <- kde(x=y, H=H, xmin=ymin1, xmax=ymax1, gridtype=c("exp", "exp"), binned=binned, compute.cont=compute.cont, approx.cont=approx.cont, ...) fhaty$estimate[is.nan(fhaty$estimate)] <- 0 fhatx <- fhaty fhatx$x <- x fhatx$eval.points[[1]] <- exp(fhaty$eval.points[[1]]) - adj.positive[1] fhatx$eval.points[[2]] <- exp(fhaty$eval.points[[2]]) - adj.positive[2] jacobian <- abs(exp(fhaty$eval.points[[1]]) %o% exp(fhaty$eval.points[[2]])) jacobian[jacobian<=0] <- min(fhatx$estimate[fhatx$estimate>0]) fhatx$estimate <- fhaty$estimate/jacobian if (compute.cont) fhatx$cont <- contourLevels(fhatx, cont=1:99, approx=approx.cont) return(fhatx) } ############################################################################### ## Trivariate kernel density estimate using normal kernels, evaluated over grid ## ## Parameters ## x - data points ## H - bandwidth matrix ## gridsize - number of interval points in grid ## supp - effective support of kernel ## ## Returns ## list with fields ## x - data points ## eval.points - points that KDE is evaluated at ## estimate - KDE evaluated at eval.points ## H - bandwidth matrix ############################################################################### kde.grid.3d <- function(x, H, gridsize, supp, gridx=NULL, grid.pts=NULL, xmin, xmax, gridtype, w, verbose=FALSE) { ## initialise grid n <- nrow(x) if (is.null(gridx)) gridx <- make.grid.ks(x, matrix.sqrt(H), tol=supp, gridsize=gridsize, xmin=xmin, xmax=xmax, gridtype=gridtype) suppx <- make.supp(x, matrix.sqrt(H), tol=supp) if (is.null(grid.pts)) grid.pts <- find.gridpts(gridx, suppx) fhat.grid <- array(0, dim=c(length(gridx[[1]]), length(gridx[[2]]), length(gridx[[3]]))) if (verbose) pb <- txtProgressBar() for (i in 1:n) { ## compute evaluation points eval.x <- gridx[[1]][grid.pts$xmin[i,1]:grid.pts$xmax[i,1]] eval.y <- gridx[[2]][grid.pts$xmin[i,2]:grid.pts$xmax[i,2]] eval.z <- gridx[[3]][grid.pts$xmin[i,3]:grid.pts$xmax[i,3]] eval.x.ind <- c(grid.pts$xmin[i,1]:grid.pts$xmax[i,1]) eval.y.ind <- c(grid.pts$xmin[i,2]:grid.pts$xmax[i,2]) eval.z.ind <- c(grid.pts$xmin[i,3]:grid.pts$xmax[i,3]) eval.x.len <- length(eval.x) eval.pts <- expand.grid(eval.x, eval.y) ## place vector of density estimate values `fhat' onto grid 'fhat.grid' for (k in 1:length(eval.z)) { fhat <- w[i]*dmvnorm(cbind(eval.pts, eval.z[k]), x[i,], H) for (j in 1:length(eval.y)) fhat.grid[eval.x.ind,eval.y.ind[j], eval.z.ind[k]] <- fhat.grid[eval.x.ind, eval.y.ind[j], eval.z.ind[k]] + fhat[((j-1) * eval.x.len + 1):(j * eval.x.len)] } if (verbose) setTxtProgressBar(pb, i/n) } if (verbose) close(pb) fhat.grid <- fhat.grid/n gridx1 <- list(gridx[[1]], gridx[[2]], gridx[[3]]) fhat.list <- list(x=x, eval.points=gridx1, estimate=fhat.grid, H=H, gridtype=gridx$gridtype, gridded=TRUE) return(fhat.list) } kde.grid.nd <- function(x, H, gridsize, supp, gridx=NULL, grid.pts=NULL, xmin, xmax, gridtype, w, verbose=FALSE) { ## initialise grid n <- nrow(x) if (is.null(gridx)) gridx <- make.grid.ks(x, matrix.sqrt(H), tol=supp, gridsize=gridsize, xmin=xmin, xmax=xmax, gridtype=gridtype) ##suppx <- make.supp(x, matrix.sqrt(H), tol=supp) ##if (is.null(grid.pts)) grid.pts <- find.gridpts(gridx, suppx) gridx1 <- gridx gridx1$stepsize <- NULL gridx1$gridtype <- NULL eval.points <- do.call(expand.grid, gridx1) est <- kde.points(x=x, H=H, eval.points=eval.points, w=w, verbose=verbose)$estimate fhat.grid <- array(est, dim=gridsize) fhat.list <- list(x=x, eval.points=gridx1, estimate=fhat.grid, H=H, gridtype=gridx$gridtype, gridded=TRUE) return(fhat.list) } ############################################################################### ## Multivariate kernel density estimate using normal kernels, ## evaluated at each sample point ## ## Parameters ## x - data points ## H - bandwidth matrix ## eval.points - points where to evaluate density estimate ## ## Returns ## list with fields ## x - data points ## eval.points - points that KDE is evaluated at ## estimate - KDE evaluated at eval.points ## H - bandwidth matrix ############################################################################### kde.points <- function(x, H, eval.points, w, verbose) { n <- nrow(x) d <- ncol(x) ne <- nrow(eval.points) Hs <- replicate(n, H, simplify=FALSE) Hs <- do.call(rbind, Hs) fhat <- dmvnorm.mixt(x=eval.points, mus=x, Sigmas=Hs, props=w/n, verbose=verbose) ##if (verbose) pb <- txtProgressBar() ##n.seq <- block.indices(ny=ne, nx=n, d=d, r=0) ##fhat <- numeric() ##for (i in 1:(length(n.seq)-1)) ##{ ## difs <- differences(x=x, y=eval.points[n.seq[i]:(n.seq[i+1]-1),]) ## dens <- dmvnorm(x=-difs, mean=rep(0,d), sigma=H) ## fhat <- c(fhat, aggregate(w[n.seq[i]:(n.seq[i+1]-1)]*dens, by=list(rep(n.seq[i]:(n.seq[i+1]-1), each=n)), FUN=mean)$x) ## if (verbose) setTxtProgressBar(pb, i/(length(n.seq)-1)) ##} ##if (verbose) close(pb) return(list(x=x, eval.points=eval.points, estimate=fhat, H=H, gridded=FALSE)) } kde.points.1d <- function(x, h, eval.points, positive=FALSE, adj.positive, w) { n <- length(x) if (positive) { if (missing(adj.positive)) adj.positive <- abs(min(x)) y <- log(x + adj.positive) ## transform positive data x to real line eval.pointsy <- log(eval.points + adj.positive) } else { y <- x eval.pointsy <- eval.points } est <- dnorm.mixt(x=eval.pointsy, mus=y, sigmas=rep(h,n), props=w/n) if (positive) est <- est/(eval.points + adj.positive) ##fhat/exp(eval.pointsy) fhat <- list(x=x, eval.points=eval.points, estimate=est, h=h, H=h^2, gridded=FALSE) return(fhat) } ############################################################################### ## Display kernel density estimate ## ## Parameters ## fhat - output from call to `kde' ############################################################################### plot.kde <- function(x, ...) { fhat <- x if (is.vector(fhat$x)) plotkde.1d(fhat, ...) else { d <- ncol(fhat$x) if (d==2) { opr <- options()$preferRaster; if (!is.null(opr)) if (!opr) options("preferRaster"=TRUE) plotret <- plotkde.2d(fhat, ...) if (!is.null(opr)) options("preferRaster"=opr) invisible(plotret) } else if (d==3) { plotkde.3d(fhat, ...) invisible() } else stop ("Plot function only available for 1, 2 or 3-d data") } } plotkde.1d <- function(fhat, xlab, ylab="Density function", add=FALSE, drawpoints=FALSE, col=1, col.pt="blue", col.cont=1, cont.lwd=1, jitter=FALSE, cont, abs.cont, approx.cont=TRUE, ...) { if (missing(xlab)) xlab <- fhat$names if (add) lines(fhat$eval.points, fhat$estimate, xlab=xlab, ylab=ylab, col=col, ...) else plot(fhat$eval.points, fhat$estimate, type="l", xlab=xlab, ylab=ylab, col=col, ...) ## compute contours if (!missing(cont) | !missing(abs.cont)) { if (missing(abs.cont)) { if (!is.null(fhat$cont)) { cont.ind <- rep(FALSE, length(fhat$cont)) for (j in 1:length(cont)) cont.ind[which(cont[j] == 100-as.numeric(unlist(strsplit(names(fhat$cont),"%"))))] <- TRUE if (all(!cont.ind)) hts <- contourLevels(fhat, prob=(100-cont)/100, approx=approx.cont) else hts <- fhat$cont[cont.ind] } else hts <- contourLevels(fhat, prob=(100-cont)/100, approx=approx.cont) } else hts <- abs.cont ## if (is.null(fhat$deriv.order)) { hts <- sort(hts, decreasing=TRUE) cont.ind <- 1-as.numeric(fhat$estimate>=hts[1]) cont.ind[cont.ind==1] <- NA lines(fhat$eval.points, cont.ind, col=col.cont, lwd=cont.lwd) } else { for (i in 1:length(hts)) { cont.ind <- 1-as.numeric(abs(fhat$estimate)>=abs(hts[i])) cont.ind[cont.ind==1] <- NA lines(fhat$eval.points, cont.ind, col=col.cont, lwd=cont.lwd) } } } if (drawpoints) if (jitter) rug(jitter(fhat$x), col=col.pt) else rug(fhat$x, col=col.pt) } ############################################################################### ## Display bivariate kernel density estimate ## ## Parameters ## fhat - output from 'kde.grid' ## display - "persp" - perspective plot ## - "slice" - contour plot ## - "image" image plot ## cont - vector of contours to be plotted ############################################################################### plotkde.2d <- function(fhat, display="slice", cont=c(25,50,75), abs.cont, approx.cont=TRUE, xlab, ylab, zlab="Density function", cex=1, pch=1, add=FALSE, drawpoints=FALSE, drawlabels=TRUE, theta=-30, phi=40, d=4, col.pt="blue", col, col.fun, lwd=1, border=1, thin=3, lwd.fc=5, kdde.flag=FALSE, ...) { disp1 <- match.arg(display, c("slice", "persp", "image", "filled.contour", "filled.contour2")) if (!is.list(fhat$eval.points)) stop("Need a grid of density estimates") if (missing(xlab)) xlab <- fhat$names[1] if (missing(ylab)) ylab <- fhat$names[2] ## perspective/wireframe plot if (disp1=="persp") { hts <- seq(0, 1.1*max(fhat$estimate,na.rm=TRUE), length=500) if (missing(col)) col <- topo.colors(length(hts)+1, alpha=0.5) if (!missing(col.fun)) col <- col.fun(length(hts)+1) if (length(col)0 | !is.null(fhat$deriv.order)) { j<-j+1; contour(fhat$eval.points[[1]], fhat$eval.points[[2]], fhat$estimate*scale, level=hts[i]*scale, add=j>1 | add, drawlabels=drawlabels, col=col[i], lwd=lwd, xlab=xlab, ylab=ylab, ...) } } ## add points if (drawpoints) points(fhat$x[,1], fhat$x[,2], col=col.pt, cex=cex, pch=pch) } ## image plot else if (disp1=="image") { if (missing(col)) col <- rev(heat.colors(100)) image(fhat$eval.points[[1]], fhat$eval.points[[2]], fhat$estimate, xlab=xlab, ylab=ylab, add=add, col=col, ...) ## add points if (drawpoints) points(fhat$x[,1], fhat$x[,2], col=col.pt, cex=cex, pch=pch) box() } else if (disp1=="filled.contour" | disp1=="filled.contour2") { ## compute contours if (missing(abs.cont)) { if (!is.null(fhat$cont)) { cont.ind <- rep(FALSE, length(fhat$cont)) for (j in 1:length(cont)) cont.ind[which(cont[j] == 100-as.numeric(unlist(strsplit(names(fhat$cont),"%"))))] <- TRUE if (all(!cont.ind)) hts <- contourLevels(fhat, prob=(100-cont)/100, approx=approx.cont) else hts <- fhat$cont[cont.ind] } else hts <- contourLevels(fhat, prob=(100-cont)/100, approx=approx.cont) } else hts <- abs.cont hts <- sort(hts) if (missing(col)) col <- c("transparent", rev(heat.colors(length(hts)))) if (!missing(col.fun)) col <- c(col.fun(length(hts)+1)) clev <- c(min(c(fhat$estimate, hts)-0.01*max(abs(fhat$estimate))), hts, max(c(fhat$estimate, hts)) + 0.01*max(abs(fhat$estimate))) if (disp1=="filled.contour2") { image(fhat$eval.points[[1]], fhat$eval.points[[2]], fhat$estimate, xlab=xlab, ylab=ylab, add=add, col=col[1:(length(hts)+1)], breaks=clev, ...) ## draw contours for (i in 1:length(hts)) { if (!kdde.flag) contour(fhat$eval.points[[1]], fhat$eval.points[[2]], fhat$estimate, level=hts[i], add=TRUE, drawlabels=FALSE, col=col[i+1], lwd=lwd.fc) else { if (i <= length(hts)%/%2) contour(fhat$eval.points[[1]], fhat$eval.points[[2]], fhat$estimate, level=hts[i], add=TRUE, drawlabels=FALSE, col=col[i], lwd=lwd.fc) else contour(fhat$eval.points[[1]], fhat$eval.points[[2]], fhat$estimate, level=hts[i], add=TRUE, drawlabels=FALSE, col=col[i+1], lwd=lwd.fc) } } } else { if (!add) plot(fhat$eval.points[[1]], fhat$eval.points[[2]], type="n", xlab=xlab, ylab=ylab, ...) ##if (col[1]!="transparent") .filled.contour(fhat$eval.points[[1]], fhat$eval.points[[2]], z=fhat$estimate, levels=clev, col=col) } if (!missing(lwd)) { for (i in 1:length(hts)) { if (missing(abs.cont)) scale <- cont[i]/hts[i] else scale <- 1 if (lwd >=1) contour(fhat$eval.points[[1]], fhat$eval.points[[2]], fhat$estimate*scale, level=hts[i]*scale, add=TRUE, drawlabels=drawlabels, col=1, lwd=lwd, ...) } } ## add points if (drawpoints) points(fhat$x[,1], fhat$x[,2], col=col.pt, cex=cex, pch=pch) box() } if (disp1=="persp") invisible(plotret) else invisible() } ############################################################################### ## Display trivariate kernel density estimate ############################################################################### plotkde.3d <- function(fhat, cont=c(25,50,75), abs.cont, approx.cont=TRUE, colors, col.fun, alphavec, size=3, col.pt="blue", add=FALSE, xlab, ylab, zlab, drawpoints=FALSE, alpha=1, box=TRUE, axes=TRUE, ...) { ## suggestions from Viktor Petukhov 08/03/2018 if (!requireNamespace("rgl", quietly=TRUE)) stop("Install the rgl package as it is required.", call.=FALSE) if (!requireNamespace("misc3d", quietly=TRUE)) stop("Install the misc3d package as it is required.", call.=FALSE) ## compute contours if (missing(abs.cont)) { if (!is.null(fhat$cont)) { cont.ind <- rep(FALSE, length(fhat$cont)) for (j in 1:length(cont)) cont.ind[which(cont[j] == 100-as.numeric(unlist(strsplit(names(fhat$cont),"%"))))] <- TRUE if (all(!cont.ind)) hts <- contourLevels(fhat, prob=(100-cont)/100, approx=approx.cont) else hts <- fhat$cont[cont.ind] } else hts <- contourLevels(fhat, prob=(100-cont)/100, approx=approx.cont) } else hts <- abs.cont nc <- length(hts) if (missing(colors)) colors <- rev(heat.colors(nc)) if (!missing(col.fun)) colors <- col.fun(nc) if (missing(xlab)) xlab <- fhat$names[1] if (missing(ylab)) ylab <- fhat$names[2] if (missing(zlab)) zlab <- fhat$names[3] if (missing(alphavec)) { if (is.null(fhat$deriv.order)) alphavec <- seq(0.1,0.5,length=nc) else alphavec <- c(rev(seq(0.1,0.4,length=round(nc/2))), seq(0.1,0.4,length=round(nc/2))) } fhat.eval.mean <- sapply(fhat$eval.points, mean) if (drawpoints) rgl::plot3d(fhat$x[,1],fhat$x[,2],fhat$x[,3], size=size, col=col.pt, alpha=alpha, xlab=xlab, ylab=ylab, zlab=zlab, add=add, box=FALSE, axes=FALSE, ...) else rgl::plot3d(fhat$x[,1],fhat$x[,2],fhat$x[,3], size=0, col="transparent", alpha=0, xlab=xlab, ylab=ylab, zlab=zlab, add=add, box=FALSE, axes=FALSE, ...) for (i in 1:nc) if (hts[nc-i+1] < max(fhat$estimate)) misc3d::contour3d(fhat$estimate, level=hts[nc-i+1], x=fhat$eval.points[[1]], y=fhat$eval.points[[2]], z=fhat$eval.points[[3]], add=TRUE, color=colors[i], alpha=alphavec[i], box=FALSE, axes=FALSE, ...) if (axes) rgl::axes3d() if (box) rgl::box3d() } ############################################################################### ## Contour levels S3 method ############################################################################### ## create S3 generic contourLevels <- function(x, ...){ UseMethod("contourLevels") } contourLevels.kde <- function(x, prob, cont, nlevels=5, approx=TRUE, ...) { fhat <- x if (is.vector(fhat$x)) { d <- 1; n <- length(fhat$x) } else { d <- ncol(fhat$x); n <-nrow(fhat$x) if (!is.matrix(fhat$x)) fhat$x <- as.matrix(fhat$x) } if (is.null(x$w)) w <- rep(1, n) else w <- x$w if (is.null(fhat$gridded)) { if (d==1) fhat$gridded <- fhat$binned else fhat$gridded <- is.list(fhat$eval.points) } if (missing(prob) & missing(cont)) hts <- pretty(fhat$estimate, n=nlevels) else { if (approx & fhat$gridded) dobs <- predict(fhat, x=fhat$x) else dobs <- kde(x=fhat$x, H=fhat$H, eval.points=fhat$x, w=w)$estimate if (!missing(prob) & missing(cont)) hts <- quantile(dobs, prob=prob) if (missing(prob) & !missing(cont)) hts <- quantile(dobs, prob=(100-cont)/100) } return(hts) } ############################################################################### ## Riemann sums to compute approximate Lebesgue measure of contour set ############################################################################### contourSizes <- function(x, abs.cont, cont=c(25,50,75), approx=TRUE) { num.int <- vector() if (missing(abs.cont)) abs.cont <- contourLevels(x, cont=cont, approx=approx) num.int <- rep(0, length(abs.cont)) if (!is.null(names(abs.cont))) names(num.int) <- names(abs.cont) ##abs.cont <- sort(abs.cont) if (!is.list(x$eval.points)) delta.int <- head(diff(x$eval.points), n=1) else delta.int <- prod(sapply(x$eval.points, diff)[1,]) for (j in 1:length(abs.cont)) num.int[j] <- sum(x$estimate>abs.cont[j]) return(num.int*delta.int) } ks/R/binning.R0000644000176200001440000001665113557542752012667 0ustar liggesusers ### Default grid sizes default.gridsize <- function(d) { if (d==1) gridsize <- 401 else if (d==2) gridsize <- rep(151,d) else if (d==3) gridsize <- rep(51, d) else if (d>=4) gridsize <- rep(21, d) ##else gridsize <- NA return(gridsize) } default.bgridsize <- function(d) { if (d==1) gridsize <- 401 else if (d==2) gridsize <- rep(151,d) else if (d==3) gridsize <- rep(31, d) else if (d==4) gridsize <- rep(15, d) else gridsize <- NA return(gridsize) } default.bflag <- function(d, n) { if (d==1) thr <- 1 else if (d==2) thr <- 500 else if (d>2) thr <- 1000 bf <- n>thr return(bf) } ######################################################################## ## Linear binning ## Courtesy of M Wand 2005 ## Extended by T Duong to 3- and 4-dim 2006 ## Extended by Gramack & Gramacki to include unconstrained b/w 2015 ######################################################################## binning <- function(x, H, h, bgridsize, xmin, xmax, supp=3.7, w, gridtype="linear") { x <- as.matrix(x) d <- ncol(x) n <- nrow(x) if (missing(w)) w <- rep(1,n) if (missing(h)) h <- rep(0,d) if (!missing(H)) h <- sqrt(diag(H)) if (missing(bgridsize)) bgridsize <- default.gridsize(d) if (!(missing(xmin) & missing(xmax))) { range.x <- list() for (i in 1:d) range.x[[i]] <- c(xmin[i], xmax[i]) } else { range.x <- list() for (i in 1:d) range.x[[i]] <- c(min(x[,i]) - supp*h[i], max(x[,i]) + supp*h[i]) } if (!(missing(xmax))) {if (any(sweep(x, 2, FUN=">", xmax))) warning("Points in x greater than xmax don't contribute to binning grid counts.")} if (!(missing(xmin))) {if (any(sweep(x, 2, FUN="<", xmin))) warning("Points in x less than xmin don't contribute to binning grid counts.")} a <- unlist(lapply(range.x,min)) b <- unlist(lapply(range.x,max)) if (missing(gridtype)) gridtype <- rep("linear", d) gridtype.vec <- rep("", d) gpoints <- list() for (id in 1:d) { gridtype1 <- match.arg(gridtype[i], c("linear", "sqrt", "quantile", "log")) if (gridtype1=="linear") gpoints[[id]] <- seq(a[id],b[id],length=bgridsize[id]) else if (gridtype1=="log") gpoints[[id]] <- seq(exp(a[id]),exp(b[id]),length=bgridsize[id]) } if (d==1) counts <- linbin.ks(x,gpoints[[1]], w=w) if (d==2) counts <- linbin2D.ks(x,gpoints[[1]],gpoints[[2]], w=w) if (d==3) counts <- linbin3D.ks(x,gpoints[[1]],gpoints[[2]],gpoints[[3]], w=w) if (d==4) counts <- linbin4D.ks(x,gpoints[[1]],gpoints[[2]],gpoints[[3]],gpoints[[4]], w=w) bin.counts <- list(counts=counts, eval.points=gpoints, w=w) if (d==1) bin.counts <- lapply(bin.counts, unlist) return(bin.counts) } ######################################################################## ## Linear binning ######################################################################## linbin.ks <- function(x, gpoints, w) { n <- length(x) M <- length(gpoints) if (missing(w)) w <- rep(1, n) a <- gpoints[1] b <- gpoints[M] xi <- .C(C_massdist1d, x1=as.double(x[,1]), n=as.integer(n), a1=as.double(a), b1=as.double(b), M1=as.integer(M), weight=as.double(w), est=double(M))$est return(xi) } linbin2D.ks <- function(x, gpoints1, gpoints2, w) { n <- nrow(x) M1 <- length(gpoints1) M2 <- length(gpoints2) a1 <- gpoints1[1] a2 <- gpoints2[1] b1 <- gpoints1[M1] b2 <- gpoints2[M2] if (missing(w)) w <- rep(1, n) ## binning for interior points out <- .C(C_massdist2d, x1=as.double(x[,1]), x2=as.double(x[,2]), n=as.integer(n), a1=as.double(a1), a2=as.double(a2), b1=as.double(b1), b2=as.double(b2), M1=as.integer(M1), M2=as.integer(M2), weight=as.double(w), est=double(M1*M2)) xi <- matrix(out$est, nrow=M1, ncol=M2) return(xi) } linbin3D.ks <- function(x, gpoints1, gpoints2, gpoints3, w) { n <- nrow(x) M1 <- length(gpoints1) M2 <- length(gpoints2) M3 <- length(gpoints3) a1 <- gpoints1[1] a2 <- gpoints2[1] a3 <- gpoints3[1] b1 <- gpoints1[M1] b2 <- gpoints2[M2] b3 <- gpoints3[M3] if (missing(w)) w <- rep(1, n) ## binning for interior points out <- .C(C_massdist3d, x1=as.double(x[,1]), x2=as.double(x[,2]), x3=as.double(x[,3]), n=as.integer(n), a1=as.double(a1), a2=as.double(a2), a3=as.double(a3), b1=as.double(b1), b2=as.double(b2), b3=as.double(b3), M1=as.integer(M1), M2=as.integer(M2), M3=as.integer(M3), weight=as.double(w), est=double(M1*M2*M3)) xi <- array(out$est, dim=c(M1,M2,M3)) return(xi) } linbin4D.ks <- function(x, gpoints1, gpoints2, gpoints3, gpoints4, w) { n <- nrow(x) M1 <- length(gpoints1) M2 <- length(gpoints2) M3 <- length(gpoints3) M4 <- length(gpoints4) a1 <- gpoints1[1] a2 <- gpoints2[1] a3 <- gpoints3[1] a4 <- gpoints4[1] b1 <- gpoints1[M1] b2 <- gpoints2[M2] b3 <- gpoints3[M3] b4 <- gpoints4[M4] if (missing(w)) w <- rep(1, n) ## binning for interior points out <- .C(C_massdist4d, x1=as.double(x[,1]), x2=as.double(x[,2]), x3=as.double(x[,3]), x4=as.double(x[,4]), n=as.integer(n), a1=as.double(a1), a2=as.double(a2), a3=as.double(a3), a4=as.double(a4), b1=as.double(b1), b2=as.double(b2), b3=as.double(b3), b4=as.double(b4), M1=as.integer(M1), M2=as.integer(M2), M3=as.integer(M3), M4=as.integer(M4), weight=as.double(w), est=double(M1*M2*M3*M4)) xi <- array(out$est, dim=c(M1,M2,M3,M4)) return(xi) } ######################################################################## ## Discrete convolution ######################################################################## symconv.1d <- function(keval, gcounts) { M <- length(gcounts) N <- length(keval) L <- (length(keval)+1)/2 ## Smallest powers of 2 >= M + N P <- 2^(ceiling(log2(M + N))) ## Zero-padded version of keval an gcounts keval.zeropad <- rep(0, P) gcounts.zeropad <- rep(0, P) keval.zeropad[1:N] <- keval gcounts.zeropad[L:(L+M-1)] <- gcounts ## FFTs K <- fft(keval.zeropad) C <- fft(gcounts.zeropad) ## Invert element-wise product of FFTs and truncate and normalise it symconv.val <- Re(fft(K*C, inverse=TRUE)/P)[N:(N+M-1)] return(symconv.val) } symconv.nd <- function(keval, gcounts, d) { M <- dim(gcounts) N <- dim(keval) L <- (dim(keval)+1)/2 ## Smallest powers of 2 >= M + N P <- 2^(ceiling(log2(M + N))) ## Zero-padded version of keval and gcounts keval.zeropad <- array(0, dim=P) gcounts.zeropad <- array(0, dim=P) if (d==2) { keval.zeropad[1:N[1], 1:N[2]] <- keval gcounts.zeropad[L[1]:(L[1]+M[1]-1), L[2]:(L[2]+M[2]-1)] <- gcounts } else if (d==3) { keval.zeropad[1:N[1], 1:N[2], 1:N[3]] <- keval gcounts.zeropad[L[1]:(L[1]+M[1]-1), L[2]:(L[2]+M[2]-1), L[3]:(L[3]+M[3]-1)] <- gcounts } else if (d==4) { keval.zeropad[1:N[1], 1:N[2], 1:N[3], 1:N[4]] <- keval gcounts.zeropad[L[1]:(L[1]+M[1]-1), L[2]:(L[2]+M[2]-1), L[3]:(L[3]+M[3]-1), L[4]:(L[4]+M[4]-1) ] <- gcounts } ## FFTs K <- fft(keval.zeropad) C <- fft(gcounts.zeropad) ## Invert element-wise product of FFTs and truncate and normalise it symconv.val <- Re(fft(K*C, inverse=TRUE)/prod(P)) if (d==2) symconv.val <- symconv.val[N[1]:(N[1]+M[1]-1), N[2]:(N[2]+M[2]-1)] else if (d==3) symconv.val <- symconv.val[N[1]:(N[1]+M[1]-1), N[2]:(N[2]+M[2]-1), N[3]:(N[3]+M[3]-1)] else if (d==4) symconv.val <- symconv.val[N[1]:(N[1]+M[1]-1), N[2]:(N[2]+M[2]-1), N[3]:(N[3]+M[3]-1), N[4]:(N[4]+M[4]-1)] return(symconv.val) } ks/R/mise.R0000644000176200001440000004500412313304434012150 0ustar liggesusers ############################################################################### # Exact MISE for normal mixtures ############################################################################### ## nu, gamma.r, gamma.r2 written by Jose Chacon 10/2008 nu <- function(r, A) { ###Using the recursive formula provided in Kan (2008) ##if (!inverse) A <- solve(A) ei <- eigen(A)$values tr.vec <- numeric(r) for(p in 1:r) tr.vec[p] <- sum(ei^p) nu.val <- 1 if (r>=1) { for(p in 1:r) { a <- sum(tr.vec[1:p]*rev(nu.val))/(2*p) nu.val <- c(nu.val,a) } } return(factorial(r)*2^r*nu.val[r+1]) } nu.rs <- function(r, s, A, B) { if (s==0) return(nu(r=r, A=A)) if (s >=1) { nu.val <- 0 for (i in 0:r) for (j in 0:(s-1)) nu.val <- nu.val + choose(r,i)*choose(s-1,j) *factorial(r+s-i-j-1)*2^(r+s-i-j-1)*tr(matrix.pow(A,r-i)%*%matrix.pow(B,s-j))*nu.rs(r=i,s=j, A=A, B=B) return(nu.val) } } ## gamma functional for normal mixture MISE gamma.r <- function(mu, Sigma, r) { Sigmainv <- chol2inv(chol(Sigma)) d <- ncol(Sigma) v <- 0 for (j in 0:r) v <- v + (-1)^j*choose(2*r, 2*j)*OF(2*j)*nu.rs(r=r-j, s=j, A=Sigmainv%*%mu%*%t(mu)%*%Sigmainv, B=Sigmainv) v <- (-1)^r*v*drop(dmvnorm.deriv(x=rep(0,d), mu=mu, Sigma=Sigma,deriv.order=0)/OF(2*r)) return(v) } ## gamma functional for normal mixture AMISE gamma.r2 <- function(mu, Sigma, d, r, H) { Sigmainv <- chol2inv(chol(Sigma)) if (d==1) w <- vec(Kpow(Sigmainv %*% Sigmainv, r)) %x% vec(Kpow(Sigmainv %*% H %*% Sigmainv, 2)) else w <- matrix(Sdrv(d=d,r=2*r+4, v=vec(Kpow(Sigmainv %*% Sigmainv, r)) %x% vec(Kpow(Sigmainv %*% H %*% Sigmainv, 2))), nrow=1) v <- rep(0,length=d^(2*r+4)) for(j in 0:(r+2)) v <- v+((-1)^j*OF(2*j)*choose(2*r+4, 2*j))*(Kpow(mu,2*r-2*j+4)%x%Kpow(vec(Sigma),j)) gamr<-(-1)^r*dmvnorm(mu,mean=rep(0,d),sigma=Sigma)*sum(w %*% v) return(gamr) } ############################################################################### # Omega matrices (for exact MISE for normal mixtures) # # Parameters # mus - means # Sigmas - variances # k - number of mixture components # a - subscript of Omega matrix # H - bandwidth matrix # # Returns # Omega matrix ############################################################################### omega <- function(mus, Sigmas, k, a, H, r) { ## the (i,j) element of Omega matrix is ## dmvnorm(0, mu_i - mu_j, a*H + Sigma_i + Sigma_j) if (is.matrix(mus)) d <- ncol(mus) else d <- length(mus) if (k == 1) omega.mat <- gamma.r(mu=rep(0,d),Sigma=a*H + 2*Sigmas, r=r) else { omega.mat <- matrix(0, nrow=k, ncol=k) for (i in 1:k) { Sigmai <- Sigmas[((i-1)*d+1):(i*d),] mui <- mus[i,] for (j in 1:k) { Sigmaj <- Sigmas[((j-1)*d+1):(j*d),] muj <- mus[j,] omega.mat[i,j] <- gamma.r(mu=mui-muj, Sigma=a*H + Sigmai + Sigmaj, r=r) } } } return(omega.mat) } omega.1d <- function(mus, sigmas, k, a, h, r) { H <- h^2 Sigmas <- sigmas^2 if (k == 1) omega.mat <- gamma.r(mu=0, Sigma=as.matrix(a*H + 2*Sigmas), r=r) else { omega.mat <- matrix(0, nrow=k, ncol=k) for (i in 1:k) { Sigmai <- Sigmas[i] mui <- mus[i] for (j in 1:k) { Sigmaj <- Sigmas[j] muj <- mus[j] omega.mat[i,j] <- gamma.r(mu=mui-muj, Sigma=as.matrix(a*H + Sigmai + Sigmaj), r=r) } } } return(omega.mat) } ############################################################################## # Exact MISE for normal mixtures # # Parameters # mus - means # Sigmas - variances # Props - vector of proportions of each mixture component # H - bandwidth matrix # samp - sample size # # Returns # Exact MISE for normal mixtures ############################################################################### mise.mixt <- function(H, mus, Sigmas, props, samp, h, sigmas, deriv.order=0) { if (!(missing(h))) return(mise.mixt.1d(h=h, mus=mus, sigmas=sigmas, props=props, samp=samp, deriv.order=deriv.order)) if (is.vector(mus)) d <- length(mus) else d <- ncol(mus) k <- length(props) r <- deriv.order Hinv <- chol2inv(chol(H)) ## formula is found in Wand & Jones (1993) and Chacon, Duong & Wand (2008) if (k == 1) { mise <- 2^(-r)*nu(r,Hinv)/(samp * (4 * pi)^(d/2) * sqrt(det(H))) + (1-1/samp)*omega(mus, Sigmas, 1, 2, H, r) - 2*omega(mus, Sigmas, 1, 1, H, r) + omega(mus, Sigmas, 1, 0, H, r) } else { mise <- 2^(-r)*nu(r,Hinv)/(samp * (4 * pi)^(d/2) * sqrt(det(H))) + props %*% ((1-1/samp)*omega(mus, Sigmas, k, 2, H, r) - 2*omega(mus, Sigmas, k, 1, H, r) + omega(mus, Sigmas, k, 0, H, r)) %*% props } return(drop(mise)) } mise.mixt.1d <- function(h, mus, sigmas, props, samp, deriv.order=0) { d <- 1 k <- length(props) r <- deriv.order H <- as.matrix(h^2) Hinv <- chol2inv(chol(H)) ## formula is found in Wand & Jones (1993) and Chacon, Duong & Wand (2008) if (k == 1) { mise <- 2^(-r)*nu(r,Hinv)/(samp * (4 * pi)^(d/2) * sqrt(det(H))) + (1-1/samp)*omega.1d(mus, sigmas, 1, 2, h, r) - 2*omega.1d(mus, sigmas, 1, 1, h, r) + omega.1d(mus, sigmas, 1, 0, h, r) } else { mise <- 2^(-r)*nu(r,Hinv)/(samp * (4 * pi)^(d/2) * sqrt(det(H))) + props %*% ((1-1/samp)*omega.1d(mus, sigmas, k, 2, h, r) - 2*omega.1d(mus, sigmas, k, 1, h, r) + omega.1d(mus, sigmas, k, 0, h, r)) %*% props } return(drop(mise)) } ############################################################################### # Exact AMISE for bivariate normal mixtures # # Parameters # mus - means # Sigmas - variances # props - mixing proportions # H - bandwidth matrix # samp - sample size # # Returns # Exact AMISE for normal mixtures ############################################################################### amise.mixt <- function(H, mus, Sigmas, props, samp, h, sigmas, deriv.order=0) { if (!(missing(h))) return(amise.mixt.1d(h=h, mus=mus, sigmas=sigmas, props=props, samp=samp, deriv.order=deriv.order)) r <- deriv.order if (is.vector(mus)) {d <- length(mus); mus <- t(matrix(mus))} else d <- ncol(mus) k <- length(props) if (k == 1) { Sigmasinv <- chol2inv(chol(Sigmas)) omega.mat <- 2^(-d-r-2)*pi^(-d/2)*det(Sigmas)^(-1/2)*nu.rs(r=r, s=2, Sigmasinv, matrix.sqrt(Sigmasinv) %*% H %*% matrix.sqrt(Sigmasinv)) } else { omega.mat <- matrix(0, nrow=k, ncol=k) for (i in 1:k) { Sigmai <- Sigmas[((i-1)*d+1):(i*d),] mui <- mus[i,] for (j in 1:k) { Sigmaj <- Sigmas[((j-1)*d+1):(j*d),] muj <- mus[j,] omega.mat[i,j] <- gamma.r2(mu=mui-muj, Sigma= Sigmai + Sigmaj, d=d, r=r, H=H) } } } Hinv <- chol2inv(chol(H)) if (k == 1)amise <- 2^(-r)*nu(r,Hinv)/(samp * (4 * pi)^(d/2) * sqrt(det(H))) + omega.mat/4 else amise <- 2^(-r)*nu(r,Hinv)/(samp * (4 * pi)^(d/2) * sqrt(det(H))) + (props %*% omega.mat %*% props)/4 return(drop(amise)) } amise.mixt.1d <- function(h, mus, sigmas, props, samp, deriv.order=0) { d <- 1 r <- deriv.order k <- length(props) H <- as.matrix(h^2) if (k == 1) omega.mat <- gamma.r2(mu=rep(0,d),Sigma=as.matrix(2*sigmas^2), d=d, r=r, H=H) else { omega.mat <- matrix(0, nrow=k, ncol=k) for (i in 1:k) { Sigmai <- as.matrix(sigmas[i]^2) mui <- mus[i] for (j in 1:k) { Sigmaj <- as.matrix(sigmas[j]^2) muj <- mus[j] omega.mat[i,j] <- gamma.r2(mu=mui-muj, Sigma= Sigmai + Sigmaj, d=d, r=r, H=H) } } } Hinv <- h^(-2) if (k == 1) amise <- 2^(-r)*nu(r,Hinv)/(samp * (4 * pi)^(d/2) * sqrt(det(H))) + omega.mat/4 else amise <- 2^(-r)*nu(r,Hinv)/(samp * (4 * pi)^(d/2) * sqrt(det(H))) + (props %*% omega.mat %*% props)/4 return(drop(amise)) } ############################################################################### # Lambda matrices (for exact AMISE for normal mixtures) # # Parameters # mus - means # Sigmas - variances # k - number of mixture components # r - derivative (r1, r2) # # Returns # Lambda matrix ############################################################################### lambda <- function(mus, Sigmas, k, r) { ## the (i,j) element of Lambda matrix is d^r/ dx^r dmvnorm(0, mu_i - mu_j, ## a*H + Sigma_i + Sigma_j) if (is.vector(mus)) d <- length(mus) else d <- ncol(mus) if (k == 1) lambda.mat <- dmvnorm.deriv(deriv.order=r, x=rep(0, length(mus)), Sigma=2*Sigmas) else { if (is.matrix(mus)) d <- ncol(mus) else d <- length(mus) lambda.mat <- matrix(0, nrow=k, ncol=k) for (i in 1:k) { Sigmai <- Sigmas[((i-1)*d+1) : (i*d),] mui <- mus[i,] for (j in 1:k) { Sigmaj <- Sigmas[((j-1)*d+1) : (j*d),] muj <- mus[j,] lambda.mat[i,j] <- dmvnorm.deriv(deriv.order=r, x=mui-muj,Sigma=Sigmai+Sigmaj) } } } return(lambda.mat) } amise.mixt.2d <- function(H, mus, Sigmas, props, samp) { d <- ncol(Sigmas) k <- length(props) ## formula is found in Wand & Jones (1993) if (k == 1) { amise <- 1/(samp * (4*pi)^(d/2) * sqrt(det(H))) + 1/4 *(lambda(mus, Sigmas, k, r=c(4,0))*H[1,1]^2 + 4*lambda(mus, Sigmas, k, r=c(3,1))*H[1,1]*H[1,2] + 2*lambda(mus, Sigmas, k, r=c(2,2))*(H[1,1]*H[2,2] + 2*H[1,2]^2) + 4*lambda(mus, Sigmas, k, r=c(1,3))*H[2,2]*H[1,2]+ lambda(mus, Sigmas, k, r=c(0,4))*H[2,2]^2) } else { amise <- 1/(samp * (4*pi)^(d/2) * sqrt(det(H))) + 1/4 * props %*% ( lambda(mus, Sigmas, k, r=c(4,0))*H[1,1]^2 + 4*lambda(mus, Sigmas, k, r=c(3,1))*H[1,1]*H[1,2] + 2*lambda(mus, Sigmas, k, r=c(2,2))*(H[1,1]*H[2,2] + 2*H[1,2]^2) + 4*lambda(mus, Sigmas, k, r=c(1,3))*H[2,2]*H[1,2]+ lambda(mus, Sigmas, k, r=c(0,4))*H[2,2]^2) %*% props } return(drop(amise)) } ############################################################################### # Finds the bandwidth matrix that minimises the MISE for normal mixtures # # Parameters # mus - means # Sigmas - variances # props - vector of proportions of each mixture component # Hstart - initial bandwidth matrix # samp - sample size # full - 1 minimise over full bandwidth matrices # - 0 minimise over diagonal bandwidth matrices # # Returns # H_MISE ############################################################################### hmise.mixt <- function(mus, sigmas, props, samp, hstart, deriv.order=0) { r <- deriv.order d <- 1 if (missing(hstart)) { x <- rnorm.mixt(n=1000, mus=mus, sigmas=sigmas) hstart <- sqrt((4/(samp*(d+2*r+2)))^(2/(d+2*r+4)) * var(x)) } mise.mixt.temp <- function(h) { return(mise.mixt.1d(h=h, mus=mus, sigmas=sigmas, props=props, samp=samp, deriv.order=deriv.order)) } result <- optimize(f=mise.mixt.temp, interval=c(0, 10*hstart)) hmise <- result$minimum return(hmise) } Hmise.mixt <- function(mus, Sigmas, props, samp, Hstart, deriv.order=0) { r <- deriv.order if (is.vector(mus)) d <- length(mus) else d <- ncol(mus) ## use normal reference estimate as initial condition if (missing(Hstart)) { x <- rmvnorm.mixt(10000, mus, Sigmas, props) Hstart <- (4/(samp*(d+2*r+2)))^(2/(d+2*r+4)) * var(x) } mise.mixt.temp <- function(vechH) { H <- invvech(vechH) %*% invvech(vechH) return(mise.mixt(H=H, mus=mus, Sigmas=Sigmas, props=props, samp=samp, deriv.order=deriv.order)) } Hstart <- vech(matrix.sqrt(Hstart)) result <- nlm(p=Hstart, f=mise.mixt.temp) Hmise <- invvech(result$estimate) %*% invvech(result$estimate) ##result <- optim(Hstart, mise.mixt.temp, method="Nelder-Mead") ##Hmise <- invvech(result$par) %*% invvech(result$par) return(Hmise) } Hmise.mixt.diag <- function(mus, Sigmas, props, samp, Hstart, deriv.order=0) { if (is.vector(mus)) d <- length(mus) else d <- ncol(mus) if (missing(Hstart)) { x <- rmvnorm.mixt(10000, mus, Sigmas, props) Hstart <- (4/(samp*(d + 2)))^(2/(d + 4)) * var(x) } mise.mixt.temp <- function(diagH) { H <- diag(diagH) %*% diag(diagH) return(mise.mixt(H=H, mus=mus, Sigmas=Sigmas, props=props, samp=samp, deriv.order=deriv.order)) } Hstart <- diag(matrix.sqrt(Hstart)) result <- nlm(p=Hstart, f=mise.mixt.temp) Hmise <- diag(result$estimate) %*% diag(result$estimate) ##result <- optim(Hstart, mise.mixt.temp, method = "Nelder-Mead") ##Hmise <- diag(result$par) %*% diag(result$par) return(Hmise) } ############################################################################### ## Finds bandwidth matrix that minimises the AMISE for normal mixtures - 2-dim ## ## Parameters ## mus - means ## Sigmas - variances ## props - vector of proportions of each mixture component ## Hstart - initial bandwidth matrix ## samp - sample size ## ## Returns ## Bandwidth matrix that minimises AMISE ############################################################################### hamise.mixt <- function(mus, sigmas, props, samp, hstart, deriv.order=0) { r <- deriv.order d <- 1 if (missing(hstart)) { x <- rnorm.mixt(n=1000, mus=mus, sigmas=sigmas) hstart <- sqrt((4/(samp*(d+2*r+2)))^(2/(d+2*r+4)) * var(x)) } amise.mixt.temp <- function(h) { return(amise.mixt.1d(h=h, mus=mus, sigmas=sigmas, props=props, samp=samp, deriv.order=deriv.order)) } result <- optimize(f=amise.mixt.temp, interval=c(0, 10*hstart)) hamise <- result$minimum return(hamise) } Hamise.mixt <- function(mus, Sigmas, props, samp, Hstart, deriv.order=0) { r <- deriv.order if (is.vector(mus)) d <- length(mus) else d <- ncol(mus) ## use explicit formula for single normal if (length(props)==1) { Hamise <- (4/ (samp*(d+2*r+2)))^(2/(d+2*r+4)) * Sigmas } else { ## use normal reference estimate as initial condition if (missing(Hstart)) { x <- rmvnorm.mixt(10000, mus=mus, Sigmas=Sigmas, props=props) Hstart <- matrix.sqrt((4/ (samp*(d+2*r+2)))^(2/(d+2*r+4)) * var(x)) } amise.mixt.temp <- function(vechH) { H <- invvech(vechH) %*% invvech(vechH) return(amise.mixt(H=H, mus=mus, Sigmas=Sigmas, props=props, samp=samp, deriv.order=deriv.order)) } result <- nlm(p=vech(Hstart), f=amise.mixt.temp) Hamise <- invvech(result$estimate) %*% invvech(result$estimate) } return(Hamise) } Hamise.mixt.diag <- function(mus, Sigmas, props, samp, Hstart, deriv.order=0) { r <- deriv.order if (is.vector(mus)) d <- length(mus) else d <- ncol(mus) ## use normal reference estimate as initial condition if (missing(Hstart)) { x <- rmvnorm.mixt(10000, mus, Sigmas, props) Hstart <- matrix.sqrt((4/ (samp*(d+2*r+2)))^(2/(d+2*r+4)) * var(x)) } amise.mixt.temp <- function(diagH) { H <- diag(diagH) %*% diag(diagH) return(amise.mixt(H=H, mus=mus, Sigmas=Sigmas, props=props, samp=samp, deriv.order=deriv.order)) } result <- nlm(p=diag(Hstart), f=amise.mixt.temp) Hamise <- diag(result$estimate) %*% diag(result$estimate) return(Hamise) } ############################################################################### # ISE for normal mixtures (fixed KDE) # # Parameters # x - data values # H - bandwidth matrix # mus - matrix of means (each row is a vector of means from each component # density) # Sigmas - matrix of covariance matrices (every d rows is a covariance matrix # from each component density) # props - mixing proportions # lower - vector of lower end points of rectangle # upper - vector of upper end points of rectangle # gridsize - vector of number of grid points # stepsize - vector of step sizes # Returns # ISE ############################################################################### ise.mixt <- function(x, H, mus, Sigmas, props, h, sigmas, deriv.order=0, binned=FALSE, bgridsize) { if (!(missing(h))) return(ise.mixt.1d(x=x, h=h, mus=mus, sigmas=sigmas, props=props, deriv.order=deriv.order, binned=binned)) if (is.vector(x)) x <- matrix(x, nrow=1) if (is.vector(mus)) mus <- matrix(mus, nrow=length(props)) d <- ncol(x) n <- nrow(x) M <- length(props) r <- deriv.order ## formula is found in thesis vIdr <- vec(diag(d^r)) ise1 <- 0 ise2 <- 0 ise3 <- 0 if (binned) { ise1 <- dmvnorm.deriv.sum(x=x, Sigma=2*H, inc=1, deriv.order=2*r, binned=binned, bgridsize=bgridsize) for (j in 1:M) { Sigmaj <- Sigmas[((j - 1) * d + 1):(j * d), ] ise2 <- ise2 + props[j] * colSums(dmvnorm.deriv(x, mu=mus[j,],Sigma=H + Sigmaj, deriv.order=2*r)) for (i in 1:M) { Sigmai <- Sigmas[((i - 1) * d + 1):(i * d), ] ise3 <- ise3 + props[i] * props[j] * dmvnorm.deriv(x=mus[i,],mu=mus[j,], Sigma = Sigmai + Sigmaj, deriv.order = 2*r) } } ise <- (-1)^r * sum(vIdr*(ise1/n^2 - 2 * ise2/n + ise3)) } else { ise1 <- Qr(x=x, Sigma=2*H, inc=1, deriv.order=2*r) for (j in 1:M) { Sigmaj <- Sigmas[((j-1)*d + 1):(j*d), ] ise2 <- ise2 + props[j] * Qr(x=x, y=mus[j,], Sigma=H + Sigmaj, deriv.order=2*r, inc=1) for (i in 1:M) { Sigmai <- Sigmas[((i-1)*d + 1):(i*d), ] ise3 <- ise3 + props[i] * props[j] * Qr(x=mus[i,], y=mus[j,], Sigma=Sigmai + Sigmaj, deriv.order=2*r, inc=1) } } ise <- (-1)^r*(ise1 - 2*ise2 + ise3) } return(ise) } ise.mixt.1d <- function(x, h, mus, sigmas, props, deriv.order=0, binned=FALSE) { n <- length(x) M <- length(props) r <- deriv.order ise1 <- 0 ise2 <- 0 ise3 <- 0 ise1 <- dnorm.deriv.sum(x=x, sigma=sqrt(2)*h, inc=1, deriv.order=2*r, binned=binned) for (j in 1:M) { sigmaj <- sigmas[j] ise2 <- ise2 + sum(props[j]*dnorm.deriv(x=x, mu=mus[j], sigma=sqrt(h^2 + sigmaj^2), deriv.order=2*r)) for (i in 1:M) { sigmai <- sigmas[i] ise3 <- ise3 + sum(props[i]*props[j]*dnorm.deriv(x=mus[i], mu=mus[j], sigma=sqrt(sigmai^2+sigmaj^2), deriv.order=2*r)) } } return ((-1)^r*(ise1/n^2 - 2*ise2/n + ise3)) } Hise.mixt <- function(x, mus, Sigmas, props, Hstart, deriv.order=0) { r <- deriv.order if (is.vector(mus)) d <- length(mus) else d <- ncol(mus) samp <- nrow(x) ## use normal reference estimate as initial condition if (missing(Hstart)) { xstart <- rmvnorm.mixt(10000, mus, Sigmas, props) Hstart <- (4/(samp*(d+2*r+2)))^(2/(d+2*r+4)) * var(xstart) } ise.mixt.temp <- function(vechH) { H <- invvech(vechH) %*% invvech(vechH) return(ise.mixt(x=x, H=H, mus=mus, Sigmas=Sigmas, props=props, deriv.order=deriv.order)) } Hstart <- vech(matrix.sqrt(Hstart)) result <- nlm(p=Hstart, f=ise.mixt.temp) Hise <- invvech(result$estimate) %*% invvech(result$estimate) return(Hise) } ks/R/kde-test.R0000644000176200001440000003353013257005521012737 0ustar liggesusers############################################################################## ## Test statistic for multivariate 2-sample test ############################################################################## kde.test <- function(x1, x2, H1, H2, h1, h2, psi1, psi2, var.fhat1, var.fhat2, binned=FALSE, bgridsize, verbose=FALSE) { ##if (binned) warning("From ks 1.8.8, binned estimation now only applies to the calculation of the bandwidths H1 and H2, and not the pvalue.") ## default values ksd <- ks.defaults(x=x1, binned=binned, bgridsize=bgridsize) d <- ksd$d binned <- ksd$binned bgridsize <- ksd$bgridsize gridsize <- ksd$gridsize if (is.vector(x1) & is.vector(x2)) return(kde.test.1d(x1=x1, x2=x2, h1=h1, h2=h2, psi1=psi1, psi2=psi2, var.fhat1=var.fhat1, var.fhat2=var.fhat2, binned=binned, bgridsize=bgridsize, verbose=verbose)) if (!is.matrix(x1)) x1 <- as.matrix(x1) if (!is.matrix(x2)) x2 <- as.matrix(x2) n1 <- nrow(x1) n2 <- nrow(x2) d <- ncol(x1) K0 <- drop(dmvnorm.deriv(x=rep(0,d), mu=rep(0,d), Sigma=diag(d), deriv.order=0)) ## kernel estimation for components of test statistic if (missing(H1)) H1 <- Hpi.kfe(x1, deriv.order=0, binned=default.bflag(d=d,n=n1), bgridsize=bgridsize, verbose=FALSE) if (missing(H2)) H2 <- Hpi.kfe(x2, deriv.order=0, binned=default.bflag(d=d,n=n2), bgridsize=bgridsize, verbose=FALSE) if (missing(psi1)) psi1 <- Qr(x=x1, y=x1, Sigma=H1, verbose=verbose) if (missing(psi2)) psi2 <- Qr(x=x2, y=x2, Sigma=H2, verbose=verbose) S1 <- var(x1) S2 <- var(x2) if (missing(var.fhat1)) { H1.r1 <- Hns(x=x1, deriv.order=1) fhat1.r1 <- predict(kdde(x=x1, H=H1.r1, deriv.order=1), x=apply(x1, 2, mean)) var.fhat1 <- drop(fhat1.r1 %*% S1 %*% fhat1.r1) } psi12 <- Qr(x=x1, y=x2, Sigma=H1, verbose=verbose) if (missing(var.fhat2)) { H2.r1 <- Hns(x=x2, deriv.order=1) fhat2.r1 <- predict(kdde(x=x2, H=H2.r1, deriv.order=1), x=apply(x2, 2, mean)) var.fhat2 <- drop(fhat2.r1 %*% S2 %*% fhat2.r1) } psi21 <- Qr(x=x2, y=x1, Sigma=H2, verbose=verbose) ## test statistic + its parameters T.hat <- drop(psi1 + psi2 - (psi12 + psi21)) muT.hat <- (n1^(-1)*det(H1)^(-1/2) + n2^(-1)*det(H2)^(-1/2))*K0 varT.hat <- 3*(n1*var.fhat1 + n2*var.fhat2)/(n1+n2) *(1/n1+1/n2) zstat <- (T.hat-muT.hat)/sqrt(varT.hat) pval <- 1-pnorm(zstat) if (length(pval==0)>0) pval[pval==0] <- pnorm(-abs(zstat[pval==0])) val <- list(Tstat=T.hat, zstat=zstat, pvalue=pval, mean=muT.hat, var=varT.hat, var.fhat1=var.fhat1, var.fhat2=var.fhat2, n1=n1, n2=n2, H1=H1, H2=H2, psi1=psi1, psi12=psi12, psi21=psi21, psi2=psi2) return(val) } kde.test.1d <- function(x1, x2, h1, h2, psi1, psi2, var.fhat1, var.fhat2, binned=FALSE, bgridsize, verbose=FALSE) { n1 <- length(x1) n2 <- length(x2) d <- 1 K0 <- dnorm.deriv(x=0, mu=0, sigma=1, deriv.order=0) s1 <- sd(x1) s2 <- sd(x2) ## kernel estimation for components of test statistic if (missing(h1)) h1 <- hpi.kfe(x1, nstage=2, deriv.order=0, binned=binned, bgridsize=bgridsize) if (missing(h2)) h2 <- hpi.kfe(x2, nstage=2, deriv.order=0, binned=binned, bgridsize=bgridsize) if (missing(psi1)) psi1 <- Qr.1d(x=x1, y=x1, sigma=h1, verbose=verbose) if (missing(psi2)) psi2 <- Qr.1d(x=x2, y=x2, sigma=h2, verbose=verbose) if (missing(var.fhat1)) { h1.r1 <- hns(x=x1, deriv.order=1) fhat1.r1 <- predict(kdde(x=x1, h=h1.r1, deriv.order=1), x=mean(x1)) var.fhat1 <- fhat1.r1^2*s1^2 } psi12 <- Qr.1d(x=x1, sigma=h1, y=x2, verbose=verbose) if (missing(var.fhat2)) { h2.r1 <- hns(x=x2, deriv.order=1) fhat2.r1 <- predict(kdde(x=x2, h=h2.r1, deriv.order=1), x=mean(x2)) var.fhat2 <- fhat2.r1^2*s2^2 } psi21 <- Qr.1d(x=x2, sigma=h2, y=x1, verbose=verbose) ## test statistic + its parameters T.hat <- drop(psi1 + psi2 - (psi12 + psi21)) muT.hat <- ((n1*h1)^(-1) + (n2*h2)^(-1))*K0 varT.hat <- 3*(n1*var.fhat1 + n2*var.fhat2)/(n1+n2) *(1/n1+1/n2) zstat <- (T.hat-muT.hat)/sqrt(varT.hat) pval <- 1-pnorm(zstat) if (length(pval==0)>0) pval[pval==0] <- pnorm(-abs(zstat[pval==0])) val <- list(Tstat=T.hat, zstat=zstat, pvalue=pval, mean=muT.hat, var=varT.hat, var.fhat1=var.fhat1, var.fhat2=var.fhat2, n1=n1, n2=n2, h1=h1, h2=h2, psi1=psi1, psi12=psi12, psi21=psi21, psi2=psi2) return(val) } ############################################################################### ### Local kde test ############################################################################### ### Hochberg (1988) adjustment for multiple correlated tests hochberg.mult.test <- function(pvalue, gridsize, signif.level) { pvalue.ord <- pvalue[order(pvalue)] num.test <- sum(!is.na(pvalue.ord)) if (num.test>=1) num.test.seq <- c(1:num.test, rep(NA, prod(gridsize) - num.test)) else num.test.seq <- rep(NA, prod(gridsize)) reject.nonzero <- ((pvalue.ord <= signif.level/(num.test + 1 - num.test.seq)) & (pvalue.ord > 0)) reject.nonzero.ind <- which(reject.nonzero) ## p-value == 0 => reject null hypotheses automatically fhat.diff.signif <- array(FALSE, dim=gridsize) fhat.diff.signif[which(pvalue==0, arr.ind=TRUE)] <- TRUE ## p-value > 0 then reject null hypotheses indicated in reject.nonzero.ind for (i in reject.nonzero.ind) fhat.diff.signif[which(pvalue==pvalue.ord[i], arr.ind=TRUE)] <- TRUE return(fhat.diff.signif) } ### 1-d local test kde.local.test.1d <- function(x1, x2, h1, h2, fhat1, fhat2, gridsize=gridsize, binned=FALSE, bgridsize, verbose=FALSE, supp=3.7, mean.adj=FALSE, signif.level=0.05, min.ESS, xmin, xmax) { if (missing(h1) & !missing(x1)) h1 <- hpi(x1, nstage=2, binned=binned, bgridsize=bgridsize) if (missing(h2) & !missing(x2)) h2 <- hpi(x2, nstage=2, binned=binned, bgridsize=bgridsize) if (!missing(x1) & !missing(x2)) { n1 <- length(x1) n2 <- length(x2) d <- 1 RK <- (4*pi)^(-d/2) xrange <- range(c(x1,x2)) if (missing(xmin)) xmin <- xrange[1] - supp*sqrt(h1*h2) if (missing(xmax)) xmax <- xrange[2] + supp*sqrt(h1*h2) } else { n1 <- length(fhat1$x) n2 <- length(fhat2$x) d <- 1 RK <- (4*pi)^(-d/2) h1 <- fhat1$h h2 <- fhat2$h } ## kernel estimation for components of test statistic if (missing(fhat1)) fhat1 <- kde(x=x1, h=h1, gridsize=gridsize, binned=binned, bgridsize=bgridsize, supp=supp, xmin=xmin, xmax=xmax) if (missing(fhat2)) fhat2 <- kde(x=x2, h=h2, gridsize=gridsize, binned=binned, bgridsize=bgridsize, supp=supp, xmin=xmin, xmax=xmax) h2D2fhat <- 0 if (mean.adj) { D2fhat1 <- kdde(x=x1, h=h1, gridsize=gridsize, binned=binned, bgridsize=bgridsize, supp=supp, xmin=xmin, xmax=xmax, deriv.order=2, verbose=verbose) D2fhat2 <- kdde(x=x2, h=h2, gridsize=gridsize, binned=binned, bgridsize=bgridsize, supp=supp, xmin=xmin, xmax=xmax, deriv.order=2, verbose=verbose) h2D2fhat <- (h1^2*D2fhat1$estimate - h2^2*D2fhat2$estimate) } fhat.diff <- fhat1$estimate - fhat2$estimate - 1/2*h2D2fhat var.fhat.diff <- ((n1*h1)^(-1)*fhat1$estimate + (n2*h2)^(-1)*fhat2$estimate)*RK X2 <- fhat.diff^2/var.fhat.diff pvalue <- 1 - pchisq(X2, 1) gridsize <- length(fhat1$eval.points) fhat.diff.signif <- hochberg.mult.test(pvalue=pvalue, gridsize=gridsize, signif.level=signif.level) fhat.diff.pos <- fhat1 fhat.diff.neg <- fhat2 fhat.diff.pos$estimate <- fhat.diff.signif*(fhat.diff>0) fhat.diff.neg$estimate <- fhat.diff.signif*(fhat.diff<0) if (!missing(min.ESS)) { ESS1 <- n1*fhat1$estimate/dnorm(0, 0, h1) ESS2 <- n2*fhat2$estimate/dnorm(0, 0, h2) ESS <- pmin(ESS1, ESS2) >= min.ESS fhat.diff.pos$estimate <- fhat.diff.pos$estimate*ESS fhat.diff.neg$estimate <- fhat.diff.neg$estimate*ESS } result <- list(fhat1=fhat1, fhat2=fhat2, chisq=X2, pvalue=pvalue, fhat.diff=fhat.diff, mean.fhat.diff=h2D2fhat, var.fhat.diff=var.fhat.diff, n1=n1, n2=n2, h1=h1, h2=h2, H1=h1^2, H2=h2^2, fhat.diff=fhat.diff, fhat.diff.pos=fhat.diff.pos, fhat.diff.neg=fhat.diff.neg) class(result) <- "kde.loctest" return(result) } ### multivariate local test kde.local.test <- function(x1, x2, H1, H2, h1, h2, fhat1, fhat2, gridsize, binned, bgridsize, verbose=FALSE, supp=3.7, mean.adj=FALSE, signif.level=0.05, min.ESS, xmin, xmax) { ## default values ksd <- ks.defaults(x=x1, binned=binned, bgridsize=bgridsize, gridsize=gridsize) d <- ksd$d if (missing(binned)) binned <- ksd$binned if (missing(bgridsize)) bgridsize <- ksd$bgridsize if (missing(gridsize)) gridsize <- ksd$gridsize if (is.vector(x1) & is.vector(x2)) {return(kde.local.test.1d(x1=x1, x2=x2, h1=h1, h2=h2, fhat1=fhat1, fhat2=fhat2, gridsize=gridsize, binned=binned, bgridsize=bgridsize, verbose=verbose, supp=supp, mean.adj=mean.adj, xmin=xmin, xmax=xmax))} if (missing(H1) & !missing(x1)) H1 <- Hpi(x=x1, deriv.order=0, binned=default.bflag(d=ncol(x1), n=nrow(x1)), bgridsize=bgridsize, verbose=verbose) if (missing(H2) & !missing(x2)) H2 <- Hpi(x=x2, deriv.order=0, binned=default.bflag(d=ncol(x2), n=nrow(x2)), bgridsize=bgridsize, verbose=verbose) if (!missing(x1) & !missing(x2)) { n1 <- nrow(x1) n2 <- nrow(x2) d <- ncol(x1) RK <- (4*pi)^(-d/2) xrange <- apply(rbind(x1,x2), 2, range) if (missing(xmin)) xmin <- xrange[1,] - supp*sqrt(det(H1)*det(H2)) if (missing(xmax)) xmax <- xrange[2,] + supp*sqrt(det(H1)*det(H2)) } else { n1 <- nrow(fhat1$x) n2 <- nrow(fhat2$x) d <- ncol(fhat1$x) RK <- (4*pi)^(-d/2) H1 <- fhat1$H H2 <- fhat2$H } ## kernel estimation for components of test statistic if (missing(fhat1)) fhat1 <- kde(x=x1, H=H1, binned=binned, gridsize=gridsize, bgridsize=bgridsize, supp=supp, xmin=xmin, xmax=xmax, verbose=verbose) if (missing(fhat2)) fhat2 <- kde(x=x2, H=H2, binned=binned, gridsize=gridsize, bgridsize=bgridsize, supp=supp, xmin=xmin, xmax=xmax, verbose=verbose) HD2fhat <- 0 if (mean.adj) { D2fhat1 <- kdde(x=x1, H=H1, binned=binned, bgridsize=bgridsize, supp=supp, xmin=xmin, xmax=xmax, deriv.order=2, verbose=verbose) D2fhat2 <- kdde(x=x2, H=H2, binned=binned, bgridsize=bgridsize, supp=supp, xmin=xmin, xmax=xmax, deriv.order=2, verbose=verbose) D2fhat <- list() vH1 <- vec(H1) vH2 <- vec(H2) for (j in 1:length(D2fhat1$estimate)) D2fhat$estimate[[j]] <- vH1[j]*D2fhat1$estimate[[j]] - vH2[j]*D2fhat2$estimate[[j]] for (j in 1:length(D2fhat)) HD2fhat <- HD2fhat + D2fhat$estimate[[j]] } fhat.diff <- fhat1$estimate - fhat2$estimate - 1/2*HD2fhat var.fhat.diff <- (n1^(-1)*det(H1)^(-1/2)*fhat1$estimate + n2^(-1)*det(H2)^(-1/2)*fhat2$estimate)*RK X2 <- fhat.diff^2/var.fhat.diff pvalue <- 1 - pchisq(X2, 1) pvalue[is.na(pvalue)] <- 0 ## Apply Hochberg multiple test adjustment gridsize <- sapply(fhat1$eval.points, length) fhat.diff.signif <- hochberg.mult.test(pvalue=pvalue, gridsize=gridsize, signif.level=signif.level) fhat.diff.pos <- fhat1 fhat.diff.neg <- fhat2 fhat.diff.pos$estimate <- fhat.diff.signif*(fhat.diff>0) fhat.diff.neg$estimate <- fhat.diff.signif*(fhat.diff<0) if (!missing(min.ESS)) { ESS1 <- n1*fhat1$estimate/dmvnorm(rep(0,d), rep(0,d), H1) ESS2 <- n2*fhat2$estimate/dmvnorm(rep(0,d), rep(0,d), H2) ESS <- pmin(ESS1, ESS2) >= min.ESS fhat.diff.pos$estimate <- fhat.diff.pos$estimate*ESS fhat.diff.neg$estimate <- fhat.diff.neg$estimate*ESS } result <- list(fhat1=fhat1, fhat2=fhat2, X2=X2, pvalue=pvalue, fhat.diff=fhat.diff, mean.fhat.diff=HD2fhat, var.fhat.diff=var.fhat.diff, fhat.diff.pos=fhat.diff.pos, fhat.diff.neg=fhat.diff.neg, n1=n1, n2=n2, H1=H1, H2=H2) class(result) <- "kde.loctest" return(result) } ### plot for kde.loctest objects plot.kde.loctest <- function(x, ...) { fhat <- x if (is.vector(fhat$fhat1$x)) plotkde.loctest.1d(fhat, ...) else { d <- ncol(fhat$fhat1$x) if (d==2) plotkde.loctest.2d(x, ...) else if (d==3) plotkde.loctest.3d(x, ...) else stop("Plot function only available for 1, 2 or 3-d data") } } plotkde.loctest.1d <- function(x, lcol, col, add=FALSE, xlab, ylab, rugsize, add.legend=TRUE, pos.legend="topright", ...) { if (missing(xlab)) xlab <- x$fhat.diff.pos$names[1] if (missing(ylab)) ylab <- expression("Density difference "*f[1]-f[2]) if (missing(col)) col <- c("purple", "darkgreen") if (missing(lcol)) lcol <- 1 if (!add) plot(x$fhat1$eval.points, x$fhat.diff, type="l", ylab=ylab, xlab=xlab, col=lcol, ...) else lines(x$fhat1$eval.points, x$fhat.diff, col=lcol, ...) plot.lim <- par()$usr if (missing(rugsize)) rugsize <- abs(plot.lim[4]-plot.lim[3])/50 image(x$fhat.diff.pos$eval, c(plot.lim[3], plot.lim[3]+rugsize), cbind(x$fhat.diff.pos$estimate==1, x$fhat.diff.pos$estimate==1), level=0.5, add=TRUE, col=c("transparent", col[1]), ...) image(x$fhat.diff.neg$eval, c(plot.lim[3], plot.lim[3]+rugsize), cbind(x$fhat.diff.neg$estimate==1, x$fhat.diff.neg$estimate==1), level=0.5, add=TRUE, col=c("transparent", col[2]), ...) if (add.legend) legend(pos.legend, legend=c(expression(f[1]>f[2]), expression(f[1]f[2]), expression(f[1]3) kde.flag <- FALSE if (kde.flag) fhat.list <- kda.nd(x=x, x.group=x.group, Hs=Hs, prior.prob=prior.prob, gridsize=gridsize, supp=supp, binned=binned, bgridsize=bgridsize, xmin=xmin, xmax=xmax, compute.cont=compute.cont, approx.cont=approx.cont) ## Compute KDA at eval.points fhat <- kda.nd(x=x, x.group=x.group, Hs=Hs, prior.prob=prior.prob, gridsize=gridsize, supp=supp, binned=FALSE, bgridsize=bgridsize, xmin=xmin, xmax=xmax, eval.points=eval.points, compute.cont=compute.cont, approx.cont=approx.cont) fhat.wt <- matrix(0, ncol=m, nrow=nrow(eval.points)) } for (j in 1:m) fhat.wt[,j] <- fhat$estimate[[j]]* fhat$prior.prob[j] ## Assign y according largest weighted density value disc.gr.temp <- apply(fhat.wt, 1, which.max) ##disc.gr <- factor(disc.gr.temp, levels=gr[order(unique(x.group))]) disc.gr <- as.factor(gr[disc.gr.temp]) if (is.numeric(gr)) disc.gr <- as.numeric(levels(disc.gr))[disc.gr] if (kde.flag) fhat.list$x.group.estimate <- disc.gr else fhat.list <- disc.gr return(fhat.list) } kda.1d <- function(x, x.group, hs, prior.prob, gridsize, supp, eval.points, binned, bgridsize, xmin, xmax, w, compute.cont, approx.cont) { gr <- sort(unique(x.group)) m <- length(gr) d <- 1 hmax <- max(hs) if (missing(xmin)) xmin <- min(x) - supp*hmax if (missing(xmax)) xmax <- max(x) + supp*hmax fhat.list <- list() for (j in 1:m) { xx <- x[x.group==gr[j]] ww <- w[x.group==gr[j]] h <- hs[j] ## compute individual density estimate if (missing(eval.points)) fhat.temp <- kde(x=xx, h=h, supp=supp, xmin=xmin, xmax=xmax, bgridsize=bgridsize, gridsize=gridsize, w=ww, binned=binned) else fhat.temp <- kde(x=xx, h=h, w=ww, binned=binned, bgridsize=bgridsize, gridsize=gridsize, eval.points=eval.points) fhat.list$estimate <- c(fhat.list$estimate, list(fhat.temp$estimate)) fhat.list$eval.points <- fhat.temp$eval.points fhat.list$x <- c(fhat.list$x, list(xx)) fhat.list$h <- c(fhat.list$h, h) fhat.list$H <- c(fhat.list$H, h^2) fhat.list$w <- c(fhat.list$w, list(ww)) ## compute prob contour levels if (compute.cont & missing(eval.points)) { contlev <- contourLevels(fhat.temp, cont=1:99, approx.cont=approx.cont) fhat.list$cont <- c(fhat.list$cont, list(contlev)) } } fhat.list$binned <- binned fhat.list$gridded <- fhat.temp$gridded if (is.null(prior.prob)) { pr <- rep(0, length(gr)) for (j in 1:length(gr)) pr[j] <- length(which(x.group==gr[j])) pr <- pr/length(x) fhat.list$prior.prob <- pr } else fhat.list$prior.prob <- prior.prob fhat.list$x.group <- x.group class(fhat.list) <- "kda" return(fhat.list) } kda.nd <- function(x, x.group, Hs, prior.prob, gridsize, supp, eval.points, binned, bgridsize, xmin, xmax, w, compute.cont, approx.cont) { if (is.data.frame(x)) x <- as.matrix(x) gr <- sort(unique(x.group)) m <- length(gr) d <- ncol(x) ## find largest bandwidth matrix to initialise grid detH <- vector() for (j in 1:m) detH[j] <- det(Hs[((j-1)*d+1) : (j*d),]) Hmax.ind <- which.max(detH) Hmax <- Hs[((Hmax.ind-1)*d+1) : (Hmax.ind*d),] ##Hmax <- Hns(x) if (missing(xmin)) xmin <- apply(x, 2, min) - supp*max(sqrt(diag(Hmax))) if (missing(xmax)) xmax <- apply(x, 2, max) + supp*max(sqrt(diag(Hmax))) if (missing(w)) w <- rep(1, nrow(x)) if (binned & d > 4) stop("Binning only available for 1- to 4-d data") if (missing(bgridsize)) bgridsize <- default.gridsize(d) if (missing(gridsize)) gridsize <- default.gridsize(d) fhat.list <- list() for (j in 1:m) { xx <- x[x.group==gr[j],] ww <- w[x.group==gr[j]] H <- Hs[((j-1)*d+1) : (j*d),] ## compute individual density estimate if (binned) fhat.temp <- kdde(x=xx, bgridsize=bgridsize, H=H, xmin=xmin, xmax=xmax, w=ww, deriv.order=0, binned=TRUE) else if (missing(eval.points)) fhat.temp <- kde(x=xx, H=H, supp=supp, xmin=xmin, xmax=xmax, gridsize=gridsize, w=ww) else fhat.temp <- kde(x=xx, H=H, eval.points=eval.points, w=ww) fhat.list$estimate <- c(fhat.list$estimate, list(fhat.temp$estimate)) fhat.list$eval.points <- fhat.temp$eval.points fhat.list$x <- c(fhat.list$x, list(xx)) fhat.list$H <- c(fhat.list$H, list(H)) fhat.list$w <- c(fhat.list$w, list(ww)) ## compute prob contour levels if (compute.cont & missing(eval.points)) { contlev <- contourLevels(fhat.temp, cont=1:99, approx.cont=approx.cont) fhat.list$cont <- c(fhat.list$cont, list(contlev)) } } fhat.list$binned <- binned fhat.list$gridded <- fhat.temp$gridded if (is.null(prior.prob)) { pr <- rep(0, length(gr)) for (j in 1:length(gr)) pr[j] <- length(which(x.group==gr[j])) pr <- pr/nrow(x) fhat.list$prior.prob <- pr } else fhat.list$prior.prob <- prior.prob ##pr <- rep(0, length(gr)) ##for (j in 1:length(gr)) pr[j] <- length(which(x.group==gr[j])) ##pr <- pr/nrow(x) ##fhat.list$prior.prob <- pr fhat.list$x.group <- x.group class(fhat.list) <- "kda" return (fhat.list) } ############################################################################## ## Contour method for kda objects ############################################################################## contourLevels.kda <- function(x, prob, cont, nlevels=5, approx=TRUE,...) { fhat <- x m <- length(fhat$x) hts <- list() for (j in 1:m) { fhatj <- list(x=fhat$x[[j]], eval.points=fhat$eval.points, estimate=fhat$estimate[[j]], H=fhat$H[[j]], binned=fhat$binned, gridded=fhat$gridded) class(fhatj) <- "kde" hts[[j]] <- contourLevels(x=fhatj, prob=prob, cont=cont, nlevels=nlevels, approx=approx, ...) } return(hts) } predict.kda <- function(object, ..., x) { fhat <- object m <- length(fhat$prior.prob) if (is.vector(fhat$x[[1]])) n <- length(x) else {if (is.vector(x)) n <- 1 else n <- nrow(x)} fhat.temp <- matrix(0, ncol=m, nrow=n) for (j in 1:m) { fhat.temp[,j] <- fhat$prior.prob[j]*grid.interp(x=x, gridx=fhat$eval.points, f=fhat$estimate[[j]]) } est.group <- apply(fhat.temp, 1, which.max) ##est.group <- unique(fhat$x.group)[est.group] est.group <- as.factor(sort(unique(fhat$x.group))[est.group]) return(est.group) } ############################################################################## # Plot KDE of individual densities and partition - only for 2-dim # # Parameters # fhat - output from `kda.kde' # y - data points (separate from training data inside fhat) # y.group - data group labels # prior.prob - vector of prior probabilities # disp - "part" - plot partition # - "" - don't plot partition ############################################################################## plot.kda <- function(x, y, y.group, ...) { if (is.vector(x$x[[1]])) plotkda.1d(x=x, y=y, y.group=y.group, ...) else { d <- ncol(x$x[[1]]) if (d==2) { opr <- options()$preferRaster; if (!is.null(opr)) if (!opr) options("preferRaster"=TRUE) plotkda.2d(x=x, y=y, y.group=y.group, ...) if (!is.null(opr)) options("preferRaster"=opr) } else if (d==3) plotkda.3d(x=x, y=y, y.group=y.group, ...) } } plotkda.1d <- function(x, y, y.group, prior.prob=NULL, xlim, ylim, xlab="x", ylab="Weighted density function", drawpoints=FALSE, col, col.part, col.pt, lty, jitter=TRUE, rugsize, ...) { fhat <- x m <- length(fhat$x) if (is.null(prior.prob)) prior.prob <- fhat$prior.prob if (m != length(prior.prob)) stop("prior.prob not same length as number of components in fhat") if (!(identical(all.equal(sum(prior.prob), 1), TRUE))) stop("Sum of weights not equal to 1") weighted.fhat <- matrix(0, nrow=length(fhat$eval.points), ncol=m) for (j in 1:m) weighted.fhat[,j] <- fhat$estimate[[j]]*fhat$prior.prob[j] if (missing(xlim)) xlim <- range(fhat$eval.points) if (missing(ylim)) ylim <- range(weighted.fhat) if (missing(lty)) lty <- rep(1, m) if (length(lty) < m) lty <- rep(lty, m) if (missing(col)) col <- 1:m if (length(col) < m) col <- rep(col, m) if (missing(col.pt)) col.pt <- col if (length(col.pt) < m) col.pt <- rep(col.pt, m) if (missing(col.part)) col.part <- col if (length(col.part) < m) col.part <- rep(col.part, m) ## plot each training group's KDE in separate colour and line type plot(fhat$eval.points, weighted.fhat[,1], type="l", xlab=xlab, ylab=ylab, xlim=xlim, ylim=ylim, lty=lty[1], col=col[1], ...) if (m > 1) for (j in 2:m) lines(fhat$eval.points, weighted.fhat[,j], lty=lty[j], col=col[j], ...) ydata <- seq(min(fhat$eval.points), max(fhat$eval.points), length=401) ydata.gr <- unique(fhat$x.group)[apply(weighted.fhat,1, which.max)] ## draw partition class as rug-like plot plot.lim <- par()$usr if (missing(rugsize)) rugsize <- abs(plot.lim[4]-plot.lim[3])/50 for (j in 1:m) { image(ydata, c(plot.lim[3], plot.lim[3]+rugsize), cbind(as.numeric(ydata.gr), as.numeric(ydata.gr)), level=0.5+(0:length(levels(fhat$x.group))), add=TRUE, col=col.part, ...) } for (j in 1:m) { ## draw data points if (drawpoints) { if (missing(y)) if (jitter) rug(jitter(fhat$x[[j]]), col=col.pt[j], ticksize=-0.03) else rug(fhat$x[[j]], col=col.pt[j], ticksize=-0.03) else { if (missing(y.group)) if (jitter) rug(jitter(y), col=col.pt[j], ticksize=-0.03) else rug(y, col=col.pt[j], ticksize=-0.03) else if (jitter) rug(jitter(y[y.group==levels(y.group)[j]]), col=col.pt[j], ticksize=-0.03) else rug(y[y.group==levels(y.group)[j]], col=col.pt[j], ticksize=-0.03) } } } } plotkda.2d <- function(x, y, y.group, prior.prob=NULL, cont=c(25,50,75), abs.cont, approx.cont=TRUE, xlim, ylim, xlab, ylab, drawpoints=FALSE, drawlabels=TRUE, cex=1, pch, lty, col, col.part, col.pt, display.part="filled.contour", ...) { fhat <- x m <- length(fhat$x) xtemp <- numeric() for (j in 1:m) xtemp <- rbind(xtemp, fhat$x[[j]]) if (missing(xlim)) xlim <- range(xtemp[,1]) if (missing(ylim)) ylim <- range(xtemp[,2]) if (missing(pch)) pch <- 1:m if (missing(lty)) lty <- rep(1, m) if (length(lty) < m) lty <- rep(lty, m) if (missing(col)) col <- 1:m if (length(col) < m) col <- rep(col, m) if (missing(col.part)) if (display.part=="slice") col.part <- 1:3 else col.part <- grey.colors(m, start=0.7, end=1, alpha=0.5) if (missing(col.pt)) if (missing(y.group)) col.pt <- rep("blue", m) else col.pt <- 1:m if (length(col.pt)==1) col.pt <- rep(col.pt, m) x.names <- colnames(fhat$x[[1]]) if (!is.null(x.names)) { if (missing(xlab)) xlab <- x.names[1] if (missing(ylab)) ylab <- x.names[2] } else { xlab="x" ylab="y" } if (is.null(prior.prob)) prior.prob <- fhat$prior.prob if (m != length(prior.prob)) stop("prior.prob not same length as number of components in fhat") if (!(identical(all.equal(sum(prior.prob), 1), TRUE))) stop("Sum of weights not equal to 1") ## set up plot if (missing(y)) plot(fhat$x[[1]], type="n", xlab=xlab, ylab=ylab, xlim=xlim, ylim=ylim, ...) else plot(y, type="n", xlab=xlab, ylab=ylab, xlim=xlim, ylim=ylim, ...) ## set up common grid for all densities class.grid <- array(0, dim=dim(fhat$estimate[[1]])) temp <- matrix(0, ncol=length(fhat$est), nrow=nrow(fhat$est[[1]])) for (j in 1:ncol(fhat$estimate[[1]])) { for (k in 1:length(fhat$estimate)) temp[,k] <- fhat$estimate[[k]][,j]* prior.prob[k] class.grid[,j] <- max.col(temp) } ## draw partition fhat.part <- fhat fhat.part$estimate <- class.grid fhat.part$H <- fhat$H[[1]] fhat.part$x <- fhat$x[[1]] fhat.part$w <- fhat$w[[1]] fhat.part$cont <- fhat$cont[[1]] class(fhat.part) <- "kde.part" plot(fhat.part, col=col.part, add=TRUE, display=display.part, drawlabels=drawlabels, ...) ## common contour levels removed from >= v1.5.3 if (missing(abs.cont)) { hts <- contourLevels(fhat, prob=(100-cont)/100, approx=approx.cont) nhts <- length(hts[[1]]) } else { hts <- abs.cont nhts <- length(hts) } ## draw contours for (j in 1:m) { for (i in 1:nhts) { if (missing(abs.cont)) { scale <- cont[i]/hts[[j]][i] contour(fhat$eval.points[[1]], fhat$eval.points[[2]], fhat$estimate[[j]]*scale, level=hts[[j]][i]*scale, add=TRUE, drawlabels=drawlabels, lty=lty[j], col=col[j], ...) } else { contour(fhat$eval.points[[1]], fhat$eval.points[[2]], fhat$estimate[[j]], level=hts[i], add=TRUE, drawlabels=drawlabels, lty=lty[j], col=col[j], ...) } } } for (j in 1:m) { ## draw data points if (drawpoints) { if (missing(y)) points(fhat$x[[j]], pch=pch[j], col=col.pt[1], cex=cex) else { if (missing(y.group)) points(y, col=col.pt[1], cex=cex) else points(y[y.group==levels(y.group)[j],], pch=pch[j], col=col.pt[j], cex=cex) } } } } plotkda.3d <- function(x, y, y.group, prior.prob=NULL, cont=c(25,50,75), abs.cont, approx.cont=TRUE, colors, alpha=0.5, alphavec, xlab, ylab, zlab, drawpoints=FALSE, size=3, col.pt="blue", add=FALSE, ...) { ## suggestions from Viktor Petukhov 08/03/2018 if (!requireNamespace("rgl", quietly=TRUE)) stop("Install the rgl package as it is required.", call.=FALSE) if (!requireNamespace("misc3d", quietly=TRUE)) stop("Install the misc3d package as it is required.", call.=FALSE) fhat <- x m <- length(fhat$x) if (is.null(prior.prob)) prior.prob <- fhat$prior.prob if (m != length(prior.prob)) stop("prior.prob not same length as number of components in fhat") if (!(identical(all.equal(sum(prior.prob), 1), TRUE))) stop("Sum of prior weights not equal to 1") x.names <- colnames(fhat$x[[1]]) if (missing(xlab)) if (is.null(x.names)) xlab <- "x" else xlab <- x.names[1] if (missing(ylab)) if (is.null(x.names)) ylab <- "y" else ylab <- x.names[2] if (missing(zlab)) if (is.null(x.names)) zlab <- "z" else zlab <- x.names[3] xx <- numeric(0) for (j in 1:m) xx <- rbind(xx, fhat$x[[j]]) ## common contour levels removed from >= v1.5.3 if (missing(abs.cont)) { hts <- contourLevels(fhat, prob=(100-cont)/100, approx=approx.cont) nhts <- length(hts[[1]]) } else { hts <- abs.cont nhts <- length(hts) } if (missing(alphavec)) alphavec <- seq(0.1,0.3,length=nhts) if (missing(colors)) colors <- rainbow(m) if (missing(col.pt)) if (missing(y.group)) col.pt <- rep("blue", m) else col.pt <- 1:m if (length(col.pt)==1) col.pt <- rep(col.pt, m) xtemp <- numeric(); for (i in 1:length(fhat$x)) xtemp <- rbind(xtemp, fhat$x[[i]]) rgl::plot3d(x=xtemp[,1], y=xtemp[,2], z=xtemp[,3], type="n", xlab=xlab, ylab=ylab, zlab=zlab, ...) for (j in 1:m) { for (i in 1:nhts) { cti <- hts[[j]][nhts-i+1] if (cti <= max(fhat$estimate[[j]])) misc3d::contour3d(x=fhat$eval.points[[1]], y=fhat$eval.points[[2]], z=fhat$eval.points[[3]], f=fhat$estimate[[j]], level=cti, add=TRUE, alpha=alphavec[i], color=colors[j], ...) } if (drawpoints) ## plot points { if (missing(y)) rgl::points3d(fhat$x[[j]][,1], fhat$x[[j]][,2], fhat$x[[j]][,3], color=col.pt[j], size=size, alpha=1) else { if (missing(y.group)) rgl::points3d(y[,1], y[,2], y[,3], color=col.pt, size=size, alpha=1) else { y.temp <- y[y.group==levels(y.group)[j],] if (nrow(y.temp)>0) rgl::points3d(y.temp[,1], y.temp[,2], y.temp[,3], color=col.pt[j], size=size, alpha=1) } } } } } ks/R/integrate-kde.R0000644000176200001440000001000313557402137013737 0ustar liggesusers############################################################################# ## Cumulative integral for KDE ############################################################################# integral.kde <- function(q, fhat, density) #, exact=FALSE) { gridsize <- length(fhat$eval.points) ## Use Simpson's rule to compute numerical integration simp.rule <- rep(0, gridsize-1) for (i in 1:(gridsize-1)) { del <- fhat$eval.points[i+1] - fhat$eval.points[i] simp.rule[i] <- min(fhat$estimate[i], fhat$estimate[i+1])*del + 1/2*abs(fhat$estimate[i+1] - fhat$estimate[i])*del } ## add last incomplete trapezoid q.ind <- findInterval(x=q, vec=fhat$eval.points) q.prob <- rep(0, length(q)) i <- 0 for (qi in q.ind) { i <- i+1 if (qi==0) q.prob[i] <- 0 else if (qi < gridsize) { ## linearly interpolate kde fhat.estqi <- (fhat$est[qi+1] - fhat$est[qi])/(fhat$eval[qi+1] - fhat$eval[qi]) * (q[i] - fhat$eval[qi]) + fhat$est[qi] delqi <- q[i] - fhat$eval[qi] simp.ruleqi <- min(fhat.estqi, fhat$est[qi])*delqi + 1/2*abs(fhat.estqi - fhat$est[qi])*delqi q.prob[i] <- sum(simp.rule[1:qi]) + simp.ruleqi } else { if (density) q.prob[i] <- 1 else q.prob[i] <- sum(simp.rule) } } if (density) q.prob[q.prob>=1] <- 1 return(q.prob) } ## cumulative probability P(fhat <= q) pkde <- function(q, fhat) { return(integral.kde(q=q, fhat=fhat, density=TRUE)) } dkde <- function(x, fhat) { return(predict(fhat, x=x)) } qkde <- function(p, fhat) { if (any(p > 1) | any(p < 0)) stop("p must be <= 1 and >= 0") cumul.prob <- pkde(q=fhat$eval.points, fhat=fhat) ind <- findInterval(x=p, vec=cumul.prob) quant <- rep(0, length(ind)) for (j in 1:length(ind)) { i <- ind[j] if (i==0) quant[j] <- fhat$eval.points[1] else if (i>=length(fhat$eval.points)) quant[j] <- fhat$eval.points[length(fhat$eval.points)] else { quant1 <- fhat$eval.points[i] quant2 <- fhat$eval.points[i+1] prob1 <- cumul.prob[i] prob2 <- cumul.prob[i+1] alpha <- (p[j] - prob2)/(prob1 - prob2) quant[j] <- quant1*alpha + quant2*(1-alpha) } } return(quant) } ### Silverman (1983)'s random sample from KDE rkde <- function(n, fhat, positive=FALSE) { if (positive) x <- log(fhat$x) else x <- fhat$x if (is.vector(fhat$H)) {d <- 1; nsamp <- length(x)} else {d <- ncol(fhat$H); nsamp <- nrow(x)} x.ind <- sample(1:nsamp, size=n, replace=TRUE) if (d==1) { h <- fhat$h rkde.val <- x[x.ind] + h*rnorm(n=n, mean=0, sd=1) if (positive) rkde.val <- exp(rkde.val) } else if (d>1) { H <- fhat$H rkde.val <- x[x.ind,] + rmvnorm(n=n, mean=rep(0,d), sigma=diag(d)) %*% matrix.sqrt(H) } return(rkde.val) } ### plot cumulative probability as shaded region on a KDE plotkde.cumul <- function(fhat, q, add=FALSE, col="blue", ...) { qind <- fhat$eval.points<=q n <- sum(qind) if (!add) plot(fhat) polygon(c(fhat$eval.points[qind],fhat$eval.points[n]), c(fhat$estimate[qind],0), col=col, ...) ##box() } ## ISE of difference between two KDEs ise.diff <- function(fhat1, fhat2, xmin, xmax) { if(!isTRUE(all.equal(fhat1$eval.points, fhat2$eval.points))) stop("fhat1 and fhat2 need to de defined on the same grid") fhat.sq <- fhat1 fhat.sq$estimate <- (fhat1$estimate - fhat2$estimate)^2 if (missing(xmin) & missing(xmax)) int <- integral.kde(fhat=fhat.sq, q=max(fhat.sq$eval.points)+0.1*abs(max(fhat.sq$eval.points)), density=FALSE) if (missing(xmin) & !missing(xmax)) int <- integral.kde(fhat=fhat.sq, q=xmax, density=FALSE) if (!missing(xmin) & missing(xmax)) int <- integral.kde(fhat=fhat.sq, q=max(fhat.sq$eval.points)+0.1*abs(max(fhat.sq$eval.points)), density=FALSE) - integral.kde(fhat=fhat.sq, q=xmin, density=FALSE) if (!missing(xmin) & !missing(xmax)) int <- integral.kde(fhat=fhat.sq, q=xmax, density=FALSE) - integral.kde(fhat=fhat.sq, q=xmin, density=FALSE) return(int) } ks/R/kms.R0000644000176200001440000002365613325712071012022 0ustar liggesusers############################################################################### ## Kernel mean shift ############################################################################### kms <- function(x, y, H, max.iter=400, tol.iter, tol.clust, min.clust.size, merge=TRUE, keep.path=FALSE, verbose=FALSE) { n <- nrow(x) d <- ncol(x) if (missing(tol.iter)) tol.iter <- 1e-3*min(apply(x, 2, IQR)) ##mean(apply(apply(x, 2, range), 2, diff)) if (missing(tol.clust)) tol.clust <- 1e-2*max(apply(x, 2, IQR)) ##mean(apply(apply(x, 2, range), 2, diff)) if (missing(y)) y <- x if (missing(min.clust.size)) min.clust.size <- round(1e-2*nrow(y),0) if (missing(H)) H <- Hpi(x, deriv.order=1, binned=default.bflag(d=d, n=n), nstage=2-(d>2)) Hinv <- chol2inv(chol(H)) if (is.vector(y)) y <- matrix(y, nrow=1) ## mean shift iterations n.seq <- block.indices(n, nrow(y), d=d, r=0, diff=FALSE, block.limit=3e6) if (verbose) pb <- txtProgressBar() ms <- list() i <- 1 if (verbose) setTxtProgressBar(pb, i/(length(n.seq)-1)) ms <- kms.base(x=x, y=y[n.seq[i]:(n.seq[i+1]-1),], H=H, tol.iter=tol.iter, tol.clust=tol.clust, Hinv=Hinv, verbose=verbose, max.iter=max.iter) if (length(n.seq)>2) { for (i in 2:(length(n.seq)-1)) { if (verbose) setTxtProgressBar(pb, i/(length(n.seq)-1)) ms.temp <- kms.base(x=x, y=y[n.seq[i]:(n.seq[i+1]-1),], H=H, tol.iter=tol.iter, tol.clust=tol.clust, Hinv=Hinv, verbose=verbose, max.iter=max.iter) ms$y <- rbind(ms$y, ms.temp$y) ms$end.points <- rbind(ms$end.points, ms.temp$end.points) ms$label <- c(ms$label, ms.temp$label + max(ms$label)) ms$mode <- rbind(ms$mode, ms.temp$mode) ms$nclust <- ms$nclust + ms.temp$nclust ms$nclust.table <- table(ms$label) ms$path <- c(ms$path, ms.temp$path) ## merge clusters which are closer than tol.clust distance ms <- ms.merge.dist(ms=ms, tol=tol.clust, verbose=FALSE) } } if (verbose) close(pb) path.temp <- ms$path ms$path <- NULL ms$tol.iter <- tol.iter ms$tol.clust <- tol.clust ms$min.clust.size <- min.clust.size ms$names <- parse.name(x) if (keep.path) ms$path <- path.temp ## merge clusters which are smaller than min.clust.size if (merge) ms <- ms.merge.num(ms, min.clust.size=min.clust.size, verbose=verbose) return(ms) } kms.base <- function(x, H, Hinv, y, max.iter, tol.iter, tol.clust, verbose=FALSE) { ## mean shift iterations ## original implementation J.E. Chacon (2013) ## modifications T.D. (2014) if (!is.matrix(x)) x <- as.matrix(x) if (!is.matrix(y)) y <- as.matrix(y) if (missing(Hinv)) Hinv <- chol2inv(chol(H)) nx <- nrow(x) ny <- nrow(y) d <- ncol(y) y.path <- split(y, row(y), drop=FALSE) names(y.path) <- NULL xHinv <- x %*% Hinv xHinvx <- rowSums(xHinv*x) y.update <- y i <- 1 eps <- max(sqrt(rowSums(y.update^2))) disp.ind <- head(sample(1:nrow(y)), n=min(100,nrow(y))) while (eps > tol.iter & i< max.iter) { y.curr <- y.update yHinvy <- t(rowSums(y.curr%*%Hinv *y.curr)) Mah <- apply(yHinvy, 2, "+", xHinvx) - 2*xHinv %*% t(y.curr) w <- exp(-Mah/2) denom <- colSums(w) num <- t(w)%*%x denom[denom<=1e-3*tol.iter] <- 1e-3*tol.iter mean.shift.H <- num/denom y.update <- mean.shift.H y.update.list <- split(y.update, row(y.update), drop=FALSE) y.path <- mapply(rbind, y.path, y.update.list, SIMPLIFY=FALSE) eps <- max(sqrt(rowSums((y.curr-y.update)^2))) if (verbose>1) { y.range <- apply(y, 2, range) if (d==2) plot(y.update[disp.ind,], col=1, xlim=y.range[,1], ylim=y.range[,2], xlab="x", ylab="y") else pairs(y.update[disp.ind,], col=1) } i <- i+1 } ms.endpt <- t(sapply(y.path, tail, n=1, SIMPLIFY=FALSE)) ## extract cluster centres mode.tree <- hclust(dist(ms.endpt)) clust.label <- cutree(mode.tree, h=tol.clust) nclust <- length(unique(clust.label)) mode.val <- by(ms.endpt, INDICES=clust.label, FUN=colMeans) mode.val <- t(sapply(mode.val, FUN=identity)) colnames(mode.val) <- colnames(x) rownames(mode.val) <- NULL nclust.table <- table(clust.label, dnn="") ms <- list(x=x, y=y, end.points=ms.endpt, H=H, label=clust.label, nclust=nclust, nclust.table=nclust.table, mode=mode.val, path=y.path) class(ms) <- "kms" return(ms) } ## merge classes in 'label' into a single class ## label is a list of vector of class labels ## i.e. all classes in label[[j]] merged into new class j ms.merge.label <- function(ms, label, verbose=FALSE) { ms.merge <- ms for (i in 1:length(label)) { labeli <- label[[i]] if (length(labeli)>1) { merge.label <- min(labeli) ms.merge$label[ms$label %in% labeli] <- merge.label mode.label <- ms$mode[labeli[round(length(labeli)/2,0)],] for (j in labeli) ms.merge$mode[j,] <- mode.label } } ms.merge$mode <- unique(ms.merge$mode) ms.merge$nclust <- nrow(ms.merge$mode) ms.merge$label <- as.factor(ms.merge$label) levels(ms.merge$label) <- 1:ms.merge$nclust ms.merge$label <- as.numeric(ms.merge$label) ms.merge$nclust.table <- table(ms.merge$label) if (verbose) { cat("Current clusters:", ms.merge$nclust.table, "\n") } return(ms.merge) } ## merge mean shift clusters based on distance threshold ms.merge.dist <- function(ms, tol, verbose) { if (missing(tol)) tol <- 1e-1*min(apply(ms$x, 2, IQR)) mode.tree <- hclust(dist(ms$mode)) merge.label <- cutree(mode.tree, h=tol) merge.label <- split(1:ms$nclust, merge.label, drop=FALSE) ## create list where each element is a vector of cluster labels ## to be merged into a single cluster ms.temp <- ms.merge.label(ms=ms, label=merge.label, verbose=verbose) return(ms.temp) } ## merge mean shift clusters based on min cluster size ms.merge.num <- function(ms, min.clust.size, verbose=FALSE) { if (missing(min.clust.size)) min.clust.size <- round(1e-2*nrow(ms$y),0) min.clust.size <- round(min.clust.size, 0) if (any(ms$nclust.table<=min.clust.size)) { if (verbose) cat("Min cluster size merging begins. Min size = ", min.clust.size, "\n") ms.temp <- ms while(any(ms.temp$nclust.table<=min.clust.size) & ms.temp$nclust>1) { nclust.table <- table(ms.temp$label) small.clust.ind <- which.min(nclust.table) if (nclust.table[small.clust.ind] <= min.clust.size) { nearest.clust.ind <- FNN::get.knnx(ms.temp$mode, ms.temp$mode, k=2)$nn.index[small.clust.ind,2] merge.label <- ms$label merge.label[merge.label==small.clust.ind] <- nearest.clust.ind merge.label <- split(ms$label, merge.label, drop=FALSE) merge.label <- lapply(merge.label, unique) ms.temp <- ms.merge.label(ms=ms.temp, label=merge.label, verbose=verbose) } } ms <- ms.temp ms$min.clust.size <- min.clust.size ##ms <- ms.merge.num1(ms, num=min.clust.size, verbose=verbose) if (verbose) cat("Min cluster size merging ends.\n\n") } if (verbose) {cat("Final clusters:\n"); summary(ms)} return(ms) } summary.kms <- function(object, ...) { cat("Number of clusters =", object$nclust, "\n") cat("Cluster label table =", object$nclust.table, "\n") cat("Cluster modes =\n") print(as.data.frame(object$mode), ...) } plot.kms <- function(x, splom=TRUE, col, add=FALSE, ...) { fhat <- x if (is.vector(fhat$H)) d <- 1 else d <- ncol(fhat$H) if (missing(col)) col <- rainbow(length(unique(fhat$label))) if (d==1) stop("kms plot not yet implemented") else if (d==2) { if (!add) plot(fhat$x, col=col[fhat$label], ...) else points(fhat$x, col=col[fhat$label], ...) } else if (d==3 & !splom) { ## suggestions from Viktor Petukhov 08/03/2018 if (!requireNamespace("rgl", quietly=TRUE)) stop("Install the rgl package as it is required.", call.=FALSE) if (!add) rgl::plot3d(fhat$x, col=col[fhat$label], ...) else rgl::points3d(fhat$x, col=col[fhat$label], ...) } else if (d>=3) { pairs(fhat$x, col=col[fhat$label], ...) } } ###################################################################### ## Cluster partition for 2D kernel mean shift ##################################################################### kms.part <- function(x, H, xmin, xmax, gridsize, verbose=FALSE, ...) { if (missing(H)) H <- Hpi(x, deriv.order=1, binned=TRUE) tol <- 5 ##3.7 tol.H <- tol * diag(H) if (missing(xmin)) xmin <- apply(x, 2, min) - tol.H if (missing(xmax)) xmax <- apply(x, 2, max) + tol.H if (missing(gridsize)) gridsize <- default.gridsize(2) xx <- seq(xmin[1], xmax[1], length = gridsize[1]) yy <- seq(xmin[2], xmax[2], length = gridsize[2]) xy <- expand.grid(xx, yy) xy.kms <- kms(x=x, y=xy, H=H, verbose=verbose, ...) xy.lab <- array(xy.kms$label, dim=gridsize) fhat <- kde(x=x, binned=TRUE, xmin=xmin, xmax=xmax, bgridsize=gridsize) fhat$estimate <- xy.lab fhat <- c(fhat, xy.kms[c("end.points", "label", "mode", "nclust", "nclust.table", "min.clust.size", "tol.iter", "tol.clust")]) class(fhat) <- "kde.part" return(fhat) } plot.kde.part <- function(x, display="filled.contour", col, add=FALSE, ...) { clev <- sort(unique(as.vector(x$estimate))) if (missing(col)) col <- rainbow(length(clev)) for (i in 1:length(clev)) { xtemp <- x xtemp$estimate <- x$estimate==clev[i] plot.kde(xtemp, display=display, col=c("transparent", col[i]), add=add | i>1, abs.cont=0.5, ...) } } ks/R/normal.R0000644000176200001440000016713013313545122012512 0ustar liggesusers ############################################################################### ## Univariate mixture normal densities ############################################################################### rnorm.mixt <- function(n=100, mus=0, sigmas=1, props=1, mixt.label=FALSE) { if (!(identical(all.equal(sum(props), 1), TRUE))) stop("Proportions don't sum to one") ### single component mixture if (identical(all.equal(props[1], 1), TRUE)) { if (mixt.label) rand <- cbind(rnorm(n=n, mean=mus, sd=sigmas), rep(1, n)) else rand <- rnorm(n=n, mean=mus, sd=sigmas) } ### multiple component mixture else { k <- length(props) n.samp <- sample(1:k, n, replace=TRUE, prob=props) n.prop <- numeric(0) ## compute number taken from each mixture for (i in 1:k) n.prop <- c(n.prop, sum(n.samp == i)) rand <- numeric(0) for (i in 1:k) ##for (i in as.numeric(rownames(n.prop))) { ## compute random sample from normal mixture component if (n.prop[i] > 0) if (mixt.label) rand <- rbind(rand, cbind(rnorm(n=n.prop[i], mean=mus[i], sd=sigmas[i]), rep(i, n.prop[i]))) else rand <- c(rand, rnorm(n=n.prop[i], mean=mus[i], sd=sigmas[i])) } } if (mixt.label) return(rand[sample(n),]) else return(rand[sample(n)]) } dnorm.mixt <- function(x, mus=0, sigmas=1, props=1) { if (!(identical(all.equal(sum(props), 1), TRUE))) stop("Proportions don't sum to one") ## single component mixture if (identical(all.equal(props[1], 1), TRUE)) dens <- dnorm(x, mean=mus[1], sd=sigmas[1]) ## multiple component mixture else { k <- length(props) dens <- 0 ## sum of each normal density value from each component at x for (i in 1:k) dens <- dens + props[i]*dnorm(x, mean=mus[i], sd=sigmas[i]) } return(dens) } ############################################################################### ## Derivatives of the univariate normal ## (code: J.E.Chacon 08/06/2018) ## ## Parameters ## x - points to evaluate at ## sigma - std deviation ## r - derivative index # ## Returns ## r-th derivative at x ############################################################################### dnorm.deriv <- function (x, mu=0, sigma=1, deriv.order=0) { r <- deriv.order phi <- dnorm(x, mean=mu, sd=sigma) x <- (x - mu) arg <- x / sigma hmold0 <- 1 hmold1 <- arg hmnew <- 1 if (r == 1) hmnew <- hmold1 if (r >= 2) for (i in (2:r)) { hmnew <- arg * hmold1 - (i - 1) * hmold0 hmold0 <- hmold1 hmold1 <- hmnew } derivt <- (-1)^r * phi * hmnew / sigma^r return(derivt) } ############################################################################### ## Double sum of K(X_i - X_j) used in density derivative estimation # ## Parameters ## x - points to evaluate ## Sigma - variance matrix ## inc - 0 - exclude diagonals ## - 1 - include diagonals # ## Returns ## Double sum at x ############################################################################### dnorm.deriv.sum <- function(x, sigma, deriv.order, inc=1, binned=FALSE, bin.par, kfe=FALSE) { r <- deriv.order n <- length(x) if (binned) { if (missing(bin.par)) bin.par <- binning(x, h=sigma, supp=4+r) est <- kdde.binned(x=x, H=sigma^2, h=sigma, deriv.order=r, bin.par=bin.par)$estimate sumval <- sum(bin.par$counts*est*n) if (inc == 0) sumval <- sumval - n*dnorm.deriv(x=0, mu=0, sigma=sigma, deriv.order=r) } else { sumval <- 0 for (i in 1:n) sumval <- sumval + sum(dnorm.deriv(x=x[i] - x, mu=0, sigma=sigma, deriv.order=r)) if (inc == 0) sumval <- sumval - n*dnorm.deriv(x=0, mu=0, sigma=sigma, deriv.order=r) } if (kfe) if (inc==1) sumval <- sumval/n^2 else sumval <- sumval/(n*(n-1)) return(sumval) } dnorm.deriv.mixt <- function(x, mus=0, sigmas=1, props=1, deriv.order=0) { if (!(identical(all.equal(sum(props), 1), TRUE))) stop("Proportions don't sum to one") ## single component mixture if (identical(all.equal(props[1], 1), TRUE)) dens <- dnorm.deriv(x, mu=mus[1], sigma=sigmas[1], deriv.order=deriv.order) ## multiple component mixture else { k <- length(props) dens <- 0 ## sum of each normal density value from each component at x for (i in 1:k) dens <- dens + props[i]*dnorm.deriv(x=x, mu=mus[i], sigma=sigmas[i], deriv.order=deriv.order) } return(dens) } ############################################################################### # Multivariate normal densities and derivatives ############################################################################### ############################################################################### ## Multivariate normal mixture - random sample ## ## Parameters ## n - number of samples ## mus - matrix of means (each row is a vector of means from each component ## density) ## Sigmas - matrix of covariance matrices (every d rows is a covariance matrix ## from each component density) ## props - vector of mixing proportions ## ## Returns ## Vector of n observations from the normal mixture ############################################################################### rmvnorm.mixt <- function(n=100, mus=c(0,0), Sigmas=diag(2), props=1, mixt.label=FALSE) { if (!(identical(all.equal(sum(props), 1), TRUE))) stop("Proportions don't sum to one") #if (is.vector(Sigmas)) ## return(rnorm.mixt(n=n, mus=mus, sigmas=Sigmas, props=props)) ### single component mixture if (identical(all.equal(props[1], 1), TRUE)) if (mixt.label) rand <- cbind(rmvnorm(n=n, mean=mus, sigma=Sigmas), rep(1, n)) else rand <- cbind(rmvnorm(n=n, mean=mus, sigma=Sigmas)) ### multiple component mixture else { k <- length(props) d <- ncol(Sigmas) n.samp <- sample(1:k, n, replace=TRUE, prob=props) n.prop <- numeric(0) ## compute number taken from each mixture for (i in 1:k) n.prop <- c(n.prop, sum(n.samp == i)) rand <- numeric(0) for (i in 1:k) { ## compute random sample from normal mixture component if (n.prop[i] > 0) { if (mixt.label) rand <- rbind(rand, cbind(rmvnorm(n=n.prop[i], mean=mus[i,], sigma=Sigmas[((i-1)*d+1) : (i*d),]), rep(i, n.prop[i]))) else rand <- rbind(rand, rmvnorm(n=n.prop[i], mean=mus[i,], sigma=Sigmas[((i-1)*d+1) : (i*d),])) } } } return(rand[sample(n),]) } ############################################################################### ## Multivariate normal mixture - density values ## ## Parameters ## x - points to compute density at ## mus - matrix of means ## Sigmas - matrix of covariance matrices ## props - vector of mixing proportions ## ## Returns ## Density values from the normal mixture (at x) ############################################################################### dmvnorm.mixt <- function(x, mus, Sigmas, props=1, verbose=FALSE) { if (!(identical(all.equal(sum(props), 1), TRUE))) stop("Proportions don't sum to one") if (is.vector(x)) {d <- length(x); n <- 1} else {d <- ncol(x); n <- nrow(x)} if (missing(mus)) mus <- rep(0,d) if (missing(Sigmas)) Sigmas <- diag(d) ## single component mixture if (identical(all.equal(props[1], 1), TRUE)) { if (is.matrix(mus)) mus <- mus[1,] dens <- dmvnorm(x=x, mean=mus, sigma=Sigmas[1:d,]) } ## multiple component mixture else { if (verbose) pb <- txtProgressBar() k <- length(props) dens <- 0 ## sum of each normal density value from each component at x for (i in 1:k) { dens <- dens + props[i]*dmvnorm(x=x, mean=mus[i,], sigma=Sigmas[((i-1)*d+1):(i*d),]) if (verbose) setTxtProgressBar(pb, i/k) } if (verbose) close(pb) } return(dens) } ########################################################################## ### Computation of the r-th derivative vector of the Gaussian density ########################################################################## dmvnorm.deriv <- function(x, mu, Sigma, deriv.order=0, deriv.vec=TRUE, add.index=FALSE, only.index=FALSE, type="unique") { type1 <- match.arg(type, c("recursive", "direct", "unique")) r <- deriv.order if(length(r)>1) stop("deriv.order should be a non-negative integer") sumr <- sum(r) if (missing(x)) d <- ncol(Sigma) else { if (is.vector(x)) x <- t(as.matrix(x)) if (is.data.frame(x)) x <- as.matrix(x) d <- ncol(x) n <- nrow(x) } if (add.index | only.index | !deriv.vec) { ## matrix of derivative indices ind.mat <- 0 sumr.counter <- sumr if (sumr>=1) ind.mat <- diag(d) { while (sumr.counter >1) { ind.mat <- Ksum(diag(d), ind.mat) sumr.counter <- sumr.counter - 1 } } ind.mat.minimal <- unique(ind.mat) ind.mat.minimal.logical <- !duplicated(ind.mat) if (only.index) if (deriv.vec) return (ind.mat) else return(ind.mat.minimal) } if (missing(mu)) mu <- rep(0,d) if (missing(Sigma)) Sigma <- diag(d) x.centred <- sweep(x, 2, mu) dens <- do.call(paste("dmvnorm.deriv", type1, sep="."), list(x=x.centred, Sigma=Sigma, deriv.order=r)) if (is.vector(dens) & r>0) dens <- matrix(dens, nrow=1) if (!deriv.vec & r>0) { ind.select <- numeric() for (i in 1:nrow(ind.mat.minimal)) ind.select <- c(ind.select, head(which.mat(ind.mat.minimal[i,], ind.mat), n=1)) dens <- dens[,ind.select] ind.mat <- ind.mat.minimal } if (add.index) return(list(deriv=dens, deriv.ind=ind.mat)) else return(dens) } ############################################################################ ### dmvnorm.deriv.direct computes the vector derivative of the Gaussian ### density phi_Sigma(x) on the basis of Equation (1) and Algotihm 2, as ### described in Chacon and Duong (2014) ############################################################################ dmvnorm.deriv.direct<-function(x,Sigma,deriv.order=0){ if(is.vector(x)){x<-matrix(x,nrow=1)} d<-ncol(Sigma) n<-nrow(x) r<-deriv.order Sigmainv<-chol2inv(chol(Sigma)) Hermx<-matrix(0,nrow=n,ncol=d^r) for(i in 1:n) { for (j in 0:floor(r/2)) Hermx[i,]<-Hermx[i,] + (-1)^j/(factorial(j)*factorial(r-2*j)*2^j)* Kpow(Sigmainv%*%x[i,], r-2*j)%x%Kpow(vec(Sigmainv),j) Hermx[i,]<-Sdrv.recursive(d=d,r=r,v=Hermx[i,]) } dens<-(-1)^r*factorial(r)*Hermx*dmvnorm(x,mean=rep(0,d), sigma=Sigma) return(drop(dens)) } ############################################################################ ### dmvnorm.deriv.recursive computes the vector derivative of the Gaussian ### density phi_Sigma(x) on the basis of Equation (7) and Algorithm 2 as ### described in Section 5 of Chacon and Duong (2014) ############################################################################ dmvnorm.deriv.recursive<-function(x,Sigma,deriv.order=0){ if(is.vector(x)){x<-matrix(x,nrow=1)} d<-ncol(Sigma) n<-nrow(x) r<-deriv.order G<-Sigma Ginv<-chol2inv(chol(G)) vGinv<-vec(Ginv) nvGinv<-matrix(rep(vGinv,n),byrow=TRUE,ncol=length(vGinv),nrow=n) arg<-matrix(x%*%Ginv, nrow=n) hmold0 <- matrix(1,nrow=n,ncol=1) hmold1 <- arg hmnew <- hmold0 if(r==1){hmnew<-hmold1} if(r>=2){for(i in 2:r){ hmnew<-mat.Kprod(hmold1,arg)-(i-1)*mat.Kprod(nvGinv,hmold0) hmnew<-matrix(Sdrv.recursive(d=d,r=i,v=hmnew), nrow=n) hmold0<-hmold1 hmold1<-hmnew } } dens<-dmvnorm(x,mean=rep(0,d),sigma=Sigma) result<-matrix(rep(dens,d^r),byrow=FALSE,nrow=n,ncol=d^r)*hmnew*(-1)^r return(drop(result)) } ############################################################################### ### dmvnorm.deriv.unique computes the whole vector derivative of the Gaussian ### density phi_Sigma(x) from its unique coordinates, based on Algorithm 3 as ### described in Section 5 of Chacon and Duong (2014) ############################################################################### dmvnorm.deriv.unique<-function(x,Sigma,deriv.order=0){ if(is.vector(x)){x<-matrix(x,nrow=1)} d<-ncol(x) n<-nrow(x) r<-deriv.order G<-Sigma Ginv<-chol2inv(chol(G)) arg<-x%*%Ginv hmold0 <- matrix(1,nrow=n,ncol=1) hmold1 <- arg hmnew <- hmold0 udind0<-matrix(rep(0,d),nrow=1,ncol=d) udind1<-diag(d) if(r==1){hmnew<-hmold1} if(r>=2){for(i in 2:r){ Ndi1<-ncol(hmold1) Ndi0<-ncol(hmold0) hmnew<-numeric() for(j in 1:d){ nrecj<-choose(d-j+i-1,i-1) hmnew.aux<-arg[,j]*hmold1[,Ndi1-(nrecj:1)+1] for(k in j:d){ udind0.aux<-matrix(udind1[Ndi1-(nrecj:1)+1,],ncol=d,byrow=FALSE) udind0.aux[,k]<-udind0.aux[,k]-1 valid.udind0<-as.logical(apply(udind0.aux>=0,1,min)) enlarged.hmold0<-matrix(0,ncol=nrow(udind0.aux),nrow=n) for(l in 1:nrow(udind0.aux)){ if(valid.udind0[l]){ pos<-which(rowSums((udind0-matrix(rep(udind0.aux[l,],nrow(udind0)), nrow=nrow(udind0),byrow=TRUE))^2)==0) enlarged.hmold0[,l]<-hmold0[,pos]} } hmnew.aux<-hmnew.aux-Ginv[j,k]*matrix(rep(udind1[Ndi1-(nrecj:1)+1,k],n), nrow=n,byrow=TRUE)*enlarged.hmold0 } hmnew<-cbind(hmnew,hmnew.aux) } hmold0 <- hmold1 hmold1 <- hmnew ##Compute the unique i-th derivative multi-indexes nudind1<-nrow(udind1) udindnew<-numeric() for(j in 1:d){ Ndj1i<-choose(d+i-1-j,i-1) udind.aux<-matrix(udind1[nudind1-(Ndj1i:1)+1,],ncol=d,byrow=FALSE) udind.aux[,j]<-udind.aux[,j]+1 udindnew<-rbind(udindnew,udind.aux) } udind0<-udind1 udind1<-udindnew }} if(r==0) result<-dmvnorm(x,mean=rep(0,d),sigma=Sigma) if(r==1) result<-(-1)*matrix(rep(dmvnorm(x,mean=rep(0,d),sigma=Sigma),d), nrow=n,byrow=FALSE)*hmnew if(r>=2){ per<-pinv.all(d=d,r=r) dind<-numeric() udind<-udind1 dind.base<-rep(0,d^r) udind.base<-rep(0,choose(d+r-1,r)) for(i in 1:d){ dind<-cbind(dind,rowSums(per==i)) ## Matrix of derivative indices dind.base<-dind.base+dind[,i]*(r+1)^(d-i) ## Transform each row to base r+1 udind.base<-udind.base+udind[,i]*(r+1)^(d-i) ## Transform each row to base r+1 } dlabs<-match(dind.base,udind.base) deriv.vector<-hmnew[,dlabs]*matrix(rep((-1)^rowSums(dind),n),nrow=n,byrow=TRUE) result<-matrix(rep(dmvnorm(x,mean=rep(0,d),sigma=Sigma),ncol(deriv.vector)), nrow=n,byrow=FALSE)*deriv.vector } return(drop(result)) } dmvnorm.deriv.mixt <- function(x, mus, Sigmas, props, deriv.order, deriv.vec=TRUE, add.index=FALSE, only.index=FALSE, verbose=FALSE) { if (!(identical(all.equal(sum(props), 1), TRUE))) stop("Proportions don't sum to one") if (is.vector(x)) d <- length(x) else d <- ncol(x) if (missing(mus)) mus <- rep(0,d) if (missing(Sigmas)) Sigmas <- diag(d) r <- deriv.order sumr <- sum(r) if (only.index | add.index) ind.mat <- dmvnorm.deriv(x=x, mu=mus[1,], Sigma=Sigmas[1:d,], deriv.order=r, only.index=TRUE) if (only.index) if (deriv.vec) return (ind.mat) else return(unique(ind.mat)) ## derivatives ## single component mixture if (identical(all.equal(props[1], 1), TRUE)) { if (is.matrix(mus)) mus <- mus[1,] dens <- dmvnorm.deriv(x=x, mu=mus, Sigma=Sigmas[1:d,], deriv.order=sumr) } ## multiple component mixture else { k <- length(props) if (verbose) pb <- txtProgressBar() dens <- 0 ## sum of each normal density value from each component at x for (i in 1:k) { dens <- dens + props[i]*dmvnorm.deriv(x=x, mu=mus[i,], Sigma=Sigmas[((i-1)*d+1):(i*d),], deriv.order=sumr) if (verbose) setTxtProgressBar(pb, i/k) } if (verbose) close(pb) } if (!deriv.vec) { dens <- dens[,!duplicated(ind.mat)] ind.mat <- unique(ind.mat) } if (add.index) return(list(deriv=dens, deriv.ind=ind.mat)) else return(deriv=dens) } ############################################################################### ## Double sum of K(X_i - X_j) used in density derivative estimation # ## Parameters ## x - points to evaluate ## Sigma - variance matrix ## inc - 0 - exclude diagonals ## - 1 - include diagonals # ## Returns ## Double sum at x ############################################################################## dmvnorm.deriv.sum <- function(x, Sigma, deriv.order=0, inc=1, binned=FALSE, bin.par, bgridsize, kfe=FALSE, deriv.vec=TRUE, add.index=FALSE, verbose=FALSE) { r <- deriv.order d <- ncol(x) n <- nrow(x) if (missing(bgridsize)) bgridsize <- default.bgridsize(d) if (binned) { d <- ncol(Sigma) n <- nrow(x) if (missing(bin.par)) bin.par <- binning(x, H=diag(diag(Sigma)), bgridsize=bgridsize) est <- kdde.binned(x=x, bin.par=bin.par, H=Sigma, deriv.order=r, verbose=verbose)$estimate if (r>0) { sumval <- rep(0, length(est)) for (j in 1:length(est)) sumval[j] <- sum(bin.par$counts * n * est[[j]]) } else sumval <- sum(bin.par$counts * n * est) ## transformation approach from Jose E. Chacon 06/12/2010 if (0) { Sigmainv12 <- matrix.sqrt(chol2inv(chol(Sigma))) y <- x %*% Sigmainv12 if (missing(bin.par)) bin.par <- binning(x=y, H=diag(d), bgridsize=bgridsize) est <- kdde.binned(x=y, bin.par=bin.par, H=diag(d), deriv.order=r, verbose=verbose)$estimate if (r>0) { sumval <- rep(0, length(est)) for (j in 1:length(est)) sumval[j] <- sum(bin.par$counts *n*est[[j]]) } else sumval <- sum(bin.par$counts * n * est) sumval <- det(Sigmainv12) * sumval %*% Kpow(Sigmainv12, pow=r) } } ## exact computation else { if (verbose) pb <- txtProgressBar() if (r==0) { n.seq <- block.indices(n, n, d=d, r=r, diff=TRUE) sumval <- 0 for (i in 1:(length(n.seq)-1)) { difs <- differences(x=x, y=x[n.seq[i]:(n.seq[i+1]-1),]) sumval <- sumval + sum(dmvnorm.deriv(x=difs, mu=rep(0,d), Sigma=Sigma, deriv.order=r, deriv.vec=deriv.vec)) if (verbose) setTxtProgressBar(pb, i/(length(n.seq)-1)) } } else { ## only with r>0 ## original recursive code from Jose E. Chacon 03/2012 if (2*floor(r/2)!=r){sumval <- rep(0,d^r)} else { Sigmainv<-chol2inv(chol(Sigma)) per <- perm.rep(d=d,r=r) dind <- numeric() for(i in 1:d) dind <- cbind(dind,rowSums(per==i)) ###Matrix of derivative indices udind <- unique(dind) nudind <- nrow(udind) dlabs <- numeric(nrow(dind)) for (i in 1:nrow(udind)) dlabs <- dlabs+i*(rowSums((dind-matrix(rep(udind[i,],nrow(dind)),nrow=nrow(dind),byrow=TRUE))^2)==0) result<-rep(0,nudind) ndif <- n*(n-1)/2 dif.ind <- numeric() ##for(k in 2:n) dif.ind <- rbind(dif.ind,cbind(1:(k-1),rep(k,k-1))) M <- 1e6 max.loop.size <- ceiling(M/nudind) ### Inside the loop we need to store a matrix of order max.loop.size x nudind <= M nblocks <- ceiling(ndif/max.loop.size) blength <- c(rep(max.loop.size,nblocks-1),ndif-max.loop.size*(nblocks-1)) #length of each of the blocks, the last one could be smaller tri.num <- (1:n)*((1:n)-1)/2 for(kk in 1:nblocks){ b <- blength[kk] if (verbose) setTxtProgressBar(pb, kk/nblocks) kkm <- (kk-1)*max.loop.size tri.ind <- findInterval(kkm:(kkm+b-1), tri.num) dif.ind.block <- cbind(kkm:(kkm+b-1) - tri.num[tri.ind]+1, tri.ind+1) ##difs.block <- x[dif.ind[((kk-1)*max.loop.size+1):((kk-1)*max.loop.size+b),1],]-x[dif.ind[((kk-1)*max.loop.size+1):((kk-1)*max.loop.size+b),2],] difs.block <- x[dif.ind.block[,1],]-x[dif.ind.block[,2],] arg <- difs.block %*% Sigmainv narg <- nrow(arg) hmold0 <- matrix(rep(1,narg),ncol=1,nrow=narg) hmold1 <- arg hmnew <- hmold0 udind0 <- matrix(rep(0,d),nrow=1,ncol=d) udind1 <- diag(d) if (r==1){hmnew<-hmold1} if (r >= 2) { for (i in 2:r) { Ndi1 <- ncol(hmold1) ##Ndi0 <- ncol(hmold0) hmnew <- numeric() for(j in 1:d) { nrecj <- choose(d-j+i-1,i-1) hmnew.aux <- arg[,j]*hmold1[,Ndi1-(nrecj:1)+1] for(k in j:d) { udind0.aux <- matrix(udind1[Ndi1-(nrecj:1)+1,],ncol=d,byrow=FALSE) udind0.aux[,k] <- udind0.aux[,k]-1 valid.udind0 <- as.logical(apply(udind0.aux>=0,1,min)) enlarged.hmold0 <- matrix(0,ncol=nrow(udind0.aux),nrow=narg) for(ell in 1:nrow(udind0.aux)) { if(valid.udind0[ell]){ pos <- which(rowSums((udind0-matrix(rep(udind0.aux[ell,],nrow(udind0)),nrow=nrow(udind0),byrow=TRUE))^2)==0) enlarged.hmold0[,ell]<-hmold0[,pos]} } ##In enlarged.hmold0 we put the vector hmold0 in those positions not having a -1 in any of the derivative order after subtracting e_k ##The remaining positions are zeroes ##Surely this could be done in a more efficient way hmnew.aux <- hmnew.aux-Sigmainv[j,k]*matrix(rep(udind1[Ndi1-(nrecj:1)+1,k],narg),nrow=narg,byrow=TRUE)*enlarged.hmold0 } hmnew<-cbind(hmnew,hmnew.aux) } hmold0 <- hmold1 hmold1 <- hmnew ##Compute the unique i-th derivative multi-indexes nudind1<-nrow(udind1) udindnew<-numeric() for(j in 1:d) { Ndj1i <- choose(d+i-1-j,i-1) udind.aux <- matrix(udind1[nudind1-(Ndj1i:1)+1,],ncol=d,byrow=FALSE) udind.aux[,j] <- udind.aux[,j]+1 udindnew <- rbind(udindnew,udind.aux) } udind0 <- udind1 udind1 <- udindnew } } hmnew<-hmnew*matrix(rep((-1)^rowSums(udind),narg),nrow=narg,byrow=TRUE) phi <- dmvnorm(difs.block, mean=rep(0,d), sigma=Sigma) phi <- matrix(rep(phi,nudind),ncol=nudind,byrow=FALSE) result <- result+drop(colSums(phi*hmnew)) } result <- result[dlabs] hm0 <- dmvnorm.deriv(x=rep(0,d),Sigma=Sigma,deriv.order=deriv.order) sumval <- 2*result+n*hm0 if (verbose) close(pb) } } if (verbose) close(pb) } if (inc==0) sumval <- sumval - n*dmvnorm.deriv(x=rep(0,d), mu=rep(0,d), Sigma=Sigma, deriv.order=r) sumval <- drop(sumval) if (kfe) { if (inc==1) sumval <- sumval/n^2 else sumval <- sumval/(n*(n-1)) } if (add.index) { ind.mat <- dmvnorm.deriv(x=rep(0,d), mu=rep(0,d), Sigma=diag(d), deriv.order=r, only.index=TRUE) if (deriv.vec) return(list(sum=sumval, deriv.ind=ind.mat)) else return(list(sum=sumval, deriv.ind=unique(ind.mat))) } else return(sum=sumval) } ## Single partial derivative of the multivariate normal with scalar variance matrix sigma^2 I_d ## Code by Jose Chacon 04/09/2007 dmvnorm.deriv.scalar <- function(x, mu, sigma, deriv.order, binned=FALSE) { r <- deriv.order d <- ncol(x) sderiv <- sum(r) arg <- x/sigma darg <- dmvnorm(arg, mean=mu)/(sigma^(sderiv+d)) for (j in 1:d) { hmold0 <- 1 hmold1 <- arg[,j] hmnew <- 1 if (r[j] ==1){hmnew<-hmold1} if (r[j] >= 2) ## Multiply by the corresponding Hermite polynomial, coordinate-wise, using Fact C.1.4 in W&J (1995) and Willink (2005, p.273) for (i in (2:r[j])) { hmnew <- arg[,j] * hmold1 - (i - 1) * hmold0 hmold0 <- hmold1 hmold1 <- hmnew } darg <- hmnew * darg } val <- darg*(-1)^sderiv return(val) } dmvnorm.deriv.scalar.sum <- function(x, sigma, deriv.order=0, inc=1, kfe=FALSE, binned=FALSE, bin.par, verbose=FALSE) { r <- deriv.order d <- ncol(x) n <- nrow(x) if (binned) { if (missing(bin.par)) bin.par <- binning(x, H=diag(d)*sigma^2) n <- sum(bin.par$counts) ind.mat <- dmvnorm.deriv(x=rep(0,d), Sigma=diag(d), deriv.order=sum(r), deriv.vec=TRUE, only.index=TRUE) fhatr <- kdde.binned(bin.par=bin.par, H=sigma^2*diag(d), deriv.order=sum(r), deriv.vec=TRUE, w=rep(1,n), deriv.index=which.mat(r=r, ind.mat)[1]) sumval <- sum(bin.par$counts * n * fhatr$est[[1]]) } else { if (verbose) pb <- txtProgressBar() n.seq <- block.indices(n, n, d=d, r=r, diff=TRUE) sumval <- 0 for (i in 1:(length(n.seq)-1)) { difs <- differences(x=x, y=x[n.seq[i]:(n.seq[i+1]-1),]) sumval <- sumval + sum(dmvnorm.deriv.scalar(x=difs, mu=rep(0,d), sigma=sigma, deriv.order=r)) if (verbose) setTxtProgressBar(pb, i/(length(n.seq)-1)) } } if (verbose) close(pb) if (inc==0) sumval <- sumval - n*dmvnorm.deriv.scalar(x=t(as.matrix(rep(0,d))), mu=rep(0,d), sigma=sigma, deriv.order=r) if (kfe) if (inc==1) sumval <- sumval/n^2 else sumval <- sumval/(n*(n-1)) return(sumval) } ########################################################################## ## Normal scale psi functionals ########################################################################## psins.1d <- function(r, sigma) { if (r %% 2 ==0) psins <- (-1)^(r/2)*factorial(r)/((2*sigma)^(r+1)*factorial(r/2)*pi^(1/2)) else psins <- 0 return(psins) } psins <- function(r, Sigma, deriv.vec=length(r)==1) { d <- ncol(Sigma) if (deriv.vec) { dens <- dmvnorm.deriv(x=rep(0,d), mu=rep(0,d), deriv.order=r, Sigma=2*Sigma, add.index=FALSE) return(drop(dens)) ##dens$deriv } else { dens <- dmvnorm.deriv(x=rep(0,d), mu=rep(0,d), deriv.order=sum(r), Sigma=2*Sigma, add.index=TRUE) if (!is.vector(dens$deriv.ind)) { i <- head(which.mat(r, dens$deriv.ind),n=1) dens <- dens$deriv[1,i] } else dens <- dens$deriv return(dens) } } ########################################################################## ### Vector moments of the normal distribution ########################################################################## mur <- function(r, A, mu, Sigma, type="unique") { type1 <- match.arg(type, c("direct", "recursive", "unique")) mur.val <- do.call(paste("mur", type1, sep="."), list(r=r, A=A, mu=mu, Sigma=Sigma)) return(mur.val) } ############################################################################# ### mur.direct computes the vector moment E[X^{\otimes r}] for a random ### vector with N(mu,Sigma) distribution, on the basis of Equation (8) in ### Section 6 of Chacon and Duong (2014) ############################################################################# mur.direct<-function(r,mu,Sigma){ d<-ncol(Sigma) result<-as.vector(Kpow(mu,r)) vS<-vec(Sigma) vSj<-1 if(r>=2){ for(j in 1:floor(r/2)){ vSj<-as.vector(vSj%x%vS) cj<-prod(r:(r-2*j+1))/(prod(1:j)*2^j) mur2j<-as.vector(Kpow(mu,r-2*j)) result<-result+cj*as.vector(mur2j%x%vSj) } } return(drop(Sdrv.recursive(d=d,r=r,v=result))) } ############################################################################# ### mur.recursive computes the vector moment E[X^{\otimes r}] for a random ### vector with N(mu,Sigma) distribution, on the basis of Equation (9) in ### Section 6 of Chacon and Duong (2014), using Equation (7) in Section 5 ### to obtain the Hermite polynomial ############################################################################# mur.recursive<-function(r,mu,Sigma){ d<-ncol(Sigma) G<- -Sigma vG<-vec(G) arg<-mu hmold0 <- 1 hmold1 <- arg hmnew <- hmold0 if(r==1){hmnew<-hmold1} if(r>=2){for(i in 2:r){ hmnew<-as.vector(arg%x%hmold1-(i-1)*(vG%x%hmold0)) hmold0<-hmold1 hmold1<-hmnew } } return(drop(Sdrv.recursive(d=d,r=r,v=hmnew))) } ############################################################################### ### mur.unique computes the vector moment E[X^{\otimes r}] for a random vector ### with N(mu,Sigma) distribution, on the basis of Equation (9) in Section 6 ### of Chacon and Duong (2014), using Algorithm 3 in Section 5, based on the ### unique partial derivatives, to obtain the Hermite polynomial ############################################################################### mur.unique<-function(r,mu,Sigma){ d<-ncol(Sigma) G<- -Sigma arg<-mu hmold0 <- 1 hmold1 <- arg hmnew <- hmold0 udind0<-matrix(rep(0,d),nrow=1,ncol=d) udind1<-diag(d) if(r==1){hmnew<-hmold1} if(r>=2){for(i in 2:r){ Ndi1<-length(hmold1) Ndi0<-length(hmold0) hmnew<-numeric() for(j in 1:d){ nrecj<-choose(d-j+i-1,i-1) hmnew.aux<-arg[j]*hmold1[Ndi1-(nrecj:1)+1] for(k in j:d){ udind0.aux<-matrix(udind1[Ndi1-(nrecj:1)+1,],ncol=d,byrow=FALSE) udind0.aux[,k]<-udind0.aux[,k]-1 valid.udind0<-as.logical(apply(udind0.aux>=0,1,min)) enlarged.hmold0<-rep(0,nrow(udind0.aux)) for(l in 1:nrow(udind0.aux)){ if(valid.udind0[l]){ pos<-which(rowSums((udind0-matrix(rep(udind0.aux[l,],nrow(udind0)), nrow=nrow(udind0),byrow=TRUE))^2)==0) enlarged.hmold0[l]<-hmold0[pos]} } hmnew.aux<-hmnew.aux-G[j,k]*udind1[Ndi1-(nrecj:1)+1,k]*enlarged.hmold0 } hmnew<-c(hmnew,hmnew.aux) } hmold0 <- hmold1 hmold1 <- hmnew ## Compute the unique i-th derivative multi-indexes nudind1<-nrow(udind1) udindnew<-numeric() for(j in 1:d){ Ndj1i<-choose(d+i-1-j,i-1) udind.aux<-matrix(udind1[nudind1-(Ndj1i:1)+1,],ncol=d,byrow=FALSE) udind.aux[,j]<-udind.aux[,j]+1 udindnew<-rbind(udindnew,udind.aux) } udind0<-udind1 udind1<-udindnew }} if(r==0){ result<-1 } if(r==1){ result<-(-1)*hmnew } if(r>=2){ per<-pinv.all(d=d,r=r) dind<-numeric() udind<-udind1 dind.base<-rep(0,d^r) udind.base<-rep(0,choose(d+r-1,r)) for(i in 1:d){ dind<-cbind(dind,rowSums(per==i)) ## Matrix of derivative indices dind.base<-dind.base+dind[,i]*(r+1)^(d-i) ## Transform each row to base r+1 udind.base<-udind.base+udind[,i]*(r+1)^(d-i) ## Transform each row to base r+1 } dlabs<-match(dind.base,udind.base) result<-hmnew[dlabs]*(-1)^rowSums(dind) } return(drop(result*(-1)^r)) } ########################################################################## ### Moments of quadratic forms in normal variables ########################################################################## nur <- function(r, A, mu, Sigma, type="cumulant") { type1 <- match.arg(type, c("direct", "recursive", "unique", "cumulant")) nur.val <- do.call(paste("nur", type1, sep="."), list(r=r, A=A, mu=mu, Sigma=Sigma)) return(nur.val) } nurs <- function(r, s, A, B, mu, Sigma, type="cumulant") { type1 <- match.arg(type, c("direct", "recursive", "unique", "cumulant")) nur.val <- do.call(paste("nurs", type1, sep="."), list(r=r, s=s, A=A, B=B, mu=mu, Sigma=Sigma)) return(nur.val) } ############################################################################# ### nur.direct computes the moment E[(X^T AX)^r] of the quadratic form ### X^T AX where X is a random vector with N(mu,Sigma) distribution, using ### Equation (10) in Section 6 of Chacon and Duong (2014), and the direct ### implementation mur.direct of the normal moments ############################################################################# nur.direct<-function(r,A,mu,Sigma){ vA<-vec(A) result<-drop(Kpow(t(vA),r)%*%mur.direct(2*r,mu,Sigma)) return(result) } ############################################################################# ### nur.recursive computes the moment E[(X^T AX)^r] of the quadratic form ### X^T AX where X is a random vector with N(mu,Sigma) distribution, using ### Equation (10) in Section 6 of Chacon and Duong (2014), and the recursive ### implementation mur.recursive of the normal moments ############################################################################# nur.recursive<-function(r,A,mu,Sigma){ vA<-vec(A) result<-drop(Kpow(t(vA),r)%*%mur.recursive(2*r,mu,Sigma)) return(result) } ############################################################################# ### nur.unique computes the moment E[(X^T AX)^r] of the quadratic form ### X^T AX where X is a random vector with N(mu,Sigma) distribution, using ### Equation (10) in Section 6 of Chacon and Duong (2014), and the function ### mur.unique to compute the normal moments from its unique coordinates ############################################################################# nur.unique<-function(r,A,mu,Sigma){ vA<-vec(A) result<-sum(Kpow(vA,r)*mur.unique(2*r,mu,Sigma)) return(result) } ############################################################################# ### nur.cumulant computes the moment E[(X^T AX)^r] of the quadratic form ### X^T AX where X is a random vector with N(mu,Sigma) distribution, using ### the recursive formula relating moments and cumulants ############################################################################# nur.cumulant<-function(r,A,mu,Sigma){ if(r==0){result<-1} if(r==1){result<-sum(diag(A%*%Sigma))+t(mu)%*%A%*%mu} if(r>=2){ ASigma<-A%*%Sigma AS<-ASigma Amu<-A%*%mu kappas<-sum(diag(ASigma)+mu*Amu) nus<-kappas for(k in 2:r){ knew<-k*t(mu)%*%ASigma%*%Amu ASigma<-ASigma%*%AS knew<-(knew+sum(diag(ASigma)))*factorial(k-1)*2^(k-1) nnew<-knew+sum(choose(k-1,1:(k-1))*nus*rev(kappas)) kappas<-c(kappas,knew) nus<-c(nus,nnew) } result<-nnew } return(drop(result)) } ############################################################################# ### nurs.direct computes the joint moment E[(X^T AX)^r (X^T BX)^s] of the ### quadratic forms X^T AX and X^T BX, where X is a random vector with ### N(mu,Sigma) distribution, using Equation (10) in Section 6 of Chacon and ### Duong (2014), and the direct implementation mur.direct of the ### normal moments ############################################################################# nurs.direct<-function(r,s,A,B,mu,Sigma){ vA<-vec(A) vB<-vec(B) result<-(Kpow(t(vA),r)%x%Kpow(t(vB),s))%*%mur.direct(2*r+2*s,mu,Sigma) return(drop(result)) } ############################################################################# ### nurs.recursive computes the joint moment E[(X^T AX)^r (X^T BX)^s] of the ### quadratic forms X^T AX and X^T BX, where X is a random vector with ### N(mu,Sigma) distribution, using Equation (10) in Section 6 of Chacon and ### Duong (2014), and the recursive implementation mur.recursive of the ### normal moments ############################################################################# nurs.recursive<-function(r,s,A,B,mu,Sigma){ vA<-vec(A) vB<-vec(B) result<-(Kpow(t(vA),r)%x%Kpow(t(vB),s))%*%mur.recursive(2*r+2*s,mu,Sigma) return(drop(result)) } ############################################################################# ### nurs.unique computes the joint moment E[(X^T AX)^r (X^T BX)^s] of the ### quadratic forms X^T AX and X^T BX, where X is a random vector with ### N(mu,Sigma) distribution, using Equation (10) in Section 6 of Chacon and ### Duong (2014), and the function mur.unique to compute the normal moments ### from its unique coordinates ############################################################################# nurs.unique<-function(r,s,A,B,mu,Sigma){ vA<-vec(A) vB<-vec(B) result<-drop((Kpow(t(vA),r)%x%Kpow(t(vB),s))%*%mur.unique(2*r+2*s,mu,Sigma)) return(drop(result)) } ############################################################################# ### nurs.cumulant computes the joint moment E[(X^T AX)^r (X^T BX)^s] of the ### quadratic forms X^T AX and X^T BX, where X is a random vector with ### N(mu,Sigma) distribution, using the recursive formula (11) in Section 6 ### of Chacon and Duong (2014), relating moments and cumulants. The cumulants ### are computed using the function kappars, which is based on Theorem 3 ############################################################################# kappars<-function(r,s,A,B,mu,Sigma){ d<-ncol(A) if(r+s>1 & r>0 & s>0){ind<-multicool::allPerm(multicool::initMC(c(rep(1,r),rep(2,s))))} if(r+s==1 | r==0 | s==0){ind<-matrix(c(rep(1,r),rep(2,s)),nrow=1)} if(r+s==0){return(0)} nper<-nrow(ind) result<-0 Dmat<-solve(Sigma)%*%mu%*%t(mu) ASigma<-A%*%Sigma BSigma<-B%*%Sigma Id<-diag(d) for(i in 1:nper){ product<-Id for(j in 1:(r+s)){ if(ind[i,j]==1){product<-product%*%ASigma} else if(ind[i,j]==2){product<-product%*%BSigma} } result<-result+sum(diag(product%*%(Id/(r+s)+Dmat))) } result<-result*factorial(r)*factorial(s)*2^(r+s-1) return(drop(result)) } nurs.cumulant<-function(r,s,A,B,mu,Sigma){ if(r==0 & s>0){nurs<-nur.cumulant(s,B,mu,Sigma)} if(r>0 & s==0){nurs<-nur.cumulant(r,A,mu,Sigma)} if(r==0 & s==0){nurs<-1} if((r>0)&(s>0)){ K<-matrix(0,nrow=r+1,ncol=s) for(i in 0:r){for(j in 1:s){ K[i+1,j]<-kappars(i,j,A,B,mu,Sigma) }} N<-matrix(0,nrow=r+1,ncol=s) for(i in 0:r){ N[i+1,1]<-nur.cumulant(r=i,A=A,mu=mu,Sigma=Sigma) } if(s>1){ for(j in 1:(s-1)){for(i in 0:r){ Choose<-outer(choose(i,0:i),choose(j-1,0:(j-1))) N[i+1,j+1]<-sum(Choose*N[1:(i+1),1:j]*K[(i:0)+1,j:1]) }} } Choose<-outer(choose(r,0:r),choose(s-1,0:(s-1))) nurs<-sum(Choose*N[1:(r+1),1:s]*K[(r:0)+1,s:1]) } return(nurs) } ########################################################################## ### V-statistics with multivariate Gaussian derivatives kernel ########################################################################## Qr <- function(x, y, Sigma, deriv.order=0, inc=1, type="cumulant", verbose=FALSE) { if (missing(y)) y <- x type1 <- match.arg(type, c("direct", "cumulant")) if (type1=="direct") Qr.val <- Qr.direct(x=x, y=y, Sigma=Sigma, r=deriv.order, inc=inc, verbose=verbose) else Qr.val <- Qr.cumulant(x=x, y=y, Sigma=Sigma, r=deriv.order, inc=inc, verbose=verbose) return(Qr.val) } ############################################################################ ### Qr.direct computes the V-statistic using the direct approach, as ### described in Section 6 of Chacon and Duong (2014) ############################################################################ Qr.direct <- function(x, y, Sigma, r=0, inc=1, binned=FALSE, bin.par, bgridsize, verbose=FALSE) { if (is.vector(x)) x <- matrix(x, nrow=1) d <- ncol(x) eta <- drop(Kpow(vec(diag(d)), r/2) %*% kfe(x=x, G=Sigma, deriv.order=r, inc=inc, verbose=verbose, binned=binned, bin.par=bin.par, add.index=FALSE)) ##if (inc==0) eta <- eta/(nrow(x)*(nrow(x)-1)) ##if (inc==1) eta <- eta/(nrow(x)*nrow(x)) return(eta) } ############################################################################ ### Qr.cumulant computes the V-statistic using the relationship with nur ### shown in Theorem 4 of Chacon and Duong (2014) ############################################################################ Qr.cumulant <- function(x, y, Sigma, r=0, inc=1, verbose=FALSE) { if (is.vector(x)) x <- matrix(x, nrow=1) d <- ncol(x) r <- r/2 if (missing(y)) y <- x if (is.vector(y)) y <- matrix(y, nrow=1) nx <- as.numeric(nrow(x)) ny <- as.numeric(nrow(y)) G <- Sigma Ginv <- chol2inv(chol(G)) G2inv <- Ginv%*%Ginv G3inv <- G2inv%*%Ginv trGinv <- sum(diag(Ginv)) trG2inv <- sum(diag(G2inv)) detG <- det(G) ## indices for separating into blocks for double sum calculation n.seq <- block.indices(nx, ny, d=d, r=r, diff=FALSE) if (verbose) pb <- txtProgressBar() if (r==0) { xG <- x%*%Ginv a <- rowSums(xG*x) eta <- 0 for (i in 1:(length(n.seq)-1)) { nytemp <- n.seq[i+1] - n.seq[i] ytemp <- matrix(y[n.seq[i]:(n.seq[i+1]-1),], ncol=d) aytemp <- rowSums((ytemp %*% Ginv) *ytemp) M <- a%*%t(rep(1,nytemp)) + rep(1, nx)%*%t(aytemp) - 2*(xG%*%t(ytemp)) em2 <- exp(-M/2) eta <- eta + (2*pi)^(-d/2)*detG^(-1/2)*sum(em2) if (verbose) setTxtProgressBar(pb, i/(length(n.seq)-1)) } } else if (r==1) { xG <- x%*%Ginv xG2 <- x%*%G2inv a <- rowSums(xG*x) a2 <- rowSums(xG2*x) eta <- 0 for (i in 1:(length(n.seq)-1)) { nytemp <- n.seq[i+1] - n.seq[i] ytemp <- matrix(y[n.seq[i]:(n.seq[i+1]-1),], nrow=nytemp) aytemp <- rowSums((ytemp %*% Ginv) *ytemp) aytemp2 <- rowSums((ytemp %*% G2inv) *ytemp) M <- a%*%t(rep(1,nytemp))+rep(1,nx)%*%t(aytemp)-2*(xG%*%t(ytemp)) M2 <- a2%*%t(rep(1,nytemp))+rep(1,nx)%*%t(aytemp2)-2*(xG2%*%t(ytemp)) eta <- eta + (2*pi)^(-d/2)*detG^(-1/2)*sum(exp(-M/2)*(M2-trGinv)) if (verbose) setTxtProgressBar(pb, i/(length(n.seq)-1)) } } else if (r==2) { xG <- x%*%Ginv xG2 <- x%*%G2inv xG3 <- x%*%G3inv a <- rowSums(xG*x) a2 <- rowSums(xG2*x) a3 <- rowSums(xG3*x) eta <- 0 for (i in 1:(length(n.seq)-1)) { nytemp <- n.seq[i+1] - n.seq[i] ytemp <- matrix(y[n.seq[i]:(n.seq[i+1]-1),], ncol=d) aytemp <- rowSums((ytemp %*% Ginv) *ytemp) aytemp2 <- rowSums((ytemp %*% G2inv) *ytemp) aytemp3 <- rowSums((ytemp %*% G3inv) *ytemp) M <- a%*%t(rep(1,nytemp))+rep(1,nx)%*%t(aytemp)-2*(xG%*%t(ytemp)) M2 <- a2%*%t(rep(1,nytemp))+rep(1,nx)%*%t(aytemp2)-2*(xG2%*%t(ytemp)) M3 <- a3%*%t(rep(1,nytemp))+rep(1,nx)%*%t(aytemp3)-2*(xG3%*%t(ytemp)) eta <- eta + (2*pi)^(-d/2)*detG^(-1/2)*sum(exp(-M/2)*(2*trG2inv-4*M3 +(-trGinv+M2)^2)) if (verbose) setTxtProgressBar(pb, i/(length(n.seq)-1)) } } else if (r>2) { xG <- x%*%Ginv a <- rowSums(xG*x) eta <- 0 for (i in 1:(length(n.seq)-1)) { nytemp <- n.seq[i+1] - n.seq[i] ytemp <- matrix(y[n.seq[i]:(n.seq[i+1]-1),], ncol=d) aytemp <- rowSums((ytemp %*% Ginv) *ytemp) M <- a %*% t(rep(1,nytemp)) + rep(1,nx)%*%t(aytemp) - 2*(xG%*%t(ytemp)) edv2 <- exp(-M/2) P0<-Ginv kappas <- matrix(nrow=as.numeric(nx*nytemp), ncol=r) for (j in 1:r) { Gi1inv <- P0%*%Ginv trGi0inv <- sum(diag(P0)) xGi1inv <- x%*%Gi1inv xGi1invx <- rowSums(xGi1inv*x) aytemp <- rowSums((ytemp %*% Gi1inv) *ytemp) dvi1 <- xGi1invx%*%t(rep(1,nytemp))+rep(1,nx)%*%t(aytemp)-2*(xGi1inv%*%t(ytemp)) kappas[,j] <- (-2)^(j-1)*factorial(j-1)*(-trGi0inv+j*dvi1) P0 <- Gi1inv } nus <- matrix(nrow=as.numeric(nx*nytemp), ncol=r+1) nus[,1] <- 1 for (j in 1:r) { js<-0:(j-1) if (j==1) nus[,2] <- kappas[,1] else nus[,j+1] <- rowSums(kappas[,j:1]*nus[,1:j]/matrix(rep(factorial(js)* factorial(rev(js)),nx*nytemp),nrow=nx*nytemp,byrow=TRUE))*factorial(j-1) } eta <- eta + (2*pi)^(-d/2)*detG^(-1/2)*sum(edv2*nus[,r+1]) if (verbose) setTxtProgressBar(pb, i/(length(n.seq)-1)) } } if (verbose) close(pb) if (inc==0) eta <- (eta - (-1)^r*nx*nur.cumulant(r=r, A=Ginv, mu=rep(0,d), Sigma=diag(d))*(2*pi)^(-d/2)*detG^(-1/2))/(nx*(ny-1)) if (inc==1) eta <- eta/(nx*ny) return(eta) } Qr.1d <- function(x, y, sigma, deriv.order=0, inc=1, verbose=FALSE) { d <- 1 r <- deriv.order/2 if (missing(y)) y <- x nx <- length(x) ny <- length(y) g <- sigma n.seq <- block.indices(nx, ny, d=1, r=0, diff=FALSE) eta <- 0 if (verbose) pb <- txtProgressBar() if (r==0) { a <- x^2 for (i in 1:(length(n.seq)-1)) { if (verbose) setTxtProgressBar(pb, i/(length(n.seq)-1)) nytemp <- n.seq[i+1] - n.seq[i] ytemp <- y[n.seq[i]:(n.seq[i+1]-1)] aytemp <- ytemp^2 M <- a %*%t(rep(1,nytemp)) + rep(1, nx)%*%t(aytemp) - 2*(x %*% t(ytemp)) em2 <- exp(-M/(2*g^2)) eta <- eta + (2*pi)^(-d/2)*g^(-1)*sum(em2) } } else if (r>0) { a <- x^2 for (i in 1:(length(n.seq)-1)) { if (verbose) setTxtProgressBar(pb, i/(length(n.seq)-1)) nytemp <- n.seq[i+1] - n.seq[i] ytemp <- y[n.seq[i]:(n.seq[i+1]-1)] aytemp <- ytemp^2 M <- a %*% t(rep(1,nytemp)) + rep(1,nx)%*%t(aytemp) - 2*(x %*%t(ytemp)) edv2 <- exp(-M/(2*g^2)) kappas <- matrix(nrow=as.numeric(nx*nytemp), ncol=r) for (i in 1:r) { aytemp <- ytemp^2 dvi1 <- (a %*% t(rep(1,nytemp)) + rep(1,nx) %*% t(aytemp) - 2*(x%*%t(ytemp)))/g^(2*(i+1)) kappas[,i] <- (-2)^(i-1)*factorial(i-1)*(-g^(-2*i)+i*dvi1) } nus <- matrix(nrow=as.numeric(nx*nytemp), ncol=r+1) nus[,1] <- 1 for (j in 1:r) { js<-0:(j-1) if (j==1) nus[,2] <- kappas[,1] else nus[,j+1] <- rowSums(kappas[,j:1]*nus[,1:j]/matrix(rep(factorial(js)*factorial(rev(js)),nx*nytemp),nrow=nx*nytemp,byrow=TRUE))*factorial(j-1) } eta <- eta + (2*pi)^(-d/2)*g^(-1)*sum(edv2*nus[,r+1]) } } if (verbose) close(pb) if (inc==0) eta <- (eta - nx*dnorm.deriv(x=0, mu=0, sigma=g, deriv.order=deriv.order))/(nx*(ny-1)) if (inc==1) eta <- eta/(nx*ny) return(eta) } ############################################################################### ## Creates plots of mixture density functions # ## Parameters ## mus - means ## Sigmas - variances ## props - vector of proportions of each mixture component ## dfs - degrees of freedom ## dist - "normal" - normal mixture ## - "t" - t mixture ## ... ############################################################################### plotmixt <- function(mus, sigmas, Sigmas, props, dfs, dist="normal", draw=TRUE, deriv.order=0, which.deriv.ind=1, binned=TRUE, ...) { ## locally set random seed not to interfere with global random number generators if (!exists(".Random.seed")) rnorm(1) old.seed <- .Random.seed on.exit( { .Random.seed <<- old.seed } ) set.seed(8192) if (!missing(sigmas)) plotmixt.1d(mus=mus, sigmas=sigmas, props=props, dfs=dfs, dist=dist, draw=draw, deriv.order=deriv.order, which.deriv.ind=which.deriv.ind, ...) else if (ncol(Sigmas)==2) plotmixt.2d(mus=mus, Sigmas=Sigmas, props=props, dfs=dfs, dist=dist, draw=draw, deriv.order=deriv.order, which.deriv.ind=which.deriv.ind,binned=binned, ...) else if (ncol(Sigmas)==3) plotmixt.3d(mus=mus, Sigmas=Sigmas, props=props, dfs=dfs, dist=dist, draw=draw, deriv.order=deriv.order, which.deriv.ind=which.deriv.ind, binned=binned, ...) } plotmixt.1d <- function(mus, sigmas, props, dfs, dist="normal", xlim, ylim, gridsize, draw=TRUE, deriv.order, which.deriv.ind, ...) { dist1 <- match.arg(dist, c("normal", "t")) maxsigmas <- 4*max(sigmas) if (missing(xlim)) xlim <- c(min(mus) - maxsigmas, max(mus) + maxsigmas) if (missing(gridsize)) gridsize <- default.gridsize(1) x <- seq(xlim[1]-0.1*abs(diff(xlim)), xlim[2]+0.1*abs(diff(xlim)), length=gridsize) if (dist1=="normal") { if (deriv.order<=0) dens <- dnorm.mixt(x=x, mus=mus, sigmas=sigmas, props=props) else dens <- dnorm.deriv.mixt(x=x, mus=mus, sigmas=sigmas, props=props, deriv.order=deriv.order) } else if (dist1=="t") stop("1-d t mixture not yet implemented") fhat <- list() fhat$x <- x fhat$eval.points <- x fhat$estimate <- dens fhat$H <- diag(1) fhat$h <- 1 fhat$gridtype <- "linear" fhat$gridded <- TRUE fhat$binned <- FALSE fhat$names <- parse.name(x) fhat$w <- rep(1, length(x)) if (deriv.order>0) { fhat$deriv.order <- deriv.order fhat$deriv.ind <- which.deriv.ind } class(fhat) <- "kdde" if (draw) plot(fhat, xlim=xlim, ...) invisible(fhat) } plotmixt.2d <- function(mus, Sigmas, props, dfs, dist="normal", xlim, ylim, gridsize, nrand=1e4, draw=TRUE, binned, deriv.order, which.deriv.ind, display="slice", ...) { dist1 <- match.arg(dist, c("normal", "t")) disp1 <- match.arg(display, c("slice", "image", "persp", "filled.contour", "filled.contour2")) maxSigmas <- 4*max(Sigmas) if (is.vector(mus)) mus <- as.matrix(t(mus)) if (missing(xlim)) xlim <- c(min(mus[,1]) - maxSigmas, max(mus[,1]) + maxSigmas) if (missing(ylim)) ylim <- c(min(mus[,2]) - maxSigmas, max(mus[,2]) + maxSigmas) if (missing(gridsize)) gridsize <- default.gridsize(2) x <- seq(xlim[1], xlim[2], length=gridsize[1]) y <- seq(ylim[1], ylim[2], length=gridsize[2]) xy <- expand.grid(x, y) d <- ncol(Sigmas) if (dist1=="normal") { if (deriv.order<=0) dens <- dmvnorm.mixt(xy, mus=mus, Sigmas=Sigmas, props=props) else dens <- dmvnorm.deriv.mixt(xy, mus=mus, Sigmas=Sigmas, props=props, deriv.order=deriv.order) } else if (dist1=="t") { if (deriv.order>0) stop("deriv.order>0 for t mixture not yet implemented") dens <- dmvt.mixt(xy, mus=mus, Sigmas=Sigmas, props=props, dfs=dfs) } if (deriv.order<=0) dens.mat <- matrix(dens, ncol=length(x), byrow=FALSE) else { dens.mat <- list() for (i in 1:ncol(dens)) dens.mat[[i]] <- matrix(dens[,i], ncol=length(x), byrow=FALSE) } if (dist1=="normal") x.rand <- rmvnorm.mixt(n=nrand, mus=mus, Sigmas=Sigmas, props=props) else if (dist1=="t") x.rand <- rmvt.mixt(n=nrand, mus=mus, Sigmas=Sigmas, props=props, dfs=dfs) H <- Hns(x=x.rand, deriv.order=deriv.order) if (binned) H <- diag(diag(H)) fhat.rand <- kdde(x=x.rand, H=H, deriv.order=deriv.order, binned=binned) fhat <- fhat.rand fhat$x <- x.rand fhat$eval.points <- list(x,y) fhat$estimate <- dens.mat fhat$names <- c("x", "y") if (deriv.order>0) { deriv.ind <- dmvnorm.deriv.mixt(xy, mus=mus, Sigmas=Sigmas, props=props, add.index=TRUE, only.index=TRUE, deriv.order=deriv.order, deriv.vec=TRUE) fhat$deriv.order <- deriv.order fhat$deriv.ind <- deriv.ind class(fhat) <- "kdde" if (draw) { plot(fhat, which.deriv.ind=which.deriv.ind, xlim=xlim, ylim=ylim, ...) } } else { if (draw) { if (disp1=="persp") plot(fhat, display=display, ...) else plot(fhat, xlim=xlim, ylim=ylim, display=display, ...) } } invisible(fhat) } plotmixt.3d <- function(mus, Sigmas, props, dfs, dist="normal", xlim, ylim, zlim, gridsize, nrand=1e4, draw=TRUE, binned, deriv.order, which.deriv.ind, ...) { d <- 3 dist1 <- match.arg(dist, c("normal", "t")) maxsd <- sqrt(apply(Sigmas, 2, max)) if (is.vector(mus)) mus <- as.matrix(t(mus)) if (missing(xlim)) xlim <- c(min(mus[,1]) - 4*maxsd[1], max(mus[,1]) + 4*maxsd[1]) if (missing(ylim)) ylim <- c(min(mus[,2]) - 4*maxsd[2], max(mus[,2]) + 4*maxsd[2]) if (missing(zlim)) zlim <- c(min(mus[,3]) - 4*maxsd[3], max(mus[,3]) + 4*maxsd[3]) if (missing(gridsize)) gridsize <- default.gridsize(3) x <- seq(xlim[1], xlim[2], length=gridsize[1]) y <- seq(ylim[1], ylim[2], length=gridsize[2]) z <- seq(zlim[1], zlim[2], length=gridsize[3]) xy <- expand.grid(x,y) if (deriv.order>0) { if (dist1=="t") stop("deriv.order>0 for t mixture not yet implemented") else if (dist1=="normal") deriv.ind <- dmvnorm.deriv.mixt(cbind(xy,z[1]), mus=mus, Sigmas=Sigmas, props=props, deriv.order=deriv.order, add.index=TRUE, only.index=TRUE) } if (deriv.order<=0) dens.array <- array(0, dim=gridsize) else { dens.array <- list(); for (i in 1:nrow(deriv.ind)) dens.array <- c(dens.array, list(array(0, dim=gridsize))) } for (i in 1:length(z)) { if (dist1=="normal") { if (deriv.order<=0) dens <- dmvnorm.mixt(cbind(xy, z[i]), mus=mus, Sigmas=Sigmas, props=props) else dens <- dmvnorm.deriv.mixt(cbind(xy, z[i]), mus=mus, Sigmas=Sigmas, props=props, deriv.order=deriv.order) } else if (dist1=="t") dens <- dmvt.mixt(cbind(xy, z[i]), mus=mus, Sigmas=Sigmas, dfs=dfs, props=props) if (deriv.order<=0) { dens.mat <- matrix(dens, ncol=length(x), byrow=FALSE) dens.array[,,i] <- dens.mat } else { for (j in 1:ncol(dens)) { dens.mat <- matrix(dens[,j], ncol=length(x), byrow=FALSE) dens.array[[j]][,,i] <- dens.mat } } } if (dist1=="normal") x.rand <- rmvnorm.mixt(n=nrand, mus=mus, Sigmas=Sigmas, props=props) else if (dist1=="t") x.rand <- rmvt.mixt(n=nrand, mus=mus, Sigmas=Sigmas, props=props, dfs=dfs) H <- Hns(x=x.rand, deriv.order=deriv.order) if (binned) H <- diag(diag(H)) fhat.rand <- kdde(x=x.rand, H=H, deriv.order=deriv.order, binned=binned) fhat <- fhat.rand fhat$x <- head(x.rand, n=100) fhat$eval.points <- list(x,y,z) fhat$estimate <- dens.array fhat$names <- c("x", "y", "z") fhat$H <- H fhat$w <- rep(1,nrow(fhat$x)) if (deriv.order>0) { deriv.ind <- dmvnorm.deriv.mixt(xy, mus=mus, Sigmas=Sigmas, props=props, add.index=TRUE, only.index=TRUE, deriv.order=deriv.order, deriv.vec=TRUE) fhat$deriv.order <- deriv.order fhat$deriv.ind <- deriv.ind class(fhat) <- "kdde" if (draw) plot(fhat, which.deriv.ind=which.deriv.ind, xlim=xlim, ylim=ylim, zlim=zlim, ...) } else { if (draw) plot(fhat, xlim=xlim, ylim=ylim, zlim=zlim, ...) } invisible(fhat) } ############################################################################### ## Multivariate t mixture - density values ## ## Parameters ## x - points to compute density at ## mus - vector of means ## Sigmas - dispersion matrices ## dfs - degrees of freedom ## props - vector of mixing proportions ## ## Returns ## Value of multivariate t mixture density at x ############################################################################### dmvt.mixt <- function(x, mus, Sigmas, dfs, props) { if (!(identical(all.equal(sum(props), 1), TRUE))) stop("Proportions don't sum to one") else if (length(dfs) != length(props)) stop("Length of df and mixing proportions vectors not equal") ## single component mixture if (identical(all.equal(props[1], 1), TRUE)) dens <- dmvt(x, delta=mus, sigma=Sigmas, df=dfs, log=FALSE) ## multiple component mixture else { if (is.vector(mus)) d <- length(mus) else d <- ncol(mus) k <- length(props) dens <- 0 for (i in 1:k) dens <- dens+props[i]*dmvt(x,delta=mus[i,],sigma=Sigmas[((i-1)*d+1):(i*d),], df=dfs[i], log=FALSE) } return(dens) } ############################################################################### ## Multivariate t mixture - random sample ## ## Parameters ## n - number of samples ## mus - means ## Sigmas - matrix of dispersion matrices ## dfs - vector of degrees of freedom ## props - vector of mixing proportions ## ## Returns ## Vector of n observations from the t mixture ############################################################################### rmvt.mixt <- function(n=100, mus=c(0,0), Sigmas=diag(2), dfs=7, props=1) { if (!(identical(all.equal(sum(props), 1), TRUE))) stop("Proportions don't sum to one") else if (length(dfs) != length(props)) stop("Length of df and mixing proportions vectors not equal") ## single component mixture if (identical(all.equal(props[1], 1), TRUE)) { rand <- rmvt(n=n, sigma=Sigmas, df=dfs) for (i in 1:length(mus)) rand[,i] <- rand[,i] + mus[i] } ## multiple component mixture else { k <- length(props) d <- ncol(Sigmas) n.samp <- sample(1:k, n, replace=TRUE, prob=props) n.prop <- numeric(0) ## compute number to be drawn from each component for (i in 1:k) n.prop <- c(n.prop, sum(n.samp == i)) ## generate random samples from each component rand <- numeric(0) for (i in 1:k) { if (n.prop[i] > 0) { rand.temp<-rmvt(n=n.prop[i],sigma=Sigmas[((i-1)*d+1):(i*d),],df=dfs[i]) for (j in 1:length(mus[k,])) rand.temp[,j] <- rand.temp[,j] + mus[i,j] rand <- rbind(rand, rand.temp) } } } return(rand[sample(n),]) } ############################################################################### ## Moments of multivariate normal mixture ############################################################################### mvnorm.mixt.moment <- function (mus, Sigmas, props) { if (!(identical(all.equal(sum(props), 1), TRUE))) stop("Proportions don't sum to one") d <- ncol(Sigmas) k <- length(props) mn <- rep(0, d) va <- matrix(0, nrow=d, ncol=d) for (i in 1:k) { mn <- mn + props[i] * mus[i,] va <- va + props[i] * (Sigmas[((i-1)*d+1):(i*d),] + mus[i,] %*% t(mus[i,])) } va <- va + mn %*% t(mn) return( list(mean=mn, var=va)) } ###################################################################### ## Modes for normal mixture ###################################################################### mvnorm.mixt.mode <- function(mus, Sigmas, props=1, verbose=FALSE) { if (!(identical(all.equal(sum(props), 1), TRUE))) stop("Proportions don't sum to one") if (identical(all.equal(props[1], 1), TRUE)) mm <- mus else { k <- length(props) d <- ncol(Sigmas) mm <- matrix(0, nrow=k, ncol=d) dmvnorm.mixt.temp <- function(x) { return(-1*dmvnorm.mixt(x=x, mus=mus, Sigmas=Sigmas, props=props)) } for (i in 1:k) { result <- nlm(p=mus[i,], f=dmvnorm.mixt.temp, print.level=2*as.numeric(verbose)) mm[i,] <- result$estimate } } return(mm) } ###################################################################### ## Parition for 2-d normal mixture ###################################################################### mvnorm.mixt.part <- function(mus, Sigmas, props=1, xmin, xmax, gridsize, max.iter=100, verbose=FALSE) { maxSigmas <- 4*max(Sigmas) if (is.vector(mus)) mus <- as.matrix(t(mus)) if (missing(xmin)) xmin <- c(min(mus[,1]) - maxSigmas, min(mus[,2]) - maxSigmas) if (missing(xmax)) xmax <- c(max(mus[,1]) + maxSigmas, max(mus[,2]) + maxSigmas) if (missing(gridsize)) gridsize <- c(201,201) x <- seq(xmin[1], xmax[1], length=gridsize[1]) y <- seq(xmin[2], xmax[2], length=gridsize[2]) xy <- expand.grid(x, y) xy.orig <- xy d <- ncol(Sigmas) k <- length(props) a <- min(c(xmax[1]-xmin[1], xmax[2]-xmin[2]))/1e3 ## max.iter mean shift iterations for (i in 1:max.iter) { dens <- dmvnorm.mixt(xy, mus=mus, Sigmas=Sigmas, props=props) grad <- dmvnorm.deriv.mixt(xy, mus=mus, Sigmas=Sigmas, props=props,deriv.order=1) xy[,1] <- xy[,1] + a*grad[,1]/dens xy[,2] <- xy[,2] + a*grad[,2]/dens } xy.dist <- matrix(0, ncol=k, nrow=nrow(xy)) for (i in 1:k) xy.dist[,i] <- apply(sweep(xy, 2, mus[i,])^2, 1, sum) xy.lab <- array(apply(xy.dist, 1, which.min), dim=gridsize) x.rand <- rmvnorm.mixt(n=1e3, mus=mus, Sigmas=Sigmas, props=props) fhat <- kde(x=x.rand, binned=TRUE) fhat$eval.points <- list(x, y) fhat$estimate <- xy.lab fhat$names <- c("x", "y") class(fhat) <- "kde.part" return(fhat) } ks/R/ksupp.R0000644000176200001440000000611213216552337012364 0ustar liggesusers###################################################################### ## Kernel support estimate - contour-based or convex hull ###################################################################### ksupp <- function(fhat, cont=95, abs.cont, convex.hull=FALSE) { if (missing(abs.cont)) abs.cont <- contourLevels(fhat, cont=cont) supp <- expand.grid(fhat$eval.points)[as.vector(fhat$estimate > abs.cont),] if (convex.hull) supp <- supp[chull(supp),] return(supp) } ## Devroye-Wise support estimate dwsupp <- function(x, H, h, gridsize, gridtype, xmin, xmax, supp=3.7, binned, bgridsize, verbose=FALSE, w) { if (is.vector(x)) { if (missing(H)) {d <- 1; n <- length(x)} else { if (is.vector(H)) { d <- 1; n <- length(x)} else {x <- matrix(x, nrow=1); d <- ncol(x); n <- nrow(x)} } } else {d <- ncol(x); n <- nrow(x)} if (!missing(w)) if (!(identical(all.equal(sum(w), n), TRUE))) { warning("Weights don't sum to sample size - they have been scaled accordingly\n") w <- w*n/sum(w) } if (missing(binned)) binned <- default.bflag(d=d, n=n) if (missing(w)) w <- rep(1,n) if (d==1) { ##if (missing(adj.positive)) adj.positive <- abs(min(x)) ##if (positive) y <- log(x + adj.positive) ## transform positive data x to real line ##else y <- x if (missing(h)) h <- hpi(x=y, binned=default.bflag(d=d, n=n), bgridsize=bgridsize) } if (missing(H) & d>1) { H <- Hpi(x=x, binned=default.bflag(d=d, n=n), bgridsize=bgridsize, verbose=verbose) } if (missing(bgridsize)) bgridsize <- default.gridsize(d) if (missing(gridsize)) gridsize <- default.gridsize(d) ## initialise grid n <- nrow(x) gridx <- make.grid.ks(x, matrix.sqrt(H), tol=supp, gridsize=gridsize, xmin=xmin, xmax=xmax, gridtype=gridtype) suppx <- make.supp(x, matrix.sqrt(H), tol=supp) grid.pts <- find.gridpts(gridx, suppx) fhat.grid <- matrix(0, nrow=length(gridx[[1]]), ncol=length(gridx[[2]])) if (verbose) pb <- txtProgressBar() for (i in 1:n) { ## compute evaluation points eval.x <- gridx[[1]][grid.pts$xmin[i,1]:grid.pts$xmax[i,1]] eval.y <- gridx[[2]][grid.pts$xmin[i,2]:grid.pts$xmax[i,2]] eval.x.ind <- c(grid.pts$xmin[i,1]:grid.pts$xmax[i,1]) eval.y.ind <- c(grid.pts$xmin[i,2]:grid.pts$xmax[i,2]) eval.x.len <- length(eval.x) eval.pts <- expand.grid(eval.x, eval.y) fhat <- rep(1, nrow(eval.pts)) ##dmvnorm(eval.pts, x[i,], H) ## place vector of density estimate values `fhat' onto grid 'fhat.grid' for (j in 1:length(eval.y)) fhat.grid[eval.x.ind, eval.y.ind[j]] <- fhat.grid[eval.x.ind, eval.y.ind[j]] + w[i]*fhat[((j-1) * eval.x.len + 1):(j * eval.x.len)] if (verbose) setTxtProgressBar(pb, i/n) } if (verbose) close(pb) ##fhat.grid <- fhat.grid/n gridx1 <- list(gridx[[1]], gridx[[2]]) fhat <- list(x=x, eval.points=gridx1, estimate=fhat.grid>=1, H=H, gridtype=gridx$gridtype, gridded=TRUE) fhat$binned <- binned fhat$names <- parse.name(x) ## add variable names fhat$w <- w class(fhat) <- "kde" return(fhat) } ks/R/selector.R0000644000176200001440000016022713620365657013060 0ustar liggesusers############################################################################### ## Estimate g_AMSE pilot bandwidths for even orders - 2-dim ## ## Parameters ## r - (r1, r2) partial derivative ## n - sample size ## psi1 - psi_(r + (2,0)) ## psi2 - psi_(r + (0,2)) ## ## Returns ## g_AMSE pilot bandwidths for even orders ############################################################################### gamse.even.2d <- function(r, n, psi1, psi2) { d <- 2 num <- -2 * dmvnorm.deriv(x=c(0,0), deriv.order=r, Sigma=diag(2), deriv.vec=FALSE) den <- (psi1 + psi2) * n g.amse <- (num/den)^(1/(2 + d + sum(r))) return(g.amse) } ############################################################################### ## Estimate g_AMSE pilot bandwidths for odd orders - 2-dim ## ## Parameters ## ## r - (r1, r2) partial derivative ## n - sample size ## psi1 - psi_(r + (2,0)) ## psi2 - psi_(r + (0,2)) ## psi00 - psi_(0,0) ## RK - R(K^(r)) ## ## Returns ## g_AMSE pilot bandwidths for odd orders ############################################################################### gamse.odd.2d <- function(r, n, psi1, psi2, psi00, RK) { d <- 2 num <- 2 * psi00 * (2 * sum(r) + d) * RK den <- (psi1 + psi2)^2 * n^2 g.amse <- (num/den)^(1/(2*sum(r) + d + 4)) return(g.amse) } ############################################################################### ## Estimate g_SAMSE pilot bandwidth - 2- to 6-dim ## ## Parameters ## Sigma.star - scaled variance matrix ## n - sample size ## ## Returns ## g_SAMSE pilot bandwidth ############################################################################### gsamse <- function(Sigma.star, n, modr, nstage=1, psihat=NULL) { d <- ncol(Sigma.star) K <- numeric(); psi <- numeric() ## 4th order g_SAMSE K <- dmvnorm.deriv(x=rep(0,d), deriv.order=modr, Sigma=diag(d), add.index=TRUE, deriv.vec=FALSE) K <- K$deriv[apply(K$deriv.ind, 1, is.even)] if (modr==4) { derivt4 <- dmvnorm.deriv(x=rep(0,d), deriv.order=4, add.index=TRUE, deriv.vec=FALSE, only.index=TRUE) derivt6 <- dmvnorm.deriv(x=rep(0,d), deriv.order=6, add.index=TRUE, deriv.vec=FALSE, only.index=TRUE) for (i in 1:nrow(derivt4)) { r <- derivt4[i,] if (is.even(r)) { A3psi <- 0 for (j in 1:d) { if (nstage==1) { A3psi <- A3psi + psins(r=r+2*elem(j,d), Sigma=Sigma.star) ##A3psi <- A3psi + psins6[which.mat(r=r+2*elem(j,d), mat=derivt6)] } else if (nstage==2) A3psi <- A3psi + psihat[which.mat(r=r+2*elem(j,d), mat=derivt6)] } psi <- c(psi, A3psi) } } } ## 6th order g_SAMSE else if (modr==6) { derivt6 <- dmvnorm.deriv(x=rep(0,d), deriv.order=6, add.index=TRUE, deriv.vec=FALSE, only.index=TRUE) for (i in 1:nrow(derivt6)) { r <- derivt6[i,] if (is.even(r)) { A3psi <- 0 for (j in 1:d) A3psi <- A3psi + psins(r=r+2*elem(j,d), Sigma=Sigma.star) psi <- c(psi, A3psi) } } } ## see thesis for formula A1 <- sum(K^2) A2 <- sum(K * psi) A3 <- sum(psi^2) B1 <- (2*modr + 2*d)*A1 B2 <- (modr + d - 2)*A2 B3 <- A3 gamma1 <- (-B2 + sqrt(B2^2 + 4*B1*B3)) / (2*B1) g.samse <- (gamma1 * n)^(-1/(modr + d + 2)) return (g.samse) } ############################################################################## ## Scalar pilot selector for derivatives r>0 from Chacon & Duong (2011) ## Generalisation of gsamse for r>0 ############################################################################## gdscalar <- function(x, d, r, n, verbose, binned=FALSE, nstage=1, scv=FALSE) { if (scv) cf <- c(2^(-d), 2^(-d/2+1), 4) else cf <- c(1,1,1) S <- var(x) Sinv <- chol2inv(chol(S)) if (nstage==1) { psi2r6.ns <- psins(r=2*r+6, Sigma=S) ##B3 <- sum(psi2r6.ns^2) ## approx to reduce memory usage B3 <- norm(Matrix(psi2r6.ns, nrow=1) %*% (Matrix(vec(diag(d)), ncol=1) %*% Matrix(vec(diag(d)), nrow=1) %x% Diagonal(d^(2*r+4))) %*% Matrix(psi2r6.ns, ncol=1), type="1") ##B3 <- B3@x if (!scv) { B1 <- 2*(2*pi)^(-d)*OF(2*r+4)*prod(d+2*(0:(r+2))) B2 <- -(d+2*r+2)*2^(-d/2-r)*(2*pi)^(-d)*det(S)^(-1/2)*OF(2*r+4)*nu(r=r+2, A=Sinv) } else { B1 <- 2^(-2*r-3)*(4*pi)^(-d)*OF(2*r+6)*prod(d+2*(0:(r+2))) B2 <- -(d+2*r+2)*2^(-2*r-4)*(4*pi)^(-d)*det(S)^(-1/2)*OF(2*r+4)*nu(r=r+2, A=Sinv) B3 <- 4*B3 } g2r4 <- (2*B1/(-B2 + sqrt(B2^2 + 4*B1*B3)))^(1/(d+2*r+8))*n^(-1/(d+2*r+8)) } else if (nstage==2) { psi2r8.ns <- psins(r=2*r+8, Sigma=S) ##B3 <- sum(psi2r8.ns^2) B3 <- norm(Matrix(psi2r8.ns, nrow=1) %*% (Matrix(vec(diag(d)), ncol=1) %*% Matrix(vec(diag(d)), nrow=1) %x% Diagonal(d^(2*r+6))) %*% Matrix(psi2r8.ns, ncol=1), type="1") ##B3 <- B3@x if (!scv) { B1 <- 2*(2*pi)^(-d)*OF(2*r+6)*prod(d+2*(0:(r+3))) B2 <- -(d+2*r+4)*2^(-d/2-r+2)*(2*pi)^(-d)*det(S)^(-1/2)*OF(2*r+6)*nu(r=r+4, A=Sinv) } else { B1 <- 2^(-2*r-5)*(4*pi)^(-d)*OF(2*r+6)*prod(d+2*(0:(r+3))) B2 <- -(d+2*r+4)*2^(-2*r-6)*(4*pi)^(-d)*det(S)^(-1/2)*OF(2*r+6)*nu(r=r+4, A=Sinv) B3 <- 4*B3 } g2r6.ns <- (2*B1/(-B2 + sqrt(B2^2 + 4*B1*B3)))^(1/(d+2*r+8))*n^(-1/(d+2*r+8)) L0 <- dmvnorm.mixt(x=rep(0,d), mus=rep(0,d), Sigmas=diag(d), props=1) if (binned) eta2r6 <- drop(kfe(x=x, G=g2r6.ns^2*diag(d), inc=1, binned=binned, deriv.order=2*r+6, add.index=FALSE, verbose=verbose) %*% vec(diag(d^(r+3)))) else eta2r6 <- Qr(x=x, deriv.order=2*r+6, Sigma=g2r6.ns^2*diag(d), inc=1) A1 <- cf[1]*(2*d+4*r+8)*L0^2*OF(2*r+4)*nu(r=r+2, A=diag(d)) A2 <- cf[2]*(d+2*r+2)*L0*OF(2*r+4)*eta2r6 A3 <- cf[3]*eta2r6^2 g2r4 <- (2*A1/((-A2+ sqrt(A2^2 +4*A1*A3))*n))^(1/(d+2*r+6)) } return(g2r4) } ############################################################################## ## Unconstrained pilot selector for derivatives r>0 from Chacon & Duong (2011) ## Generalisation of Gunconstr for r>0 ############################################################################## Gdunconstr <- function(x, d, r, n, nstage=1, verbose, binned=FALSE, scv=FALSE, optim.fun="optim") { if (scv) cf <- c(2^(-d/2), 2) else cf <- c(1,1) S <- var(x) optim.fun1 <- match.arg(optim.fun, c("nlm", "optim")) if (nstage==1) { G2r4 <- Gns(r=2*r+4,n=n,Sigma=S) } else if (nstage==2) { G2r4.NR <- Gns(r=2*r+4,n=n,Sigma=S) G2r6.NR <- Gns(r=2*r+6,n=n,Sigma=S) vecPsi2r6 <- kfe(x=x, G=G2r6.NR, binned=binned, deriv.order=2*r+6, deriv.vec=TRUE, add.index=FALSE, verbose=verbose) dls <- (0:(d^2-1))*d^(2*r+4) AB2 <- function(vechG) { G <- invvech(vechG) %*% invvech(vechG) Ginv <- chol2inv(chol(G)) ## direct computation ##v1 <- n^(-1)*det(Ginv12)*drop(Kpow(A=Ginv12,pow=2*r+4)%*%D2r4phi0) v1 <- n^(-1)*dmvnorm(rep(0,d),rep(0,d),sigma=G)*(-1)^(r+2)*OF(2*r+4)*Sdrv(d=d,r=2*r+4,v=Kpow(vec(Ginv),r+2)) ##v2 <- (1/2)*drop((t(vec(G))%x%Id2r4) %*% vecPsi2r6) v2 <- numeric(d^(2*r+4)) for(k in 1:d^(2*r+4)){v2[k]<-(1/2)*sum(vec(G)*vecPsi2r6[dls+k])} AB <- cf[1]*v1 + cf[2]*v2 AB2.val <- sum(AB^2) return(AB2.val) } Gstart <- matrix.sqrt(G2r4.NR) if (optim.fun1=="nlm") { result <- nlm(p=vech(Gstart), f=AB2, print.level=2*as.logical(verbose)) G2r4 <- result$estimate } else if (optim.fun=="optim") { result <- optim(vech(matrix.sqrt(Gstart)), AB2, method="BFGS", control=list(trace=as.numeric(verbose))) G2r4 <- result$par } G2r4 <- invvech(G2r4)%*%invvech(G2r4) } return(G2r4) } ############################################################################## ## Estimate psi functionals using 1-stage plug-in ## ## Parameters ## x.star - pre-transformed data points ## pilot - "amse" = different AMSE pilot bandwidths ## - "samse" = optimal SAMSE pilot bandwidth ## ## Returns ## estimated psi functionals ############################################################################### psifun1 <- function(x.star, pilot="samse", binned, bin.par, deriv.order=0, verbose=FALSE) { d <- ncol(x.star) r <- deriv.order S.star <- var(x.star) n <- nrow(x.star) ## pilots are based on (2r+4)-th order derivatives ## compute 1 pilot for SAMSE if (pilot=="samse") { g.star <- gsamse(S.star, n, 4) psihat.star <- kfe(x=x.star, G=g.star^2*diag(d), deriv.order=4, deriv.vec=TRUE, binned=binned, add.index=TRUE, verbose=verbose) } ## compute 5 different pilots for AMSE else if ((pilot=="amse") & (d==2)) { derivt4 <- dmvnorm.deriv(x=rep(0,d), deriv.order=4, add.index=TRUE, deriv.vec=FALSE, only.index=TRUE) derivt4.vec <- dmvnorm.deriv(x=rep(0,d), deriv.order=4, add.index=TRUE, deriv.vec=TRUE, only.index=TRUE) RK31 <- 15/(64*pi) psi00 <- psins(r=c(0,0), Sigma=S.star) psihat.star <- vector() g.star <- vector() for (k in 1:nrow(derivt4)) { r <- derivt4[k,] psi1 <- psins(r=r + 2*elem(1, 2), Sigma=S.star) psi2 <- psins(r=r + 2*elem(2, 2), Sigma=S.star) ## odd order if (prod(r) == 3)g.star[k] <- gamse.odd.2d(r=4, n, psi1, psi2, psi00, RK31) ## even order else g.star[k] <- gamse.even.2d(r=4, n, psi1, psi2)[k] psihat.star[k] <- kfe.scalar(x=x.star, deriv.order=r, g=g.star[k], binned=binned, bin.par=bin.par) } ## create replicated form of psihat psihat.star.vec <- rep(0, nrow(derivt4.vec)) for (k in 1:nrow(derivt4.vec)) psihat.star.vec[k] <- psihat.star[which.mat(r=derivt4.vec[k,], mat=derivt4)] psihat.star <- list(psir=psihat.star.vec, deriv.ind=derivt4.vec) } return(psihat.star) } ############################################################################### # Estimate psi functionals using 2-stage plug-in # # Parameters # x - pre-transformed data points # pilot - "amse" - different AMSE pilot # - "samse" - SAMSE pilot # Returns # estimated psi functionals ############################################################################### psifun2 <- function(x.star, pilot="samse", binned, bin.par, deriv.order=0, verbose=FALSE) { d <- ncol(x.star) r <- deriv.order S.star <- var(x.star) n <- nrow(x.star) ## pilots are based on (2r+4)-th order derivatives ## compute 1 pilot for SAMSE if (pilot=="samse") { g6.star <- gsamse(S.star, n=n, modr=6) psihat6.star <- kfe(x=x.star, G=g6.star^2*diag(d), deriv.order=6, deriv.vec=TRUE, binned=binned, add.index=FALSE, verbose=verbose) g.star <- gsamse(S.star, n=n, modr=4, nstage=2, psihat=psihat6.star) psihat.star <- kfe(x=x.star, G=g.star^2*diag(d), deriv.order=4, deriv.vec=TRUE, binned=binned, add.index=TRUE, verbose=verbose) } ## compute different pilots for AMSE else if ((pilot=="amse") & (d==2)) { derivt4 <- dmvnorm.deriv(x=rep(0,d), deriv.order=4, add.index=TRUE, deriv.vec=FALSE, only.index=TRUE) derivt4.vec <- dmvnorm.deriv(x=rep(0,d), deriv.order=4, add.index=TRUE, deriv.vec=TRUE, only.index=TRUE) derivt6 <- dmvnorm.deriv(x=rep(0,d), deriv.order=6, add.index=TRUE, deriv.vec=FALSE, only.index=TRUE) RK31 <- 15/(64*pi) RK51 <- 945/(256*pi) RK33 <- 225/(256*pi) psi00 <- psins(r=rep(0,d), Sigma=S.star) psihat6.star <- vector() g6.star <- vector() psihat.star <- vector() g.star <- vector() for (k in 1:nrow(derivt6)) { r <- derivt6[k,] psi1 <- psins(r=r + 2*elem(1, 2), Sigma=S.star) psi2 <- psins(r=r + 2*elem(2, 2), Sigma=S.star) if (prod(r) == 5) g6.star[k] <- gamse.odd.2d(r=6, n, psi1, psi2, psi00, RK51) else if (prod(r) == 9) g6.star[k] <- gamse.odd.2d(r=6, n, psi1, psi2, psi00, RK33) else g6.star[k] <- gamse.even.2d(r=6, n, psi1, psi2)[k] psihat6.star[k] <- kfe.scalar(x=x.star, deriv.order=r, g=g6.star[k], binned=binned, bin.par=bin.par) } ## pilots are based on 4th order derivatives using 6th order psi functionals ## computed above 'psihat6.star' for (k in 1:nrow(derivt4)) { r <- derivt4[k,] psi1 <- psihat6.star[7 - (r + 2*elem(1,2))[1]] psi2 <- psihat6.star[7 - (r + 2*elem(2,2))[1]] if (prod(r) == 3) g.star[k] <- gamse.odd.2d(r=4, n, psi1, psi2, psi00, RK31) else g.star[k] <- gamse.even.2d(r=4, n, psi1, psi2)[k] psihat.star[k] <- kfe.scalar(x=x.star, deriv.order=r, g=g.star[k], binned=binned, bin.par=bin.par) } ## create replicated form of psihat psihat.star.vec <- rep(0, nrow(derivt4.vec)) for (k in 1:nrow(derivt4.vec)) psihat.star.vec[k] <- psihat.star[which.mat(r=derivt4.vec[k,], mat=derivt4)] psihat.star <- list(psir=psihat.star.vec, deriv.ind=derivt4.vec) } return(psihat.star) } ############################################################################# ## Estimate psi functionals for 6-variate data using 1-stage plug-in ## with unconstrained pilot ## ## Parameters ## x - data points ## Sd4, Sd6 - symmetrizer matrices of order 4 and 6 ## ## Returns ## estimated psi functionals ############################################################################# psifun1.unconstr <- function(x, binned, bgridsize, deriv.order=0, verbose=FALSE) { n <- nrow(x) r <- deriv.order S <- var(x) ## stage 1 of plug-in G2r4 <- Gns(r=2*r+4,n=n,Sigma=S) vecPsi2r4 <- kfe(x=x, G=G2r4, deriv.order=2*r+4, binned=binned, bgridsize=bgridsize, deriv.vec=TRUE, add.index=FALSE, verbose=verbose) return (vecPsi2r4) } ############################################################################# ## Estimate psi functionals for 6-variate data using 2-stage plug-in ## with unconstrained pilot ## ## Parameters ## x - data points ## Sd4, Sd6 - symmetrizer matrices of order 4 and 6 ## ## Returns ## estimated psi functionals ############################################################################ psifun2.unconstr <- function(x, rel.tol=10^-10, binned, bgridsize, deriv.order=0, verbose=FALSE, optim.fun="optim") { d <- ncol(x) n <- nrow(x) S <- var(x) r <- deriv.order optim.fun1 <- match.arg(optim.fun, c("nlm", "optim")) ## stage 1 of plug-in G2r6 <- Gns(r=2*r+6,n=n,Sigma=S) vecPsi2r6 <- kfe(x=x, G=G2r6, binned=binned, bgridsize=bgridsize, deriv.order=2*r+6, deriv.vec=TRUE, add.index=FALSE, verbose=verbose) ## asymptotic squared bias for r = 4 for MSE-optimal G D2r4phi0 <- DrL0(d=d, r=2*r+4) Id2r4 <- diag(d^(2*r+4)) AB2<-function(vechG){ rr <- 2*r+4 G <- invvech(vechG)%*%invvech(vechG) G12 <- matrix.sqrt(G) Ginv12 <- chol2inv(chol(G12)) AB <- n^(-1)*det(Ginv12)*(Kpow(A=Ginv12,pow=rr)%*%D2r4phi0)+(1/2)*(t(vec(G))%x%Id2r4) %*% vecPsi2r6 return (sum(AB^2)) } Gstart <- Gns(r=2*r+4,n=n,Sigma=S) Gstart <- matrix.sqrt(Gstart) if (optim.fun1=="nlm") { res <- nlm(p=vech(Gstart), f=AB2, print.level=2*as.logical(verbose)) G2r4 <- res$estimate } else if (optim.fun1=="optim") { res <- optim(vech(Gstart), AB2, control=list(reltol=rel.tol, trace=as.numeric(verbose))) G2r4 <- res$par } G2r4 <- invvech(G2r4)%*%invvech(G2r4) ## stage 2 of plug-in vecPsi2r4 <- kfe(x=x, G=G2r4, binned=binned, bgridsize=bgridsize, deriv.order=2*r+4, deriv.vec=TRUE, add.index=FALSE, verbose=verbose) return (vecPsi2r4) } ############################################################################# # Plug-in bandwidth selectors ############################################################################# ############################################################################ ## Computes plug-in full bandwidth matrix - 2 to 6 dim ## ## Parameters ## x - data points ## Hstart - initial value for minimisation ## nstage - number of plug-in stages (1 or 2) ## pilot - "amse" - different AMSE pilot ## - "samse" - SAMSE pilot ## - "unconstr" - unconstrained pilot ## pre - "scale" - pre-scaled data ## - "sphere"- pre-sphered data ## ## Returns ## Plug-in full bandwidth matrix ############################################################################### hpi <- function(x, nstage=2, binned=TRUE, bgridsize, deriv.order=0) { ## 1-d selector is taken from KernSmooth's dpik d <- 1 if (missing(bgridsize)) bgridsize <- default.gridsize(d) if (deriv.order==0) h <- dpik(x=x, level=nstage, gridsize=bgridsize) else { n <- length(x) d <- 1 r <- deriv.order K2r4 <- dnorm.deriv(x=0, mu=0, sigma=1, deriv.order=2*r+4) K2r6 <- dnorm.deriv(x=0, mu=0, sigma=1, deriv.order=2*r+6) m2 <- 1 mr <- psins.1d(r=2*r, sigma=1) ## formula for bias annihilating bandwidths from Wand & Jones (1995, p.70) if (nstage==2) { psi2r8.hat <- psins.1d(r=2*r+8, sigma=sd(x)) gamse2r6 <- (2*K2r6/(-m2*psi2r8.hat*n))^(1/(2*r+9)) psi2r6.hat <- kfe.1d(x=x, g=gamse2r6, deriv.order=2*r+6, inc=1, binned=binned) gamse2r4 <- (2*K2r4/(-m2*psi2r6.hat*n))^(1/(2*r+7)) psi2r4.hat <- kfe.1d(x=x, g=gamse2r4, deriv.order=2*r+4, inc=1, binned=binned) } else { psi2r6.hat <- psins.1d(r=2*r+6, sigma=sd(x)) gamse2r4 <- (2*K2r4/(-m2*psi2r6.hat*n))^(1/(2*r+7)) psi2r4.hat <- kfe.1d(x=x, g=gamse2r4, deriv.order=2*r+4, inc=1, binned=binned) } ## formula form Wand & Jones (1995, p.49) h <- ((2*r+1)*mr/(m2^2*psi2r4.hat*n))^(1/(2*r+5)) } return(h) } Hpi <- function(x, nstage=2, pilot, pre="sphere", Hstart, binned, bgridsize, amise=FALSE, deriv.order=0, verbose=FALSE, optim.fun="optim") { n <- nrow(x) d <- ncol(x) r <- deriv.order if (missing(binned)) binned <- default.bflag(d=d,n=n) if (d > 4) binned <- FALSE if (missing(bgridsize)) bgridsize <- default.bgridsize(d) if (!is.matrix(x)) x <- as.matrix(x) if (missing(pilot)) {if (d==2 & r==0) pilot <- "samse" else pilot <- "dscalar"} pilot1 <- match.arg(pilot, c("amse", "samse", "unconstr", "dunconstr", "dscalar")) pre1 <- match.arg(pre, c("scale", "sphere")) optim.fun1 <- match.arg(optim.fun, c("nlm", "optim")) if (pilot1=="amse" & (d>2 | r>0)) stop("amse pilot selectors not defined for d>2 and/or r>0") if ((pilot1=="samse" | pilot1=="unconstr") & r>0) stop("dscalar or dunconstr pilot selectors are better for derivatives r>0") if (pilot1=="unconstr" & d>=6) stop("Unconstrained pilots are not implemented for d>6") if (pre1=="scale") { x.star <- pre.scale(x) S12 <- diag(sqrt(diag(var(x)))) Sinv12 <- chol2inv(chol(S12)) } else if (pre1=="sphere") { x.star <- pre.sphere(x) S12 <- matrix.sqrt(var(x)) Sinv12 <- chol2inv(chol(S12)) } Idr <- diag(d^r) RKr <- nu(r=r, diag(d))*2^(-d-r)*pi^(-d/2) if (binned) { H.max <- (((d+8)^((d+6)/2)*pi^(d/2)*RKr)/(16*(d+2)*n*gamma(d/2+4)))^(2/(d+4))* var(x) bin.par <- binning(x=x, bgridsize=bgridsize, H=H.max) H.max.star <- (((d+8)^((d+6)/2)*pi^(d/2)*RKr)/(16*(d+2)*n*gamma(d/2+4)))^(2/(d+4))* var(x.star) bin.par.star <- binning(x=x.star, bgridsize=bgridsize, H=H.max.star) } if (pilot1=="unconstr") { ## psi4.mat is on data scale if (nstage==1) psi.fun <- (-1)^r*psifun1.unconstr(x=x, binned=binned, bgridsize=bgridsize, deriv.order=r, verbose=verbose) else if (nstage==2) psi.fun <- psifun2.unconstr(x=x, binned=binned, bgridsize=bgridsize, deriv.order=r, verbose=verbose) psi2r4.mat <- (-1)^r*invvec(psi.fun) ## use normal reference bandwidth as initial condition if (missing(Hstart)) Hstart <- Hns(x=x, deriv.order=r) } else if (pilot1=="dunconstr") { ## G2r4 is on data scale G2r4 <- Gdunconstr(x=x, d=d, r=r, n=n, nstage=nstage, verbose=verbose, binned=binned, optim.fun=optim.fun) vecPsi2r4 <- kfe(x=x, G=G2r4, binned=binned, deriv.order=2*r+4, deriv.vec=TRUE, add.index=FALSE, verbose=verbose, bin.par=bin.par) if (missing(Hstart)) Hstart <- Hns(x=x, deriv.order=r) } else if (pilot1=="dscalar") { ## g2r4 is on pre-transformed data scale g2r4 <- gdscalar(x=x.star, r=r, n=n, d=d, verbose=verbose, nstage=nstage, binned=binned) G2r4 <- g2r4^2 * diag(d) vecPsi2r4 <- kfe(x=x.star, G=G2r4, binned=binned, deriv.order=2*r+4, deriv.vec=TRUE, add.index=FALSE, verbose=verbose, bin.par=bin.par.star) if (missing(Hstart)) Hstart <- Hns(x=x.star, deriv.order=r) } else { ## psi4.mat is on pre-transformed data scale if (nstage==1) psi.fun <- psifun1(x.star, pilot=pilot, binned=binned, bin.par=bin.par.star, deriv.order=r, verbose=verbose)$psir else if (nstage==2) psi.fun <- psifun2(x.star, pilot=pilot, binned=binned, bin.par=bin.par.star, deriv.order=r, verbose=verbose)$psir psi2r4.mat <- invvec(psi.fun) ## use normal reference bandwidth as initial condition if (missing(Hstart)) Hstart <- Hns(x=x.star, deriv.order=r) else Hstart <- Sinv12 %*% Hstart %*% Sinv12 } ## PI is estimate of AMISE pi.temp <- function(vechH) { H <- invvech(vechH) %*% invvech(vechH) Hinv <- chol2inv(chol(H)) IdrvH <- Idr%x%vec(H) int.var <- 1/(det(H)^(1/2)*n)*nur(r=r, A=Hinv, mu=rep(0,d), Sigma=diag(d))*2^(-d-r)*pi^(-d/2) if (pilot1=="dunconstr" | pilot1=="dscalar") { pi.val <- int.var + (-1)^r*1/4*vecPsi2r4 %*% (vec(diag(d^r) %x% vec(H) %x% vec(H))) } else pi.val <- int.var + (-1)^r*1/4* sum(diag(t(IdrvH) %*% psi2r4.mat %*% IdrvH)) pi.val <- drop(pi.val) return(pi.val) } Hstart <- matrix.sqrt(Hstart) if (optim.fun1=="nlm") { result <- nlm(p=vech(Hstart), f=pi.temp, print.level=2*as.numeric(verbose)) H <- invvech(result$estimate) %*% invvech(result$estimate) amise.star <- result$minimum } else if (optim.fun1=="optim") { result <- optim(vech(Hstart), pi.temp, method="BFGS", control=list(trace=as.numeric(verbose))) H <- invvech(result$par) %*% invvech(result$par) amise.star <- result$value } if (!(pilot1 %in% c("dunconstr","unconstr"))) H <- S12 %*% H %*% S12 ## back-transform if (!amise) return(H) else return(list(H = H, PI.star=amise.star)) } ############################################################################### ## Computes plug-in diagonal bandwidth matrix for 2 to 6-dim ## ## Parameters ## x - data points ## nstage - number of plug-in stages (1 or 2) ## pre - "scale" - pre-scaled data ## - "sphere"- pre-sphered data ## ## Returns ## Plug-in diagonal bandwidth matrix ############################################################################### Hpi.diag <- function(x, nstage=2, pilot, pre="scale", Hstart, binned, bgridsize, amise=FALSE, deriv.order=0, verbose=FALSE, optim.fun="optim") { n <- nrow(x) d <- ncol(x) r <- deriv.order RK <- (4*pi)^(-d/2) if (missing(binned)) binned <- default.bflag(d=d,n=n) if (d > 4) binned <- FALSE if (missing(bgridsize)) bgridsize <- default.bgridsize(d) if (!is.matrix(x)) x <- as.matrix(x) if (missing(pilot)) {if (d==2 & r==0) pilot <- "samse" else pilot <- "dscalar"} pilot1 <- match.arg(pilot, c("amse", "samse", "unconstr", "dunconstr", "dscalar")) pre1 <- match.arg(pre, c("scale", "sphere")) optim.fun1 <- match.arg(optim.fun, c("nlm", "optim")) if (pre1=="sphere") stop("Using pre-sphering won't give diagonal bandwidth matrix") if (pilot1=="amse" & (d>2 | r>0)) stop("samse pilot selectors are better for higher dimensions and/or deriv.order>0") if (pilot1=="samse" & r>0) stop("dscalar or dunconstr pilot selectors are better for derivatives r>0") if (pilot1=="unconstr" | pilot1=="dunconstr") stop("Unconstrained pilot selectors are not suitable for Hpi.diag") if (pre1=="scale") { x.star <- pre.scale(x) S12 <- diag(sqrt(diag(var(x)))) Sinv12 <- chol2inv(chol(S12)) } else if (pre1=="sphere") { x.star <- pre.sphere(x) S12 <- matrix.sqrt(var(x)) Sinv12 <- chol2inv(chol(S12)) } if (binned) { H.max <- (((d+8)^((d+6)/2)*pi^(d/2)*RK)/(16*(d+2)*n*gamma(d/2+4)))^(2/(d+4))* var(x.star) bin.par <- binning(x=x.star, bgridsize=bgridsize, H=H.max) } Idr <- diag(d^r) if (pilot1=="amse" | pilot1=="samse") { if (nstage==1) psi.fun <- psifun1(x.star, pilot=pilot, binned=binned, bin.par=bin.par, deriv.order=r, verbose=verbose)$psir else if (nstage==2) psi.fun <- psifun2(x.star, pilot=pilot, binned=binned, bin.par=bin.par, deriv.order=r, verbose=verbose)$psir psi2r4.mat <- invvec(psi.fun) } else if (pilot1=="dscalar") { g2r4 <- gdscalar(x=x.star, r=r, n=n, d=d, verbose=verbose, nstage=nstage, binned=binned) G2r4 <- g2r4^2 * diag(d) vecPsi2r4 <- kfe(x=x.star, G=G2r4, binned=binned, deriv.order=2*r+4, deriv.vec=TRUE, add.index=FALSE, verbose=verbose) } if (d==2 & r==0 & (pilot1=="amse" | pilot1=="samse")) { ## diagonal bandwidth matrix for 2-dim has exact formula psi40 <- psi.fun[1] psi22 <- psi.fun[6] psi04 <- psi.fun[16] s1 <- sd(x[,1]) s2 <- sd(x[,2]) h1 <- (psi04^(3/4)*RK/(psi40^(3/4)*(sqrt(psi40*psi04)+psi22)*n))^(1/6) h2 <- (psi40/psi04)^(1/4) * h1 H <- diag(c(s1^2*h1^2, s2^2*h2^2)) psimat4.D <- invvech(c(psi40, psi22, psi04)) amise.star <- drop(n^(-1)*RK*(h1*h2)^(-1) + 1/4*c(h1,h2)^2 %*% psimat4.D %*% c(h1,h2)^2) } else { ## PI is estimate of AMISE pi.temp <- function(diagH) { H <- diag(diagH) %*% diag(diagH) Hinv <- chol2inv(chol(H)) IdrvH <- Idr%x%vec(H) int.var <- 1/(det(H)^(1/2)*n)*nu(r=r, Hinv)*2^(-d-r)*pi^(-d/2) if (pilot1=="dscalar") pi.val <- int.var + (-1)^r*1/4*vecPsi2r4 %*% (vec(diag(d^r) %x% vec(H) %x% vec(H))) else pi.val <- int.var + (-1)^r*1/4* sum(diag(t(IdrvH) %*% psi2r4.mat %*% IdrvH)) return(drop(pi.val)) } ## use normal reference bandwidth as initial condition if (missing(Hstart)) Hstart <- Hns(x=x.star, deriv.order=r) else Hstart <- Sinv12 %*% Hstart %*% Sinv12 Hstart <- matrix.sqrt(Hstart) if (optim.fun1=="nlm") { result <- nlm(p=diag(Hstart), f=pi.temp, print.level=2*as.numeric(verbose)) H <- diag(result$estimate^2) amise.star <- result$minimum } else if (optim.fun1=="optim") { result <- optim(diag(Hstart), pi.temp, method="BFGS", control=list(trace=as.numeric(verbose))) H <- diag(result$par) %*% diag(result$par) amise.star <- result$value } H <- S12 %*% H %*% S12 ## back-transform } if (!amise) return(H) else return(list(H = H, PI.star=amise.star)) } ############################################################################### ## Cross-validation bandwidth selectors ############################################################################### ############################################################################### ## Computes the least squares cross validation LSCV function for 2 to 6 dim ## ## Parameters ## x - data values ## H - bandwidth matrix ## ## Returns ## LSCV(H) ############################################################################### lscv.1d <- function(x, h, binned, bin.par, deriv.order=0) { r <- deriv.order lscv1 <- kfe.1d(x=x, g=sqrt(2)*h, inc=1, binned=binned, bin.par=bin.par, deriv.order=2*r) lscv2 <- kfe.1d(x=x, g=h, inc=0, binned=binned, bin.par=bin.par, deriv.order=2*r) return((-1)^r*(lscv1 - 2*lscv2)) } lscv.mat <- function(x, H, binned=FALSE, bin.par, bgridsize, deriv.order=0) { r <- deriv.order d <- ncol(x) n <- nrow(x) if (!binned) { lscv1 <- Qr(x=x, deriv.order=2*r, Sigma=2*H, inc=1) lscv2 <- Qr(x=x, deriv.order=2*r, Sigma=H, inc=0) lscv <- drop(lscv1 - 2*lscv2) } else { lscv1 <- kfe(x=x, G=2*H, inc=1, binned=binned, bin.par=bin.par, bgridsize=bgridsize, deriv.order=2*r, add.index=FALSE) lscv2 <- kfe(x=x, G=H, inc=0, binned=binned, bin.par=bin.par, bgridsize=bgridsize, deriv.order=2*r, add.index=FALSE) lscv <- (-1)^2*drop((lscv1 - 2*lscv2) %*% vec(diag(d^r))) } return(lscv) } ############################################################################### ## Finds the bandwidth matrix that minimises LSCV for 2 to 6 dim ## ## Parameters ## x - data values ## Hstart - initial bandwidth matrix ## ## Returns ## H_LSCV ############################################################################### hlscv <- function(x, binned=TRUE, bgridsize, amise=FALSE, deriv.order=0) { if (any(duplicated(x))) warning("Data contain duplicated values: LSCV is not well-behaved in this case") n <- length(x) d <- 1 r <- deriv.order hnorm <- sqrt((4/(n*(d + 2)))^(2/(d + 4)) * var(x)) if (missing(binned)) binned <- default.bflag(d=d,n=n) if (missing(bgridsize)) bgridsize <- default.bgridsize(d) if (binned) { bin.par <- binning(x, bgridsize=bgridsize, h=hnorm) lscv.1d.temp <- function(h) { return(lscv.1d(x=x, h=h, binned=binned, bin.par=bin.par, deriv.order=r)) } } else { if (r>0) stop("Unbinned hlscv not yet implemented for deriv.order>0") difs <- x%*%t(rep(1,n))-rep(1,n)%*%t(x) difs <- difs[lower.tri(difs)] edifs <- exp(-difs^2/2) RK <- 1/(2*sqrt(pi)) lscv.1d.temp <- function(h) { lscv1 <- (1-1/n)*sum(edifs^(1/(2*h^2)))/(h*sqrt(2)*sqrt(2*pi)) lscv2 <- 2*sum(edifs^(1/h^2))/(h*sqrt(2*pi)) return(RK/(n*h)+2*(lscv1-lscv2)/(n^2-n)) } } opt <- optimise(f=lscv.1d.temp, interval=c(0.2*hnorm, 5*hnorm, tol=.Machine$double.eps)) if (!amise) return(opt$minimum) else return(list(h=opt$minimum, LSCV=opt$objective)) } Hlscv <- function(x, Hstart, binned=FALSE, bgridsize, amise=FALSE, deriv.order=0, verbose=FALSE, optim.fun="optim", trunc) { if (any(duplicated(x))) warning("Data contain duplicated values: LSCV is not well-behaved in this case") if (!is.matrix(x)) x <- as.matrix(x) n <- nrow(x) d <- ncol(x) r <- deriv.order if (missing(binned)) binned <- default.bflag(d=d,n=n) if (d>4) binned <- FALSE if (missing(bgridsize)) bgridsize <- default.bgridsize(d) optim.fun1 <- match.arg(optim.fun, c("nlm", "optim")) ## use normal reference selector as initial condn Hnorm <- Hns(x=x, deriv.order=r) if (missing(Hstart)) Hstart <- Hnorm Hstart <- matrix.sqrt(Hstart) if (binned) bin.par <- binning(x=x, H=Hnorm, bgridsize=bgridsize) if (missing(trunc)) {if (deriv.order==0) trunc <- 1e10 else trunc <- 4} lscv.init <- lscv.mat(x=x, H=Hnorm, binned=binned, bin.par=bin.par, deriv.order=r) lscv.mat.temp <- function(vechH) { H <- invvech(vechH) %*% invvech(vechH) lscv <- lscv.mat(x=x, H=H, binned=binned, bin.par=bin.par, deriv.order=r) if (det(H) < 1/trunc*det(Hnorm) | det(H) > trunc*det(Hnorm) | abs(lscv) > trunc*abs(lscv.init)) lscv <- lscv.init return(lscv) } if (optim.fun1=="nlm") { result <- nlm(p=vech(Hstart), f=lscv.mat.temp, print.level=2*as.numeric(verbose)) H <- invvech(result$estimate) %*% invvech(result$estimate) amise.opt <- result$minimum } else if (optim.fun1=="optim") { result <- optim(vech(Hstart), lscv.mat.temp, control=list(trace=as.numeric(verbose)), method="Nelder-Mead") H <- invvech(result$par) %*% invvech(result$par) amise.opt <- result$value } if (!amise) return(H) else return(list(H=H, LSCV=amise.opt)) } ############################################################################### ## Finds the diagonal bandwidth matrix that minimises LSCV for 2 to 6 dim ## ## Parameters ## x - data values ## Hstart - initial bandwidth matrix ## ## Returns ## H_LSCV,diag ############################################################################### Hlscv.diag <- function(x, Hstart, binned=FALSE, bgridsize, amise=FALSE, deriv.order=0, verbose=FALSE, optim.fun="optim", trunc) { if (any(duplicated(x))) warning("Data contain duplicated values: LSCV is not well-behaved in this case") if (!is.matrix(x)) x <- as.matrix(x) n <- nrow(x) d <- ncol(x) r <- deriv.order if (missing(binned)) binned <- default.bflag(d=d,n=n) if (d>4) binned <- FALSE if (missing(bgridsize)) bgridsize <- default.bgridsize(d) optim.fun1 <- match.arg(optim.fun, c("nlm", "optim")) Hnorm <- Hns(x=x, deriv.order=r) if (missing(Hstart)) Hstart <- Hnorm ## don't truncate optimisation for deriv.order==0 if (missing(trunc)) {if (deriv.order==0) trunc <- 1e10 else trunc <- 4} ## linear binning if (binned) { bin.par <- binning(x=x, bgridsize=bgridsize, H=Hnorm) } lscv.init <- lscv.mat(x=x, H=Hnorm, binned=binned, bin.par=bin.par, deriv.order=r) lscv.mat.temp <- function(diagH) { H <- diag(diagH^2) lscv <- lscv.mat(x=x, H=H, binned=binned, bin.par=bin.par, deriv.order=r) if (det(H) < 1/trunc*det(Hnorm) | det(H) > trunc*det(Hnorm) | abs(lscv) > trunc*abs(lscv.init)) lscv <- lscv.init return(lscv) } Hstart <- matrix.sqrt(Hstart) if (optim.fun1=="nlm") { result <- nlm(p=diag(Hstart), f=lscv.mat.temp, print.level=2*as.numeric(verbose)) H <- diag(result$estimate^2) amise.opt <- result$minimum } else if (optim.fun1=="optim") { result <- optim(diag(Hstart), lscv.mat.temp, method="Nelder-Mead", control=list(trace=as.numeric(verbose))) H <- diag(result$par^2) amise.opt <- result$value } if (!amise) return(H) else return(list(H=H, LSCV=amise.opt)) } hucv <- function(...) { hlscv(...) } Hucv <- function(...) { Hlscv(...) } Hucv.diag <- function(...) { Hlscv.diag(...) } ############################################################################### ## Computes the biased cross validation BCV function for 2-dim ## ## Parameters ## x - data values ## H1, H2 - bandwidth matrices ## ## Returns ## BCV(H) ############################################################################### bcv.mat <- function(x, H1, H2, binned=FALSE) { n <- nrow(x) d <- 2 psi <- kfe(x, G=H2, deriv.order=4, add.index=TRUE, deriv.vec=TRUE, inc=0, binned=binned) psi40 <- psi$psir[1] psi31 <- psi$psir[2] psi22 <- psi$psir[4] psi13 <- psi$psir[8] psi04 <- psi$psir[16] coeff <- c(1, 2, 1, 2, 4, 2, 1, 2, 1) psi.fun <- c(psi40, psi31, psi22, psi31, psi22, psi13, psi22, psi13,psi04)/(n*(n-1)) psi4.mat <- matrix(coeff * psi.fun, ncol=3, nrow=3) RK <- (4*pi)^(-d/2) bcv <- drop(n^(-1)*det(H1)^(-1/2)*RK + 1/4*t(vech(H1)) %*% psi4.mat %*% vech(H1)) return(list(bcv=bcv, psimat=psi4.mat)) } ############################################################################### ## Find the bandwidth matrix that minimises the BCV for 2-dim ## ## Parameters ## x - data values ## whichbcv - 1 = BCV1 ## - 2 = BCV2 ## Hstart - initial bandwidth matrix ## ## Returns ## H_BCV ############################################################################### Hbcv <- function(x, whichbcv=1, Hstart, binned=FALSE, amise=FALSE, verbose=FALSE) { n <- nrow(x) d <- ncol(x) RK <- (4*pi)^(-d/2) if(!is.matrix(x)) x <- as.matrix(x) ## use normal reference b/w matrix for bounds k <- (((d+8)^((d+6)/2)*pi^(d/2)*RK)/(16*n*gamma((d+8)/2)*(d+2)))^(2/(d+4)) Hmax <- k * abs(var(x)) up.bound <- Hmax if (missing(Hstart)) Hstart <- matrix.sqrt(0.9*Hmax) bcv.mat.temp <- function(vechH) { H <- invvech(vechH) %*% invvech(vechH) bcv <- bcv.mat(x=x, H1=H, H2=whichbcv*H, binned=binned)$bcv return(bcv) } result <- optim(vech(Hstart), bcv.mat.temp, method="L-BFGS-B", upper=vech(matrix.sqrt(up.bound)), lower=-vech(matrix.sqrt(up.bound)), control=list(trace=as.numeric(verbose))) H <- invvech(result$par) %*% invvech(result$par) amise.opt <- result$value if (!amise) return(H) else return(list(H = H, BCV=amise.opt)) } ############################################################################### ## Find the diagonal bandwidth matrix that minimises the BCV for 2-dim ## ## Parameters ## x - data values ## whichbcv - 1 = BCV1 ## - 2 = BCV2 ## Hstart - initial bandwidth matrix ## ## Returns ## H_BCV, diag ############################################################################### Hbcv.diag <- function(x, whichbcv=1, Hstart, binned=FALSE, amise=FALSE, verbose=FALSE) { n <- nrow(x) d <- ncol(x) RK <- (4*pi)^(-d/2) if(!is.matrix(x)) x <- as.matrix(x) ## use maximally smoothed b/w matrix for bounds k <- (((d+8)^((d+6)/2)*pi^(d/2)*RK)/(16*n*gamma((d+8)/2)*(d+2)))^(2/(d+4)) Hmax <- k * abs(var(x)) up.bound <- diag(Hmax) if (missing(Hstart)) Hstart <- 0.9*matrix.sqrt(Hmax) bcv.mat.temp <- function(diagH) { H <- diag(diagH) %*% diag(diagH) return(bcv.mat(x, H, whichbcv*H, binned=binned)$bcv) } result <- optim(diag(Hstart), bcv.mat.temp, method="L-BFGS-B", upper=sqrt(up.bound), control=list(trace=as.numeric(verbose))) H <- diag(result$par) %*% diag(result$par) amise.opt <- result$value if (!amise) return(H) else return(list(H = H, BCV=amise.opt)) } ############################################################################### ## Estimate scalar g_AMSE pilot bandwidth for SCV for 2 to 6 dim ## ## Parameters ## Sigma.star - scaled/ sphered variance matrix ## Hamise - (estimate) of H_AMISE ## n - sample size ## ## Returns ## g_AMSE pilot bandwidth ############################################################################### Theta6.elem <- function(d) { Theta6.mat <- list() Theta6.mat[[d]] <- list() for (i in 1:d) Theta6.mat[[i]] <- list() for (i in 1:d) for (j in 1:d) { temp <- numeric() for (k in 1:d) for (ell in 1:d) temp <- rbind(temp, elem(i,d)+2*elem(k,d)+2*elem(ell,d)+elem(j,d)) Theta6.mat[[i]][[j]] <- temp } return(Theta6.mat) } gamse.scv <- function(x.star, d, Sigma.star, Hamise, n, binned=FALSE, bin.par, bgridsize, verbose=FALSE, nstage=1, Theta6=FALSE) { if (nstage==0) { psihat6.star <- psins(r=6, Sigma=Sigma.star, deriv.vec=TRUE) } else if (nstage==1) { g6.star <- gsamse(Sigma.star, n, 6) G6.star <- g6.star^2 * diag(d) if (Theta6) psihat6.star <- kfe(x=x.star, bin.par=bin.par, deriv.order=6, G=G6.star, deriv.vec=FALSE, add.index=FALSE, binned=binned, bgridsize=bgridsize, verbose=verbose) else psihat6.star <- kfe(x=x.star, bin.par=bin.par, deriv.order=6, G=G6.star, deriv.vec=TRUE, add.index=FALSE, binned=binned, bgridsize=bgridsize, verbose=verbose) } if (Theta6) { derivt6 <- dmvnorm.deriv(x=rep(0,d), deriv.order=6, add.index=TRUE, deriv.vec=FALSE, only.index=TRUE) Theta6.mat <- matrix(0, ncol=d, nrow=d) Theta6.mat.ind <- Theta6.elem(d) for (i in 1:d) for (j in 1:d) { temp <- Theta6.mat.ind[[i]][[j]] temp.sum <- 0 for (k in 1:nrow(temp)) temp.sum <- temp.sum + psihat6.star[which.mat(temp[k,], derivt6)] Theta6.mat[i,j] <- temp.sum } eye3 <- diag(d) D4 <- dupl(d)$d trHamise <- tr(Hamise) ## required constants - see thesis Cmu1 <- 1/2*t(D4) %*% vec(Theta6.mat %*% Hamise) Cmu2 <- 1/8*(4*pi)^(-d/2) * (2*t(D4)%*% vec(Hamise) + trHamise * t(D4) %*% vec(eye3)) num <- 2 * (d+4) * sum(Cmu2*Cmu2) den <- -(d+2) * sum(Cmu1*Cmu2) + sqrt((d+2)^2 * sum(Cmu1*Cmu2)^2 + 8*(d+4)*sum(Cmu1*Cmu1) * sum(Cmu2*Cmu2)) gamse <- (num/(den*n))^(1/(d+6)) } else { ## updated constants using Chacon & Duong (2010) notation Cmu1Cmu1 <- drop(1/4*psihat6.star %*% (Hamise %x% diag(d^4) %x% Hamise) %*% psihat6.star) Cmu1Cmu2 <- 3/4*(4*pi)^(-d/2)*drop(vec(Hamise %x% diag(d) %x% Hamise) %*% psihat6.star) Cmu2Cmu2 <- 1/64*(4*pi)^(-d)*(4*tr(Hamise%*%Hamise) + (d+8)*tr(Hamise)^2) num <- 2 * (d+4) * Cmu2Cmu2 den <- -(d+2) * Cmu1Cmu2 + sqrt((d+2)^2 * Cmu1Cmu2^2 + 8*(d+4)*Cmu1Cmu1 * Cmu2Cmu2) gamse <- (num/(den*n))^(1/(d+6)) } return(gamse) } ############################################################################### ## Estimate unconstrained G_AMSE pilot bandwidth for SCV for 2 to 6 dim ## (J.E. Chacon) ## ## Returns ## G_AMSE pilot bandwidth ############################################################################### Gunconstr.scv <- function(x, binned=FALSE, bin.par, bgridsize, rel.tol=10^-10, verbose=FALSE, nstage=1, optim.fun="optim") { d <- ncol(x) n <- nrow(x) S <- var(x) optim.fun1 <- match.arg(optim.fun, c("nlm", "optim")) ## stage 1 of plug-in if (nstage==1) { G6 <- Gns(r=6,n=n,Sigma=S)/2 #(2^(d/2+5)/((d+6)*n))^(2/(d+8))*S psihat6 <- kfe(x=x, deriv.order=6, G=G6, deriv.vec=TRUE, add.index=FALSE, binned=binned, bgridsize=bgridsize, verbose=verbose) } else if (nstage==0) { psihat6 <- psins(r=6, Sigma=S, deriv.vec=TRUE) } ## constants for normal reference D4phi0 <- DrL0(d=d,r=4) Id4 <- diag(d^4) ## asymptotic squared bias for r = 4 AB2<-function(vechG){ G <- invvech(vechG)%*%invvech(vechG) G12 <- matrix.sqrt(G) Ginv12 <- chol2inv(chol(G12)) AB <- n^(-1)*det(Ginv12)*(Kpow(A=Ginv12,pow=4)%*%D4phi0)*2^(-(d+4)/2) + (t(vec(G))%x%Id4)%*%psihat6 return (sum(AB^2)) } Hstart <- matrix.sqrt(Hns(x=x, deriv.order=1)) if (optim.fun1=="nlm") { result <- nlm(p=vech(Hstart), f=AB2, print.level=2*as.logical(verbose)) G4 <- result$estimate } else if (optim.fun1=="optim") { result <- optim(vech(Hstart), AB2, method="BFGS", control=list(trace=as.numeric(verbose))) G4 <- result$par } G4 <- invvech(G4)%*%invvech(G4) return(G4) } ############################################################################### ## Computes the smoothed cross validation function for 2 to 6 dim ## ## Parameters ## x - data values ## H - bandwidth matrix ## G - pilot bandwidth matrix ## ## Returns ## SCV(H) ############################################################################### scv.1d <- function(x, h, g, binned=TRUE, bin.par, inc=1, deriv.order=0) { r <- deriv.order if (!missing(x)) n <- length(x) if (!missing(bin.par)) n <- sum(bin.par$counts) scv1 <- kfe.1d(x=x, deriv.order=2*r, bin.par=bin.par, g=sqrt(2*h^2+2*g^2), binned=binned, inc=inc) scv2 <- kfe.1d(x=x, deriv.order=2*r, bin.par=bin.par, g=sqrt(h^2+2*g^2), binned=binned, inc=inc) scv3 <- kfe.1d(x=x, deriv.order=2*r, bin.par=bin.par, g=sqrt(2*g^2), binned=binned, inc=inc) bias2 <- (-1)^r*(scv1 - 2*scv2 + scv3) if (bias2 < 0) bias2 <- 0 scv <- (n*h)^(-1)*(4*pi)^(-1/2)*2^(-r)*OF(2*r) + bias2 return(scv) } scv.mat <- function(x, H, G, binned=FALSE, bin.par, bgridsize, verbose=FALSE, deriv.order=0) { d <- ncol(x) n <- nrow(x) r <- deriv.order vId <- vec(diag(d)) Hinv <- chol2inv(chol(H)) if (!binned) { scv1 <- Qr(x=x, deriv.order=2*r, Sigma=2*H+2*G, inc=1) scv2 <- Qr(x=x, deriv.order=2*r, Sigma=H+2*G, inc=1) scv3 <- Qr(x=x, deriv.order=2*r, Sigma=2*G, inc=1) bias2 <- (-1)^r*(scv1 - 2*scv2 + scv3) if (bias2 < 0) bias2 <- 0 } else { scv1 <- kfe(x=x, G=2*H + 2*G, deriv.order=2*r, inc=1, binned=binned, bin.par=bin.par, bgridsize=bgridsize, verbose=verbose, add.index=FALSE) scv2 <- kfe(x=x, G=H + 2*G, deriv.order=2*r, inc=1, binned=binned, bin.par=bin.par, bgridsize=bgridsize, verbose=verbose, add.index=FALSE) scv3 <- kfe(x=x, G=2*G, deriv.order=2*r, inc=1, binned=binned, bin.par=bin.par, bgridsize=bgridsize, verbose=verbose, add.index=FALSE) bias2 <- drop((-1)^r*Kpow(vId,r) %*% (scv1 - 2*scv2 + scv3)) if (bias2 < 0) bias2 <- 0 } scvmat <- 1/(det(H)^(1/2)*n)*nur(r=r, A=Hinv, mu=rep(0,d), Sigma=diag(d), type="direct")*2^(-d-r)*pi^(-d/2) + bias2 return (scvmat) } ############################################################################### # Find the bandwidth that minimises the SCV for 1 to 6 dim # # Parameters # x - data values # pre - "scale" - pre-scaled data # - "sphere"- pre-sphered data # Hstart - initial bandwidth matrix # # Returns # H_SCV ############################################################################### hscv <- function(x, nstage=2, binned=TRUE, bgridsize, plot=FALSE) { sigma <- sd(x) n <- length(x) d <- 1 hnorm <- sqrt((4/(n*(d + 2)))^(2/(d + 4)) * var(x)) if (missing(binned)) binned <- default.bflag(d=d,n=n) if (missing(bgridsize)) bgridsize <- default.bgridsize(d) hmin <- 0.1*hnorm hmax <- 2*hnorm bin.par <- binning(x=x, bgridsize=bgridsize, h=hnorm) if (nstage==1) { psihat6 <- psins.1d(r=6, sigma=sigma) psihat10 <- psins.1d(r=10, sigma=sigma) } else if (nstage==2) { g1 <- (2/(7*n))^(1/9)*2^(1/2)*sigma g2 <- (2/(11*n))^(1/13)*2^(1/2)*sigma psihat6 <- kfe.1d(x=x, bin.par=bin.par, binned=binned, deriv.order=6, g=g1, inc=1) psihat10 <- kfe.1d(x=x, bin.par=bin.par, binned=binned, deriv.order=10, g=g2, inc=1) } g3 <- (-6/((2*pi)^(1/2)*psihat6*n))^(1/7) g4 <- (-210/((2*pi)^(1/2)*psihat10*n))^(1/11) psihat4 <- kfe.1d(x=x, bin.par=bin.par, binned=binned, deriv.order=4, g=g3, inc=1) psihat8 <- kfe.1d(x=x, bin.par=bin.par, binned=binned, deriv.order=8, g=g4, inc=1) C <- (441/(64*pi))^(1/18) * (4*pi)^(-1/5) * psihat4^(-2/5) * psihat8^(-1/9) scv.1d.temp <- function(h) { return(scv.1d(x=x, bin.par=bin.par, h=h, g=C*n^(-23/45)*h^(-2), binned=binned, inc=1)) } if (plot) { hseq <- seq(hmin,hmax, length=400) hscv.seq <- rep(0, length=length(hseq)) for (i in 1:length(hseq)) hscv.seq[i] <- scv.1d.temp(hseq[i]) plot(hseq, hscv.seq, type="l", xlab="h", ylab="SCV(h)") } opt <- optimise(f=scv.1d.temp, interval=c(hmin, hmax))$minimum if (n >= 1e5) warning("hscv is not always stable for large samples") return(opt) } Hscv <- function(x, nstage=2, pre="sphere", pilot, Hstart, binned, bgridsize, amise=FALSE, deriv.order=0, verbose=FALSE, optim.fun="optim") { n <- nrow(x) d <- ncol(x) r <- deriv.order if (missing(binned)) binned <- default.bflag(d=d,n=n) if (d > 4) binned <- FALSE if (missing(bgridsize)) bgridsize <- default.bgridsize(d) ##if (d>=4 & nstage==2) bgridsize <- rep(11,d) if(!is.matrix(x)) x <- as.matrix(x) if (missing(pilot)) {if (d==2 & r==0) pilot <- "samse" else pilot <- "dscalar"} pilot1 <- match.arg(pilot, c("amse", "samse", "unconstr", "dunconstr", "dscalar")) pre1 <- match.arg(pre, c("scale", "sphere")) optim.fun1 <- match.arg(optim.fun, c("nlm", "optim")) if (pilot1=="amse" & (d>2 | r>0)) stop("amse pilot selectors not defined for d>2 and/or r>0") if ((pilot1=="samse" | pilot1=="unconstr") & r>0) stop("dscalar or dunconstr pilot selectors are better for deriv.order>0") if (pre1=="scale") { x.star <- pre.scale(x) S12 <- diag(sqrt(diag(var(x)))) Sinv12 <- chol2inv(chol(S12)) } else if (pre1=="sphere") { x.star <- pre.sphere(x) S12 <- matrix.sqrt(var(x)) Sinv12 <- chol2inv(chol(S12)) } RK <- (4*pi)^(-d/2) if (binned) { if (pilot1=="unconstr" | pilot1=="dunconstr") H.max <- (((d+8)^((d+6)/2)*pi^(d/2)*RK)/(16*(d+2)*n*gamma(d/2+4)))^(2/(d+4))* var(x) else H.max <- (((d+8)^((d+6)/2)*pi^(d/2)*RK)/(16*(d+2)*n*gamma(d/2+4)))^(2/(d+4))* var(x.star) if (default.bflag(d=d, n=n)) bin.par <- binning(x=x.star, bgridsize=bgridsize, H=matrix.sqrt(H.max)) } if (pilot1=="unconstr") { ## Gu pilot matrix is on data scale Gu <- Gunconstr.scv(x=x, binned=binned, bgridsize=bgridsize, verbose=verbose, nstage=nstage-1, optim.fun=optim.fun) if (missing(Hstart)) Hstart <- Hns(x=x, deriv.order=r) } else if (pilot1=="dunconstr") { ## Gu pilot matrix is on data scale Gu <- Gdunconstr(x=x, d=d, r=r, n=n, nstage=nstage, verbose=verbose, binned=binned, scv=TRUE, optim.fun=optim.fun) if (missing(Hstart)) Hstart <- Hns(x=x, deriv.order=r) } else if (pilot1=="dscalar") { ## Gs is on pre-transformed data scale g2r4 <- gdscalar(x=x.star, d=d, r=r, n=n, nstage=nstage, verbose=verbose, scv=TRUE, binned=binned) Gs <- g2r4^2*diag(d) if (missing(Hstart)) Hstart <-Hns(x=x.star, deriv.order=r) } else { ## Gs is on transformed data scale Hamise <- Hpi(x=x.star, nstage=1, deriv.order=r, pilot=pilot, pre="sphere", binned=TRUE, bgridsize=bgridsize, verbose=verbose, optim.fun=optim.fun) if (any(is.na(Hamise))) { warning("Pilot bandwidth matrix is NA - replaced with maximally smoothed") Hamise <- (((d+8)^((d+6)/2)*pi^(d/2)*RK)/(16*(d+2)*n*gamma(d/2+4)))^(2/(d+4))* var(x.star) } gs <- gamse.scv(x.star=x.star, d=d, Sigma.star=var(x.star), Hamise=Hamise, n=n, binned=binned, bgridsize=bgridsize, verbose=verbose, nstage=nstage-1) Gs <- gs^2*diag(d) ## use normal reference bandwidth as initial condition if (missing(Hstart)) Hstart <- Hns(x=x.star, deriv.order=r) else Hstart <- Sinv12 %*% Hstart %*% Sinv12 } ## SCV is estimate of AMISE scv.mat.temp <- function(vechH) { H <- invvech(vechH) %*% invvech(vechH) if (pilot1=="samse" | pilot1=="amse" | pilot1=="dscalar"){ Gpilot <- Gs; xx <- x.star } else if (pilot1=="unconstr" | pilot1=="dunconstr") { Gpilot <- Gu; xx <- x } if (default.bflag(d=d, n=n)) scvm <- scv.mat(x=xx, H=H, G=Gpilot, binned=binned, bin.par=bin.par, verbose=FALSE, deriv.order=r) else scvm <- scv.mat(x=xx, H=H, G=Gpilot, binned=binned, verbose=FALSE, deriv.order=r) return(scvm) } Hstart <- matrix.sqrt(Hstart) if (optim.fun1=="nlm") { result <- nlm(p=vech(Hstart), f=scv.mat.temp, print.level=2*as.numeric(verbose)) H <- invvech(result$estimate) %*% invvech(result$estimate) amise.star <- result$minimum } else if (optim.fun=="optim") { result <- optim(vech(Hstart), scv.mat.temp, method="BFGS", control=list(trace=as.numeric(verbose))) H <- invvech(result$par) %*% invvech(result$par) amise.star <- result$value } if (!(pilot1 %in% c("dunconstr","unconstr"))) H <- S12 %*% H %*% S12 ## back-transform if (!amise) return(H) else return(list(H = H, SCV.star=amise.star)) } Hscv.diag <- function(x, nstage=2, pre="scale", pilot, Hstart, binned, bgridsize, amise=FALSE, deriv.order=0, verbose=FALSE, optim.fun="optim") { n <- nrow(x) d <- ncol(x) r <- deriv.order RK <- (4*pi)^(-d/2) if (missing(binned)) binned <- default.bflag(d=d,n=n) if (d > 4) binned <- FALSE if (missing(bgridsize)) bgridsize <- default.bgridsize(d) if(!is.matrix(x)) x <- as.matrix(x) if (missing(pilot)) {if (d==2 & r==0) pilot <- "samse" else pilot <- "dscalar"} pilot1 <- match.arg(pilot, c("amse", "samse", "unconstr", "dunconstr", "dscalar")) pre1 <- match.arg(pre, c("scale", "sphere")) optim.fun1 <- match.arg(optim.fun, c("nlm", "optim")) if (pilot1=="amse" & (d>2 | r>0)) stop("samse pilot selectors are better for higher dimensions and/or deriv.order>0") if (pilot1=="samse" & r>0) stop("dscalar pilot selectors are better for deriv.order>0") if (pilot1=="unconstr" | pilot1=="dunconstr") stop("Unconstrained pilot selectors are not suitable for Hscv.diag") if (pre1=="sphere") stop("Using pre-sphering doesn't give a diagonal bandwidth matrix") if (pre1=="scale") { x.star <- pre.scale(x) S12 <- diag(sqrt(diag(var(x)))) Sinv12 <- chol2inv(chol(S12)) } else if (pre1=="sphere") { x.star <- pre.sphere(x) S12 <- matrix.sqrt(var(x)) Sinv12 <- chol2inv(chol(S12)) } if (binned) { H.max <- (((d+8)^((d+6)/2)*pi^(d/2)*RK)/(16*(d+2)*n*gamma(d/2+4)))^(2/(d+4))* var(x.star) bin.par.star <- binning(x=x.star, bgridsize=bgridsize, H=H.max) } if (pilot1=="dscalar") { ## Gs is on pre-transformed data scale g2r4 <- gdscalar(x=x.star, r=r, n=n, d=d, verbose=verbose, nstage=nstage, scv=TRUE, binned=binned) Gs <- g2r4^2*diag(d) if (missing(Hstart)) Hstart <- Hns(x=x.star, deriv.order=r) } else { ## Gs is on transformed data scale Hamise <- Hpi(x=x.star, nstage=1, pilot=pilot, pre="sphere", binned=binned, bgridsize=bgridsize, verbose=verbose, optim.fun=optim.fun) if (any(is.na(Hamise))) { warning("Pilot bandwidth matrix is NA - replaced with maximally smoothed") Hamise <- (((d+8)^((d+6)/2)*pi^(d/2)*RK)/(16*(d+2)*n*gamma(d/2+4)))^(2/(d+4))* var(x.star) } gs <- gamse.scv(x.star=x.star, d=d, Sigma.star=var(x.star), Hamise=Hamise, n=n, binned=binned, bgridsize=bgridsize, verbose=verbose, nstage=nstage-1) Gs <- gs^2*diag(d) ## use normal reference bandwidth as initial condition if (missing(Hstart)) Hstart <- Hns(x=x.star, deriv.order=r) else Hstart <- Sinv12 %*% Hstart %*% Sinv12 } scv.mat.temp <- function(diagH) { H <- diag(diagH) %*% diag(diagH) if (default.bflag(d=d, n=n)) scvm <- scv.mat(x.star, H, Gs, binned=binned, verbose=FALSE, bin.par=bin.par.star, deriv.order=r) else scvm <- scv.mat(x.star, H, Gs, binned=binned, verbose=FALSE, deriv.order=r) return(scvm) } Hstart <- matrix.sqrt(Hstart) if (optim.fun1=="nlm") { result <- nlm(p=diag(Hstart), f=scv.mat.temp, print.level=2*as.numeric(verbose)) H <- diag(result$estimate) %*% diag(result$estimate) amise.star <- result$minimum } else if (optim.fun1=="optim") { result <- optim(diag(Hstart), scv.mat.temp, method="Nelder-Mead", control=list(trace=as.numeric(verbose))) H <- diag(result$par) %*% diag(result$par) amise.star <- result$value } ## back-transform H <- S12 %*% H %*% S12 if (!amise) return(H) else return(list(H = H, SCV.star=amise.star)) } ############################################################################## ## Normal scale selector H_ns for kernel density derivate estimators ############################################################################## Hns <- function(x, deriv.order=0) { if (is.vector(x)){ n<-1; d <- length(x)} else { n <- nrow(x); d <- ncol(x)} r <- deriv.order H <- (4/(n*(d+2*r+2)))^(2/(d+2*r+4)) * var(x) return(H) } Hns.diag <- function(x) { if (is.vector(x)){ n<-1; d <- length(x)} else { n <- nrow(x); d <- ncol(x)} S <- var(x) Delta <- chol2inv(chol(diag(diag(S))))%*%S Deltainv <- chol2inv(chol(Delta)) H <- ((4*d*det(Delta)^(1/2))/(2*tr(Deltainv%*% Deltainv) + (tr(Deltainv))^2))^(2/(d+4))*diag(diag(S))*n^(-2/(d+4)) return(H) } hns <- function(x, deriv.order=0) { n <- length(x) d <- 1 r <- deriv.order h <- (4/(n*(d+2*r+2)))^(1/(d+2*r+4))*sd(x) return(h) } ####################################################################### ## Normal scale G_ns for kernel functional estimators ####################################################################### Gns <- function(r,n,Sigma) { d <- ncol(Sigma) G <- (2/((n*(d+r))))^(2/(d+r+2))*2*Sigma return(G) } ############################################################################## ## Normal mixture selector ############################################################################## Hnm <- function(x, deriv.order=0, G=1:9, subset.ind, mise.flag=FALSE, verbose=FALSE, ...) { if (!requireNamespace("mclust", quietly=TRUE)) stop("Install the mclust package as it is required.", call.=FALSE) if (!missing(subset.ind)) nmixt.fit <- mclust::Mclust(x[subset.ind,], G=G, verbose=verbose, ...) else nmixt.fit <- mclust::Mclust(x, G=G, verbose=verbose, ...) if (is.vector(x)) {d <- length(x); n <- 1} else {d <- ncol(x); n <- nrow(x)} mus <- t(nmixt.fit$parameters$mean) Sigmas <- matrix(nmixt.fit$parameters$variance$sigma, byrow=TRUE, ncol=d) props <- nmixt.fit$parameters$pro if (mise.flag) H.nm <- Hmise.mixt(samp=n, mus=mus, Sigmas=Sigmas, props=props, deriv.order=deriv.order) else H.nm <- Hamise.mixt(samp=n, mus=mus, Sigmas=Sigmas, props=props, deriv.order=deriv.order) return(H.nm) } Hnm.diag <- function(x, deriv.order=0, G=1:9, subset.ind, mise.flag=FALSE, verbose=FALSE, ...) { if (!requireNamespace("mclust", quietly=TRUE)) stop("Install the mclust package as it is required.", call.=FALSE) if (!missing(subset.ind)) nmixt.fit <- mclust::Mclust(x[subset.ind,], G=G, verbose=verbose, ...) else nmixt.fit <- mclust::Mclust(x, G=G, verbose=verbose, ...) if (is.vector(x)) {d <- length(x); n <- 1} else {d <- ncol(x); n <- nrow(x)} mus <- t(nmixt.fit$parameters$mean) Sigmas <- matrix(nmixt.fit$parameters$variance$sigma, byrow=TRUE, ncol=d) props <- nmixt.fit$parameters$pro if (mise.flag) H.nm <- Hmise.mixt.diag(samp=n, mus=mus, Sigmas=Sigmas, props=props, deriv.order=deriv.order) else H.nm <- Hamise.mixt.diag(samp=n, mus=mus, Sigmas=Sigmas, props=props, deriv.order=deriv.order) return(H.nm) } hnm <- function(x, deriv.order=0, G=1:9, subset.ind, mise.flag=FALSE, verbose=FALSE, ...) { if (!missing(subset.ind)) nmixt.fit <- mclust::Mclust(x[subset.ind], G=G, verbose=verbose, ...) else nmixt.fit <- mclust::Mclust(x, G=G, verbose=verbose, ...) mus <- nmixt.fit$parameters$mean sigmas <- sqrt(nmixt.fit$parameters$variance$sigma) props <- nmixt.fit$parameters$pro n <- length(x) if (mise.flag) h.nm <- hmise.mixt(samp=n, mus=mus, sigmas=sigmas, props=props, deriv.order=deriv.order) else h.nm <- hamise.mixt(samp=n, mus=mus, sigmas=sigmas, props=props, deriv.order=deriv.order) return(h.nm) } ks/R/hist.R0000644000176200001440000001365713262114464012201 0ustar liggesusers############################################################################# ## Histogram density estimators ############################################################################# histde <- function(x, binw, xmin, xmax, adj=0) { if (is.vector(x)) { d <- 1; n <- length(x) if (missing(binw)) binw <- 2*3^(1/(d+2))*pi^(2/(2*d+4))*sd(x)*length(x)^(-1/(d+2)) nbin <- round(diff(range(x))*1.2/binw, 0) } else { d <- ncol(x); n <- nrow(x) if (missing(binw)) binw <- 2*3^(1/(d+2))*pi^(2/(2*d+4))*apply(x, 2, sd)*nrow(x)^(-1/(d+2)) nbin <- round(apply(apply(x, 2, range), 2, diff)*1.2/binw,0) } if (d==1) fhat <- hist.1d(x, binw=binw, xmin=xmin, xmax=xmax, adj=adj) else if (d==2) fhat <- hist.2d(x=x, binw=binw, xmin=xmin, xmax=xmax, adj=adj) fhat$names <- parse.name(x) class(fhat) <- "histde" ## compute prob contour levels #if (compute.cont & missing(eval.points)) # fhat$cont <- contourLevels(fhat, cont=1:99, approx=TRUE) return(fhat) } hist.1d <- function(x, nbin, binw, x.cut, xmin, xmax, adj=0, ...) { if (missing(xmin)) xmin <- min(x) if (missing(xmax)) xmax <- max(x) if (missing(nbin)) nbin <- round(diff(range(x))*1.2/binw, 0) if (missing(x.cut)) x.cut <- seq(from=xmin-0.1*(xmax-xmin), to=xmax+0.1*(xmax-xmin), length=nbin+1) if (missing(binw)) binw <- diff(x.cut)[1] x.cut <- x.cut + adj*binw hs <- hist(x=x, breaks=x.cut, plot=FALSE) hs <- list(x=x, estimate=hs$density, eval.points=hs$breaks, binw=binw, nbin=nbin) class(hs) <- "histde" return(hs) } ############################################################################## ## 2D histogram ############################################################################## hist.2d <- function(x, nbin, binw, x.cut, xmin, xmax, adj=0, ...) { if (missing(nbin)) nbin <- round(apply(apply(x, 2, range), 2, diff)*1.2/binw,0) if (length(nbin)==1) nbin <- rep(nbin,2) if (missing(xmin)) xmin <- apply(x, 2, min) if (missing(xmax)) xmax <- apply(x, 2, max) if (missing(x.cut)) x.cut <- list(seq(from=xmin[1]-0.1*(xmax[1]-xmin[1]), to=xmax[1]+0.1*(xmax[1]-xmin[1]), length=nbin[1]+1), seq(from=xmin[2]-0.1*(xmax[2]-xmin[2]), to=xmax[2]+0.1*(xmax[2]-xmin[2]), length=nbin[2]+1)) if (missing(binw)) binw <- c(diff(x.cut[[1]])[1], diff(x.cut[[2]])[1]) x.cut[[1]] <- x.cut[[1]] + adj*binw[1] x.cut[[2]] <- x.cut[[2]] + adj*binw[2] index.x <- cut(x[,1], x.cut[[1]], include.lowest=TRUE) index.y <- cut(x[,2], x.cut[[2]], include.lowest=TRUE) m <- matrix(0, nrow=nbin[1], ncol=nbin[2], dimnames=list(levels(index.x), levels(index.y))) for (i in 1:length(index.x)) m[index.x[i], index.y[i]] <- m[index.x[i], index.y[i]] + 1 hs2d <- list(x=x, estimate=m/(nrow(x)*prod(binw)), eval.points=x.cut, binw=binw, nbin=nbin) class(hs2d) <- "histde" return(hs2d) } ## plot histograms plot.histde <- function(x, ...) { if (is.vector(x$x)) plot.histde.1d(fhat=x, ...) else plot.histde.2d(fhat=x, ...) invisible() } plot.histde.1d <- function(fhat, xlab, ylab="Density function", add=FALSE, drawpoints=FALSE, col.pt="blue", jitter=FALSE, border=1, ...) { if (missing(xlab)) xlab <- fhat$names if (!add) plot(fhat$eval.points, c(fhat$estimate,0), type="n", xlab=xlab, ylab=ylab, ...) rect(fhat$eval.points[-length(fhat$eval.points)], 0, fhat$eval.points[-1], fhat$estimate, border=border, ...) if (drawpoints) if (jitter) rug(jitter(fhat$x), col=col.pt) else rug(fhat$x, col=col.pt) } plot.histde.2d <- function(fhat, breaks, nbreaks=11, xlab, ylab, zlab="Density function", cex=1, pch=1, add=FALSE, drawpoints=FALSE, col, col.fun, col.pt="blue", lty.rect=2, cex.text=1, border, lwd.rect=1, col.rect="transparent", add.grid=TRUE, ...) { if (missing(xlab)) xlab <- fhat$names[1] if (missing(ylab)) ylab <- fhat$names[2] if (missing(border)) border <- grey(0.5) if (!add) plot(fhat$x, col=col.pt, type="n", xlab=xlab, ylab=ylab, ...) if (missing(breaks)) breaks <- seq(min(fhat$estimate,0), max(fhat$estimate)+0.1*diff(range(fhat$estimate)), length=nbreaks) if (missing(col.fun)) col.fun <- function(n){rev(heat.colors(n))} if (missing(col)) col <- col.fun(n=length(breaks)) for (i in 1:(nrow(fhat$estimate))) for (j in 1:(ncol(fhat$estimate))) { if (fhat$estimate[i,j]>=breaks[2]) { rect(fhat$eval.points[[1]][i], fhat$eval.points[[2]][j], fhat$eval.points[[1]][i+1], fhat$eval.points[[2]][j+1], col=col[findInterval(fhat$estimate[i,j], breaks)], lty=lty.rect, border=border, lwd=lwd.rect) } } if (add.grid) { for (i in 1:length(fhat$eval.points[[1]])) lines(rep(fhat$eval.points[[1]][i],2), range(fhat$eval.points[[2]]), col=border, ...) for (j in 1:length(fhat$eval.points[[2]])) lines(range(fhat$eval.points[[1]]), rep(fhat$eval.points[[2]][j],2), col=border, ...) ##abline(v=ev1, h=ev2, col=border, ...) } if (drawpoints) points(fhat$x[,1], fhat$x[,2], col=col.pt, cex=cex, pch=pch) } predict.histde <- function(object, ..., x) { fhat <- object$estimate if (!is.list(object$eval.points)) d <- 1 else d <- length(object$eval.points) if (d == 1) { gs <- length(object$eval.points) x.ind <- findInterval(x, object$eval.points, all.inside = FALSE) fhat[x.ind == 0] <- object$estimate[1] fhat[x.ind == gs] <- object$estimate[gs] } else { x <- matrix(x, ncol = d) gs <- sapply(object$eval.points, length) x.ind <- matrix(0, nrow = nrow(x), ncol = d) for (i in 1:d) x.ind[, i] <- findInterval(x[, i], object$eval.points[[i]], all.inside = FALSE) x.ind[x.ind == 0] <- 1 x.ind.flag <- x.ind == 1 for (i in 1:d) x.ind.flag[, i] <- x.ind.flag[, i] | x.ind[, i] == gs[i] } return(fhat[x.ind]) } contourLevels.histde <- function(...) { return(contourLevels.kde(...)) } ks/R/kdr.R0000644000176200001440000001254713257005542012007 0ustar liggesusers###################################################################### ## Kernel density ridge estimation for 2D/3D data ##################################################################### kdr <- function(x, y, H, p=1, max.iter=400, tol.iter, tol.seg, min.seg.size, keep.path=FALSE, gridsize, xmin, xmax, binned, bgridsize, w, fhat, density.cutoff, verbose=FALSE) { ## default values ksd <- ks.defaults(x=x, binned=binned, bgridsize=bgridsize, gridsize=gridsize) d <- ksd$d; n <- ksd$n; w <- ksd$w binned <- ksd$binned bgridsize <- ksd$bgridsize gridsize <- ksd$gridsize if (missing(tol.iter)) tol.iter <- 1e-3*min(apply(x, 2, IQR)) if (missing(tol.seg)) tol.seg <- 1e-2*max(apply(x, 2, IQR)) if (missing(H)) H <- Hpi(x=x, nstage=2-(d>2), binned=default.bflag(d=d, n=n), deriv.order=2, verbose=verbose) Hinv <- chol2inv(chol(H)) tol <- 3.7 tol.H <- tol * diag(H) if (missing(xmin)) xmin <- apply(x, 2, min) - tol.H if (missing(xmax)) xmax <- apply(x, 2, max) + tol.H if (missing(y)) { xx <- seq(xmin[1], xmax[1], length = gridsize[1]) yy <- seq(xmin[2], xmax[2], length = gridsize[2]) if (d==2) y <- expand.grid(xx, yy) else if (d==3) { zz <- seq(xmin[3], xmax[3], length = gridsize[3]) y <- expand.grid(xx, yy, zz) } } if (is.vector(y)) y <- matrix(y, nrow=1) if (missing(min.seg.size)) min.seg.size <- round(1e-3*nrow(y), 0) ## exclude low density regions from ridge search if (missing(fhat)) fhat <- kde(x=x, w=w, binned=binned) if (missing(density.cutoff)) density.cutoff <- contourLevels(fhat, cont=99) y.ind <- predict(fhat, x=y)>density.cutoff y <- y[y.ind,] fhat2 <- kdde(x=x, H=H, deriv.order=2, xmin=xmin, xmax=xmax, binned=binned, bgridsize=bgridsize, gridsize=gridsize, w=w, verbose=verbose) ## projected gradient mean shift iterations n.seq <- block.indices(n, nrow(y), d=d, r=0, diff=FALSE, block.limit=3e6) if (verbose) pb <- txtProgressBar() pc <- list() i <- 1 if (verbose) setTxtProgressBar(pb, i/(length(n.seq)-1)) pc <- kdr.base(x=x, fhat2=fhat2, y=y[n.seq[i]:(n.seq[i+1]-1),], H=H, tol.iter=tol.iter, Hinv=Hinv, verbose=verbose, max.iter=max.iter, p=p) if (length(n.seq)>2) { for (i in 2:(length(n.seq)-1)) { if (verbose) setTxtProgressBar(pb, i/(length(n.seq)-1)) pc.temp <- kdr.base(x=x, fhat2=fhat2, y=y[n.seq[i]:(n.seq[i+1]-1),], H=H, tol.iter=tol.iter, Hinv=Hinv, verbose=verbose, max.iter=max.iter, p=p) pc$y <- rbind(pc$y, pc.temp$y) pc$end.points <- rbind(pc$end.points, pc.temp$end.points) pc$path <- c(pc$path, pc.temp$path) } } if (verbose) close(pb) ## remove short segments for p=1 if (p==1) { pc.dendo <- hclust(dist(pc$end.points), method="single") pc.label <- cutree(pc.dendo, h=tol.seg) pc.label.ind <- pc.label %in% which(table(pc.label)>min.seg.size) pc$y <- pc$y[pc.label.ind,] pc$end.points <- pc$end.points[pc.label.ind,] pc$H <- H pc$path <- pc$path[pc.label.ind] pc$label <- factor(pc.label[pc.label.ind]) levels(pc$label) <- 1:length(levels(pc$label)) pc$label <- as.numeric(pc$label) } ## put paths as last element in list path.temp <- pc$path pc$path <- NULL pc$tol.iter <- tol.iter pc$tol.seg <- tol.seg pc$min.seg.size <- min.seg.size pc$binned <- binned pc$names <- parse.name(x) pc$w <- w if (keep.path) pc$path <- path.temp return(pc) } kdr.base <-function(x, fhat2, H, y, max.iter, tol.iter, p=1, verbose=FALSE, Hinv, ...) { if (!is.matrix(x)) x <- as.matrix(x) if (!is.matrix(y)) y <- as.matrix(y) if (missing(Hinv)) Hinv <- chol2inv(chol(H)) nx <- nrow(x) ny <- nrow(y) d <- ncol(y) y.path <- split(y, row(y), drop=FALSE) names(y.path) <- NULL xHinv <- x %*% Hinv xHinvx <- rowSums(xHinv*x) y.update <- y i <- 1 eps <- max(sqrt(rowSums(y.update^2))) disp.ind <- head(sample(1:nrow(y)), n=min(1000,nrow(y))) while (eps > tol.iter & i < max.iter) { y.curr <- y.update yHinvy <- t(rowSums(y.curr%*%Hinv *y.curr)) Mah <- apply(yHinvy, 2, "+", xHinvx) - 2*xHinv %*% t(y.curr) w <- exp(-Mah/2) denom <- colSums(w) num <- t(w)%*%x mean.shift.H <- num/denom - y.curr fhat2.y.curr <- predict(fhat2, x=y.curr) for (j in 1:ny) { Hessian <- invvec(fhat2.y.curr[j,]) Hessian.svd <- eigen(Hessian, symmetric=TRUE) Up <- Hessian.svd$vectors[,tail(1:d,n=d-p)] mean.shift.H[j,] <- drop(Up %*% t(Up) %*% mean.shift.H[j,]) } y.update <- y.curr + mean.shift.H y.update.list <- split(y.update, row(y.update), drop=FALSE) y.path <- mapply(rbind, y.path, y.update.list, SIMPLIFY=FALSE) eps <- max(sqrt(rowSums((y.curr-y.update)^2))) if (verbose>1) { if (d==2) plot(y.update[disp.ind,], col=1, xlab="x", ylab="y") else pairs(y.update[disp.ind,], col=1) } i <- i+1 } pc.endpt <- t(sapply(y.path, tail, n=1, SIMPLIFY=FALSE)) pc <- list(x=x, y=y, end.points=pc.endpt, path=y.path) class(pc) <- "kdr" return(pc) } ks/MD50000644000176200001440000001041213620451512011174 0ustar liggesusersd7b4faae76ddb1c7354a3a327be254e3 *CHANGELOG 4db2838d73a1af56de5098991e2a67c7 *DESCRIPTION 67c5c3127482ba7ea1770068d5d428c7 *NAMESPACE 5904c0a7cfda51bf48f8361632d388b9 *R/binning.R 81a135908c91c83359ca16de9cddeec8 *R/deconv-kde.R 79c64502c06e449e90c07d6d7d56fb60 *R/hist.R 2c7e7957c3381128b22e89aeebadd2ec *R/integrate-kde.R a3411cdabc97ad13b392e6da952a0aa8 *R/kcde.R c59e02ecde86686454e976a6c40c4b19 *R/kcopula.R cb7f3188d719329c9d346df0f4872f81 *R/kda.R b1907f9c6040e979ea841e79c573d502 *R/kdde.R 7309fa4380b6a2dd9fe1fc1ab297cecb *R/kde-boundary.R f72432d669f4da92146887ca21ad5078 *R/kde-test.R b6ed1af2e092ffac7b074c00339b9d9c *R/kde.R b8c1b3b53156de8b6e4802096d3cf5f4 *R/kdr.R 4d1e1f03eab0ed514c8208d1d9d228f1 *R/kfe.R 85583dc7d488fb13195d7c1b0b9a645b *R/kfs.R a2878af62cb94eb7be1404f2f34fa53c *R/kms.R ae2db321d6d430d0507b697a895b3b88 *R/kr.R 8247721d5fe09f00538a8350122d6388 *R/ksupp.R f032b244be84390facacd2ee529476c6 *R/mise.R b6f77557a7ab726a47d446d242d99259 *R/normal.R 72e2b397bf8f42aee0ea303ed49b9cc0 *R/prelim.R 8451fd37a7a64cbfa765a8ee7b04ffba *R/selector.R e68a52fb96cbce55833a0fd7766152d4 *R/vkde.R 6c70c99d2b88d82a74ef52b332f72122 *build/vignette.rds 3c7be27cb3c3505cb05a32dbdc3429ce *data/air.RData 421d741ffd92ca967c18a8f69a4824dc *data/cardio.RData 0b36987e874b237b5f47264783c15d56 *data/grevillea.RData 4d7c1de5dc3f1f1439c334bdab304544 *data/hsct.RData 9c17a5b702e37cd8622d47e8fcd28de7 *data/plate.RData 538a3d83385e0ed088088650f01931b6 *data/quake.RData cfd66d7c906e51e34dcc3138079b5aa2 *data/tempb.RData 000e3e99be5ef662b38c44716894009a *data/unicef.RData 9bbcbfd4701d3cf7b336d8d4a2d15226 *data/worldbank.RData 98233c320602e02860adfb695a903cea *inst/doc/kde.R 67b2ecacaa219eb280291a7e3fef063a *inst/doc/kde.Rnw a193b8913bb4e228e2275cc51e2d56ff *inst/doc/kde.pdf a552ddadac60a9371838f1232332e9c0 *man/Hbcv.Rd 46c0e4015819caebcddf6ab57916b208 *man/Hlscv.Rd 0de7cc39a26a1a4f31958ca079054f4e *man/Hnm.Rd 8d20eb3c1df93c5f50020b5b9bb01523 *man/Hns.Rd 2344c2c97f86c7935e8af10e05f92048 *man/Hpi.Rd 06dc834c8a5cd08173db5dbd12fe6da3 *man/Hscv.Rd 79d1d98cb86093b6d15d644f4992db0f *man/air.Rd a4be1c4fd0eefcd11269a8fb1a8edd9c *man/binning.Rd 4a76760abbe8932e97607ed562ba44c5 *man/cardio.Rd 5a797d0ae490bdac29a487906e8964d5 *man/contour.Rd c750cd7f7e0251357a1226b8bd65f757 *man/grevillea.Rd bb82dffbf943f95787dc2c21ae11b98c *man/histde.Rd f2a4d0c195abd4238b8262ecf912dcc3 *man/hsct.Rd 424ca1593ffeba56dab8bf8fe6fc6ae8 *man/ise.mixt.Rd 39a020d2daebc8e865eb96536d643027 *man/kcde.Rd 0b9bc5a69ad974fd745070a23b75bf6b *man/kcopula.Rd 8d8b3938c8252e5ffea632aaf44c1cbb *man/kda.Rd b53482585b84d5a22267eb298cf1b5b2 *man/kdcde.Rd fa7ef8f70f0a5bf2dee8ca8d3520d327 *man/kdde.Rd 8818b57bd5211a3dd54db15c201479b8 *man/kde.Rd 0b10a538029d44150de8cf680efd268d *man/kde.boundary.Rd 537626554e3a3b9f815bbb1c96e1ce9d *man/kde.local.test.Rd 85c9f9603f286266378a0756a060ef72 *man/kde.test.Rd 23cd3433759f50c19355f7ce2c764dd4 *man/kde.truncate.Rd 15e0ae5f09312d43911ab030775d389d *man/kdr.Rd c917f82a0091d96b0b55ec5abfd14e5c *man/kfe.Rd f7987b21dc246a0c292aed0685b8dc3f *man/kfs.Rd 420e71c0b7a4510b5d8d1a20d9397332 *man/kms.Rd d9915065d816a803b769b25bd3dd07aa *man/kroc.Rd fe4a517f1f253ba81069544459b1f266 *man/ks-internal.Rd c43c8a669e06d41597f580ba97377214 *man/ks-package.Rd 55197436cf0e1256d85cba00b06a4108 *man/ksupp.Rd 143cc46e0a7957338bcedee1c1e5cd94 *man/mixt.Rd 1bbd60fcff696c705e347050ec5a2e2a *man/plot.histde.Rd d461a57e7c2cb92094a465a8e32e901c *man/plot.kcde.Rd 5c855b74a83a3d2546377c65f4fd94f0 *man/plot.kda.Rd 80d580d20603a6a44ac9b840d49d04d5 *man/plot.kdde.Rd c3fc52b210ba14b0a32eb3c113037830 *man/plot.kde.Rd 447f5960cd6e5ddf3bcb98f8cf8f3a11 *man/plot.kde.loctest.Rd f70566e7397d82656e49d1eac92951b2 *man/plot.kde.part.Rd 764fa76bd2a8af745710c15cc696e4e0 *man/plot.kfs.Rd fcd5987c5287755e41def3ea4904562a *man/plot.kroc.Rd 5198f6f7624fa6cc118cb0770b1edd91 *man/plotmixt.Rd 09f6bb388d05f6dc1b0402331e38e46e *man/pre.transform.Rd c198b09ca9bb6ff7609731fb9b9f96a2 *man/quake.Rd 53b33be82c9432838334f638f5b21475 *man/rkde.Rd e2a1d478c968d08fd7a96c0fcf25cffe *man/tempb.Rd f7953c065505c49636994f769cea6c60 *man/unicef.Rd b81e8a9f86c4d2fbf8cd4992a35795fa *man/vector.Rd 5357f702cd5e5d68ace388043c268ab5 *man/vkde.Rd 0d4f303c2f74335780444f73a4b67df3 *man/worldbank.Rd 9f2af8aa0744c09e3ec177c998361f29 *src/ks.c 67b2ecacaa219eb280291a7e3fef063a *vignettes/kde.Rnw ks/inst/0000755000176200001440000000000013620371402011642 5ustar liggesusersks/inst/doc/0000755000176200001440000000000013620371402012407 5ustar liggesusersks/inst/doc/kde.pdf0000644000176200001440000066160313620371402013661 0ustar liggesusers%PDF-1.5 % 5 0 obj << /Length 3844 /Filter /FlateDecode >> stream xko# }\r/ 5Zg ]K%;]qerM~p8r<ꭵ*%_N6'Jfr|7p&g3#%6oys6BL؂ ;S#,wشn?_`OgVO>%"g?)ZŨ6fC+-z~yΎie_p̤ӓ2J8=jpg̏<@?%5 TU#ͤWdfd%| Rm@D>[<.G5OOHA[⏟O="78~wr ύޟ(¢-ެ"UzS4._._FxH(+K|OA /8cME"˦/s 2ƝƗ8D4nw{p@`bBoy,6n0hbZG1  fIHPkؠŒ2cqMQrx> <:|lxav"Ӣnz a$&ko uņ}Q6cB5%/T#XyP&W=#@iQRO_Z(7e S *k{ T%$IxfJо"?3qj,Ċ)!) HZWvq]28E ̀5XTa{Q-hE 1Ʌ}(f.!w2|ՀOz֍stue"G!:.qE!6V{g֬.4Gjs3fN1Z]au6u;Kh6E)Y-Apn27;F])hO93ga{*8`⢅O&P@@G dCz#+hLnHQT*P* X6d5gEJsZZt5Hi@lC oG X,/|,Fbwtr(~*wkl0pS K+8Vܬp8PZ"5P 9b_1G+ :A8Pc1'vb.755&# *aMc7}WhDS υ\ZK "87c ( |S:T~ƽwQ፪7h,B>P%t:Z)׫AE { D_%|h^ÑxeDu<XU+!fH0 1gX QmW"DžY=gI~,ؙ@ #,̬}jd[צ3yzԸm6i|(7Ý?MxN; Du I(SDpoD囑{m=A> Xj Y{i,*B1A p7 Kq< nQ@!"+ӲDֲXX8ZwZipѥoODcdEX0QT}yS XB7 d~bί'2ou%C'4L9)W~+"s8CH~a^v\BdCճpx:>Dϻ66n C3(Ϲfzuƒ6/pk<5#*R?jѴJ3'>.btDMvčC2l  \ p5x.4O- Zs̷lo:^1g}=1=UlXfm! S%?ќJ*; ï1:ޥ 5Wa!ێSxM26w}yN vSdMyя_,%e'p[deD R (KZSP j}uZK&?cX=Ó@RiSڟڙkoJ=)I!Xo Rrj꬛|muVfU|uA.CBQu1lb$Mr1TL\PuG%;R/R!( XR]d^KF٧>p7WT@6$91t$u^Ad-GMV!ǵZ TJ5[ &@]gҷDޕmw= ͷ.--IYȱ/ î[Zu+> =&rA̤[%;,RW6qс#u,9|r}`A ʀ.`[)NBZ# (*}*a5<5R5hw,@J`M`Z2 lex=]?q +\KPfY8UI<ی}Qv6>wOQ'KKB:E.Z~~;)09-m@cq^#  ĩS"BTtuWL<)I8UefD{p gǡ0YTS?y* *-GuZf:]p!0®BϪ:PtYDIQ7d0 +v6G(㍼#' :⳯M<\vGαnR-.9_]d)(_,13kV):[YQ^LX,YIrHsXe4OQiwG [ncJAhvJBa9gї9TB@S"Y#Tx(^~b& 6}T#~Dɳ٥>֕#IHQ~|oCU`T sy[dMFZn>}0pV# wv6=}}!t )c}/J01tD~{?8D/Ni endstream endobj 26 0 obj << /Length 1732 /Filter /FlateDecode >> stream xڭXYoF~KP 6܋GiKk!}HhK$:w!( ˝9'V)&>Tib{J8G !,/zSs;Is_%̜ Tλl7OtʴԓDktn&j23/'N{8=YktM&jw`0\︝"L7d%.ص"Pb>{jмr'PEx$s K4f+8* LS}&ǖo27͕wld.]oR{Xf/w&=4DxCs8ٷLv8. ++,f+Y̒%{ S@qL pÙVB mty;Ω-<)U".ʌ* +:5_:yFdY\B-P.ORZ.Lƞ0Z!{9{7-]i=/5VωJ+{$J_φ<*d>WfX؉,,={0xňxts#emX Ċ@ahzl?*~E%(q3kD8 H\_3 ǫ:%6dy2`[I:fUv [^:X]9}aj*ڴӻtǼ"Spy٨sWR&+-qj}fQ3*l8?OVQ5zA5dU,ާ¶WPD&3;K\o匿4 ӝ'Y#Ć5<$D&2X\{:C-gПP9j^g|Ђ:n!{TTh-f%a n{!ۡ[iO"z$n1@ JG¢1¥5k9[!S@*Ԩd=x=L 1F+AZK]Ҭ7b5O13!/B޸";<~KHڏP.% "T{>RxK+R%Ij(GBdiqU' ]aȜQf=Gj\-gX׽Wį@-nHmg Vk=\LMȬ,mg $M(ٜhft rwUXIvKR.܀ݰ᎐ozw OC FYͅ>6Zy*V2\D&^22}w NK]DTq]QlR7‡OCVRO,g J 7Juʈ&nѥR;1E""Y\^7pqkx(oOzqTtJCc W! Ϸx_ʵ-OWEU_|>#O[Kb0 ~r~;AC]B ٲ[~=T}סGYgUnPTpq}/d؃@_XHn`W'鲤_2PEV-% ؅\%Hje) _u naU'']yةn3[2a7Hy~/| endstream endobj 1 0 obj << /Type /XObject /Subtype /Form /FormType 1 /PTEX.FileName (/tmp/RtmpScfW0M/Rbuild7790546f8907/ks/vignettes/kde-002.pdf) /PTEX.PageNumber 1 /PTEX.InfoDict 27 0 R /BBox [0 0 432 432] /Resources << /ProcSet [ /PDF /Text ] /Font << /F2 28 0 R>> /ExtGState << >>/ColorSpace << /sRGB 29 0 R >>>> /Length 7486 /Filter /FlateDecode >> stream xMm7R8C䴿= H QnKUk7JD-1Ƚv}>_|wG~߿Gz^?b?^uP.y7)ow?:nzs {Dz7olc{Nwk _ן5?|?}?__oGﻏ3_eqy.lz?+ǾL x|\'?# #2y rtA^#6BQyxz#]&O'c3.N~- 61[̊l7zyW;3d[s=l|)y5~PO{ #plbQ)w.go+fc0Bn~>.6/rT{_L{w|rV/Lm#Fև<޽(O_/sJ%%~JreWIwyL 24=Xxz{[2wo|3r IQlߏ'lcɋ??t e\?d;r*SܿL g)wT7-ec)7 do+`I6E)7ߟվI~ }lI~ˉק/{,-aO&W?^^k(7?XLO 'hXHF·-æ4re~~lOϾ?lYuڲsaۂFmw㳍nl%7oSǶϛWsmK(jPFȕ).쳩Q繾ij?z rz6C1~|fLѡ|aKʚ3dX?>7Bμ毙HL) r>naff~O6%9C`Vǐ~W7nf{]PeB _p /!/B{ /dOp/DBuGng0}>lL}6?q# w/]_j m>!mחjC0myo< |m=b`ewٶGWO_W|a?;v*^/?L|h}C? ߚ=3ś쯰蟡ϰ/0Cg>!r#S ⫭_a/~B9_&>l=]=c uʿ= Dy+|;*z#W<2GS}~n8099 //@>oog|xطx$y;G<0;RUZO lbU|fjxV׊2'͎_<)3_S> ŷ_x`O|8+D)e?=skv|x>G<N8*0 /wǧg,lm⑿VP•zʧlٸ''V;1kx>:.ˑD>Xa+|Ҷqg>Z|$VB<_Q>>?Pʇ"65LOʧ`(%~~Ѩ/QXQ05CNQ0A:uG ~_窯f="W}fȿB?1UrMW}A!Z=/ ՗|F n>c2ɖoĊ[[7E}H4&@~R>O>uP\qC=X&AQktCiuU5-y`Dȑ"F2%DW=P|eK\x#uݹך׫yTE֌us7%ؖ:7_/~so:=?fmWUʫ {6?qY.͞H%N\F+Ȁ(K̒śf'~nB//̐gWof{f}QWb}k?/hJC0ޜ=?:{} F/&~ -< .%7|zv f Wwy ͆l}{vߌ&:'V8Q``gixx'b:AAle$5c^hDŶk*p;0v*Zv"J[j[AA(/LuFM9S( GCzDͦd".TĆ]dY;4/G(Ʀq.>FJdeY*;R{L~BgjR? <VfCw<'hNT(*RHEJ0L jD*Thoz|P LJT,Ju6[z^&/\zL`7 47T[JFsHmhnc*_GW*'4RbMSWvlOKZu?@SBBsCTw@sMSџ\*E6(4!4Wc6ABsKш|Vu 4#4WЎm<Ҏ\j+ Ei6fIWi)#4:hOvi*P\Wn^h7#L6X*ۨrδb#Co9;R] 47tLYjQ_Y܈R$KݐT*9K0[ܟ((ni4oUZUiuJC* Pzޥ^%{(fJv4c @JB!&SNT{ޥ@/(uA3E4h(Ǧ plTVO)>Pl|@Or|?NO\h 8:p{ y\(J!_MQ]L.&jai _F,L(P9 tptL!.`(.~r:FFfO=DSCUm^:he@p B3"g E6g=y)we=l][@B1~{gyY뉈C̏\bHiڙ1`}lZ֯VS%z6CTYz g\rtWj{"jl2߿!ɬ} 19R>᱁&[?K}F鸿_/e|F&_-Ϙ~fi<y X7QNo_[c_oIS'm+O/mӵO?ѹsVg}X j@O$5uwrv⾿{j76utd6Їґ -xhy\|*ja`rf'+0>h\ѸSwqgD^(\h:CػM'; 4]_ MϦnF+Qho |HhzFd |ۘFж } UGr+9{Ȏ#>c~4Wjsзt^ӍKFzp@MxEīRzg'U~/\QgKx;t2K;^4]X^<_(](̟/tleP1fBBţ}G~?_gnYlwkx{5V|VYod} =+pD|b߮[GzHbaEgFa ^z'zU%P~zX?WaqTYsn_ &7^pnl7`X^guӋ2!حG-\ W/Z:E.ua./OwU=G.[kkr`i Ǽg$OHgPvxpJy@EW@#uQmZ}ȫr}prWKΔ <\Cݽeqo5d鞲w&!$ʞG${,Ů0uBڅ@I%HwU--@d CWɊ GzUf(?k*eg,*C=:s s<|u\xq7>'rܗoA8hxc/O_^p}U;dg>xpKx*T8DϏpƫjāGpUvM:p 2;; 1\<}=pr|n}g8pcykƱk=W#dG WaNÞ]m*)9d9-aL>*rY?ӎ!Gx^z܀%"4Bn p;߹D>d's0қ' S1ҥ'NreK8Tʹ7.U6柝*f \;57e: 9wFrR<8xTlZk*qR<xT_ *cmJs# %lqRz^pPJK?[*\uSwkēCW$8y3g¡ 6Q%1/rCW>:׉}"u_ Wb2Ý W/rdr >d.:QG$ddeK'Ƒ›HȬ^W&p䊓yrX.pr2OLr䟟~>IWUP^κ~‹U\yr q]N}._8 ~~;paO<'aL\hOSP# nLQt2UA*9YKxPgG1v1㍛wnXw93pƒM'IU *3O.Jrkm:骓ǵy}kٟ}^ȓ̾mOɽO..: V sÓ_wq2'5{<@¹˗F9_\ |; qnY@I 8xGHׅg;ccOE mYRFgC<³Cx/p jƱ_ Ư,UF\o?_/4gǡ׵ߋ]PзvO^˷} @xҎ&ۼ"_/9ppMV>,w)ַzONqrX2_Dqx/CҠ <8<8<77d5/}68}3'ǏL+^򕿩^?3UIKɞ@>ICzg 'U=+ z=\yywGskzS_ޚw~>/y \| ӯ@d Kŏ]%g,O8%sԏ{~_^C;U};jx͢D8>S-:j~t]8>I/_Cua7^oρכ/p7ow"N&5] WD $Jp4Uh&,m_-hn@ @=qčm$Tuq< ! Vm ۄyWHy<&ђg7H O GBNC%dJ@P<@뀎B2T15_4$"|'v /7Z 6diw~Mvv^Wkj> stream xwTSϽ7PkhRH H.*1 J"6DTpDQ2(C"QDqpId߼y͛~kg}ֺLX Xňg` lpBF|،l *?Y"1P\8=W%Oɘ4M0J"Y2Vs,[|e92<se'9`2&ctI@o|N6(.sSdl-c(2-yH_/XZ.$&\SM07#1ؙYrfYym";8980m-m(]v^DW~ emi]P`/u}q|^R,g+\Kk)/C_|Rax8t1C^7nfzDp 柇u$/ED˦L L[B@ٹЖX!@~(* {d+} G͋љς}WL$cGD2QZ4 E@@A(q`1D `'u46ptc48.`R0) @Rt CXCP%CBH@Rf[(t CQhz#0 Zl`O828.p|O×X ?:0FBx$ !i@ڐH[EE1PL ⢖V6QP>U(j MFkt,:.FW8c1L&ӎ9ƌaX: rbl1 {{{;}#tp8_\8"Ey.,X%%Gщ1-9ҀKl.oo/O$&'=JvMޞxǥ{=Vs\x ‰N柜>ucKz=s/ol|ϝ?y ^d]ps~:;/;]7|WpQoH!ɻVsnYs}ҽ~4] =>=:`;cܱ'?e~!ańD#G&}'/?^xI֓?+\wx20;5\ӯ_etWf^Qs-mw3+?~O~ endstream endobj 2 0 obj << /Type /XObject /Subtype /Form /FormType 1 /PTEX.FileName (/tmp/RtmpScfW0M/Rbuild7790546f8907/ks/vignettes/kde-003.pdf) /PTEX.PageNumber 1 /PTEX.InfoDict 32 0 R /BBox [0 0 432 432] /Resources << /ProcSet [ /PDF /Text ] /Font << /F1 33 0 R/F2 34 0 R>> /ExtGState << >>/ColorSpace << /sRGB 35 0 R >>>> /Length 2079 /Filter /FlateDecode >> stream x[M\ϯ19fy0!Id@!wUsfg|JOU\K'Ko˫>KKsk[ͳw5}g[ǿ~MRJzۿgOT?.ǟ7o._ٰӿC-|`:r]?7~p^Gc$=%L/%י--LwKM"Lacusϳ|͕;[)L#̼=U[L%Yv_[tۓ>_})l2 %Zs݅mE۹a: 7 nj6Z-NjR nUcE c0]txIFol& 7<7I`'顶5Ȏ[J5V@NRdIP ҕ;}OXi1J+y-`JnW{P+nz.#%r~DVG@)vGr=v^Gm,e10TVgii8⼮"!%\ FIfr̄ݪyRPѾ(6]Xs% GĄxitG;+{,QCsBE1zdHX5b:|*>3"N!O'T."!$ށˢNX5/lp6 LQ h674]vII 6:X Vyr-|)^biz3p4"+0fu(l")V%=B Ng@HFtyH@YQR-) Z" ):ٴTw8-(kZ+?J^R'@~#(a g ^p'W(%K={GAZfp "8+RdŇObnŪV TYbJ>_J$X@Zw Z`Oz'l@ X Vpָ1 U)-zATVӺ/)1p")-Ľ{BvA\3Dhvb ZUOEA25"C Pϊ],WQEsQHj!-_ݕ  ?ζ??R.8]2}"A=.Bt^nMWZ,ԀYdUTQh(.*AU kY.]i(Iy#`; } zMW] $x|]6d<swxwpo8ALJ<>Ëg^O?llk癿+3j> stream xwTSϽ7PkhRH H.*1 J"6DTpDQ2(C"QDqpId߼y͛~kg}ֺLX Xňg` lpBF|،l *?Y"1P\8=W%Oɘ4M0J"Y2Vs,[|e92<se'9`2&ctI@o|N6(.sSdl-c(2-yH_/XZ.$&\SM07#1ؙYrfYym";8980m-m(]v^DW~ emi]P`/u}q|^R,g+\Kk)/C_|Rax8t1C^7nfzDp 柇u$/ED˦L L[B@ٹЖX!@~(* {d+} G͋љς}WL$cGD2QZ4 E@@A(q`1D `'u46ptc48.`R0) @Rt CXCP%CBH@Rf[(t CQhz#0 Zl`O828.p|O×X ?:0FBx$ !i@ڐH[EE1PL ⢖V6QP>U(j MFkt,:.FW8c1L&ӎ9ƌaX: rbl1 {{{;}#tp8_\8"Ey.,X%%Gщ1-9ҀKl.oo/O$&'=JvMޞxǥ{=Vs\x ‰N柜>ucKz=s/ol|ϝ?y ^d]ps~:;/;]7|WpQoH!ɻVsnYs}ҽ~4] =>=:`;cܱ'?e~!ańD#G&}'/?^xI֓?+\wx20;5\ӯ_etWf^Qs-mw3+?~O~ endstream endobj 42 0 obj << /Length 837 /Filter /FlateDecode >> stream xڵVr@:JUٴ\rq|* ebL˨AE9|TTU"uAfKm-DR)1K}h */rf:Ku]g(݋pp|\k /#U&,>IT<5ݬ{ƘXJRkMAaJQƃ։;Lx[5y{eg ZAtN 1 |ޮ|(SI%px͙MRMHUn`)>~ bڏ`')PCa3!(gO2R ,Un`9X%,#\V) ؃tcN|%Ypc`zLɡB} hL%U`yz^=ȉJd9"cN9+s{93Ms濏zmw7s_1mXߡ'<1@9e(i8TtUtRh&넨t8(IE- Va'DM0r ;~J1{z @ס)W~%C@3n FAMy}ٲAYӶО3"!Jί[N: Ĝ CTcƵc*xZ*#xMa5rHq~M#6 n#KnΖ!Ew%/%ұkwٲ:`ֻ;$I#JL1yp1 !&~w_BF߰[ˍ~Mٔ^N!~+=VD\}3zFko\\(m?M7> endstream endobj 22 0 obj << /Type /XObject /Subtype /Form /FormType 1 /PTEX.FileName (/tmp/RtmpScfW0M/Rbuild7790546f8907/ks/vignettes/kde-007.pdf) /PTEX.PageNumber 1 /PTEX.InfoDict 43 0 R /BBox [0 0 432 432] /Resources << /ProcSet [ /PDF /Text ] /Font << /F2 44 0 R/F3 45 0 R>> /ExtGState << >>/ColorSpace << /sRGB 46 0 R >>>> /Length 4396 /Filter /FlateDecode >> stream x[K&9V_-Ars;#i$P%b4!ZZωqEĢ+:tv^__ן~zKWJuӟ~|o^y^?}_m=^_o?ˏ_~7G8.zf's8~xt{?'؇}jU[ ׿5 37cuᏯ[[5t܎z75 ۋW`w?q%ϛj+^W~l5n[k߲-X1{]cgvl8)M pR$[/l`ҟ)_);nٱTfyep_lX8Whj%ގp^ ۇ 7p/Dzsx] oRuv`Wws+Z&x +x-p~}k$`[b+ei/e9NݎA-9.bă&uaK& c/4x12\<Rg,;1"0c}c|Iٴu^"zZ*bOxnϻ}lՇc3Vkz05A"4Oúų%^*>K]ĻUI2,0l,̛t;;x!V}^~@AZ'qxNEc"f~ daoe$x!l'/|wc q^>_e;+O|_Vr|c v޿7p~o~gzОhsc\?]֟sY?wi>-~9/{=oO{i'֟b#/?ɿy!yKfe ;>*;#Sg`^X~Pxӑ7W֛{Y e>CԻ6zzhe-t#Sr{z2_z_b} cvT0o1WٰԿ*&x-귆>gXGQ7||է 3ZO|0O eq~ldT~'z~F?w>~FXO廍 Ck/z Fgi30\󑁒u+B__/""^L>ِ$Bi mFo__ Be"ë#. mh:sl볣Zp_\yUk/ NQirEE+8~ܾ-3Ђ(qNO z~w|pV3Mљ-vʴE&h/3js[z`\? ++ڌa_›FSqEcbM֒ߨX&#?R7*xCb0:Ľa-|rbP-')VL08c85S&QܔƎ1͇*z6jVi?DhM3_ a <?[-߅s?ާVmvWݦi-aw4ʩ4|cD=X;Uk$71|R͔ih}Ĺ6Jk 9'뿭[86bdLIpuZ1Sz!uAaňań5b0 *V 8:Y%ae眇BjT҇bHu-q)eOX1^*񟽻UJ'^^Hkj|}+ް[HPTVRb8 Φa,IٰFfH_Uyw) i{H Ώ-]!)Wj<үuG`CH:ºBiel-:qHY D#*ϰJrJ;Y%9)KTJzFX#[ZJrX|KװJ"?XItUiN¾?V[|Hy_Ã׋mny&wW\k@c>rH5#k)>*ja9Z/vc/(.JeËl9&bQ{MVE=(*Ƈ~o  =g<=ཁ-9b~Vθf+U`=#ie_fodf12,;#12ғ,DTu +0+o<+ Qa튠XqV$iw7w 鉨8V8`V X]faDtsVP'a>d hߘa7f*V?*:G88ؓI}K*E>qOSWf[3lW0ۊL!<̶c+t1v|AÈA@Ѕ}<|K }w͌0߲06&y=oU~:xo][T`b8b`s_Ͷxu0C 'ͷo2(،z=oM6b$<6Ba l 6J|{R,0}=М${y=)zҎq EV i=2cq^@¯~O?+p8beK >wc41uh,->ѣ:94zb\w7b9!o<yz옽h{b:U4iŠ:t=<ulऎ>NA512y#<1C0CV}aO!4|lwYx S糽)<1$:BޞVm최/)0/6)c۱n㇦_b᧎tF>4<4} #$Mρ„ Ll2^m% _Bf/+x4LM&AHf&Gi&77Jsi-7x|%15#mFMe% W;<5,0B@͋hvVЮHGqN<íRD5&ڀ2U5Q`5qЀ׿, rb EX[1VXy ^πq$g9i郂gx>YO1Jsi+u/O c *⚼!4wtnc3~Xa62a~X|WboO+E#2ni`y338",<)rG1[x x:֑ OŚOkݥNÎqx+x<p :"ö8Ӂ~TudT<<x:O>;Cb39U}b U ,c]ʮb@!A sC '<tq3z::Vx(%Q{0HpyS |~sCkx:|' <8`I]8>xFx(ElER*2`x.Q+<:4}ߞOl,`vc 7q{ endstream endobj 48 0 obj << /Alternate /DeviceRGB /N 3 /Length 2596 /Filter /FlateDecode >> stream xwTSϽ7PkhRH H.*1 J"6DTpDQ2(C"QDqpId߼y͛~kg}ֺLX Xňg` lpBF|،l *?Y"1P\8=W%Oɘ4M0J"Y2Vs,[|e92<se'9`2&ctI@o|N6(.sSdl-c(2-yH_/XZ.$&\SM07#1ؙYrfYym";8980m-m(]v^DW~ emi]P`/u}q|^R,g+\Kk)/C_|Rax8t1C^7nfzDp 柇u$/ED˦L L[B@ٹЖX!@~(* {d+} G͋љς}WL$cGD2QZ4 E@@A(q`1D `'u46ptc48.`R0) @Rt CXCP%CBH@Rf[(t CQhz#0 Zl`O828.p|O×X ?:0FBx$ !i@ڐH[EE1PL ⢖V6QP>U(j MFkt,:.FW8c1L&ӎ9ƌaX: rbl1 {{{;}#tp8_\8"Ey.,X%%Gщ1-9ҀKl.oo/O$&'=JvMޞxǥ{=Vs\x ‰N柜>ucKz=s/ol|ϝ?y ^d]ps~:;/;]7|WpQoH!ɻVsnYs}ҽ~4] =>=:`;cܱ'?e~!ańD#G&}'/?^xI֓?+\wx20;5\ӯ_etWf^Qs-mw3+?~O~ endstream endobj 23 0 obj << /Type /XObject /Subtype /Form /FormType 1 /PTEX.FileName (/tmp/RtmpScfW0M/Rbuild7790546f8907/ks/vignettes/kde-008.pdf) /PTEX.PageNumber 1 /PTEX.InfoDict 49 0 R /BBox [0 0 432 432] /Resources << /ProcSet [ /PDF /Text ] /Font << /F2 50 0 R/F3 51 0 R>> /ExtGState << >>/ColorSpace << /sRGB 52 0 R >>>> /Length 4710 /Filter /FlateDecode >> stream x[K^ϯK~?6qD,NF!1!Su?Y,4L۷:{;:&;CZ=̯:PR\>k/k˗/޲./O|{뇧x}-~~?(#,83*ze|^Sk\fϧŞw=2qEay_ .-be wy^v/-ÞwzN?e2I2ԉGS޳+q<ޟqP{39 n,xE|f<+]rkw:kݯu#Rj?}оRm);fź^]p_iI}^J5{5o lgMb'' $e13ozvdz\FrybFvyPa!0ekݢe,8b<`hۢe-3v(h#r{TѨ=RV8W={FoCvpLFXF-1aEfg⃲ wê}C1`MekmQCgC=T쀘RT1ی5oGqo z0+kM=Nz~A'S^M8F$ƪ˚bd{ lp Ţ0#`4bب6jP}<mH{ed}<޷֮7]ܿon'$a3D_ yzX>uG #[fAڏ S ygu lM?5ˈʨة&([\.z-;7ss<-郁O{ Gp-l& [ @ pD`5rSZx>]qw|Wm]~wQ$ {l(KA%{FsD ihFs5#!v=v£]8j7۳U06վg^b)&w{_Y9ӻoKFn+}))~e;/g)$sPrQKe4z*Adu{;!F֮9BEs$fOaiZB "B I _YB REŒU(0Zں .$H\B$Pu[1&݄E)$d-v-R SXMI4A*EB( 7P@w( ]aϣ$<pNp'ZaQ+Хhu Q[HTaD%\IV-(>,1S]rkb98-4ƨ=L%bHA,7 ֓d̂!:&R,@UEBOe PeJTlY\-i7Zr6dd,XCqvTñOX;BQ6JC㙶thPU_R58#&/'fTSX?9\OV5p~4Z%~A~yP5)dU1UBdWEV%Oml CwQQl56*`[|QcZq!48#>i_3Ka]^;tMUO6~#0po⭦N\ڡ J|vWAk2UURPQk6{OƟO7AA?]0ƿI5YGޯOt:L"/5a= X<1󧸩`Mp&ߥxAXhӎ| Œ jCk%q)*pb>#f}~CšCc3]wj E0 CUe !/SB2K" q)f?Im!3ʖ 6b^? YI2|}`XtFZliX҄?_qgK N|8&"4EjFjEbe%u6\N*Ѧ2pE +5wli@&xD{Q[U{ފ: R FTBcčDBp1iȈǨVD"HT7-jI1,8'`Cd |ΈD̓&hH^'essz $v(ʱ^$4e/` ]Y]ZQ{:5VaًK)8t7DS OV)ҜHt4G)HC1QDR)JKM? cDEĒvJAV$7Ril較R`J3K!}: }KCcIA>I+ɈKAQHZ4li(m)(5%9bF 'y yIءZ܏B$-}lҏKELyC:b͑EQ&t$8rH;AC.65.G.H:Ν )e'/HS~"1$$)' Oo OoNIh6>H0H܀$mV5mLta89)4D#IٯS1Rd(&vg$ nL 4R0g1YzQ9-^yJ5vQ RX;aO#m!T /Z0"IT .3$FzNr FB_xQ!Cڮh`Ɛ6m|!HAd#AIpH 8Wo[;DqH/؟-p >Ѫc=AzM}owIﯝkn/,l ~#kJ2ё"Emg֬^(Q$%j08g׋2&#U)AuYAmAm`c9FH\掘 -bFZ! F' ~Yj_; <2K Y2(Le M,im-ugxT̐*c9G-Cp퇬!xCmJ43\?v2ׇgPQʃ짗sDb:[(QPe<C1Yd9r\q,zʸeXrwB 8z +CaEϳ[H+P_IS`0q*lg@VEv3hSߝaYG0uehV8&(ĨWgEcB΃VVxvVd)p?(R°(^ѐ`ăYhת2ȸ݆] M %8#L l*bXqGH32^;Mwx_(ԏV2d;T?L?:.#3}JF?0;ZaR1IxE8 b:Z!ni GTXͣ+2+'$|R)4Q*R@T\R8M;[uҺYֿ l-όa*nl]_ endstream endobj 54 0 obj << /Alternate /DeviceRGB /N 3 /Length 2596 /Filter /FlateDecode >> stream xwTSϽ7PkhRH H.*1 J"6DTpDQ2(C"QDqpId߼y͛~kg}ֺLX Xňg` lpBF|،l *?Y"1P\8=W%Oɘ4M0J"Y2Vs,[|e92<se'9`2&ctI@o|N6(.sSdl-c(2-yH_/XZ.$&\SM07#1ؙYrfYym";8980m-m(]v^DW~ emi]P`/u}q|^R,g+\Kk)/C_|Rax8t1C^7nfzDp 柇u$/ED˦L L[B@ٹЖX!@~(* {d+} G͋љς}WL$cGD2QZ4 E@@A(q`1D `'u46ptc48.`R0) @Rt CXCP%CBH@Rf[(t CQhz#0 Zl`O828.p|O×X ?:0FBx$ !i@ڐH[EE1PL ⢖V6QP>U(j MFkt,:.FW8c1L&ӎ9ƌaX: rbl1 {{{;}#tp8_\8"Ey.,X%%Gщ1-9ҀKl.oo/O$&'=JvMޞxǥ{=Vs\x ‰N柜>ucKz=s/ol|ϝ?y ^d]ps~:;/;]7|WpQoH!ɻVsnYs}ҽ~4] =>=:`;cܱ'?e~!ańD#G&}'/?^xI֓?+\wx20;5\ӯ_etWf^Qs-mw3+?~O~ endstream endobj 38 0 obj << /Type /XObject /Subtype /Form /FormType 1 /PTEX.FileName (/tmp/RtmpScfW0M/Rbuild7790546f8907/ks/vignettes/kde-011.pdf) /PTEX.PageNumber 1 /PTEX.InfoDict 55 0 R /BBox [0 0 432 432] /Resources << /ProcSet [ /PDF /Text ] /Font << /F2 56 0 R/F3 57 0 R>> /ExtGState << >>/ColorSpace << /sRGB 58 0 R >>>> /Length 4267 /Filter /FlateDecode >> stream x[Kf7 17~w E z(h:d?:UJ :Ǟ?ԇ2|{ҕ |J1ڣOzyo<~ z ^|#=ȟ^~/yר 7s=>)n]pm1F*3z0Q2E<1+%ؤxd/YeÛOS #()a*̊ˆK* f(Wg%kc]6W]Mў"ueX/JglZ\o x_B>-_&CSk)u!Ő:۞^u؊`Xϗ|2ڮf˕ϗj Qڕb["#byTl(Z򾲸>KY|1H<ؒb1|w|ְ.4>kl .cZ_~2ډaOIo_r\"3v m}aY_5:_q$1$=#0+WpW܃xފ=?5$5  u+:>Ɠqbf2lC]¦ƄV_vӮ?JXZx@#{N?ԅw}n?S;#=^Qcz>dP9H76UoM3ReaKC# F|ِ$bW|.sup]I 5kGo0\ٳ;߱6gMK룸O7arƕOwSAUŞxVʤI%&|&6z^6+bvw>>89>(#nFzh/Fv"ψ<1{!zsRajXf$V#Fp 6}X2r|g@t4ƉB?WϠQu ۿ=l{3(}wcW9>+B /`szV>YQq V[Br~o[ܽBC;G+/ӳ]p)u ӳ7CF9c{мGzpz^+?8g"yJxj*;/|&Vqp|vh2;tt=n9v E ]vs Ω'ӕr겏+X967N]K3t4ԥ>mok}\uwP&|:l;2r謧">mΜ'$nZGΜq#gj5ÕgM9zZNGlim=k!8_l8*DwG2x%C Bɽa5>u9 ?鞡> d _!җàjsH(3oUebeoZ'b8s.1V1<3J`@O؁< v_ȇ{3je3nڄH nE[Qi/_6b> stream xwTSϽ7PkhRH H.*1 J"6DTpDQ2(C"QDqpId߼y͛~kg}ֺLX Xňg` lpBF|،l *?Y"1P\8=W%Oɘ4M0J"Y2Vs,[|e92<se'9`2&ctI@o|N6(.sSdl-c(2-yH_/XZ.$&\SM07#1ؙYrfYym";8980m-m(]v^DW~ emi]P`/u}q|^R,g+\Kk)/C_|Rax8t1C^7nfzDp 柇u$/ED˦L L[B@ٹЖX!@~(* {d+} G͋љς}WL$cGD2QZ4 E@@A(q`1D `'u46ptc48.`R0) @Rt CXCP%CBH@Rf[(t CQhz#0 Zl`O828.p|O×X ?:0FBx$ !i@ڐH[EE1PL ⢖V6QP>U(j MFkt,:.FW8c1L&ӎ9ƌaX: rbl1 {{{;}#tp8_\8"Ey.,X%%Gщ1-9ҀKl.oo/O$&'=JvMޞxǥ{=Vs\x ‰N柜>ucKz=s/ol|ϝ?y ^d]ps~:;/;]7|WpQoH!ɻVsnYs}ҽ~4] =>=:`;cܱ'?e~!ańD#G&}'/?^xI֓?+\wx20;5\ӯ_etWf^Qs-mw3+?~O~ endstream endobj 39 0 obj << /Type /XObject /Subtype /Form /FormType 1 /PTEX.FileName (/tmp/RtmpScfW0M/Rbuild7790546f8907/ks/vignettes/kde-012.pdf) /PTEX.PageNumber 1 /PTEX.InfoDict 61 0 R /BBox [0 0 432 432] /Resources << /ProcSet [ /PDF /Text ] /Font << /F2 62 0 R/F3 63 0 R>> /ExtGState << >>/ColorSpace << /sRGB 64 0 R >>>> /Length 4440 /Filter /FlateDecode >> stream x[Kf7D"7~?R$`F@ ~>uT&=XLwN^_\s+^?\|?7_\u>*oz~[^6<۝7_o>zӯJ_z?I }o~uo?~[&;CZ=Ȭ:PR\>kO׏f/߼`7_NoS?߹UnxP3q&t$iOm%9:10bvjOļTL80%+ҭ^Yk?W㑁\4ެ ?b=i>($᫶y;`,t| !|pG$jϿVLM$—lm5J!}]m_[q?3ž># [$݉"N,D(+Nl&|V,7v0nNYLq 4đIɖPcXb d2i"q9<} >BAKͅd"2=8HXO>ta*1??K[Q-95t%Kf.04}I AT<2~F=iݚb-D|>< g%=؊كhR+1B7]IJg<#1"&x `bdDr]Ŧe*euY|?_kC=6[lhߓvݞF o7x%턻=tvGdٗ Hbi>k/Qߍ">/xY"x9S_.s=kxwY1"a s*~KGTwH#Nx#LNS*ZKY]bIipgd j$hH(^qW_RK$6Bd{Q_};cS_E]՗S1>諯_%gT>hav"^\u !>+w^ډ$DTK;>*si'֟RZeI#YRրti)QS.DXC[4<_$*gd%-Ø`|Ӫ\5fH&٭C.-S$>^Y;LkjEAZqTJC~{hM_XZT]-#xq# M r-*]=-(]Cf,ֺl dtU}s"Hc5oiQfiMГOPRwx-#"n<-Ȃ"bSzk,E8t~l2C*Fʐp. /%JI,%bFbZ0zWm}XD\4F[e)d+292MqhKLlZ }\6pmH0N87m #[{6o=*SB6Z-JaC !M}hi:4X{JHCxjM#6%X,*򡅍t3 LXPC“mτ FfԃtmacfL@ b.H(j.@{Ǧ7UFCS2zsܒDg5o E)edeZ5CHVs EۖI|[FmJe_2śOƇq̷M>̲SB[χ=ڶ[e _bǻ!2~ O%~F_hXUDZ x,Xm}^xH13Yfu-O˸Cdzi+3} #65`;2[,kGfцXJtr!%8.yHN?,GtqK)-g;i0ii04d87"T}~F34i$/beE"ҶӲ>-DqXr:Fd5\Ė69~< H3dFH[h0LȷEyg R+| Fqj/`X 0U(B_MR$I%J*,!RINiV ]h@$Mƿ%4$_27!^pApad _KxȌBs&-.;E(v!,at<SY!),y"|B@,Q,ex6l)V0Ǐ=5):"0U/YH 5%L~x{ c|eGEpl%Qd>C'&E$%LJ)KWdO0!e2V%8s~(/Ktl;ƧAxQ\EiI VJ|Jj?JR}e"%ђ)*֋ui=`dVYiN3`P./Aq) Ce3PrP\G%jA 2v9՛;*3j?R4?:Ð2n7CxE奷MQݽpJ5"-đ^ yev)jTsST/ʊdS gƶ<(ۏےu ?֫M}=R+L?X۔9!8DSbIAP6ν_PVΓ2nQOoZX=/[=#NzPFjHbG;1hSDÃᰀXhFZF1'9Iŝ ЌaA823 <"])\q'HA8HyInIwcelR].:71T:TxF D,'EՒM&ݤx襜MQɿ?"y!T8I6+DvNT'ɶ$Dr;VфdiH' VQIå15*`-c^^i*F̐IKD`x}.2H(G F2Mk+[ݏ" f\GEa !E?#Ði'g(ZACbE> stream xwTSϽ7PkhRH H.*1 J"6DTpDQ2(C"QDqpId߼y͛~kg}ֺLX Xňg` lpBF|،l *?Y"1P\8=W%Oɘ4M0J"Y2Vs,[|e92<se'9`2&ctI@o|N6(.sSdl-c(2-yH_/XZ.$&\SM07#1ؙYrfYym";8980m-m(]v^DW~ emi]P`/u}q|^R,g+\Kk)/C_|Rax8t1C^7nfzDp 柇u$/ED˦L L[B@ٹЖX!@~(* {d+} G͋љς}WL$cGD2QZ4 E@@A(q`1D `'u46ptc48.`R0) @Rt CXCP%CBH@Rf[(t CQhz#0 Zl`O828.p|O×X ?:0FBx$ !i@ڐH[EE1PL ⢖V6QP>U(j MFkt,:.FW8c1L&ӎ9ƌaX: rbl1 {{{;}#tp8_\8"Ey.,X%%Gщ1-9ҀKl.oo/O$&'=JvMޞxǥ{=Vs\x ‰N柜>ucKz=s/ol|ϝ?y ^d]ps~:;/;]7|WpQoH!ɻVsnYs}ҽ~4] =>=:`;cܱ'?e~!ańD#G&}'/?^xI֓?+\wx20;5\ӯ_etWf^Qs-mw3+?~O~ endstream endobj 69 0 obj << /Length 908 /Filter /FlateDecode >> stream xڍUKo6WTP@Mmٶ(lAAǵW lm<(=Pr7 fW7QI)fOET2PĠ -?Ť}*h-v_{ djGUQ0dKteeVy75`t9;YyFH ǎ:Icщʹ$ CamoK}薨[g$j L&NQV rL5v `xʊbxK.,[^-M\4HP3Hjȝ^gg~W: .LNyu0bQ.hi$ fhtf@YaS >: (1iro5KK@}u/S䨍2nRTVpWC3!|:' B:2rwCS .aG@33Bqb?Rgg"EQwmW2uLޜqA}VOxvc=<h7p^;r 㽓U.a;5|R8]8` endstream endobj 88 0 obj << /Length1 1464 /Length2 6795 /Length3 0 /Length 7783 /Filter /FlateDecode >> stream xڍtTk6a" ! =  303t* ]҈ҠR4ҝ"H;kz׎{{_{su@CՐ HPU2 $La DPDH/ eb*` P<တ $.-$!  ߆H49Eq(#}Q0'g u`0cn!`8`u`ܥnh$IaC(:Jn? q0_ ##X@h'F:=w(/c ? '_``FN# `|0| G#`/0 N 5 ԇ`U0gVE8(#ܠ W~*0}w_?uE K02<M0O,Db HB\zP }ݡB`l Hw[4^Poſ%"!!P'X? X@~9YcD}1bA#mUCum?%G~a1 $$. H`j"_bpπp2 pCt+忢?y\z \O v tY@UB[cg. g`>P}]M~ #Ѱ_K.+v}bW" H_S&0a!8:@}~@ 1X[\ Dꨄ0 -Ju ݱ+:bAo{ Aoo_YC`c4J4u}ԺcG'-yPj9+H`)xX]j#<۴޽#Fy=Οy/]]ĸYKwHn$~xcYWI}@:Dn,2IƧ)Ltki ِ6NY_Kf v(EB 4bGV|*-ܔ~mr˳@%-Fntv=x\4CC5l'ٳ2o>AAȳܛ.^*C֋pxN+딓{ ( #Ug2 zA_CLG+=txm \Fk0A< u 4W4j/S|Ã^ z` I XE0|2ԩZܑFu&W& ׳sZ ,nl%Ɣ_u''Y<PO/[ ?Vr޷wmU&&~WV"g.elw[?99J?LLgdzCecY"+z+jkPs pz^ꑛu7/E/߲}`Mn޽m.j%:%c?;/9R_ ^{q+3j:Kx)\=qi70v6JO-UYi<ںOe{X1 JE2M5A-1>迒+|=DNxi;Ou9%j)(b,ήXRt ߈xo*)>o$2гz')J[ϗ\D"1hٰ+Ѯ…5wCk mdffhsG썹w*rYcyoy, n%(f`8V(wK/ZȞx^Q^mL-bċ~z7JGyd+aIQJڭsVi/IVݭ^ :W[mOb IgN_+\!ZVTy`;v)SZ4ZK0s_!QRՅXEhvo}5'|0;f@\%jz} fR@䷢vX36 _ǒ`409\Bۥ2-Eˀ]=~y=DA\R^>%z~!Fτw/|TMFz0ɴD5 Sľ߲,"!!GicxmL}8O-2Z^ۤ^(N608iY;jwjr|<[qYԶRGT_kdI8| " Rr^[T_`j[ RDAn>t>/q>3=iW@\n1cIpt^ABW$sD3p~[Xt|"A~G%Ȓ亓haŜ:'^h;Y ̫&L:)n4n4I{3 Ae!Aũ+.,+Q/|៸^V3{yT+s&nȑ)^j wHgEizY݃0f\d^g(yqꆺowYՙVH r+$ /eZ^f_f3+w?SQl6Yn{ڷ.|8;7M8J@d[ ѥiFV޴=I27|YR15KOaBO}=?vd0w4W>)`[HW\;BPm'k1)!|x=0b*=j􇠾^5͎ٮ܁ZN#blJu|Y9dc ܹ)$7fpۑoK6d6dMEo?\y)zA#8x4 }/blrKG8R#>wrz/ɹ*$\(v=,\r:K}upPlJ|[Hs59Rp$m۞ɻ[:RFhOp_d69VPjʪp5<.ٍ6oh#%fc"5c XZNo8m/d|֧YPL-I0A1ھo`- 84!5VGi L ChkM6ߜ;N kyHcTDfD7NxVA;qb G8C7RFc%\lnsUmVFQڝ%9/'3NM#'/n#VSlF(E;rq$6$j|Z(^׮Q[8Crz 89nFNU*0rj(v`59(k%ر2SkOJA<9~Ir>$|m/q[5:tXS5cܣU}G;^OKTL,Z^EloXb2>6#;zi}e .f/2jF^O~d[\,4+fc%CRPj "ԸW eZG` g`3Ay ,):jś MZmo(qt (0dCH?AݜimwpDtzW?4T6Big]lxp(Y%"-ȲtSKh5. u\puښ3bf:ukQή4Éz{_JuimY_ƕy|4Hj1# R62ZKN2N\ed3ɯ^X;ug^Asl)0mWhϨD)9r>)44wnFL,fxu 1Fg974WCB&NKnE/*/qHkqFcHq;K 䳨~GP4ދ2d )Smg NW<m^ũ$3~O i+J34j*|zֈiә:٭To *#(o[ַyL1L9ZŸol$9&Uf3Nncu?S *UkLؗRoFM8,NQPPk75&[٘ysgvKCQWWjAR H<\d3_"UKk<3e?x>L>ӕx> kT(vYo /6w=v,IM:L Zqæ~|ya!y06h{[@krӫzJLnj+T4nT|eg4ՑWh5ii)gzԁ)^ȇ('S$d9&s"{:a#kդnmsPܜtH+c*]73_ɲ@rIkk7cjw^tuTYIA3~!mq=pj,2Ã-譬ZzMR2E*|I]͜sd"$?:0T%moId>$Փ)$[Ty?'+08 }ǣl蚋W2zIZdp,ގ;l# rVы0X||ӷh RB 8;@\ -E.1ۦCCvI}p#s-4I+=-=^|Saʠ5uҲSG۽~yY+<"*D wϻ2\Mx~(IOU6 EX;?k I2>2}@4Mf#foIlNS}2P٦)9|^dFn(ޛG2j&bXRJ6;@w(t)dWV[Up,+ulLƲE: z;j> 8.4[*j}kc, J6:L۴8 -?۸9`xÃ{/sͿ}l?"teZal?OɑW믌2 RJ:DW}M>-3M}'i8Ml2/\*zz!{:ӏTR'G,:'2-.sYpj٢ e@2I-Fq5%S_P^=tSjk۵A7˶,9_LT4eXpIU՚3AI_G;[Uf;S\u ˩b' R&,i?使*djщ\A1SE^O?]_-Cyb#3iԾ+PBTԐY+nѦ! f*"!W;ҩN{)|1t>-.H5ۡ1쏿\%"Mw4<_aO%(+bbқ(MP댢ۗ9`II1#!p,!M+ԉ{B5mR) zaBš } Y(ݎ3=a;ki[$!~kHכ*Qb endstream endobj 90 0 obj << /Length1 1458 /Length2 7160 /Length3 0 /Length 8144 /Filter /FlateDecode >> stream xڍTk6LHt3 !-!=030 CwK("J7t4(]gy}]7<a QAQ|@~A))P ((/((aC9CsC0\HuSnZ8@ŤR!AAɿ@ 8Cꃄ;ne JJNȻ@0;B9@\nW9 v0_%P(W)///~;?i/ w r`s+`@H oS<`p:@M  9 ??d*N!\\Ap9C:*(o/ Od{ :"Ng>w;$s52۬ +"\\ p;`H9\'8 _c=\07̭ =@o;_ B~ܷ3"\1 0(PHHm0TuCٷ珄yozgy00 ?A7OT'$ ’qQA@`'W E$jvnZڈ[B\BPT?%v;} n끺UV @15V p{l#] Pv//9]; OV]vNׇ-' p;ʄD $/xK%!QQV`om vuB_ߖ$@?q2oL @_@_(@~<[f0ۿb?;{>RދomHfc$oqA]y"t~EVC5NTc^ӥ3ѵ&7[U]x |C09r<$uϼ>zWuZ[ *{jgR0k5IÊcĽOM2q|2N=|ì?S|?EI/Bf4d6Sԩ &Gƾ2ZMɶDޱJ/|Q,&YL[PlJCS%^0v ~׺qM[6 vBm Eu>wf ?n݌L ~~ٌm.ʼM݊!~0< }e~dx[p fIow9ٍ,:}Q ǁw_|o:_mمYI?$Xv3\CF;w5.c؄ *_lue)ؒ j"ߋW@oR8 NuGƞ|W(D@9.J eRj5mzا n. !;gү]ȓXFX%2fE<[cOxt.5|/`}adWQ6a2ZSAW_hq7U|Vrʸ'.&l+X[L#O ݺppe?mSkml& y8nWPZMh݉v{D^ny`6XjfG9xx%j3 ,L8zMZbu0p]ٴ ^b49 TZV{Eʛ2YTT5\fF _.:69]ZBiYGV%FwHRfQX ODa:kNtIeѐ~uɚ , J,뚡l&b@tF 5?{q.SAڔ'1R,K`,:%`*R$JΒGh]̤~_ZGj13aiKAӘT]q5|~b^1C ,kIrfeuό٫&p͠@e>i.5YԖjyM28f t7}1 -,luSG\f.)H%tG * bo.퐣¼)+O-ѹ0L9 <Ɯ$i>;ryGW_}o|xM! k5$b􀳹>x-?kJQЃ(G˽ϼx^|<"U c oRe!5`4+GWX񩷼!ez W>6ᣬvQނJ;۬UY|qӣ,v9{<.C 괗b4>8ђOHbkl:[b^~$v2 $h_qO9*=-H2Z d{d}~%  ,[:@ mys8$j,C^bwy)MkGo9!]-}>M!۠+/x׊jrҢX6)Z3ŭ4Z 0wN7V#Hbxp3}Wd`Ν]O`Ox z2Ž3Kiq\&:)!Qm;8B|,H>{<X]YF%zRG<ܠX5ȷb7iљ^J{-"|% %`B23T^OÏ{Vf-D,ۄ|3pMAH>׼M/=asbkxJɬkזmYiM67TGKy"K{(rӂ ʎ; /i3trm\|h{pAr4yۥ;v jHͷz";M$3Culs)R!89hX-DXM!TeB@5 Ѐ5h%ghY;7Ԣ:tᅾ@REa $ZƴWP.D3 ڬ]wɵ=~z-BW7G2ɇI߅?lGy8vTX5 v3}.7k%03ř×Q'x!x^KK0B]=_#2pHܘYױV9 ӼKQto/Xe WOKH 9q61duվ$.;M;p8fVw|mߙ/hhԅ7t@yY_xpy"' Q&ӏY_0+2<߈ ~N"Ym8Eȕw/ukDbTCq֍cNa6 D j'˽ur6R[RW>eɌ/ҏO/kˎz0p)[$_BpGd&  ܔ~rjB]/zɂav9›'XMZH?&5X7Y~܇dG?A+'L־-/Fvb9yK~yMЗOkW/Uj HԢvie)=((T2^:A`D}kV?GhFvE_ V/ b1f!_}h^U,#`l|Zny kطZ1kp ƇHRO_3,0!g\sRk 7r~9k+Spu.rKlζ6@6ηnK4[>;ܢV 0`g.!k<8w2H+^|O _pbhHvZAqXG.]ǺY%ٕr;[cp`޹-okBElkA{3Q(uz9(5Vs^7cKo2)G.jԝl(/(ۺ=U{MF^nt@Eʞ4?;!^V^l%^Hyz֝hJ|hӱvD3&sr[(=sUvm"QW%*F?L ڂw9'H# &(Y?rrV|C8{^k2#FESG1xhֲ]4 Sˋaoq;x#1H1FtY1G{6s\~mـnԝc44ো 5A|WB+Od;捻@ՒOqQ<\`Ӧ |J"*EIF AJq{OgVUX*0EG⠺umZp[a,lmr):*W`jxޮߡ9Yy*O_1lɨ$tJw3琌Fx R]&H;6 }yNC-YkW1h 6%ڮljLlF~Ί;U@v`xβWeKv+#۱xrF)0}#NsZ2M(M욐 #">--E1sPhIt(vT&Bp*p|P'P&LtMZ#3[+ޥFN>]EXJ+ iLvRu,+´PH&;yxAysL1/Iz$>9'lk376T4;bsFͅzbnlu:\yZ_4?w<9q(< OZ3$#j;˭[bk$?,;-2 r4Y]a<ݻ84dqúE$&u];pMbB)zj>ꪼGeoJ0x~WϾGԕ[%ǣokTfrs|"8Ӻqx8a2$j,Wb *Xܰ^ۜ)n_n)$3]Mwk(LenGDCLȚ7Ůa*UtiWf?,ksP-a[y | ˸\'$ FΠPN???;pr.Qs$vƅ/f]_խ rO2+X+-cÒ:Oҁ{5DY<)9(n.vn낦MhaivLf 4Is1rbhu`qSBXto`2N&uKcu]@Ex;ZUufR'9DϞ!(Urb ⨒t p<Ӎ^ê%Jhv,N_ t6&yDOחz\˺+ŏ8v{2r&dj h+p1U߆i)YP?ܻθ2A(=f׳[ P+2ȼC ךsZ3R% [?=MĞ_-[i}T7k2`Xp]|ƛwb 4Qw6Q+ı-1PqG|tCxIEJLN4$~8KFL?=AIcjvk/[-0&.>uӿT^lv(=-c&xNgO^uT-jֿ s%)௺ҶeI4roB"}7̚-l7.F!£# KhwX;$ܚ!ZVΔ#:ATw_ XlJu"]E|ee,R Z(ߵhԎ襘ڭM$2tt̹w]ZVTK72P 4^,4-h/(=U0n6 6ӵ<]x. Q2Pt|G >YX>m8tlafNԢ>W橼>5Y^iܟ=|y()g<fF*ךʬMX$XZbQgE L2V`Di\c3"r԰1*pSI)Kbh"#[~rjܢ&9WgP~z×woZ䮁6`| f,)Rf z`-!]).k'Ks˳V-۰W1՛x^L!^$ɐ7uhn48TqsqU ߼̋qiח'6Ҩ˜4i&/OڬXqF0L_4Îh8XKf 39}?N$K"pV$;#-͇UwA˝(ٖtb=M (a~d:a >,/\!Y}9л#^:U^HMuѠjg /1Jy56iiF%>"2J`aCmUuґDIx J*[] endstream endobj 92 0 obj << /Length1 1361 /Length2 6104 /Length3 0 /Length 7044 /Filter /FlateDecode >> stream xڍw4 3Zm-zމn(3hAމѢQDKDD%"DI59{?{~wf70T 8JPDt|_  @nn 6"aPAB(Mtp;PD ("qWD.D U0PWC*O$9_K #PDZZRw8P9@]094F8 (uA< =Hgy> 4zCPW@=OgBn #@{c"|(9hu("$t%`? tC:B(4JC~L< s;`+Օ `LvD*@A|a9a>BvA1jpGD%`$`S(,G0!@Ls@'k@{LuA"1=v̙1:f&2um'/Ƹ  g=\D)e~|O>{8v~tKayЅ]Z+`zgh[YDq=+, -/)RB. t}w5 mQDqgO&9P,)(ٴRŊ-DN'+MD2p1XҳR TҢ ,+}l|nZp-Aɣlt I38~7fwUAMjcC( #piz2BՆRO0;՚W(ϺW\=wr_5)eiSkΛqU2ƩHڿ_wvoX{-aYDțɌTbz-;6C!JNav7#éNꆸ s,! %Q 7+;PK׶ Yg0e7K!B$7) VtUR@Bt˵<#esٻ$vcP|&Ք~%,& +B7]J~w8KrnY݌aϨcQ*$P&]#o[… -[zѩSQ|o׷_JAyJ|sKHįvLmdi2nj!G2AH7uѭnX ҽ@n\8KM"ܛ4u͂-!D<ǡ)R>8{j>Ozj8-S7{K p+e;'n*OU?6ϜTvى$ɓɓN]\tP ]ZnŒ r+?DDʔIUJ 14};/J*a#qE3ă3Di7_&$oMvNAf; (5P)@dK =aMҏnbU,'qtmn篚hnـøAdjxnj>ԕZ\}GneoKvԶp*u"2iԋ{9T~9'2k=؀%%]wpiBLJ: !6x3"e}SvߠVSCPҎݣ(MB]#d'+toN*=bL4@5S.q;`yBdڜ?e 7wt'{;㇊: 93BLb3%YM/X7;9L~@F//L^ezǂiO)m?ةGi7%=oQ> < "9(B=]L@sZTDkRD Pu!7ċ/F/"f5n1m VUe=gV3m'|QGL]N\Hv{(H%dA–DH1Gx/g8y7);М&_ (YOUҩeBeJN#GH|T{b 77fi$UWg1sx~h ?QfPk؇8Us"XLπNқ[?qgBTMjݻ Tnd}qT"KN7ɫwC o3'KKV2;XDkHqM)4s.ή.R^*<&p2->μ6qLnn`ݱ yc\9V$哂s6=Ds~^J3/TLJt"E}*M寙dAsDDm />ɸ=CU<f gλ;̦:r4*THrhؾUk dϟ!6Kkmd(bg%cZOhM+9oo"K țv;bOG2^3oa'bH-Y4^1ǷSçLJ>:1J<z)6Xm{yM^t BK%gE[>Ji1XTQ޼)aw;ᔶ˺WG ~€Y{Ӝ=oEu?=ϵH 6?I KVZ|$<`hT0ޓO mj'Qo :HDR]gGTv.pq8X?"ךј8: .b6 1jh;ƮNHڤ z<|n2= t׸TJoi\4~hCOb+]ѸI [**ѷ|vJPN fUG1VE(*ʰ׼:nPw^BAi&W]2#=y`?Y'f IbeՉo WJҵ}g~0/l+- .gzX1c{|Wu8VhJN#L)-& zL=7>o:ێTEZO ~GǝŸ.ID^^K27*cUOt 4ltXSoT}ёi_>cis0Of.#z#YU5P RZXͼTaUu=Z'OȄO*=mIؗy8bqXا3%VcYt2$8JE,0v?SE*__2yvPbs1 <{$VE&g|Z},7XNɤX$Opy!6+ܣ|G%sB֬XvZXP*}`t+']\8I6:ΫEBЕ+DtȘ5U}a f#j,*L,U.$R VkVT?lxiksxL $2Qf8?Ԭc~򂗤tI6fNQ'? XDcJK E{)Xjrڑ}b$.Mr^M !Gqvyh­d:*sDu+ydwh׋O3v,vto9)W<я!o+_$O'&VXd>XS3GŔ8YY)b?< WX 9c ֚: ] 2@O16C֐8q[5ۧi2 ,nYOqmU>ӑod6jB5a?<6enbY9k}av: 3J0%Jx2y^2ma%o3P)Y*-0wLz],82\nZ 1jjxRTj0[x9-C< "?9ZЁhUfr5Ѵ,}PgQ0\9e٬Ju6OVn~DdCA?U^KA>v9sN/6ɦ3 Ogt IVےݞ;nNJVIVþkfW*1MLTNwJw{X/cϵ÷`RS<)/uE x0UG44</]`N1\6e:2ͧƽ×tuIu5=l.Ly~en!hDtu&?/3+khv>Z5L 52&'Yt~|54 + ߐQn%<)_9d_TP4\w1 ǖѢƦ.V7 ]?~_J֝{i"hg >(C[a7!r''&OHRm 'ð}"@;v F} g»y+hJ{nUZbr$N-Rl9gU/H"/$&w@7&.Ӯ.D u=õLsTYЀp endstream endobj 94 0 obj << /Length1 1497 /Length2 6463 /Length3 0 /Length 7459 /Filter /FlateDecode >> stream xڍtT6ݨRKwt, , %!RJtI(-(HKJHK R?{{s9̼3<3,:rp24L|>>>>~<(paP@@@;"yGԄ=@PX("GAP[&1qcQ Ȼ{ `sbb"\r. 4AHݍ`3@B>.Dzyy\y{i.ЃC[Z ȟxXP} P0~ w4ڮ_d\?@Pog wq|0{VAz# /"~AA6wߩr]s#Hwwy{f%CO݇Os`p/';(W0DM΄o= @o |\!A/] ~pW]  yP0` |`w'? _,f 9ż ƜJ(/q ń@A!A? t@?+߻;g?"`3!҂I`-w_ovW;#eg8_A.Pg?;z @~7 C]M-Q5$n`zH2bER_v_ At_ /nNwN!J%nk w滓x7B;]y;8WO6 r6P{_0࿰}- $z{B]A>@y#Ͽ7  NaZk{qH}fY7Ey$N YBɥv̯*1\47`G{reLolofSю\}n k7`'fԎ,ynD:^*}_>FLn_sYLdO0a!pxO}&t'^n@2ŤB{'CZ3:Sc~iJ '\oUd NYlBT:Ѱ9O|! bN|"Mc^!+&$TOM_°PyL>GQ +y\DZhVH*:me>'2\phTSE)ڥLqMA |RDQfhvL L~%&t.5\We_ !G9i" ej?Tj}"+}oXX'ܑg2ǕA#5&_KxOK8 hKfّr}1!rHylKɞyܓOgQJz%R(0KK;pOt:%Cd7"$P3sFpLg-Oss_-19nYW>]rGc1־}+3Dx U_vXzjG.Ě}bVۯfC שFwM<|g`_IkW\pT':\Ym@zg/}S'JjO5͉mow Jw:]˛G(LWw* `UW]ح_S_x~U>{MQd\N.`q9"}B9χVA+?J,>zTO`/$Ȭaj36r0%fջb2ߺɶKs* +[٪ʥ,7)E \h#:T_Hzjuvi5۫Z0CA3+[+'Zo|V&} =^)136Ce@"vs\0Iʃ7@ zEz iұCs'l~qW:F2|ft  )"5x\Jy?C8ZXj GމsG\{S Hrѽ> w^}5h7{l]؎!EUSC}NrHEklGھwXJȠ+Ƹ.!/;BJmDvP>7vN ti޴q lR]AGe@ց-,y6Iq~2HL=^7n AgYitl<=K܎„Tk~(?$׻y.,V?[`Egܰ_M@s&`qi&d{˄fY7\T_P{w4%6vZ7 3=p{gq@OB(Ksr]J ϙ17f5Z-C)x|BOz.q?dB!5mzeY`]3 Tsy}<_ea-m‰*#=i)5݂̂8qފpq)z?0afꗖ^sN3sR-./0OzF?hjO9LW_p-йf5$ ZFX}Ez*ox͌ 9Gx׸Wѵ=Hd}bCGoQ_zF|gP;(ir OA ۽w۴3]P2^oA UrCGTg5j3c|@ yxd|91>3CĨSw|Ok/seT㵨-m;WKgv6|N=A$ـ͌z>Q`J^ק%C y:>FXYh@)? L6UU[Tbk+##AX)qmpIL@DjƠiOO|dCD v?F!i]*ym2b&TEt;dm8i78۰+\#ᠼ,{La#qHG?pN:yQ؟/λ#\["R1p2L" _)Hts'aKZ|h\mlIR`yz62YY貊5AjJ4D]к|>)M"" J<|EUKˍ,:(xrS74-Cfx1OGTg>uxԲ[9H(G 4l9y~( tͯqW93_镮᷍x:BbHzۙ:jF}$Hqm41g'R!Zkjb Hi )Z̈́Dd]x'V&3#k-;6%W9{֦n#VaQ?H ;* Y䑷8!)? [Ew;>c3|( ŵn&d RʃJ|%r$^+LQ\6kklCu#ge3<ޣG=G)CbE:WKɬ9b[n#KƚX 6۠0 &˜etFuUW/:u:h)C'"ٜd|'i_"+øWh9$kbk4o$LOxM.߸ji1*v*N!+M Z1y\책ZoX>mlN00)Ʒp8/?EdnBiM?L2R%^zuv] ($0{3`rKlMJuF})rS3,Ź$_R+<|4`͂*qYjt)סKNz/&Gֹ^Z;fy؀`7zs4y7~^8Sio%U[v:&u٥FYEoKig,Q{'D2k>R=ZT`Dn"y/RH뛗~Q3EZ.`K'}Qd< "R.*[\woɥզ̇k[@'D/0@\IhѽbEM&co1&~[6&[_yyo>AM3R#"e8Ox{TL烬d%`H_hbu kSL5$& J],, Hi[g ,dT^ØEl4&fD WW$N r)/[7Ht7t}c e<$|$⚵4A*M'/Rl4̂c渁dK;P=#Gu?=[&J}`yPi*5%U|Z1 pA8!xUViw >NiD>nORW!JHkMЎ^pu2$n٤{O endstream endobj 96 0 obj << /Length1 1548 /Length2 8423 /Length3 0 /Length 9462 /Filter /FlateDecode >> stream xڍT6LUH$t7鈔DzGz^ HERETAzs=Z߷Vgf̛IGWaSB8cx| 1*@ ~"66}8;! #G sCD8Ԟ;XD @CD W5@pHs('Y' 84!;͎P#@0J!a ŀ@777>1v]rY~ Ђ8j oGC` (œ7!ϝa(=U 6'YO+w"(ᄄ8{m6pG@[I@!hM<wX(P}tWh( Ġp=9fEgky&]ޜupF9{m~a 4p<*Ź1f @"B @ m @lnڀm`7D^h+ A=xoDP f w&o3O|s(;t#?0FagGbSZ)'px x@0HP rw:lNޛOͮ ;F0 $޼Gg*+RzOq;zŸsh"nF?gWf ^U fdmo$  i0k8jl8G3L~D@㻙2c}?]av3TC=}B  $ߌ5u|Mg EEn'F7o$v'0oR otoU 6 pcsHqaP T}JYz7A Sc~|sLbJ]`%sv-9̹ǼmZN\c%x00O6b%={a$ c#~T9NU$ܢQYAp{Idէ*tH(kerԳWmgDnd fɻG`oWu2̖uw6A=g9njMESZ gh7& q}]`r)x{&>RMP3*?| X MtsZMmTW P( msd3RsnL_+ݾ_  &U*7GOxdaVk&Ózzqk<i!1sW*K qnϡ{*(bX2cG4 k пb4$LPCUJ\a &i8&?[~3(x,xp-k9{*gS&nut[y<\u]B>|o ޯbԒ߅l.Q0|upo8hA.>[ĒIte+E+/k:sG]+xM Ʈ+Zǂekfe-mGB&(.P ygNyǰ v%SH_gg҃4(Ԗf#6Fs_pE;+|):" 01|j[8t|ZJq̡ڿɸC#47 8}xVRLd-l7:N,d3zUTkοZ%9$T2@/Wך̣tszZ=탳[ ٦Ԟ6U)6\Lmh%q4)F9Z~%-o)AZ' 'ql)j']uʓ<5Sx_ 2<%5K-ynw[ zReFsr33d/ ^AUI#BFޞ#){3r3j-kmuWWHgTMC|)Mx1ieƽ( %ƀYzՌE=hiL*Y~Q&2-D뮡]65[.@#r'æ}_#9p9zf"+|6pqs%:h5GP@ѴazPQgkKT9>k[b `DwF9#$2} 0 m@9Z0k ƞ\%/C˻̞dËwʝ"Y>Zxgݦ%μKsk8 9rrV^֗ʘyoqd'c+mb@bXOk^__q ?:[[LŊĵ/psËjo2~Z &ͯ}r}ot H x Z[*SA߶9t+Zx xC='O3C#+$+' i-x%h',syUx#+݁R>MwAw>2wJ?+KvMmr:T7 EFNeOݕBHhOB^=a_D?򅄇DmX?FTqW ڍ/w9d4RKKC>Z!҅. a،+Ȱwx2vp+7hO6!Ǵ $9)!ly@vR㷡/ EBQWН9P^e85_s•CdKӀ`@B9eeǑLg2 3] 6g{#:'!t wVKڅV*'Ilt,|a,K߈=l4\ShN7_@eq0HgtՌWLNq2Y(;艶D[fFM_ve,-@eJRD=S><1gn @Yvhw@ڵ=+Z:5|_qaM-fK/_Z-^[ X)89d}ŀct8+K DD`6勗{p DÑ-z4&;_~`o 1l%E,3%(ٯ>@1foVJ|>[ߚ-maЂP";SCXz]n"k+b !V x ^aN@cEIbmijY4ӏ+Lcq#&@/h-jsZ^pj(&, Џ!ix /j۔2h<ң@7a7Iݧp!/[uƲ [96<7\[c:0\Y?_AɰҪ-1cs7޼W*:MsmWV;<Ѧc9U?A[n|($\Fb ǖx}eקi3~4cnlmrg-hدI_ȷeqsyJ*oa} G2~oiZ0뉠m7#HpObT-u|JV<[SOOg>C=c'd5O ڰL rJ]p,QYўnD,}Dፕqݸ(p~ >ޭoL-Fe&!>VR'duvJmQh̩;N(47cWBЬB5 ÁoV+ҸP GgJI\:K/Ny1rC} aŮlfKo^Ŋc)!=AAG^KPY5iE#'I̛,߲eϽՈ9UߢIq5VO5On/tinCK/|W몚NjXDޕ ,Yt=8qAQO$Β2h¸K)%C!CYV>,FB4>$ߧbT H=XzF|*:\J=4٦s*R0Y; 'Oҽ?rdb[:;bDjM3EsRIw%^vk,JK.+4C!qQKU$:ۍ\rxCzЭ|j}2k2;K[q:㗘a:bw⤃#j.]!'4`WS>vWqkcyJLURdCwD;!ok/!*JдÊ!^N8O'ÉyRWFWAI`i;;XIGg@=6vF<DBhnBY{yD' wRNy' ;LI14"JsH e)YWIdj|v9fa33{&&.oQڢ0 ht!gyDIxhkh0\^}jӮ)υ{A *Hxڵ!.ӌƑ|R7d,}L bEXXl8 4 }) )B'@f"͂Hr.>*CEC(WQ̿%wte6+y. ٽ8QL;?ROҹYmpnެ?/ i`H,>v7$ pfuy8Ltz-pi=Ǧu c %7N>לw^X/Bi Kߟ!J}7:jG]*7GU36zAxvfhAWmOM:g]ĉ&~]_fh.Ǖ{ѻ{[(G"uw% 9e>q{J*bnƖj ws͌}yfc{WJw~iAiNR%of>Pi唝91V?.ET X|Dv;=Q>1rǝ= N1)h['h<~fj{ƇVB׽v\U$?T<wSU=VӉ?+s1[pHKk{irXqHDW%6]wX̟YT1 5n bQ$'EfrAKJ/'ή{K?nCxdRx""a)]0{6n@#]s{dLm G)Sf,=or^ǔ:Iǭ@x wYGc/U4_n@lL3k-;PwDv8tR$UL_|Ͽu %b@o=E\.xsĥSš//~T<9nahd:< K1&^ȁDҙc?zK%(vGܵ)ϯXxY?wZ5|sŒƵX `(%+4B֢g)!^'h\;S^~xIX怬`#e_lj54 uW? ti_g7̲VM{/]z|iY$/卩=JS;Ȼ4M -;v RSĐ|".(M:Qdi(ۙcdtL:m\.R+r喙C*x?ȜGgI!6E(OI-TW&kGQUȽF :0xT-Kq)89߬m1O3vETXmPgi2$KDtPJiJ:׎qL^39O`Uw,kBǫ ;.8q f+K"Ͱ*T`:Tm( |Cx)-qAYӢ{Σw m^z >}G"1ǟKd"s_q'Gn+hPNN];̋Li\ ".F8@֢[iQQ: ˶e܉Rk4 ka-cf%HO Tay$c4$ bJ9x?bO: A͢fRgK?cct%y"Pq/=d\gD;`l(tM~{OڀjJyo֌Ζ=;mx(C/8CRz`~)\Sg8Cgw4{F歿Z$Pg yn")Z_֝-y jUF;ܧh* =\hʏrt]y=&?#qayP1;pOCij93HՌ({Vvb12뺨8o+ mF qS)g Q~+=*5)3wIjROЈx֢7-},#KA3.p37"-^՚ܵbNV&Zؑt|_] Yl?-w?jr~Dguk" 1_.[摎 yS>۷$ę=,^DZhHT6~hj-qK@V># lcCa'T~HhKlfHEHbղs"7}Gb':G:x.m+e^էK A}&nB/ӏS׵3GK2m>GST#Qg\5"{2[n膃b@lہ%=۠-͍ ɧbs%.zlѠد\h7C>|t,aݿsJ`E/ײv%ueti҇󢑏26m3mrA:qBEzWWl,yZB{. |Ku`-qDH`z}лr!1pٗhÕDJg6 ׷xY"{] 42xUpMz(?R)ڕu3>qr@Qk2\(㻫6*-Arl&<j*P ~MT@,߷e P endstream endobj 98 0 obj << /Length1 1433 /Length2 6673 /Length3 0 /Length 7656 /Filter /FlateDecode >> stream xڍT4]"(F3=zk`3ѣEDAB D/Do$]5ksgs03hpK[,a ($Ȫ) @ ~YAr1\pRd]`P '`qj($@`!Q rA52 C1ˢ<]v6Zج`!iG A1v0GVP@ea|>vuxm$q' Y^إG.妤m3S֪ ,wKC՛Z*K2TӊƼ]Sf;-DD17ŻW~"ok Pv \f Őˋu TO>.vFmxGZ.6Ql^-*s }F]*yi+v(~H[pJcmӻ!ʣ݋▁ S%~=:QV<9;V wqԦQ=;#3AՔ]O zwڒ4Jn٭11:s}\AZB}({ ac Ԣ,cla“%qFg `7k!?[Yu>75,s~}}cKQJu&JUvH鏳'4խtL?F'4F燹'5{vJ ŋENnGLhSL2$71}zE-> 3؇UEnXJ*2?Z+R*dIxypÜX#(׀Zss7}s]nq]:P|5"J~Vy|qh3M3K,\G 1ޔMMT#l @Y4cߝl6:,iyy}6/FKH5+~W_\fOV7nwj\vka[\%@LV٢^~mN;k!o/T_:.Ox.1H_tH at綯m)åbeXvEh< Dq%MI2_U`*rMA:SqbLvڣ.Bke 7|ZڀtwQgᏄ_rkb1~ Jăt֨;>:VNɱ)d*z̸J R2T-o OӸy4Pĺ6k`vk#(xC䤡6b#U9uFby/?;05|)yF"yDȈb\c/%i6 X{$e2hnc\Ggv% g 4;Tn [+# a6trO%ύNZelNC*Ӌ},*2*(ӖbuwpS5W0u\<=:k>ɤ%zdR"x0>)s5L !koR3gr@;i-ճцC,r2|Gڥ>sfu|{CEŭqWFTOYN^gߗ'(f^tt+&%닁~Oݣ҇[r Hd\/  (鸤 !1]W$Ȣ4˧ ; *i!ɦf)oAi3* qGkUyf]+_Zt4%^Țn1 /fQqqڳ- OǨc,7<ފJAOpRt5xH.bldF9q3Cf|>7%SE9d4Hr&|&A808z1Fx6 Pzfw9bY!؊OAa0Kd^Ƣë}`X[ kޭYꉋ#;g6<?^\!!1@&s~֖v/E#VZ%5kOx枋0Rn. t0n3;̌s\IXQ)޻.+ҰqߟT_tHj,="`G?꼥5tƥQ{j5Na5Ux"ögVBAM+̷duD|}qs7Oh5S7=+NMO'S*μp4N6%JSʧ]1XPOP&"i݀WW%?&;qbس~{fx\a֒%8(T|%燞ŒF1+u4rcI jZî:y%fJe$hm_~tVx(2*7r|&I ?>%#P:^b`|2#XNkпWG`GWZ7~Zq;}ǬWN*?.`}qA IxzNz3Oc3cLnv|Vڽ{M$^/a$Վ0C!L{AQY~+sǮZ6UF/Swh?&LCa/ya<,3j M ܊y$\jHYYR;~]8 8DTG4ڂ,+Ҡ  ġ" o18tӶcUMˢ3c osM݆_g1,𡼆#~ޜY 'WRwLIsrև\t)zKJy],gpP&{'Z~2rS oW8 yV)Oj&b3vo5jgߖv..r'kwD2u6@s yy UČV2V#|ZKs? oZb̜;]Ѧ:4_c]e ֪8nD1wv,Dȕ& pkO1D/(& ][#UT ·rT]Z$6Ǯj!U z~B Wd=Ҋ%m`֮H62Y | R#/{#w <\ZDJ0I fR]B828ы ;xS*q-tjmKhYC=n/l4cOzx}(vx/c4r-WAma7W@(Đhdp־ȱg)tLVlZŘ6tC<rnXoeK!/W@Sw??U"_޺G"mzZΰ؛8TmݦuTX~|* (3oC+]'syO|K4ؽ>~+[rJWTZ|6ͭMڊR@HCQQMQN[R{q;RpPw]uCciS^vD/ #µ1&4%z OʘF'IF2#H)L$jlZ\qbv{rp̙>$FP|:'OUؽ/Pu6,ڳDVrG{Āǫ4eQ:C9]H-0X:ō8cB2bu  (8{;z g/N̐"xýv'7d~!M2VVAF&ǵ :%G +f m8>6[% = eSFtTc8p'G[Li&_N'Fq‰l qyH5=#tzERƜjH/[Z & K3j]#[t1{\\~.g@%8%4B3Q4}]Ŵ*+}iMsa[nKǭAWSlV=HM {:J hAXF-'\%'uqtC>\dWhzn7kN;nm^i?:e[9(SNa.T=~H]y~UYX>#k[wݗB'T56 _~GgSsPxDʎ e>l}GrФksVK-dg6-BGy eqe?ɰyu:2 IFBf{Eg"5L&bQO/M_zL{5Bw퐩I;5RZiIAo5uL*N_'r ++dNB촴1{v96KP ꪴßD FG[%LKmE-s1yE9Y{~[DUUĽCJ2xP7$B́} QN[ru u; wۢlřNJtۖ_0>DkPrHwW#ӷM\OB$!7uLxZ sfE(jg|7RĬ%ʐuj>>}2gi=?O-a UE^&r;u^_\%ϾdBDuI7-6Mg DE|Lď#7}D|K#OkZ˧nf=Ȩ"ЯI%2d`D)ZbzI+[wI$aΗ%jnџ^!='.?oD=Y#HGpr _Zag~VT_qHCkѝ37^~K>0ntX ynlnhr/ZLUXi; B{=InO)w$.Tct_3'T#L=Y@|*`q1 ԛYIqdv-Ԙ43Q]gWH61FXU-m4%Fv?6ڝ?= x taSEb|>j;:hzOnGN̘ ;A$"q޺B( qH .i'&W&?w[GRP^vб0Lo0nK8LJ")y@ڰ\S m~w R6S]!U#>%#ͬu W^ UPnMخFiOpM%zRXONC=)󐱑9rB}M'h==b ^ĉ:'XDF]mvN0- {vo\XlضAنWK%^ !f^iu7?76|B0jkS{8Đz #H9!O>'_EC&ʖ2J9 THo1S_,dKҔT+A'AO.<$w&sS,.iQO{+V8#wis_X!QMHHU;M7 `͖gRfIS{ 3|*AճmLUaK0 u؋fy"aKK۝c&y 3 i`> stream xڍwuTTm>]JHIshPbtaAJJAi  i;$TCz[Y{}8<FB0=\ dU}}m0ĄA Q23 uGbвQ!:5%Rtr A(r""wa AA@Fz8&pw8 ~5 @\&L9"b,TP8 c􀩶` G y;Xw?B;CP+D;$ j {x4r\C Hvl @.[Aw(.DjRW{VGT1..p;ٯԐX8}E3[D 0įF`"H7OڟK?: n(++K}E+@\6@"2?wzo `H`w@~#/)EVKЯ%`4)j翭**O,J(X<;g!ᫍF`?꽼j.XKn A/_3+N.I  .HKzz\>r! cU0(۴= v$X\$鮁ÌP?h~=K_ǿدE X,ėr87Ma4,=@`d&&- XR @,PO,s,/>p(g VSeXWB1$wVCT~|{p\ud9MѢ:g zCY&BMw=Oݖ{bhznOG5xˏn _{H --v/Y9\򧑷JI?;zE%:'Kq䮺Y O$t xNC‚Rt2O|VYbկ:H|!*6؍;*]~RgA%wm u&X `B\kT!#oat]] =hE%Bm}Kgxw6NY$䗅;JwZͫ0"8E ̮7> 63s[wç=nl3CwUN"}hUve'wwm IG;(/J`2gGtobnΖhd:\ {sd6IZ {{3$߀ꨥގޞiˢ=,]ƏφדUYV)WjvrFeglmg+ ά3.r$`YbgGV;*n3 ^5 s5>|*ʔPgV5ܳN I'݈gqtRh(]\8r0lVo>O: pwdߤ٨.DDԮi7sU<>RT/=T5;TTtծ*)ALH?A$f!vqV:[ |o"6;ЖWk2]Bxa({sneFBI&ÖXM0E !CaE\\i\w<3cwe%-/S\Py'_ $p0IcmN *ݝ?H|Wݜ8Y;؝q:%ocoP"stƳu>u$BĻ,Kp9#2@u{\Sao}i tsBZD FmcsPj44)1 ѮobTB66X9?ˎ:/'$T#kHܖ! 9[働>mCM9ہl?ѻ;]N^^f5"?!m]j>g*}ow DVHo.l<<']b" FéjkskwO,(yM}{4屪AePmH#NlyH'ͦIg`(|LyP~2=8~<[ʷ5MTG.Ynӊ\3p>۳ώmNX(*xWXf[¡¤ٶ9D(Jʫl~Owt#!k-ܢk/gt 3;Y6ӳC%"'XY5yO}w Ω1-KQ3=WC LuHh76FھO%.;,@!I4e8/16_/LNA䙯ǀ[( lV'+1S VÌޓN%\Addo9eX_ ~b tf,Ds4)3oSN=:餲}lvNȖ{ǭ*!M8͢sϕ]$;Noq+!hs3BLL&f#ZX~oޫ_O .pW~}˜{̵smrqDv{_ǁ: g[hrSU>MlRcOu3 ^nΌsߎ)Ab/£@4FeL5=XW/ahόP,HEiDʓrU=>mo0 rOa qpWYٖІ"G]rqKGcyڎt!L$y5um2G _PƆ6-vVKs_̀)V] `$^-N? l?gc:)-Qlx90D%4-|Ϋoܬoy9M-q`F0y0M,bрyB{-&GtS0"ۖ1 Z22Do끊6m󽂎Gwkb_5+Rl e7Hl?m^y mR0ĐwF+Tʯ9޸) R2b='trrat@rc(_Ѣז+YHw|ZQF<^g,96 Wxz=b7֔ t)ODLFl VzYIG E|@ G̎R{L")BRE#S4Dzɋxd='o׮P#w~eR]1&zO$ӻSEE|\.~H[b4WXs-UMx.ud}󒜩2_ nN2# {Nͨu+'0ֵE5SG&Uw# iedFP^ eʗ@RGB|6:)Ju8?" JEJ <,LRۉKST}0/E]lwO yMR:R3Z#.cʬ'G{ yA v{B1s 'IW}0C%PƆϟnB:4؋Dy5ds"n~Q Swdsa^|'W?y(4;B-_k=G# z>FcFFjpr9+J%FSqX/6T/>\84@}-m Җ{w₴q[tZub~Rp.c;i{gswKh kEkdy76!Ѱ.0Ul Μ+k=1xX"jxv *o7Nv^/g -VMx%y!-1_D@%ۨoVLb56\7 dv*WVp=>_N~` y>2^6 yz>[M.`|6*L.[z6mA.,R39HB=n1PB1.|ъ-uSOX]W'ɤ~~PNжZ4\ϻVr*4):N¤24?hL!Md5MTn4Щq,.9h"};rE&8d8:HW=\Ǻ@W^U7wMI`Odܕ),ijz'4=t$Qṟ#!,{Bl>BDWWΣ!҅S]YͦxMC ܤ wr)K1: X4~"҆ t50>~Gk)ݴT7a5~p£< lej`3S[ LzLٮ-mB@ Tp;Shmɑ /QV Aw6x~2h"OkDV|}jz;- q ܜXK#h'j ʏ,ΗDPu{$~$=;51of)tCw9,'UNSsLƾwWjO(Qw)<ۖn|)PzWm1_B1pMc,Acà]{A_ӝSIylG8?Sh9ll1۠ޯSRϾS|vuO/'.pU_2_-:e\d\χD wރ:%<΢HvC9 dD-{K;̂M >W,5UuN yw+ï܁H?i8u$r5}I(- 8ɏF>>[~d b&`{Zk_?$+ |.Ztk DW>LN 8S{A-b$>y 7@M\nv7iCG+ U ,tGM9TqyJ\[C8fR45_k.TR0NbAL+բz|8|:xa4.dKT&萤Z<5ʔ a[#>, ~kWCo4mTLЪ[ NVMmhk.Lv'ɥu!)y bUXJwrgTP3)施L 6:a)k6y[}ơY;[aģS+(WS~DeI_V%ER84+KisRLHl, $ڐ3 grn; (zN(:%ph]J^=vU!$吻^k鴕.:y E1.^qbna?] R,`:hHPF}Tf]ީgyPpk|E?ᕜyevEI%&Sg{-`v!ix'wrQ"F]Q"L(5bojŸ%(:B tłc-2ЭELP(14Y_ۢ32_(q+-C|`70 GFNUKad[M#}GmsߐLq%?ziAa(>7{/U3G/'#P7=v0ۙNRĞ_O0h0eO`> stream xڌT 54Cww H7JKtwKwg[kXk*2%Ua3+3# * @ -_1Qg+X&f wȸY<̜<@ 3@ q Q:8z9[YXi@kJ`|;@lejl7vفMmV W Aghll!@aj PAf (ہ fi\ lLA.`7{33LP(:1=_Yllj`hleeo0%]=]24uq[  ! 0oy.V..VWpD@.H'f 2݋;x ̭*͑I $- X[fr@NnV 4d+#o%_bp~>sp ?+s;S`fe 0YX#;[ytc7}z9z6{L2bRT_' ``aZ2N dloJۛ;ܦd{tZفϫ +ے߄$lmVQYzk^Z7W;j9ZyJAmr)YZ-2[+{_x4G>-S@_Jq{SN`l2|h{L`̧qJ]7F`v̮5~#0o/#pf&7Z9ٙۂ;1;;#]\d[ ~ۂ7_r0[f{>l8ں 8+8Y/'33tߑN. ; l@0~LΠ?FyxO`?X x87y9G;x 2EZs0 m&`9?MS3Ϣs#'u[OCoVioH_|#Z[| T&"-L #1 8j@7C~urBSǺ+[ [!\6Q/ UI,9+1;sOi̜_2 H~1E>:,ޫj,.:x7#>")2>%E+ |E9SW0dT[DuY`!I-Й\0˵Da.venJ=U 0my:4pr?mxO` ;qKݨe T2QNM7?q=_<0o:\=#D칾~ 3!B8~|O=?/ķd7 G[j )c:ߨa+"Kb_,b9_5e]xQ^Ls04(}ku[^.b}p^)2C%0E1MR8n{фDMĝ[hg2i1*E>E@!7Yi!P2߬Re.CS}Ӹx%!TUϧހ號&1Mc[ 1 6l~;0jcԫyTӚpQmL?hxpFV`X PXJ&WD\Rw#i\^r~NmHu1HCĉgO9SyQ;VTsdHr,EtdôL1 fiť\`)瑅2b`lNɠW3.։ʌAȸAPps"QiLLtI&]E3I[xK'y\FRV rPKEF4ʗE ,EHz`wa!sm|-7t &CpH3p$VS,:*/GZsS(U:Nke߭ܫ) ޺Y^K.";ntK~Y}3vi4pR^A>GX1ñ;rvذVŝԃLJvB4g+ +VLa=%'1dٶS)hө1ᜲcf eVDhYЂK$G 売իKcye" l57JЎ##<֠5AH() B4+ Eڶ)d˪.]ůpe2U  8M"= xe+ygAk_T0qp[%bڕ`&=a uǴ4"1psQՔ~ݸ> ':.8X&=6%\ć~4!@) rH+Oz㫏b䌾)g&yW3Y'O?`Z6T̊69YȨa|$'<"_C\bQV^-sBFP-EUW֒Te*Y~l͗c6efܚ@9FQӗ"@IYl=wB|e^!\7~,y3rTQ~YXG$'7+uᦽ-d bb%,#BXaaa𤀵)|{ 4cK?C;AW|t&+D)7DlnQ$^oaVH$/K\UWfaʲ,GqF]dzSkiϒHln<QS{K`]jte? (p9En D) "I*$\OAg`A|LMf әuū]BLMd>?^G.,ۅFgMڢ̏efBw%\6 3Ѳ5Ӽ3IAp !y76^+N +K4&Q޻5@YN>v=}Ic]Iz켤\t<2}3T<%ӀXs5yrE c5XWOrQ͞wLF^ek#?uJ+[Rù7PܚR+rU#Ы:e<jah;jP#$ ^?Oˆt΢K}kQC^p*٩[BKk9fRM3lUF9`f=\2mR^tFbYs nC#}eB<>HL3|kϔXv¿N]>Y~_z7rsD'kLT4Q3@.y1E%ämLw&t[,fGơޔc^%!u"U9,3mpPWm7=Zd\vH)xdH?%T/r*lD*ISɀߢ$QVOK׍u#<r}5x%I޾"gf_z޽ߔ#.ׅgNK;1eW.s`iyjta>jA{]ꉭU@jk4Iҥ)T[-u䣝WU#~ЁufI\#zy,:v/0뻧oϢb[+ J 6֌OĨ5v攵)ֿ졏JV! 2.j]-c;1>_ F@P|vVeCON5\10 [x蟍cDR3qR"+vڵBZЄ$o]1! A ώ+L[qZ0X Tl@Mylx'B W[9Q$^(A*S|TQN7*}'Qs? hJe\&E~i8-t#%I hH',' (ʗgya8J*rCy-F{_^u [u$ُOLJd33?KseMīI2EG UW-h#re ?U_Jڒ$01D08aB쁉듴H Y=!߆Ĥ#l`;c{ 2v ,MUWۤV-RTS-\'w$3 |ߖ6RNۖx r ʒ&֨-c2&j湘mJVyl2.:a܏u=%G6di F$ m&y*2hE_C_y#.dW((ЗiD-BU^[O~t]%Ue!W42M0 ?uЄlsbh~^zوʝʨF6%`gsʹROr>x31G}#Ehoێ(\n^+Η)WܐLzٻ^Vg ;WBvZH]v(.V%4:^&p*7z$y"7/zC2tO:!HP' 6~xQ*m5}eǫ:l{+x0zGl=/%d>bӤxqN8`LjI3-:hLǙ}3'Z_gwhZҍP2q ݕ F9ۇZJH'1?G8]2 nKJǒ>H}3fI[^rBVig3Vsum +՝ɳ)Lm7b7 PRW!;fzFξ5ю|[_ 1YԖ-t/Qjƒx/P xaȧdo)rI=$A@#!vzQf8~)L|Rf4h%e"U)68YjrIgSuI쬱ԍ_ &@uըhFw/oB{,(Z.K NA53=_Z]Z V 9v6f oqˌ jPt $a~/#uı'D!cT`A3mSzH_\O^_7ٍp% 3A sL7,`#/y_ HdC,( ӉGr?e>zU[`Ev0(j^w@.lsq@ehJD&U-{ йv +蕛mPŊ* 4/k-z7wˏ0[om!Y&Sox /k5dkvUd+{{YR_HˆOkH3CtWԻx`Mo6jOZWDTٹC!cʲ{z3-Vw LJ5iQ>zUaG}L3x@\٣]WN+l&-Jh` a{>)Fn4H~UHRhp$MH/N#nԈ„gn5ɉC|¼~ȇJL *>-]hKM탑㚀bGPbGCRnQu{~WJ'8AmjE *_ _497+ S pdVDR̅27iv6aPPlƤD(LH⼱e$i0 Sm؝;f}b ^ߤX~"AFEڗaz:hpg$pm7C$f·e*"216hgtƫO#Yٞ7VyYz 0\媍?Ao}>5%U{_jPO<?\jZڎ fs#>piۛ\wOjtM(Բ4f俈ߥRw\lw 2)nhoEH&1{~p)NmP@EkFe/` * 0ck&U=kv#n|#x"@++pe)@?.ZibiKLGSsɒ=+xY"j(7"VpZYt1k(,&&4mvytq=L C4A2*_@&< v`8)k61t7 fc̓&v&* 莮̖ s{X? O.+{}1?RQJҽ!f׃? ]_PSD9|tH^_ X~;0[ŀM܅:w /8JtYetfBqKWuuVO^KyC1tמ;V32ڐJNhIAM~uR8DBTR6 X;ԢLOegfu|SY^e'X\.4 D7"Id%@HúGZ)$>@3 鶏i>4?dho `7C u bVsi1 űo6Lr/aeܛRQ$вp6&\|M$?t{ˮ`̘+4uռ)Qd;Y. -ݢ HOWt2FeE带ўd[LSIR/Cȭ6B A n?QudD<B+\7/ 8,RK(cĒbiKYueQq !YTۧ>'J<5L2$F"GbJQ5\Ѱ/"v XrՐ,"e+dSi8c fPA14?0qmib loR d )*paTPܛ#ȥC<3)Vel-^71\i$'*Ծ7n#zY"W^_g 46<ҋ;^n$"ub_ r$V043:Cx[>6HZ꣸&!>6 qHX˙ۓk zq-Hw:%/}Һ ++zW}߷EnU TGơʔN/ _;/h1Me-W6bXZ&>KRaz1=88ܨEP,q}8vFFH-}Mj[6e4BOhwr~(p #ff+w9n3>ɺk.X3W@O@)LD6AqVv穸؂>w-/\I9Ey*bCD$YS:bf6k<SI(MuSBZO!Z7+bNu+g!˰|k`pX.9렴է{V aXq߸|Y/BiN jS /ڙu{ ֵF*O.xK5J.VP5Ain֩^rw19Wю6$e{ĴV$F).\x/'⣨Rq.moDãs5c⽥6@]4-M=QX»[ρll nĩ6A ѓ8o? @4 }V*l'~ Ni;Óft}tO8DjJz㼸OdG\MXb˜)y(1,KT}-}j:kc0yb!5HwU9SF,2̡.9 YWn%.oZ"`a^kGѧ!UFBO[f_ޗKY(f_7Y=Z9"ö/8-~=V^&ؔ\F^cfRL戗3Lj#i5/u |W+IFF?j/('o1=W<Lhq_S9 dd" C*WBuMjkx'#i:,t>HK[ZoN1A|%Iߵ@=j]}qrhe-Y7!m*VMw"/^lNƪ7 f\Ed8}uu*,M]DN9tZ02Bh9Tac./0Ǖ ʣ @EnIiu/`G>դrP}PtVriV@1B؞P/9$#; Cɘn@\}8]}$ꛐU9Ri(ehw܈ͨ !*~Zv/:T"Vc„>&,_wR,Ǧ'[@!G43g.11,z抨!✘BV†> c4 بX kB\5((\SubgT%{Jʨįp}]BL^!#`1kzKȘ a;.#DeGoNg:,Vz кcFZj v#}; :ӓmO2Wckéэt3D|`JQW&iO%S!}xiti.&j6bp|iv`2XY}s- x('3|\p؛1S1 #`Z@N@抶2/6;^ۓð">˩3t1\=eD-T-J`gƎy|S[T\{Ux3n ##խ.tMj0)G !zm>仚_Ƃ 7g䌀Vbֲ\[ JK9dCfđ+#H'{\dÌ "X"yܘ֤Pr)}j06n0?'צ{3qb2on:֙3o.1bpCLJcs 2ƙMzP “554>.w@O51]ؕ%͚M~d%7\c& *NA$5聂Rǧh-Ll۩ ۝B&-R␇]ѦEGc_Q_q8PN!K'6F}vYp 8 PWAP_Iw,i@bmεYvrҽgxuItжMQ9K(4ESOj'jDQ_%!SFdqvnVo j>|kOfXѬx3`LI϶qr%Yplj2Ȧ8/vjafg&??*p2Z*P [9;DžQv3 +ʵ6qa`kA\'+łyTj|3EoԻ{Z<#'ޔz٤xy9k3пw6k㏺4yvGgeTz|TLIL ԛnjw%M8|-"xì%в#.Fm tWr$d5LZ3=8ʋTZ4RX{H`ڝ%˴oF:Nu><=_eCp$$9 )E 4oM.wnLT/*/6n73KQEe \3 MF9ǶV/5TeL[^ɮ$OJ'~V-F%競>• 8#sْ9Cx}fyHHOO»8UanM)+U7܈{܄p|O@&(ʭIcGF7m*E32 wk¯*ɂZZvgj<&SƂ 8:¥#\)/KGg ݲf,av-]q2JqK:a3&4鱻0wa٠3e3 b)}횴 񡄟]-aO*EKx{Ngkڂe}"+3Bc2Ր;\w}ئ,1~k%nu*XgÏ.B!4V,fZ#5$0^_ W:7aoT3?([GD-j2WAzL(Kkj r`k^RnN'3Q﫹O#_pq#V˳ a\QG568͋"'` &671[7]FBJ ]PAR?5_!7SkD$C˹E򟘈܄۠yPXE(d}$)} aqe33aaaBl<2!F(of ġߧxc "`9 ub(X#(pia>'4|)E"*VjOBo|P{F~}%1mlQo=YPZyqG^F,H}=zWJW}sLbjiOx12 yglF+sh5ճs%)fUPQE^J3wx )O*v<|ru9<)Y*uҼr=Z(LqG&({;Ht dq‘T5>H"Bf_( OB'gZBJx ,e܄oI&LٛmТ$f Aۙ狋1eٗ? U\6-2u:¥4H/͉諰#(2ji?5sc|Z4ApR+0^7 Sś)OYE;s/Z/9f'm0fz"d(JFOn9g3XUUKYُ'ltޤV}G [exGm9l2>*f;4G'o<|u 9w3L"B~B`i)MHb2ԫe$>9M#rhM |RRgbŧC6';Z(Nt;Ò:W e. 5BaӆGnr?,Q 3˘7Q-OY,\#&dFP5rW~LF[ur{Ӆ`$?_̋*%Lu20 ^ՠUv܇'bq r!+*?}Mq4ϊL@iܺRc.#.)ŋp2Cq$q˃`1K=pg7lγJK|`Ȅomm aj"zx_SJo~Ɠ7d2xRYy' % {4wq s(tߍl3_׉캡LXLQZ7e 3]li,ӝ,OHt+6*ߨoid$QdqP.F2h*_[kb@_~`cdt@4iYsl oiIIܛ=HB)?Hd!WpNYt#s+>V-Lw8e,dGz>hѢ|QFh>\$|թUzE+ V}gmN:}R:e)'U?{ 3}X5^cg]+vѹ"!b9Y=߼&,l&˝D6#80P:K!^`E5 p_RY. A[,hO̰'!a8t[ KC"+eG_&WD:%7{>k!G;$ 0H&x?4ogT1J^+b}y\(Q^t=`7W 8TWd3evKd'=n"{:iqU1s7b K44j'9D hE5'+3cmL kM ֔ o-ҤH 쵬\~ә;︜&O1Jc())v5>Xf7 ݚ̴m+5xο=eCQDզ^>!젊64]tA\PpJya4 #nkl5vWcDb/sWt* h2Ou ^V Kبi*WhnfxR(:TaO\ CAd_{GMD"(|usc'onWf_mG9l!C oY9K=\‚(6wz=/DDqlC{%|˩'=Bv"QZ\}cѥ~MxǐGːtyU^$9Թ9" Vl1'li2R7%2+–rO58Q= rذSnpYXK|vLJվE6ŘQ1&ԱPq] Oߩ [啍|Hn,5B3ˡQ1iY<8GO,k)Źo]{j`5X-t\++#-kӻq=lN_Ԯ L@.6]Eabd'=Dm%?#N}B[GZqf1]C W9u/u,=owE! 'x])[>Ra9pE-'쩵in*9b Vmr `?q i&"k-w<.dGA" {MMHq4V @:پ~I(%qKw i1=[yy*] i{eS">X9o⫾qъ>GQ}y tؐW`iڀl|Al*'jOdwd꣎eb =moiRWx3i۾7h_ƺdUnf-$tަKQ ߸;rIZvoؖU;D6b ȒtoWu7@x$_u{4[N:8jd7GOAd65C`}d?NYX}'XC`3IZ 'Oxl$NgR4;>M#k;ުNJ ݶ E;o_PID}FHBbQ;5Z2\w[{B)^7"co0]I&qhɠeUa"w# !|IL1zDCb@_RĠ<3D*(b@hw,^2=1?֪u nPe JT؅T`  ,V۾կHGH)+͟幦}ʰr!A:4BɏzܶBF07Εlۦ1Ф鉮}>pz<0_Oǝ>oLތa\u$w?&t@fu/T^ E]@o皶KN`2823K>RjAv~Y uE5(o(5nt}1IҫVQ[R"pݼm7n]@DalDfh{o~_~ȠjqY |wH7,{nLgbJ;R]E]$T8gj4[Q\N'NRͺΏ02j>sB <#TOlXX@C^ twC+4A8DǢ'2,ޜFZ@<r"SD~ ^^AFxQ &&M7yc,"_ j46]>sY27P(-WB C/¿Y7K5|%n0A! ҪnT1x^tg;H;*_}O, ycF~?u`;Vd015tnMpiO\e ,) ^6 {sm]#7s qpF؜P{Tg[ סUŹq#ޱ* %&y c+W_OIG7GG]9h0ܱ)~Ʒ(PXw ڢ?5>;C.?U|QAPβ9D +}^)vT֤:]\hof` zK,08|ۛ]ǨoX>hp$uEu%5-vfA̱@;=' 7A&EU&b8說ěL]/ _XO_3R'ȷ&E8Coη IIިⰘ_8$JA';" bI?mDPl'M^ڝ! (:]a6cx"hWlѢܴ̕\#.Dm8$SSa҂!Q͒^sFa<C>؍fP~v ˑz"hN!Lb8ff"ݧEb?ISh:vOj9qk14&]LAS>)a,5qdX7!ߥln޶˜̌?[ܽ1ޟXߜA,uǛC>8 =]"VfQqzxnUU>H %*88>9p1W)Ϗ"<&sRߟQcpݚk=O ɴw?'!Y4ܹYb'lM|8Jh qiQFq ͨmL%| /}0YXV^zvT*1h~%1 $. ާ3dxuz璙M%E!L*Nv޲qwcg8,X$O-2wQ\׏E(5Ց]-Yy<-@"R*PV.Y鵽Up рWm*8k$U>T:I"XR·-yON|FW.iLS_1Gm mVTw\DTk!2FRnLKrO)ˆ3ӐhndA]}sֵ:[X(;(ƘO…qCkg22Þ* cxnBXbs("z”{I[#N, Sg*.9R^ܬgoZ֔ur祇6b?DrBI 6?: #D ltʙOC ~fAފi:0]M&3HM^ q6 sf$2iDefBsV~3 }SUVj_`p{6H eⶋ&ʩ E [$ ǥ׼Edipd  F]7WgmekP&kj8!3A~&eW&%SS'P@O*juCvecuUyx$HN,}^tJy>&+S_vU6e7JnTZ{eh= jx _e$ƒ0q!Kʴ+;u~yBMbO,~<;S% -ߪ8tDD5~L։<= J}:,bY>+rߩntV^T8٦@eO1BRk҂@lvyARQ'0M>vn\ߓgNeqPۡ0rRZW0K+4D:L,3U~5@_TmH~<ܲ#+HE챘 ci(ax6҇VRbXwT oQf8WM'1GnU,_(CP f2 zm:A,gU;[s ʼn} ubyojn0K~]'Glj-.d0B =4"GY5$wbhesx3vogM3ZOX@;X`aMM:^\m1GІ̷ٍ̜7> FB ў$lxStetF`79dTsQէ+e飒$x'Y,n=\8$gb??uGF-JD՘ev&؂&L$RN@T;^w:auySjBBשkT`bxj,(;%Oִ#.y, ʞʣ޽Rt>o56=X Ө9 \}epquQჸyb1~AM ٘⼭Wv›19%#]n?)|I;UMt)sQ\攱b΃!ōeHŁT80Ze"nW{*7 fF [{%*]tƔ)B觮5ͣD);c.H{R &C-)p6?]k=*d6N$ԗCZp!֮C@+6D;:#ez"l}4|i n}D>Bz5|&G*9 [o/Iybckp|nS oEte6F:-+"5mV eD3-!h 'F㹜D\D'/&*>17Q1rNrVPG-C@3o=)PmHBJWMA:^MU?A)(YUe0pb %Sov.nk0WNZ'uH/m-d.YX-ߜT@-l?qV"-9vs5U 'D!4p= VnNO`|%3KO+NpbD`m4XYxex]OW=ݨ^zCתȃ{t{dRk 46c7\ߙ/Ј0fGz}2pygPa[䫮°fG`VЏ n@Iؚm`OG~] ,> stream xڍT-n;;kiHN  N!䑙3skzUTuh4u8AN`'+'(@VM͋ queFc\ NPda`MSsT<|AQ!Qnn/7N0QqT`4Y'g/0[xDDH;a+ t;>ht8YA^YYÃ`ax@\m`0 nt'@] +0) OtU`d? 쀿f;_ѿAP/` q4T9]=]@(7tBO?*j qvut8nw)CAN` 0ؽY{/` 7rs҃B^<ـ]B"kʖwz]/gN|OM 4; sX,6(?ٟ`? WOpI^ '??KSVZZVώ8y|8<aa7￳h!UO2 gOSO?_\NOѸ ,7oA n@G_'ͺ>_i K5j`ʮ=8=F ҄Z)?zk:@~*n=m?\#VN+ `@/4'! |xVC.NS=? ~@B.0?Ko$",F%'SY`؟ T!).`+Y'!v!?k=8v>O3p,nPRXjSF>,o3_J-R|okD oO{g=Ӂ6hpt%*Ԯk_@{6nnX?==ʗfwvk_ߕOqŘ0[f%Ev|Ίw=sy5;HȆwWcw{RץԘolGf?UxΧx 6k|->O#Ä(3) "rtZRc)M2ɲʚP FQAA@]d6{ސ5\ۖ0'N Qc3tKj2d2B*e!Oi#`EfdsXyT{*`Ձ*i{wHj$_۞+FMԐMv%FDK.3I}ܴ~;:KV~ǀψo[z5UypPPnZ7݈lʭoD=0T}<p~lZ-Yn#8G#Ax:?NLAe;+GHbx@<iίם]vfiS B#;!#/HG4/][m Ib_y=rSoCm áS(ļ8:aә$ uW Rff `s <7Ss/lyǩߨ4>QD=3[':Y킚%lIl%m2JQGµ[m+r_,L[񌼂>ֳؑw8(g6j&(XTueSĞSYVΐїiB%gX"E7故 ;Lr&i OG[3oؾMVLeR 0%lJ^%f-"D*H5F~{6C;"oj8zӔ2$IZSMz5\ ;-ԁ z>Z(Ը[Rɉie^ R/O8DIvu>wg{~BS*zzaIWGiOֱB ejmD8ڽpGz4%j 6KB$,mŲR- 6r_DSyzHSR4GWh5^V5R0㿑,8e) waKnEC/P+I\E6%8c'mB%%=Ĝp>)+G; V1g4M&-^N %8<`87HyWʀ.%ď.G9S`"gʖɹrj3}/^2z WqWR4-Ȭ9):7y{!Fʋ7β:1ۡu03C[lx-">~\Ex(AkP%[i2o wԼH)RJ.lO^T"P5OM5Ma˼]sH0$Q$0t1 $ayFF/姜K7#Ihu3yV|kcuG˖Z6XH|šyec`u%,'[pHA!v먶CSmˇƋLineR{?g6A<ì_ b^x蜱'jdv)p$;3uيN"=c3fU78E4fd瞼Bˀ wlp#MS& B`Ҹ%,l)р_v jX0v M |I٫!A.~C\F@s|3q1GޟwUO=bV9Nn4mRzdwEf1u7M`*R|A@O₼.>ﰣ6D #H=}z3ih#J>,\5#f9ziWZZ O@Wp9F,~VMBi[Y`P65$&n\kT2Ǿ7v'o%=WpPG~\(4T3[˺= 55qVFgӗ7.Yˋ(a襢]B5̱5&%m Y553[0[+G#ૢ +Xn_}YAbzLK)u5+7E!|I0|Ϩqb#O-G!uo>tey8V;~v[BGۤV甇:l]~śU7%fa u;21͋dn5k2_ |ɱ:JPg?:#^@w|Wq82XkH;iHVzgelmzIȄjrh}㞀XJ!̉셀$ ;9EcJpD0gqis q On]޾Yc[j[5֬k! QƬi sxTaGܜ`@% TdCHSj @|mљCmt 5N 0.rH.Zڻͪ c癈| wDŽlIh~%g.9(+Q歸dk6Ǟ_|.;W^UFK ͥG{k2Y!0LL]gcx3AҐ7gFWugN 36d؇-!l1Cx9C7jE6*K^5pN$+xnD{SMz?MbM&?1c0ĝɱfr)yT׷ҍ;{@-JgO6!JB(Z' T{[1]K]gsm]΂v:hΞW:Kb"ج~eT{R7 姍J2g&Hfl*}/< MbXuN=Gq1?CWK|Ҽlﴛp I9?OɑSn}ܣ%!);y'!0)rpZ %,T*Rv?^QvD䰸ÍI|x:HS\R[_ & ǵW13pZp^a$YG_5CyvlP%vzq`Ua!㣇O,{8OG™^JkyG&pN >ͺ( Df&bJ44ɶ4X˧)P_-v^ Nt_vLb4:DOk)qwfpn%le4# P%:ͷhr} ~UeVk7kO=++Fh A촽s+@EϖTI ܨ9VvY!fy0zgAX\2"u(1耙%˟"VO AmV Z~{7&lCR@Yg96,eK@#3_%Jk v{d98y;x*KMEfUu}W-p*2k􆟳&,JmCc"OGA@z1HWģ0$E:׻ %qyTBvrr3zlTЗeMr|vb+my]מڰ'x/ o P?,Ze_G"ʄPK={VJKDոˉ3 D, 7y{b"cz)@?مځ s/{FϴүäH_{ J,;(P_Uw1,]@Hg;ٯ68`[h$ag_&kcY&b)ӗV /ɎgfPЅڸzi4&XŲIIAs;<,>z}c8tEiEA:y,5"6N:Eelcb1O&6MQ%Vs#ZRM*r8ߧY&+OHnQ]:@ٝ5Ga!4:N6>z4AJْs̠mbӗ|g~<7h F+WWa x;61a3H5/y~uD,I}dk?MK੼?L5-\> }8 >IYIɳp&0{?=n!yԪkHl4FIAޘ1N7$pe념ܹu bL6AՖNx.ë!Db +&\p.ZV#B A \j ϼMh|>|^ ^ v98}9ð9k-`WIM4DY++S]x@\ :/&+x5!##xj{Muµ:?=WmVEKhBeC]|nxYQf4@'M  kP 'rekoC/0i27ѿBk -N%= p$h}`ei[w+Maly"QW4j^pXJ(rqkIv+%n(ba|R01zz! '{;ڮ򣻛7!\끟i,qIx9[ݛD{[P8nT^|l?w*SC㫼v ',];d#7Pbnf+ @k,fu]5ѐH4;X"&p鰱DbXL| "$3$pəq:Rm\3)\+E"~ePj~$E0WHPO[k@iѐ';䵦}-$U R#t ;
ES2HD^Fȼyr8j!ә+M)d琁z{.wy.HxkJ'C?;ߓ
j"d'0;߱ph+H~UΖ[
5#,y`Ql?!]ȼit!8ZBJeFN4\>9vn<+<7:GՎj@AC
endstream
endobj
106 0 obj
<<
/Length1 1618
/Length2 9208
/Length3 0
/Length 10258     
/Filter /FlateDecode
>>
stream
xڍP\[.!
.Cp.
4ҍ'C.[<ɽ3sg:U}η|]ME$j1JALl̬|qU6n++3++;2:Ja 4q~I8)@Y[7++_G>+NT{GK}hl܌v@G	`l{hfbPV͍ٞΉh)Dp9[TN@GW9wE;_1#Sԭ@N n&@d;x́5y=_g`cfw8AM %d(I3;;3L
Ml /&& [?DU&/
ݞ#ى	dEa^,	6Nȿ9^ڀ!n`ln	s{
0(#ɋ?2K3tͬX~WQteX4Y_^^N&@럊Flls3h	#'h~9|G;@{lϿ^ez(*k3ubbwweUUlU˔UOn;"䅴@8j?.-H6zmY+@^ZvVhr_-m=Fhr6,5~/-T8~*&6Vѽl?*wJIs8:x @?0!/.|G'`-x,&A<#d})_XLT6/my,vl/eX DN,/\_By5V3GǗ_f/݁fK3`jQB7q=T:&%7tUעC=;W"ˤ[ZUUڐ'q'
EE9xk@upyu+^W2:_NlF~@,Ui931"=;f3l<"/M9ϵ
uv.|J|]E7328@^%5e=.׍ qtIٿG7vR
E%
_mQ.LyJw$&SJqz{UE+V6T5cgkzm
ΰb	!a~yLk(H}md|8hɨ^7Gj:h]-c8B?eMU{fɲZlZeO>eE"xMƶ'<@NO&;:ݰ{Rfۧf0W3v}o$Gf߀HARJ9ۋx~_E^҃7ÑwhKLBCؘ"Qficx#1Hȹ?@g$QqL$-Nâ"$'<UZvHHmMeJH-wx_a߯J %VJ TzⲏTԸD{owCJ0xRL&*䪍8DM
$3
v?
hy^Ab\<=O;lgucW~h)>`hۦ[C$;ۂ^_Ä́$޳M ZY
ݡ{6B)%!ui֏#
XE;Oޠ
%k8{ώ[
2 3NZEӶ*3*°J?&\fTr	kZMUw	o^Cs-Qk[0]vm:Ap.[;
3owcXFsȨIg$	.&>ꑲ}J5⻾w1}~V&܈DzZ9JrŪ\iʮ-ѲqhOq=Ԏ!ڐZJ継acyv05?'oBiA~xȽҥAe YO.t4%1I]J`ӏ.|GkNlLɫ(lqAUŬq1·ϚwsEƔX,BKٿh3FP 9vz:gFD*h5wB#/BX%S
,m֠.3uplUf=Py__qk95ߴM;\a9KcjQ؊#6т7^AM(4Y@ZgȐ$E9ݣ†;m6=4gf0m.Ե<)`#TCaRwKiTۄqnJ9^)FBp{aG)uT/x}Ϲ\Xm'l׵s5{+%'IQ)X9ܬ9)֚ӵ@FnEn+?֚Bj!6፭
i	;UV5<"-z7`qoǔz4Ƞ7R%+U[7SiEp('hƖN2Uk <Hg 2k{8ݦ/̰5ٝ*ȋ=᪂_e&Z4wKn\YS"Cɸ$a26|ckOԷT,HjAwԀH:\XdJy9`uJ]zq`~EO*,*V)J*fƐ@gAg8t̛Cq񝈚}lu06m2xˉǶ E|})s]S<^M{B`~>kAY0G߼VDEojl>G)NGߧC\ӭBhY~oz!Y2ԩPʴlX%,f"D	hJ|\ZvYԃCf@kMZ,zM|6{诠ewuYW%0FYCڲ?&iVOw阯+OjGrEMud J2%Ǵ`n̑G91X*KQ``LQoMzL;dI/Cz;8>~jSQ/@
;	JBoeoM8okjoXH5Έ'Y<jüH*짟#3<2~׮.ལȄnOX[!)4-|a[]d~B1,f0実N꘎cR${up2UPZIaIf+/aEzRUvĆ)tմ^}
^~N=v
ye{9ϐўc/E1eP1;eyY_j-WGVޫ`م٭W^-'DU0jԐIϨdFfHc\ҢOX#?5.*Џ$6W(5NhX=w%~63 yވ(䟿s#pgLg,SOα
Nhi|iT~2nKH%rn%*t!WWMR(ݦP8@.AkLeDl9rDNRҟK0(1Δd
/;JzRs-Zt=ޏ*'h2ѱ3IظK}Yv.s0wPq(!U|WFA+AgGD'qAskuD}-o#hnGLDxF(a~57SMHj:|HhkmHz4mǘӛsu^]׆g4m
ا^KԁjqbQqp
Xj'7QRx<̷klf¡db5OKyIۇ
Xe*G
3f^8P^wаS2lDjg"Ʋ=$`+l=S
)"jWRg>+`o?r]3Vvţq.vZ-gۮ|~RdZ8.ARZ蕶%fUoEQui/➖hg^fz:vc+oZlo=XORTec*2~uoe	xV`Ж5i;(zI*/BXN<|hrКiFV6l*ŝ''+1A,޹]Vujbn2h"lh^Ac=G ٫I+Y
No!X4cA{c'ى/c_H;a9V]$g]dHߒʅ>!'P.GWYp&u0=J48<}l|V&V
%IYVW>XDh\H
,ޕjZ7I(PrW-[.
SP|Ti[qGWH+JxF"(0_<9bjw:KdE= 52KۧQw
C%r592YWSSd_>};qm:8	dH~*A[*l6jPbŷ	9NmH;br[Oؤ"ϡl|^@Fяyu8b0.@vԜ;<X!3
њs^4Q!:MwA,k-yˣib>Qpr"|%W4)sÊ#D'9&YX]VTRvO.W
,\]{ծ iNO
kkA5r;|+i7Y%Cf-X'ѐ0hh.'u~iCkT(ƂVa^"J(6 Saܻ)CuiH)zF"1go~ChF3z١G50o%WekU4 ms
?IeIQJ0kmP[CM=iLi2ТX@PELFLq*Ti#M?֛]]xԄ|xYKJK?w}pH.-ƒܚ&VH+Lx+$/E$Zg<4p]Z\S#:W`/8O	aa<0[
b-+q1O>1>`l=#b!$;£'?L`MJU>Õ5 2B?J#{'@:vaSɄ;C-IKM!,Q,`td;]rfAkY5;RJ-ᔮ-+'alzGK_
dbo~~zZ,Z%uH&4+ʽ7lzۥL6\x/626`l!Ms6YnO)X$!z9F܏OO1fZ2XiUĉ~.]kxOOwpn5DE7ʶڮE3Nh?+	?
[hX[J'4ڜᘑ'ҙ!JݍKX<{>7!EDN@qT7%0YmCkڟ+fuؼ$t86MMD_F-a.7W`ߑNd>ׯ4vK4GxpJ*1{u*39s˼#9?WjomG&c=j
rW@_{U<5`zXLN"E
j1$*z4`MBИa`;b!o-Nɔ:~3Т~o:DM?ܙ`
m: {ޞd~QKINYR
m`ņR4LG~
aGnr$dº:Nj1(πwlY+_Wg,cCt-?˜Pz]l[|9$ZZ+k@^^=u}絍ݧv}6[9Gt$(wZ7}Ac>o:?APcoMTN鶫'y5rR,
#P)$3BErzuv) 51?hg?&t9Zi|-q冓Պ*Oe!Ycqlu>
oŜ4UҦblR'ɤ`bQ9jB(ݫdW5̛+t*VRcrV|y~9'ϭMLxAV̗&	K8 
'nqWHxa+?\-MC*N렷OG4-kEi.G8]oP:S,C*D4T(ygU1ʬbjܾfmȽ?vHob"6%k3x7Vh)QVFH:Ng}T_3q[+gȪ틐QXg<)AI0n{\?ⶠێpm-]}ua>8jlðOT]r>В-3=
}嵺T9Jݛ
>T/(3CE/!՗m;Hq	G24=\.'G-G|,ҢچT@P^hYff[hk퀄|'<>|wz00W֢
IJ=q:%ouss"`xY#_QŨOcz2	M6<63?%3|4ז3ZPN$e,7r?G]5 -]bZ$N˙&v)c'+ygƝdqMƽLv۷$$$鍱*k3%!;7*{HICIQ&z\diXc04RwPmlIӱ>o_6f&hF䌾\+O0m%gOs2?P
endstream
endobj
108 0 obj
<<
/Length1 1391
/Length2 6189
/Length3 0
/Length 7143      
/Filter /FlateDecode
>>
stream
xڍtTk/]JH!݈ 10CH7HJ	HH4"-%-) J7y{ZY?=Lzv0
	H
B|F`GKjraPeWtY#P:%kMhx@@!PT(&) #]d	h4`PUvpD%$x~]@`[k(@rAUa`_)8:"^^^|.p>'p wO׸kXF`!e-
Gx@@Tm@ǁ|+;j
C`Ň@"xP_8oi
X۠~7n
PXk:;烃!&uP;EO	Eݺ7:Ca^P?g{0vPH]/@n֑Wr#oWoo5_W+5lB­=A-;-`rC	ɎRȨͻs_OOPزA!^.*6)(_^!Q( &CEWĪCa?͢n?
{}	w.
 ?E}0C,w?*o+/avC@a_b]Udpo:yKUHa*ƿCAz08׃

*[gԣG	"ͿK*Cmav%("
vw&@%|(ځj<=̝>E~Qa	?[FUGx~*m"oh dK0=	zTR΋w}Hzu+N^i"Ίg')}HV9f}57&7]]Y%7|B=\MHn$M5CH/̫SYU2;6Q!yd78"h5&kˀEv$?>#{=|˨M+lI0|gHƌl`Waƽ)7T-./-u3ퟖlÒ41jI.ELI8YsHb
6p$.DȪaU\Tj#^jPVjm}?YQS#J1Z'8?	.J(7V!RjD=~Zit?{c
6tMSt8~zm)T:*MW;9-I/9VSx>9V]>qݓݔQla`Չmg9S!5HlcDh	e)?ht.,pB$V$b2h{aNu-lx%9cS$AWPH|&}v^lm

jLܑ9崯uVPτ{nÑÙJՎgDJ%+ɳ3 T1 ֯;;&+I aM9?Ƅ>pYĊ-|HD\k|bf8DyE/~Prᕿvd^aߖj!v`Exh;B+a 1uEI)EKd'D0LZXvO"IЗq̲0Τ *b }Ύ{Nњ߰RLnB2m0Mzt^mDfEw j:?JFI_amj&SY,Sm5=W1w M624U6wvcl8$2M<7b/UC$Armť1>Zz(q#ID뇻+u|٪^͆'$2MN>4cۊҸt]8O/_e!L?iSL.ښF,1S=BqΣ%.jxp&53 "3@_fp-Ge}\AMkQxqR&θnx*ebI՝%KEq+$"'1Qjg߿qnfy B5oYg11~fv}YqnuۜoUBhyS: -q"e<7L1̾+쇶(}L!bQOÆpE+}dW' Ijķ,e9슧x[l+WuƲK gULoVM3]لO(hNt-Uo\=cB-S(:;qcg ,qC֐I4b+4@CQw mpҢ[AӴP…9Fv|A@F+R"ȍl ne3=i}e{V-fcix?RϬJ]/\;\}\qHOC{䩾nfr=KvXgPC5fQmW:0bq<=[SaG]H R3zηomofa˽9.[U>-d"w5]s۳54L.v l >  />M4uJ8).MsHTa1S)%y]=bj:hV?uII2T G~g}BUZ%0\ZRe  f+pvYn=iGٹ/=zpTjYx#x#'SNP~W`uDyԐE\̉oDu5rwJJ]bsM 'tA ٧_/N#PclEst´}Ch&{?}h4rfkɹ+2DxhyrLr ؆cD~Ѵ[{A|?`C16:$yLx^It 2ɺ,,ojT&~eN޻{앟xӍذ\-<]JD*Ҭ&i Ioy3UOHc20ܣk3P|c1Uܣ1#+2y6Z2Pi`ڥ2g.?F$su]a1 !WblŽ'MI.Z%8)SVtأ>lyZR){fqen<0?;L(|݀s5<,3 dKwߑX*G kmE( b &n=ؑmqMdhO;p⻎ɦe{N2j#q ?}2wd8*.63#pܒ}z( eӇC#{3~:)NSɨKŨT b_z:YV = 6[)"H\ny, Izm%;[d-(۹wL3 q\ N d]gv$r* մ﬑Mu:PO7w4QT:!5p=m{č' w?$nLYniHm*S/#SQ@tuhx_^yH5wEh=K'mKƈFm O6s"W6F7r%cյ&*(=ީޟۍ;5oDkďѡWy;ؔsV:%_z f L{>+l<9.`>wу䇆-l1wzfD}>挪mo[ N:i Lxh*,u9xS1 ckY=UM}t/ݚIdҌ-OSS"D7`]=I]QOQPCb6 wVV԰ZO".0 Vw$9 ؂r!XjpDSY3=}qܵ=V÷eqa {LRTENO2~H8[g*z! 3Pl.IGi^:;BG?hD5Uxe ;-~߇<.WE߂ U)B?̺eI]cg'~0ux?O7cJdMk(e6[SA%ܛ6ZTHL͙4P坃cط%ݳQ*]PN>AO|x!BjX-d/ 4!o(x.h'CHZ\u]$@v9Pȳ 0W}8BUU1+8ԋ's.FӀfQ8W]{f"t?ޗuGM!9h׻ ϻ[U"}:_3}Zs.dA+HY4aWfN:UnS0!F겏{72i"zNSI>4b-PT;HAhq⻁%USwƷ&!oTb/˙ct8EMKH|lc75 YcK/>2,+\[k|^&)ݷ@w֩t G4f})Iܭ( ( hX./iSyxx5 xԒ*|0@T _mdiWӻKȟ[;%.q}{c>O( W}w\w5޿\=PӴQaW~Sb}V\%YykcDO3-[d=RD3%Y%?l]wu;4|_ms_uq<~K᧠赝lP5lHEfZiW( Jn~D ^Xi%7mtae7:= "{m/919 婨\l/>dĖ*~IQwHi[VduTEnY`mdZM0,<d;*Ͷ'"9y xD)W+l8dvJSwجHUkj}Rq96k㎛ť&> stream xڍveT[%ׂ{a]\;$xp@pwy3?fVQw(HTM@v. ,<QyU955f33BǃHrrGl3vd\m,@  '33߁N<1c7+3<#@H!jdea~ҿMi,ܜmANVvycK-6U{S+tqqabrwwg4ufw[XT@ '77m-?)jVT]܍@d Nr39J@v@x,,)߅J665u0󴲳[ـr..c;߁6|c7c+cp_$`bldle%2Aۙڂ\'f2Oޓ?G633MՁI$-( `gff,0d5O_Nf0_o{9 l8|o02u,TAc <`>Xgfv6:h&5y-m-%[D ``,nR2W#H3p/xP_Bמ=X 13?XUWK쿫{p+!Wbvu=x)7T˃̬\m+b ^ a; 86[9KXy̔\L-fkgceRw}X5ο\ *SL~+;,*Vvv7 x9@hgN-'+I/0qs . `2bc#vͅ,mwt O 5@poNw/۰;y:X/?`? @0? p?6?g?vSpsv6 ?cac鿦x1a0̂O`lclp?/-n  \O7T/ߵKমN`.E` yLMyj v'8o^]Icl zp?JSօ 't-.J*Oz~B4nڧCQsҊm q P{,?;GEX*Ńyn3E)<߇;ŘҐddtOnUu`}Dt0!.b}/̣ڿ/]N߉Sk$7DLbt/E}w<ŖRg^R0ffƌ|R͗&]Ќ8 nk9yIؕH00lC~Kt@EWѨG?#qV55-$<=ݜ(.f쑼MX8c7㦯sSW0)?BPu2G6 {JΟ&?rVTEeu޴MV ҷMg;@5iZ%" 2.s!VP$AMLƢ1{lebIJx&F7p{3P<|Hk+=I:hI}wѸzPQx"~Ȉ#j|L3T$g_W[8ޓί_qATml\z3[ ZZȞ?ʹ[!F< \UF6΃r靝l/眤4JB0v7,޹,x _UÖzC"Twİ^O5 7"3 ʃɌVqH{֧ mق/{K£ߧ;3Cw؎YF:Ϛ{z;Q9&4@Fܟ?mʙB0F9j߾%ræ ~.W\kSq; oH+b̤YD[@.* +# gh;3IpƔK ziIF6cIfPP wH N4ajIenq3]qkF^F69C 10-&T>_ÂAܽz$#n iu% 粭UK F G_4_9 "-[d3IV܋Jc6Ҫ"rO* n =fCJA؟ [Q-g9F>o1;[5 ?A`;FRe(JPkųU2 ?[.b|q7DբvU8P1brgy 93K@өhmDofUyѴmjtUZc}W,b{NCql\=ƴ9Nqwn_Xߛ>i_P o*IjSS5`͘:1ܛE+mw5)4~ jpxVc2TGkٱc {rG& vf'c(1_?-r_1]^BW4ѳ}džj^"b,ڦ}|&2,!S_=0D;&~æ/ھ g)\z֐ܴrybrū&x HftJ(ɞHn҂_EsKM}N{ZM^^ S$9dRbլ]& ݊*+ZhJHH2?ѥ2:E,o6GB/%.H2_hʎ<|+ɑ5(?M㪒$~F낝`6RA]n=i;G7Zm6o0b9yVw ~d$MZ)㦙0>)ؐQ;vĞaoyG_Յެs!~m[4>lMboL!Q$[5\YblV}o4#;I 3Vzhbɓ/RKHlM>:FV$6XHofqHu#Ĝ|bhge.Qʐmzr`C5JPϑʤ+M"*A$[< $)ʒSNRI @㜊:6ȹU]tP&\ %t[3 Z.HiyЂ @NDM`T:~ U,aE[DGN? ‰@"eZ~j<_IO#$IWCuu۩N.tBwt קd 0~1)u!jDB2]-qtBm ͧeIѴ^:уo D, LAzum&k7[ 75C:']H+.5(B8,? 3e>ei} ,Yʍ A!A۝=txvϬr@@A|e)E cp3f*Ф ~hU<r#ן$8}Tܵa ;Fw~͉J[ØEa2{cA: !F842 c(!m[P!at`8z{UWl/@}2?s)@.|O7ɶ(*YSMJQmxr_fGy^\] 3z<:wKTq3`8]wGB(WvO(fM/s_$$\c""Xf)cbgv+Jxrd#u(:ts*Zx1Jjy=y<.,R?ְx@Rï3Ў䊆 8T>wV}GZt_K;aKmBKR (GP.naܺR@rH?$})d{$Jɕ:WA B^6fmiCg 1<~NRטa B1xӌaNw "Fy թLhf~#u7=@hw;n:ּ/Ʋ\mm ? %uKa5e;WɃLN`zGGY3n""|J\Ha[gV{ "kRK3'|u-,0,CB,污aE2(%(9Ɵfa&Ì!f.JdKv!^ g}PV 4dD$2CiDž?xG%g)Ro.Q#M*u!'>z nի4pjaXVKTaHV {b,g);s7s 8)xj"#(wNn]c VR~Iò0 Bv`鳤ؾ 7KK&daLCDŽ4h.7ͥ ۬TӧbAu&<=A9]f8\cZT.VWh˖bf =,kܯ&H.Bע>9S:ٛOe`fH[?'N\Ab wHP.[SVWk;g7A|'\:_UldP4K^ᢀd.S9vނ 5x- #\00IēEHo? u N6Enqyy@֪B6ddG$S*MۻsatT= wΊ>II{ DF$E!6j)qwk{rYR#R҈^q:i=߸N;sKn|Oc?b @L 8˧ǀvtzy]GTj%9D(T[_]bx烴g5dL;vC|yinPrr^3q }G"a+Ы6{3G }4^M LY60IěT[K T%пIn06%g> ~R!tP_fzbу=;j6`a;ֆ0=tQt%BfDpiw!"H滂%)wr~U,J$Wc(ֶWZTfr5ɇ_ u̠̕{Q(8X)RptS˱Ia?;=kuD\[c֙?lw;BttǵSt"z5e>-Sy^ҡқܢ柱䠢QZy$0ؓH}^UX4s ;mi=&9))I,!\U[0궘tw}Cy=EBL>'v31!6xGj?r4 ӬGѽW&^:3X \E)[3F_eJR}N?-IEfo{:BK"^2n'}F2/dgG@.Fxz+0rȕuNlPNddz0󆊫PFtz@@~,\V_2VX!TX~r8NW8?jiΊg;L^ⱝ% پ\d?U?qɂ["d.ɤZqb<)*ebjշKtl h@*1m| fPPbCք~^, ]YBÞf4!?4`"]1}3UYZ~d<I&r7jݣ({1<.3'qAל$Kõ~:BZuɄ7"(5ބAYUU1?[s=0k@M9eޏ'2Қ$m/!5ڷ,7֗w%Iwlc?'QwVEK81I>'=cOGVX6Cv ` P}vlyW&[ALʗH@4'GFuyoN˗dݨlT$E>a"7zڍJk۴hdZom 7M棜ݣ5'␰޿hYr?k\-Kl6]&0|OʍB3.tu?{q1Ù zp) vNW5)o d\hoN5nƋD71'~(UOj*"Sx4ܛ7lڪEQUYI}U/֯6 +ܛ˸Y!*7 I'_8QLuҧsۓyhi6 `!%z{}4'B+CӖB$;nW8ޥ mQR,'5vO|U^m! s| yeA9kX숵9Ee;4Vt[~R;e  Zw2pv}W\=GC#jj/sqN.^QbsZԵ"~zQ #4tO?6uD+f IPߙ$r1^+٦l/n4Ry|H7FK6&Ad2)f2o[GS/0`H?p3;%vQ|[:Xz$0[b0oKG@l*vL!&5>#|{0, @P\7␅H14jkI$mPYL^#kr[Ͷ|:SAORC~[iMD s}ߝN5wC=t\Ea6GL;r1`360ؑFNqRižobVFrYp4ݧo1~"#^Sl{>Z#1nf_dتq ,2NQ\>XMc-[W&Zo/_aYߒ8M(vFf߻㓋l?* E.dSaYdSJ[i+[j e S% N{R,ߓe͑- o WUm?ˡMʝ-6BNAiElP?lB }ぢqD4Ɓ]g8뫴᮸OKUެN泦Yc?5 .G:eՙr0ӆ%4u.-,DŽ< 7i58RqI'CWc G/i5\7pjB XpQo_֏CKS*t#4֨r6uDW}֊kS֢OSvZ^3_ ՗(gZB(I'5c1Ҷ`P\ ~fPŁ߶3{ŭ~W _r;VåH"E%K+M*ږa3d݊_wcQ}M 93o *B뺃<+ϖ^NP:MeY@z&8n8!J$͕ڞu7FqMfbQд*# Vל2kyЦͪ!"ME)-4R1*. ֜lZmt#R;|jpL8Ξ.Q|>ŵ[W3*'⬕>@BnFPv#[EC1D"6#+Xqѡ֖\-n6,uK*1iWѠ9(_<'Uar7g/NhS::S p*4w6;wo M1tr%&L*niXlN<򦐃a5+`OMI7ϫ1ZXilSR{tPzpk 1p;ݤ}'h {#˪;:l#4S|ښԔ> ob A!gIcNHl(ezE T98SfVVl_ ~.9a}E.cO^fH}E}mo% *C܉6+)M@)ނ:VD(*" LB8Ӧ[(Dkδ cR_'>67dU@wWZ{p.{Ֆ@|^#=!u['O= ss ÎzmJVU]0C}[O/y۳?KM&SUq$ b! ܱ/:*wI8%ڻuj#Ahy>HsmgD0ܒ4{Xm>~R.jGVi{Ju.Fxx=iR @NG>TkiiEq[jgcWCy(m)u.je|E Z zh酪:Qҩ-'ZZo-ęC7"f-l_YvzG8X ̮V b@|ϣytSiUjfw%z2BA| ΀?F$jH8P/;񾈿CW!xpI+6bOǻ~;"u]KD(0rLy!%bbR QJzW2#ewyN ZfnA89f7ceyi <8x)/\ Em(n|o =@m?-ջ$R1FBfq.Wid8dޫQZO~鎧qI++H/x#I~9 )R$CZQ ɚ$@><HrP5]!\*OIxDh@s%8*-6cb> Gm9(xcѤ3nePpyx.&cThZW1M,g&vubذFT#L+C'#~AB6KAV14s32h֖lʛD~m(1[Z_ʆv1 $6ڎe//yg/hͅϸ{%^FޙA&'hsNү$~ȟQdF&Z]&gz2Nك,}Z8%.7u`:^tnHmwk^ 3;X⁒BORj|IV'յa ֞+kq>:Hbv8<iwUs1jg5^2oHI2{;LYHO;́L>uJwB>-6X#J0!J !ȸY>L2xE첃8jTjۇ!>/o?BE̩LSW*3Ҷ_6 )F[ m[lY}@/F`YСy\J "?iy<.]]q ـ+03} ; EAqAq2D2RmܹLA(dl޲yVrw]cm}[8fP0 wun_@\EI =r6kO8v䧭u3 tʲ Ekh΄Q~$[Y[$wZ[ɬ*EVU?Sw.jh78_/M0.w*6N';rR MѾ.:\nxGd_0Ec^n"H;۲]Qr \ϯ_0T3XE;DʄBⰨFޒdw$$5Qt JRf&VG%-YEE=9Z敂^CΔ~qH2,ɧR׮oA)+un!= M$f30*4_6DCfILb‘SUgN ׻+e^oV2pڿ2|Q *Zo LqmXL,t{4j²2&R- 8Nmf67NMoedez=@cd8-ɄׂzWHIjY*HpPnIEGU 89W_SH`aLk^%S yٲSId ]@YߜZD0UO endstream endobj 112 0 obj << /Length1 1396 /Length2 5966 /Length3 0 /Length 6925 /Filter /FlateDecode >> stream xڍx4\ڶF{'ä5z.D'A5BѢE 7ɛ_֬g?}ykϬfh"t#hAPgb@Q! PCqCP0$B?*^P0cS1@=$ D qi4"`@OD@QD*HO/+S[Pz `@vz`*Bp G{^._` EA|N_#? qL]a&Hg/ 0„x#^Lu. @gs !п @`? pu]!ZF8($&u%#3P/'%(+ fN*H("՟* 컿uG }a'_c8y{ !`Z0ѿm.P4@ (%..@~W_L=͘=g`3E@h/ohp:"N0u!c:Ɯ`0'$o#757S3H?@@PJ@ 1@?aX-3 W}e?#^?s#1̅xM{@1 s;_YWwGpo?_ 0FcThP _Ճ:=۫cԠp0ZtWx/; :׿X0z`aDq\Z~cOdE幕.v&o_8$概Dl3C(YJJt^(T .qy*WIJdsBչhdφakΕ gUI{/DEKӉ`8ʅ-l0yJ|n+=錢@h>Y;%m3|KI1w!IkX3r.=%~8ɈVsx!`̪x_ϫ ,Ŋ{9锲ˆIOFC|Rg9]*NV="%|H-Pd銥ibvGq6&Z̧iNҨĥiONNwc&(T]?n)g_\(D8s/=yh aLo@0H玠tC'ꮻ93@Z!R2'w9|ql޳>|1>=snWɱ-$<3y+2pښo.f({`aq6˄X&y;$HI8G\YbcN4'a=j꼊VL0$80vjpXh&!S.u<^\o8XM_uʉVsTj{_JYk~c|(\k{0+@.g4鵯7y(b1g3<*KLYuv<;?Emf u@>(R8Ҷv)1@CE3<T˶ݐ5&8ZflEϮ]Ijw˜k6{Z_` 38$,0&#b/%xy=i@R/`jmpzRț~!EXGYQ "*{7 @JskFɳ*Ip)R% .OUDTE}ymƬ>}v"@lX d; Uw6iFP'a<RZҟ Iz|'Mop3f=|Ε&47zPiG`]C<3AQm3X.eBV=F엕xZD3uWw @껣іzr} ч[u#To $ Tlg6l=QZ%m|J?ߪ n׼.2 C0G5=B˝˻|fJV&'9?šj`=q'[A=eN?Ms=>=Z_Ee>$pe{ MX~ԁh $3#AYH:}3*?vc_઺F8a-iqU >T3H4H",OM#/Ȥ@[jy87\&c ۱f +{4.p ?s M0&{4z0K^E7Jyo"&n5ΚvfP,ꎯjة*mʏQZEzپP/\ae&f$T+"+A+λY).Tg@H?1 dƮ0|u\?Op/[{r쥛m%DR^8@aAu?TN"F#91><$1J Z@Iz/IZۅmi(qc ͞@4a 9B4[ wwwۻ{u4G:\,ѓg:V{h>yd~[}JǬEZb-@ٞB0uě ڦ'_h[@eg܏ D)MjJ7={jJo^ l2ʥ' z̡^6KSu؜AQ2\GxРr Yμk&V\P#Sڀi[7eg2n8*洹;W8oⓅWJ/\>AzkK6,Z,*KN;&mA/CMÚEg&̚v3’*YpUKFʹ4 t3ΙƳ4)Ě^ƇzUpؑt-W'7 3aEsIdg2:.wߟL%ȼei`5ztUABvDp:P=P~ L$}dfJn/ jgy?mPPhQhU#-Eًڧ/%P6G LTĮ4\p$='})JvuO/2#=MnP8^ιˢ[5][EFoZs9,y~G|z/)%t=Wѱ QW +KZO"\NojoI+3SM !n"*6ek $-.JG-#0ʚU<(tr[D#%'ι%k mD#ů&pO 8`{V Ck yaǻ$2'VVYg?X}T;9l9j ndRkO^+$,$(%T~S%x5H-k6`A)#MFhh,]7plzn^tN]e F3VL7k2P,K _!A7GDchv\;3Www z o9EǴl/v. bhtz2GT44lC3ZdEI;pY~3@3@x)_Y(C37ZqZ|v򔫉5e2)θm#r|7 j8 ÍH>85`<βh(7? j<2r?F!5P*{a7 }s!Ll]SҹV/&0bw)ӒVZlߛ˙[HGnˏE8 |`}_gj÷= bdzk<2cpK\?BJ{;z[S?7ubO~ȿ v^[x] y<E_[r^ݐ{ o;,vdJ>7 |ZDn\n._ݰ Hjg9+}vR L9ݐLW4l+>M!H`֑D/O*a&S1b=1O!#A4l߁Mt}Ofe |aVo0w)Bn\Dz{5hWe2u亣0]5<,@![;Wq^z/{\/ffF&9y=.^Vi&V]/ԣ**fr5zpzTo,r83c/= O]u~NK 5ӣCRR iC?JO3-Lb߽Ng'1hapu*.Av!H$ƊjU]= 9Mgv#Z+ WosVIl(&}퍀)c- r, ٷ=V,.7{U8-7x\T {+{}0Qf;,X( qdBk1pbQ*sph8ED t'SȾ$0ģ)VuCyZnk PqD xMa+U{Eʗ̼S\x!6Ϲ$ij<&T}|,MpMFި6 *c8M /x%KO > stream xڍuTݶ-AzBUz/A1 JIW* "M:H/RD)"Wo,xods͵Z{DH~@pB" ,PUR`Q7) ,_U cjPFuܝ"b@IY)Y0( ՠH8PAX*w#TvA`0( 9 \; @4 y*+, `Ah s#50g2hMv8O(Hg 9D[h@!! P$rB~'Ca0+DBQ_D3χz@xΡ@ e# ?0 aοFU(*aSCb0{ Y'waD~ ww6C!j)xJe$%e7 +wP G!?_,a;@DGp{$ xag| '//86WUSѿgTT^@_!10PHFB(""-! rQvh̟n= 9uW-[%0Kݐ0 u T #Hwjx#(bH 7D`$7e5g$ a"[Y`9X.xs_u 3Q I zx9WoH8뷒 Ogڡ1_  Q_(a a_vF 0&*RS/щQ8gz35GTˮNc8nKz#P\P=mG܄퇤Ң7ݠ!>8 j[._*8o.[ɬ]T,9k\_p-i0twSmsXdJcӱ$>lOvWgNn{dY-{N_R7l:,āꋔD.{5:7)ã8Kd_}ϊfQn?'U40ȣaiL+nqg"-oU:u\ HM`jjUjd5Ԅy̡mN1j6JcLh('A*q/ɌRC M&z(i`S/T1_\_9Kyi{S⣷D *b6Ө3j)ryVuٟ19a? oJfl,AÜ-PU`<䀹-AvV zCO <y2X%#Ɔm%QXX ikcB]SnrB%Qd4O؋]_.闐J (D#/A͔% y#c"cIUO1g}k>]'{ 6*SNwo6qY5fk )"@ؚv9ȶIrbȢo%feXwC&&PΝDCwfϢW"-BAMYaPK ASսXΝڸe arȡbJM75 %T =ȹ@Ij 4 R kV?WvG&P6ԏ=k5?F]3 m3)uő(;Z۟>!>#ZXHZt+,%{&_Ř\;4 m)=n/3|aO\nCD T+QE;j^L r`}75̼XE`=P^xN e7>ޙuH2K&*9zX]x#>G͡ul%hȰP0Z{cyn ;[*k.2;~:^8f|VQe'ի.BEhnXs k?'M F,puMΔ1(xNwYEB}Xh5q~:|xL g]flƩin.psY7=5 9{f_vVhzRpqd=һ?y<)Qkl]| #` ?xI޸R}J $ A%Sʊ eËfGuyri\/^ {,zh0XcOA@Lɧ@`VKRfBȢx,? P4;iwp%{#UZWLbJ[4PĈYWƑƶyf?>nqm{ߴ(UȰ~V6"?|k`|ٖl=O'/fʹd+Et} .jz[*vzq,GJ4J K?CEqQI]'mW µ%u-l$=J_'S_װ{:)m|%a CLG'PQrEp4I_@ԝV7]85)F,ʓr6ۻoH`ӷR MyK7G/|,c0Uq Fc$ԨGu Oʹtͭ4~l̬;B\ewxM-ƖO[j}qKs) ߞA-mZY (LJ[tW2 &Ȍ)=Gqxt.~Ѻ\4\fԸ~Bl0!ڧN7E5<:!ESF-} FuI|u)!OǡRtUw;|,T*2Zw{ʄ«IC8!-=FNɹʍr?8xt:ˆ.^#kd7C,T?yɏ"b^'*oA]J8g_O>o^]vɕT{!o,뛹v1 U>K俺=nUymZjV·$̥&qJ4腡8-`M!J1OI?U=htQSBYVg'>5S2YԸUCG2G Ξ)/ h-е>ٹDO@psjK󓘰km{k BtʁԵ/9IwHL0'!Ry[Āζ'u#^˔ eZvo+BD %է|mʟ%[3s3V:MKwdMD:{RIubdj:L_]@qN{Tܻ.*p锓RIoϲc!$m*ʐ7!bQkJ(xsŎ3qYmDhە?\6{$_J1NytNn~[: ÄXz|THOMp/slR&7\Ə\o>Zmƪ4X"'wE ^L;o^gΒ-~;WFkˏ6+U4ϙT*޳'n˵6wGzVJ11 <֗{xf<㱖@ ŦT5s"O(ƃםKٓ9HVǓ.DŝE?5羴Cp<|@tq%k{$')Q`xgԿ,.S#>d?f,RIE21 A-l㑞O@ZT:(m5)Bn~jaRۀ砎܃EP%,k%%zA;Dr{\VJW>1G0eo,SW^hCͦ΁( %E;4*קH4۱$LjDl`IgZTkw$wy&d@zV*.j 措u3gh Nfն#G/EV Ma>yP1N_u(}V\#W &*]WV z7'QϕTMvn3) k65a;hVU{eӳc[(z{MOL%/[Fwg<ĥZ}̋9yvJZtxw'{lK\!Jv Pof\8Q0O{>]: ͼI~NF'bKmlTB[C 0&Bkҭ* EYzy0J$sܕV;ˡ$Vo*Ξ6UBmWij( *}A dK|p!ۖ WLSѨu,f3"U*:aIFA&D9ɠP|E,PQ#k"U]8ϡC6:q g-Yu1A 1Oqޖ#宇[$+X=4o ~j5өmnňYDz'o"DPmDE|Y  # 7g$_H2|+سc$h{i\޻|]YMY^j:pm. S;ܶs5dj`5Zgp 5YJ=_UCTfL~;BC endstream endobj 116 0 obj << /Length1 1910 /Length2 14418 /Length3 0 /Length 15610 /Filter /FlateDecode >> stream xڍP,]Cp  gApwwI˖s>{UUo=GO*2e5&Q3{=ș . `e`feeGRrǎ@ tt+Bhn0v~T\ll6n>6>VV;+;$]9{ J|hMl>0:ZΖ@MmjV@g)A+`lllh!Dpr@3-ƌ@PrˡfoflL ~:@MV+XF1lljjo` Y̭lR ΌcƶNƮV&R7H;?'SG+g'f'+?zd%Afvv@$s`rm@n s+m8h>e%y7!c:XYYyy%{8ta~`pvtx `fe 0ZXn]~l?03{?^1 -)&fb0s9<>[Goʕ>E}Nh^:RW.@XXM?ϔ*/#)[?l=xW(ڿjZ]E:o(]Ll̬٭܁fVΦ/fk*;Y¼gڼ"N|ߡ=WdjoDzsq=q޷ , {{>s{G?. "/ `/aH8,r<E񿈗zi}xGE]U<`1/z1},̉_ dNwſ{_Y |'c/},zO_D 9ߓ|vxA@sl[ڧjv| +_3c{s|dfNW]>@;aeޔ?Ⱥ>VЍ$;'U ־$J5GahȇmfmV-H>hs=Fi 'ݺF 3 n7"st/,dI PTjyK b2: "S4ZNtnKJd4X!}pkwhj'A&X(@h0G'Gpi\M?[vJj?ZVբEfxr0R|;b^4݄f׀[-b%YؓRSP q`^jWP=s.BLSr\z1X&fڵی)XdcX'j XN4FsFQG? "j Ef7ٸ|' ,'`ugfylCZca}9uH Ɛj)LexM>W;"^:sFkN3Vs/{DcoA axu2Sl/R߂5#+}?G2T%{5qo GȩuW 4R&5X5S^B( \Q>8cp)/4w-%WGń`9 =vdi9__I 1Vs+ƲzJ ]*ykXҜ0hXG ڮZQN'P+jxKW ~bAcRY./_Xt!n[da܁' ˯%O8>h=,FQ{Tۋ_J;{h*Q[J_#XύVC%f|v BgWkVkqާkś9IYѲJle"NMcy.-Fڒ"/0V}j*" JA"{MU`GǨ*%Kty QѽxO C"pY~uSyN}iTd&ĘEFс1vYz$ѼVQeh" oQRWE?N&Wj(a>e8 =I8_=Ou~`Q\7?m^5*dz^EٮBTQkY_yjG?ˏY R4Ő>y6$ƺdcM5GXqaVX$9Jw%z>-8[f6޲ǟJ E,U=hQiԲl[ԗBÖ]\k80M..Y#3k5SeX>ͭ$>}lj@{֩pQ{15Uk6փP"D; _Wz (BBfdg!?Cź6+'S5]. M ;nLRIy)EyM׫ozU#؏fBd:k1'Ta&Y4v6^!ke/։doEoK1-[ZеWwE6eZ?mJ,5( -JN\^nL=?4yT6LK8P.^+ cu&ZX[gI0% !b?=CFGG*o`_IeWG^+Lމʢfs ^I&џ$ç&9VSQK X Am_b0M Sݎ#tr3arߎg=hQ4`ze|D_,z8q鱜 ]T!HNʊ9@Ō+ۡeXm_?}50ڲZG*O}>̼˄w@ ]+Q"9BP&rAgkYʾNX7My45I1v,nH+D!Tΐ+@u=G.̡JMxܓ30A* Y%[N;f(]YWk[QOycGgҭ䮝UĺEpmP!Y$w[l LԺ6?\khę[I6c2<3K?yLϛ*1AhFPC,%{D*z-̂$⬰p˧b$T3v|Fj #v rc.0ė.zFd~ nKY Oοog (^vu==#aP% 56h;L=nUʶk1ECi vT XKB"'1νQ-JKߓmo zG&,!@=_&v-Fvr%KMTF ckYD3#kM<&MDR?g,n=q& kk9haLxJΙWQ6wjċ8!>!*-W!Q^^cT"ڊj# G&m/@k8 ںlNCx4-k$κEzT{>,dK.ᓀq+}| 4WF0mۣEfH5W4˺&`w408Kx;]B6s2uu9<,Pk̏o䯩0U".=1W3u \ a`*9|qk c`Dr90!"mB 23|0BEo2 Yiw2zg"na1D x6{Nh/B#4"j3A՝6ʼB•_?Ytw! mGSίD,-))!sI n҅Q,G'-a U Z0o˲K4DcD qG7/v46'<_!SY vʅ--韸Y+혖(6%~@:>\a\PL'b /r1|`WoS"c말{Y0P v!nȮRA46GpEe]Gُg|Z'GuˑN=͆)̒wvRG1cR@J6Y2k1+YPEEsJ ?]u/OW s)zdN~[ɡUpއgY4ƾ˭pn_)r#P5߄1CطZ8hsSuꏛJox߅u,(aDOł=՚S=n5>I gAT) ,]*|Ao9_p1zq.L8 +e~= 6fxDtqvmz^b7.`3Jm=e _ PjzUvkjU팳׭ ~{ y<Ok*j.A Xg14 %;_i 5ۉ*w+B.(},)!WHGԣ F)=aI#j%G f&'>p^dl Lr V`)}``zJ5'd"P/[1if\׃h9 pa^WvP~/45Mo[L2S.2aJFش]W Ē+KW JŮymeMYˡԻv |hfU齷 `}E`{7<jl Y= f QqB6}prW Zlf:ԝ]yfd-v o0ez(6ԂtӖwP[a[$+rI2?,@+1ӛWF<Cl\s^)Xwyx$"fިQy-6X9$BQ<=NaARbo}@Mm̞I8|^ ͓Ȼ&Jaes)һ1ufZq-p [8LrwkӖsy͔|g<~\Wn*0D&S5H?v$ qӲTt2U|v2M8$ګ Ph%V̀ Ku*I`_l.BX9%\5%ՇALbr'%*ZIvΙϻ3o'w!eq6F쨯 HzL|5p#46z{&r:$:9!@wDž;coj@Iy Z dׁ j:"Cg*.ԓͫdI9ʈQ7usl /P99S΁bg bݳŰ6폏qX$kNa]g(~dY6;8Lzq?9[\G4 y/L.R" ؄5iBE&k}Oe(!yߎd$迲a@8hG? NW{FiLRz@^q<%3)Q?˟"1O#q'IwD٘ q7AkzU$r8MۃYx,͠ 4HxGj\;i&.#.+X H>+VwJP*A6i<#5NG :'!6^pgm5K0OgkZxb$ivA)bh씝opLXn(]tśg?s?i^&-E v >11=Al>TLz-Q* K. |I)a0jCcrj>!EtqVj:q;FJr,ddr=h)Nd:j{5?&Vv[05q?Y'h$x1aL֘R`5hI<ȉ#0H`AԞ/V乌OI t@"mag,lͷ ѲJJR#'Dz6u$ nH>jI_yuqn̅qeZ>}eohgaX.Ie\#$|/v!id2Z3!_oĹQDs खT*oEO qdXDl啖GQDw=Y00e !].*> )mjm7eJqad3~^D(.+T?mhoZdm:>eaTj?Ó[M5}4bk΍,ޟ{2B`c#|virx`dW~#Å<}H ̳טK}x֠'[O~t2 '):uRA@V w/ +xl)i0!P=+"wW7鬞 .>f 4aEkOvy݂؄P(M,num_v$!.l}hy$_2DaԘ}){UЫk1w:SUU4Wv.Ht0ڲpY\e$ Hh \s$wn{Bv RdA#ZumڅR阀БN=aRl1D`e.6=pTFN褱h9"!Ӡh܍^Fn3VM IdhsM[p +1gCJv0D\ (-d! l>bh*$(ȎL܌YSgqN6; \d{ N#M iՆo ["Y M+aTGJ+u ϏB_Jnq!ryeG%ٲڟ.ldDžآfϦfG4K(ÎM5y;o*>z9}K"#}-<)0Hew!&Op@$|yw1SI͞ ddU@|g@SIYX}2Syz{DsQ8lhbY|YYIo]g?e5,ZD%!P˻ڕp4L 铸ҹ: b%?cPLNS.Z>E_sL&NS]7X+#M5ЮGbGJwTg:u[ZfFJS  !Ef>4+w5ygOΰ; (/Lp7gTkޯ?kF`t* ik p\>\;o)n0 T=J4K[='ڲ’>\"'& )&qaò`wK&m'+,B&Z3) ]hTVv5L O9Qp/e:R I*D@FBfw9EۅgLf{W(̑1R`y>HionǤʅ"nj3LY>FfS0$w'qעM =e kJWHoIѽ!?Q)oA~eiOO8`]J ܮOWw͍N'o$>8!"? Gu3/#Jgց J08fO K\\|wa߫5»S0N]FscٽT7FC`EcnEX( \B*e R_Ժ<쥗,ae1oN[=0R4=!˫6O!ٖA[c7l*j(8 A՝+A;mi[/8H_-2]JNbpHl wpB|Psw%-5ҔdO q/҃q$NfYq [o_UN\OMݩ$Mk?<ꊞ~{ \U5VE1J ; iyU.*Ղ5U%kAA{knP{=.~X9vzH+<U\ OV*r>Բd@ТFdfKS_6] mR 4Zo[FE陈x(Fs<";&ف 0$q?3/e^@G4":dN;I$jX#f XHd`:kw?Ncuؒڈr#Sc@| 0漋I\U!*wOxJϐ&)!4w0S>j5j5xyt Bjfi) Ru`ؚyY$"BDښoX0xlpe@BVs,7lYJ֬rZ'|5WwZO2u_ϲwu:BEZ+5;˗JI?SͫlbgeR+}-`Zt$hDہ=[|[ZJTr9ie:(<ȞQn3FșЖK⓰٥r& JG'_큃֫Q:ZVyFqQ'*W)SC#(uWm%h'gTUL~At2bRO}t5ĩRI\Ux}af0.mFґ~]'o} Q:W˜acd -[=~/t>/8V? ʪӵJu,d:Tx]$l!teqt&Hr|l>fC7ꪋ]eb>E/ >oM*QuS5n[B>U#B!9t%07i%cCқvzsd` JjQ5bnϛ&Q8$?lRv&FUFi/ JOUL'b"MoQ Bݢxy3ݚ]!Je8sh|SeRb2Ŝ[OCX@ki '1o> w(Y#G6tw`B* Ř f{{@W8+mI!mf־2Af`9*zG124ƨe73S[BzКf ukvQ+5M8:xy ^V;Gm>=֬ T;m@ ƌ/!Iz?3&ZEJhtx("(`w5󊔫/$U@C,s@'VT*soQi$U $f(Q%Wcui7 Ir@꟮sdȄϕUEYy*Dkdnf[[r$tI ~=Kٽ7#]1@EuDyHz%+%tS*>o7DpĉbӵZ)]GkwC;)&%k*s|a [#XlSO0|?r{/ Z&QA cA fߗ*1 ]Op4 d?%?]7eT 05 tt/>fE}z2)6IK)vƩ1ze,۾a0C?[M gR#XAd~aSrx\uV@i^ȩ!ivc}W?r 0ۗNChHi$-Ge G@nMrSdz:ٲqT87^"@P7g{lX yD`)I6ϨgQvo@ 2YX3{o% S׾i_)?5(s}*g8Cίm:W& ׀i6 ./ ;dT]6$)7|_ }Eg,cMJlm9~u!Y1-s]0<6x8|wA7d݈ coY`CiV011iyTۤL> g靕y `uErӨ=ij49~Z3 'YAd*D7F⸇qz',B+xu˖t/nnsƺ~f/* I<04p"ÍK"zKᏢ|_.,m6İF4΂XpWHPL? zJ\p}‰/[T?P5pIcMB{Qkυf{,)hٸ&Pu)UV|<)tU=:^G)T^LjGCc='M= ؠXߥ0i m`^V&gZ) ˄v.'^p^!^@֗^Ջ}Y?70C~v%_٭Ni=GbL Oq!yԗ A0r°lW/J@ЦYbiYoa*|F=p=,WJkLvL=K Q(G0y"j (A/{)^;h^ͣ>94e 9*!ܻS.wa^qWK 4BG|OFKv0jFw 0ҍy!;ȃ m_1+hF<ަ˫PO3/ of-䂥7]‡0t=4 /,d^Bl( 6>a`8 jE}YMMKC[NN.vJL`|y0ed.\NeOy]ܭ]68Jycm%^2,Acdn%8:+#͓x443C8t]&6^W:,;z5,~'F:/yS>u= sgdˌk"|IW^zd;Ѩ]e$,|+1Hک3Bó>( o_K]?B,ط;):v,h0$P( ͵q0TNh< ?yrSLJ̥O> -{j) Y9=w'p"٦`"n2>]*HbETl=6*KzMR+USP셳T`} FC 0gL wW2ny(ȐBƳR[ BVSE$q endstream endobj 118 0 obj << /Length1 2019 /Length2 13504 /Length3 0 /Length 14745 /Filter /FlateDecode >> stream xڍP\ #[4{pwwww B#sz{c9n e5s)P SPWga03123QP[#:Xxe! 4q}*nv6 '/ /33? g^9@ rQ-\@mF` bt63q(Z3@f@W AohbrxXZT.@gw9E{(V.)@&@ `tge@9F@:M,v@<+=C;л$ET& blbmG?¼Y\ dotpu>qkg{߽>\[44܀2ۼY]lifGu/GJ?|Aw@?k ; ` v'h~?gkO}Av^yLtSRT a`08ظ<lbwqx*K) {=hK>@?clyt7D[ݟz &v^[ϭ(7jZ\ʸi"i 4Wv5s6kgv@e7 ޗpy?Uߌf ?`l>Im4z9&F  Ǒr8LrE:I db0:Q l5U8!'a2|O '; ,[c^l=O) 7FWi n'oV/2Svbs](d*Fd²%g" Q,OF}X͍0 hO"RňaZm-QR9 _bToj V~b>t2E{^mz!!KLfO3 jo5Uzk dӺ_&=c"ǂ()ZHyÔLnWl^fc ֧[7c O~zO,*/zw,cԥcL m 2:$8Z0r W0Y3.W}An >pRk#;zṡ^ro0%}9s-AR_+KKKdCII)/n3!Fz:\1ϯ)wơg[Ujbno 2=e;Qj.GXvf3p̥e+73Dᴬ\=/i1-9BV2:Lsv^i!GKaaٟxPH +i*}5.G+Oc,[K\,dpᷕ\p RZ c/DN3;EilK7'tJi,F\( f.n4TJcM9T cCAbq:PTV/\dS;vMPgUx GYMn2Ə?Me "r:x-V +7NN˞*,,( |*㗛<_ՀToS ͬs~Dخst!ekoT HJ> Mvƃ~ql(ۋ,hNzoN'eaG#+Q54 $ܫfW}0x!%rC'4&zJ~1Fs"[NEuH*Y 9iZ0jĶ"=(56)VU$aNm!eC,Xo?n$2u>TUxL)i8ΔRi7bA024%V|4xWˉ zУ;GI!m+C!uxjO@"ޙqhw+{Aw "-$j:,w՟ 4j*Δ()|Bq>2Y{Jf@wߕx^b4 0X9%F2C8]v5 *bi~f%B Qrmcpftf+U+I\soOƹqFG j(7S{i>]Ok`_fKcKGuQ#K>sm;~Gפ@Ga;z*yscl}sov}㑨_YqKdY6:0#yūX h_3zZHJ<3zh=e`KEmmZ}`x,>ZZ>ӃVS~AR7-^"DN&xƥqfv03S FС<9uT}bMs2C m 5K zauk "qh {r 4d[cJ-Zr"ܮ(B-lR L;7J8$LYt^f)b}-GED^M`~jq*`@Ruwrw>pGdg^"hB7i_#xM'xZ$ ͳDgVdU9iIrbtZ_!k?֟O*W+Z$ZĐ~ާjS&HTq~@ᦜd5AKK&blrEiW ˲EIſbs`yBohiUлun#lhSafLcNoBv3)=l;z݉ #K>t\(;79nT4nvyw\K}.i8h3ȭzObYh!mδ,W2m,!΅T(~wV>p,0eE(~i1tL)ۭ$A463g覱74J#D$hxN#AԏA,j'jPpt/ŒiJjoFpVy.SQ Kԩz^eXI'dܽ!`H(qt%P#hxIc4cf ko-^*!2 HUw 2~ h;#X ՐS$ xFB{zt5w)W6k* :ԑF.WGxS̙hTe @qm |Mir@yndB1틟YfQgs**Fl}Ic7=H|_ǝla\Cኲĭ's?3_ $kmk~)mҵh]*5ӣi~g nT^h^Oes @ʳ` + ~6-VD"0k_wn魇練LOЩR;685, 4Xv~=a=mIvhRrGn:r Po$Ʌ=`ۋywKvkaw}ZnU>nik颙G p̅CÿfdkIBC:UK+Θ ~QJd@s6g=+zh眱]ٶ.1~5СuXB۞߅?+HPl^8<]8?_ܠkj-7|OWQݴUu? Ո-J]4ij .5Hُ髥Kz2/-;!|1e4\|8n~;ƝT(xu׆GQF*c#jyA?9a_t sRɁsyOb)5 3@{c; ;"Xz -5 T"F8klrGu[1bX?G}y8!5 F1J05'65OV'!l0rwTU<:(?*d˒)ӳAq|tQU觥JP5# ^H{KUibe[k{-uSHY$,;uZ}fu"q&!(tGܷWF)&&Ah=¸}U)G']9@q Uv3ek7oډ܄YKсY$jOF r}kՒ#d0W[G쎐n2?C8%$lEu-Q2>@C7adFGWAX`f/Yu/^iѹ҈ lU3 Ym(HVULW[U=0%>S<on3Qfy Ԩ~XVf7_EpT2w&Нl3i&N E睋v+9)SxV읡|n(x#~:2iiT>6 =&>L#CȢ(}=k3I{j#9jN= uG/iz27}b G0)'ef_6L׷m\l\o:jxioW$[rGN dNy1EN^?g>|U1Zb!<@:΋Xm*}r\Xcp}TDh{ŧs? C)#)Agb%mqO!3y9kH"qX[{`"qUP!1gFQsܳR}PgicG&*?d혋}>H[ j 86V^Z&٩tҒ=AQy86 4!9Jt2S X>F7_]2mq3[ 9ד>-šߴhy()ͥj7ʦq|kGi6"n^/]s740*WOp#e\3!m9y-WؘqݾY/73(uپLBF AHT$MO;/H3YѠYQ3փ+罏Rl}|~mK8wi]YP&vp+ڨGn#kgCTd n-f$|HJ0tH81 .2a|?YnCu`OhӢ"XPjus|WbZ-_|6&ɣ҇¤OE'2@_2nrѿ)/+ͯ2Rd=[Z̈́ &r~f 360\:)SLC jX}ɩOзfxF98at#a,aAY~7hcA"3."LC8L pbYe 1FlTx({v&\(ֿyDt 3O#3q^ݕ r/a>6^+Fal;TmM~L俢:Yö-,Ug˷JW8mbk_/6{,7e'`i/:ykIɍbŪKVAKƒ - K2+>Eqm}e1WMEBǏҞR^q\yᦕe+L~C UJdT8OK!2 ^M!AP*Wsr>q#McVh)mI$"9?S%ozXUf]Dw[I'rzA,*Kg(rv. I koc J !ʴ?j5K4 06sldz`+kdm{&L7[MA,T9$ fI[9KFܛ0hCο{0[G^oh,/R7‡OEU i[^ 6D6u7O/g#~O6>)DNQ+a ?Ԙ2kɀK4o;Y$q5~ oӉH3m lhZ7J`tϟxd1lTPg|& 5 d4uW" f~U̇}_D޾KXC6eR.a:-6ljgQSutu_'ZL&E{N'%RnF[_|ϿQ LspC6)$csDVPM=#TA8US]w>.U9>4Ѯ!:cm[0;Ei{{JO]M]7&Tz*OǧyU4߫FB^MD?Ρ1zwu&Πb-G, e8\(id^e(_P@6~+W;g֤N*3X]&BaĻӬHٮIv|ZqG".h\x&^֗'Zb9!q Ex&m;~)xzYx? 'x-kf{E7ΐ9긵zhWvK8@nhѣTEtڨkW#9yA$RH:#aIOmj"xy&F^;1+X&aa5]njc5s ø]l@Dٽu-)'+L-QJ}E1`gkjKeOGE/=1H `~Zl@d"XI= Ywt6VTHQk~]jF q5Dc "`>MSJ(weMNƄUY@#"vy0q]GˀkȄ9?QXA_>\hC1l:2='A⍥06퟾%S6x-TIJ4{UB Gt! &1bbwc3`Q F_[Buk4֫6 X]@|(k\+W}Zr*~qz?'5fXwv֪lCί?nF9I|H΂+W&ոi=s*GNם7`rA:<k0A=/x~]?| BS)0y}fr+e|zdӇ)CQdU7(m@; Ј5w8U󭨸76M(`P)jFya4\XMbt@IM9B)-o"!); B6 %9 ^븀 0{daHOO[Ҩ))B"JGyK.1ds|ZXz0܃rȧQxR }PER;#v'_Gf3 G Qil>}R*JWA Rky`ʤJMbׯ0)-#+ _W^JK1it9(h19vAIydht0"tLQThM,7DBG{x[]xn(6P ]6~*D pDQ?gУ}+!ˠ,wXZƱ@GL-x[V?oD~d -;F^ W,{:;?(ˢMBQƳ6.,d5`hVU[Q0BaM1eVN!\|/ =Q4by@K|*,ſ&F3awcQ+E0!&,`~e89C7܃Tah=$-#πR!v 8}]bIB"ɮ C̎n-o/XWF 72߾ϽJ`zˌi8CQ| d~uu ҄u5@+0'/_$0Ct$QqeTN(y&H² 3ȩϘ2PU+4|g]o@{zJ'7Pk G?5jaA^K>k=[fD7/v[a-2A@IꙈ׻Ӎ(ŁZp;6L\c3?SUΙt[K0//=(Nz+qˈB%SdފB[}RM1?e0xeQjG(C`ʸȷt9U>ΚW3/I7(*Z\Η9cֆ LimU]i}j;N5u(sY XV:D6ek7#_;l-tv.Ǿ;wB&K!+h5AAIReqK8 mh9*(-緕'MtSpB;oWXmj~4G[b ~IwKAU"1@y=z! OaDPԽ)C!=c c wDկXJ-0b5ahvU9!uY4t'rƠIrcqwU}*^&b81je G,.O:W߻jIuhM ]ߌX `k3j/&{"qR~${|vB@M3A !͐l#K9,e&mvBGe{CmxP.?U;O`;8Et9/agOٽY*sH%{nyBҢqzZ5#C^c`j3b!^J{'+yY-D&n>d8Z|Xڌk8Ic9ї`"LWERR$dB+ř5K%e /x@-$Czt6G N^S}v)T^PtO98ٮܙ 0y-=Rw?N jvrTŎۀ\t@Y0p2,'̛kx-dp>}U[T~~6(9m+i1-d-~rF%ZLn7>*nMiE˺&A)py~~}F0A; (I't4EZ1-w\~,#[f@ȬUnMr4!` ?)8swjWdYS]@J/>?8_`5(Uǥ6nIz1р{cG{~.`BTL[0-G$.9m4LH HS endstream endobj 121 0 obj << /Producer (pdfTeX-1.40.18) /Creator (TeX) /CreationDate (D:20200211011914+01'00') /ModDate (D:20200211011914+01'00') /Trapped /False /PTEX.Fullbanner (This is pdfTeX, Version 3.14159265-2.6-1.40.18 (TeX Live 2017/Debian) kpathsea version 6.2.3) >> endobj 20 0 obj << /Type /ObjStm /N 87 /First 719 /Length 3879 /Filter /FlateDecode >> stream x[[o~ׯcAP ƹ7vn &gf+mj9.pRwȹjm`EϔeZh<3B1Un0V,X4ʹaRXӖI c0}`F2idF3i`ƽ ЇLFavR˞L) %SFKX30ZW $QC `<Ks $6si+@1P؂pK{kL!j<1*,O "ހ@^x N1< RZ9tdzx0 `~d @hAC B{6By0ӓI)\#-言`t 2hJFN!j.%P ѻ*!*bCzYv5u(0Q|J 9FӐбZqkMDCc+c p`޽{=~dEq^`:YŜY=Oa9*{6ھ#!~*3,c4qx .ƹX>_Ѻ+zƮ=h麏{ih-5txR.{fkKl0+E5p_%JB(Xt:wZ-p%iV\]T9{\\-wHrX鋾SН?Y~\W={yIrQ 0NG!V=? x4i!cO˭g7d^mnVgg% M_VE_N<[)h?W|V|*y1\.J>fٸxTb8NY 40 |Ty5t1* x!xp<.փy1[^Oϧ7>,pU1,?s(s/R\V#o &}r&_z%KH߂QF1ʈ5F+tLǣfowGKpl͂ÚQJpOpGKpl̓}SVSmQ)*(W}tXt t]a9f8{}Xt>6Э{\I [#B?֭~Yx4iנ}P!*{DRXϚP|_h4b0T_8$Jjcu'Sm ss:[mX>GE)D'rzJ=5QlP&bAtz0ߡu3|L[zUwS낇VK rsj=ZG3kzшmtX£S_|%RԦ>zݻN+k,JHFhv'L@mRK8M[1TǗL<@ıuhOZ"(vA>֥u`Y$Qebж$} D@L!"ruʬl3C(ծDPxҦ6)]nK bUX|ӄ[m l2E|H˺H/ _okz5AR&{qzH&7Ab-Vj%D&~)2$&EMN}wݫZphZ˺M#!E 1݂R {$B`AY[)80]POA%{Jv'JHLǣ'!, V"h8h+iI+H԰U\a4<()ʩRLж#͍?RWR(ף<KɿFZ`w"Y `$k*8 K;d]eu.jAр%X͎hQcD"+(BCzGA%e ;Q@oր6ZR8ڍU U&) ΍,~ E5:9Ub d3PЎF8Ǹy%Qb9)z*hW 3=Z$ǒJx44hNKUE1JW#T5@qA#y2,lJL&ф09~/)oP:7+ܒ6N5ɎySE~BJ:eȰf˩}h"erJ6u%REtJSSӎzfz'b:i֫R ^.Ԛ]E۽X퍬yF>U5jW&uTTH$dwy]*Ij@QZ_ N9pF<$[t@p (H 4QiJ4S]AHj4^k6R ?­Xsq#tS 1Pt"e}AcV:r£AJtR^7G(C2eX[`uFМ]# #±WXW$J1# XW`zU]fLV9ImUW,=LO?x n932޵U|P>s|" vAq/kp=l]7ŸޟK˟,װy[O- k\3|ȧ_3L|jz3S9?wxG,仵}~I[աFmth+b/OsG׃^ZCXP[rR>lhwo@ f n.F䪈L(:1>C\b[8XS4:L767KiTͯŗQ>Fyѣ_(OU_a_WͿwqk&xiˇSPWW嬚U?74uhi}#)nKЩ)6R{#RҮt߲?3:wۦKG?^vc*E/w>#9z>|_7/Gt}-ɓGS8~]륰i@i<aE9Rr@W @M^ճWMNuI*$&+o70Yʭ +fuRj<%vM?!6t; ˞=yst3s]* -J.|5 Q} ; v^LF768G]tWo~qi`ѳ_^:$C\ =SRG1cm6[lAT0 /m^=k?Wh8^e:fڃIQǛjtͻ}o;v\ϼuom^ug> ] /Length 335 /Filter /FlateDecode >> stream x%̹/qQgQu}}UꮟU׀I,1YD?D"`1 D?OWOx#Iq,%N*%kdHaEdk;yL\b -F҉2E$Y$@lTbZ~"5 0ioOk&~L܄&aߵ`>ZӰ>= library(ks) set.seed(8192) samp <- 200 mus <- rbind(c(-2,2), c(0,0), c(2,-2)) Sigmas <- rbind(diag(2), matrix(c(0.8, -0.72, -0.72, 0.8), nrow=2), diag(2)) cwt <- 3/11 props <- c((1-cwt)/2, cwt, (1-cwt)/2) x <- rmvnorm.mixt(n=samp, mus=mus, Sigmas=Sigmas, props=props) @ \setkeys{Gin}{width=0.45\textwidth} \begin{figure}[!ht] \begin{center} <>= plotmixt(mus=mus, Sigmas=Sigmas, props=props, xlim=c(-4,4), ylim=c(-4,4)) @ <>= plot(x, xlim=c(-4,4), ylim=c(-4,4), xlab="x", ylab="y") @ \end{center} \caption{Target `dumbbell' density. (Left) contour plot. (Right) Scatter plot.} \label{fig:dens-db} \end{figure} We use \code{Hpi} for unconstrained plug-in selectors and \code{Hpi.diag} for diagonal plug-in selectors. <>= Hpi1 <- Hpi(x=x) Hpi2 <- Hpi.diag(x=x) @ To compute a kernel density estimate, the command is \code{kde}, which creates a \code{kde} class object <<>>= fhat.pi1 <- kde(x=x, H=Hpi1) fhat.pi2 <- kde(x=x, H=Hpi2) @ We use the \code{plot} method for \code{kde} objects to display these kernel density estimates. The default is a contour plot with the upper 25\%, 50\% and 75\% contours of the (sample) highest density regions. %, as %defined in \citet*{bowman1993} and \citet*{hyndman1996}. These regions are also plotted by the \pkg{sm} library. <>= plot(fhat.pi1) plot(fhat.pi2) @ The respective kernel density estimates are produced in Figure \ref{fig:pi}. The diagonal bandwidth matrix constrains the smoothing to be performed in directions parallel to the co-ordinate axes, so it is not able to apply accurate levels of smoothing to the obliquely oriented central portion. The result is a multimodal density estimate. The unconstrained bandwidth matrix correctly produces a unimodal density estimate. \begin{figure}[!ht] \centering <>= plot(fhat.pi1, main="Plug-in", cex.main=1.4) @ <>= plot(fhat.pi2, main="Plug-in diagonal", cex.main=1.4) @ \caption{Kernel density estimates with plug-in selectors} \label{fig:pi} \end{figure} %The commands %\code{Hlscv} and \code{Hlscv.diag} are the unconstrained and diagonal %LSCV (Least Squares Cross Validation) selectors. The unconstrained SCV (Smoothed Cross Validation) selector is \code{Hscv} and its diagonal version is \code{Hscv.diag}. In Figure \ref{fig:cv}, the most reasonable density estimate is from the unconstrained SCV selector. <>= Hscv1 <- Hscv(x=x) Hscv2 <- Hscv.diag(x=x) @ \begin{figure}[!ht] \centering <>= fhat.cv1 <- kde(x=x, H=Hscv1) fhat.cv2 <- kde(x=x, H=Hscv2) @ <>= plot(fhat.cv1, main="SCV", cex.main=1.4) @ <>= plot(fhat.cv2, main="SCV diagonal", cex.main=1.4) @ \caption{Kernel density estimates with cross validation selectors} \label{fig:cv} \end{figure} The unconstrained bandwidth selectors will be better than their diagonal counterparts when the data have large mass oriented obliquely to the co-ordinate axes, like for the dumbbell data. The unconstrained plug-in and the SCV selectors can be viewed as generally recommended selectors. \bibliographystyle{apalike} \begin{thebibliography}{} \bibitem[Bowman and Azzalini, 2007]{sm} Bowman, A. W. and Azzalini, A. (2007). \newblock {\em sm: kernel smoothing methods: Bowman and Azzalini (1997)}. \newblock R package version 2.2. \bibitem[Duong, 2007]{duong2007c} Duong, T. (2007). \newblock ks: {K}ernel density estimation and kernel discriminant analysis for multivariate data in {R}. \newblock {\em Journal of Statistical Software}. \textbf{21 (7)}, URL \texttt{http://www.jstatsoft.org/v21/i07}. \bibitem[Simonoff, 1996]{simonoff1996} Simonoff, J. S. (1996). \newblock {\em Smoothing Methods in Statistics}. \newblock Springer-Verlag, New York. \bibitem[Wand, 2006]{KernSmooth} Wand, M. P. (2006). \newblock {\em KernSmooth: Functions for kernel smoothing for Wand \& Jones (1995)}. \newblock R package version 2.22-19. R port by Brian Ripley. \end{thebibliography} \end{document} ks/inst/doc/kde.R0000644000176200001440000000513213620371402013276 0ustar liggesusers### R code from vignette source 'kde.Rnw' ################################################### ### code chunk number 1: kde.Rnw:103-111 ################################################### library(ks) set.seed(8192) samp <- 200 mus <- rbind(c(-2,2), c(0,0), c(2,-2)) Sigmas <- rbind(diag(2), matrix(c(0.8, -0.72, -0.72, 0.8), nrow=2), diag(2)) cwt <- 3/11 props <- c((1-cwt)/2, cwt, (1-cwt)/2) x <- rmvnorm.mixt(n=samp, mus=mus, Sigmas=Sigmas, props=props) ################################################### ### code chunk number 2: kde.Rnw:117-118 ################################################### plotmixt(mus=mus, Sigmas=Sigmas, props=props, xlim=c(-4,4), ylim=c(-4,4)) ################################################### ### code chunk number 3: kde.Rnw:120-121 ################################################### plot(x, xlim=c(-4,4), ylim=c(-4,4), xlab="x", ylab="y") ################################################### ### code chunk number 4: kde.Rnw:132-134 ################################################### Hpi1 <- Hpi(x=x) Hpi2 <- Hpi.diag(x=x) ################################################### ### code chunk number 5: kde.Rnw:138-140 ################################################### fhat.pi1 <- kde(x=x, H=Hpi1) fhat.pi2 <- kde(x=x, H=Hpi2) ################################################### ### code chunk number 6: kde.Rnw:148-150 (eval = FALSE) ################################################### ## plot(fhat.pi1) ## plot(fhat.pi2) ################################################### ### code chunk number 7: kde.Rnw:163-164 ################################################### plot(fhat.pi1, main="Plug-in", cex.main=1.4) ################################################### ### code chunk number 8: kde.Rnw:166-167 ################################################### plot(fhat.pi2, main="Plug-in diagonal", cex.main=1.4) ################################################### ### code chunk number 9: kde.Rnw:182-184 ################################################### Hscv1 <- Hscv(x=x) Hscv2 <- Hscv.diag(x=x) ################################################### ### code chunk number 10: kde.Rnw:189-191 ################################################### fhat.cv1 <- kde(x=x, H=Hscv1) fhat.cv2 <- kde(x=x, H=Hscv2) ################################################### ### code chunk number 11: kde.Rnw:193-194 ################################################### plot(fhat.cv1, main="SCV", cex.main=1.4) ################################################### ### code chunk number 12: kde.Rnw:196-197 ################################################### plot(fhat.cv2, main="SCV diagonal", cex.main=1.4)