pbkrtest/0000755000175100001440000000000012652216416012133 5ustar hornikuserspbkrtest/inst/0000755000175100001440000000000012652165060013106 5ustar hornikuserspbkrtest/inst/CITATION0000644000175100001440000000155312372106011014235 0ustar hornikuserscitHeader("To cite pbkrtest in publications use:") citEntry(entry = "Article", title = "A Kenward-Roger Approximation and Parametric Bootstrap Methods for Tests in Linear Mixed Models -- The {R} Package {pbkrtest}", author = personList(as.person("Ulrich Halekoh"), as.person("S{\\o}ren H{\\o}jsgaard")), journal = "Journal of Statistical Software", year = "2014", volume = "59", number = "9", pages = "1--30", url = "http://www.jstatsoft.org/v59/i09/", textVersion = paste("Ulrich Halekoh, Sren Hjsgaard (2014).", "A Kenward-Roger Approximation and Parametric Bootstrap Methods for Tests in Linear Mixed Models - The R Package pbkrtest.", "Journal of Statistical Software, 59(9), 1-30.", "URL http://www.jstatsoft.org/v59/i09/.") ) pbkrtest/inst/doc/0000755000175100001440000000000012652165060013653 5ustar hornikuserspbkrtest/inst/doc/pbkrtest-introduction.Rnw0000644000175100001440000001243112652165060020721 0ustar hornikusers%\VignetteIndexEntry{pbkrtest-introduction: Introduction to pbkrtest} %\VignettePackage{pbkrtest} \documentclass[11pt]{article} \usepackage{url,a4} \usepackage[latin1]{inputenc} %\usepackage{inputenx} \usepackage{boxedminipage,color} \usepackage[noae]{Sweave} \parindent0pt\parskip5pt \def\code#1{{\texttt{#1}}} \def\pkg#1{{\texttt{#1}}} \def\R{\texttt{R}} <>= require( pbkrtest ) prettyVersion <- packageDescription("pbkrtest")$Version prettyDate <- format(Sys.Date()) @ \title{On the usage of the \pkg{pbkrtest} package} \author{S{\o}ren H{\o}jsgaard and Ulrich Halekoh} \date{\pkg{pbkrtest} version \Sexpr{prettyVersion} as of \Sexpr{prettyDate}} \SweaveOpts{prefix.string=figures/pbkr, keep.source=T, height=4} \begin{document} \definecolor{darkred}{rgb}{.7,0,0} \definecolor{midnightblue}{rgb}{0.098,0.098,0.439} \DefineVerbatimEnvironment{Sinput}{Verbatim}{ fontfamily=tt, %%fontseries=b, %% xleftmargin=2em, formatcom={\color{midnightblue}} } \DefineVerbatimEnvironment{Soutput}{Verbatim}{ fontfamily=tt, %%fontseries=b, %% xleftmargin=2em, formatcom={\color{darkred}} } \DefineVerbatimEnvironment{Scode}{Verbatim}{ fontfamily=tt, %%fontseries=b, %% xleftmargin=2em, formatcom={\color{blue}} } \fvset{listparameters={\setlength{\topsep}{-2pt}}} \renewenvironment{Schunk}{\linespread{.90}}{} \maketitle \tableofcontents @ <>= options(prompt = "R> ", continue = "+ ", width = 80, useFancyQuotes=FALSE) dir.create("figures") @ %def %% useFancyQuotes = FALSE @ <>= library(pbkrtest) @ %def \section{Introduction} The \code{shoes} data is a list of two vectors, giving the wear of shoes of materials A and B for one foot each of ten boys. @ <<>>= data(shoes, package="MASS") shoes @ %def A plot clearly reveals that boys wear their shoes differently. @ <>= plot(A~1, data=shoes, col="red",lwd=2, pch=1, ylab="wear", xlab="boy") points(B~1, data=shoes, col="blue", lwd=2, pch=2) points(I((A+B)/2)~1, data=shoes, pch="-", lwd=2) @ %def One option for testing the effect of materials is to make a paired $t$--test. The following forms are equivalent: @ <<>>= r1<-t.test(shoes$A, shoes$B, paired=T) r2<-t.test(shoes$A-shoes$B) r1 @ %def To work with data in a mixed model setting we create a dataframe, and for later use we also create an imbalanced version of data: @ <<>>= boy <- rep(1:10,2) boyf<- factor(letters[boy]) mat <- factor(c(rep("A", 10), rep("B",10))) ## Balanced data: shoe.b <- data.frame(wear=unlist(shoes), boy=boy, boyf=boyf, mat=mat) head(shoe.b) ## Imbalanced data; delete (boy=1, mat=1) and (boy=2, mat=b) shoe.i <- shoe.b[-c(1,12),] @ %def We fit models to the two datasets: @ <<>>= lmm1.b <- lmer( wear ~ mat + (1|boyf), data=shoe.b ) lmm0.b <- update( lmm1.b, .~. - mat) lmm1.i <- lmer( wear ~ mat + (1|boyf), data=shoe.i ) lmm0.i <- update(lmm1.i, .~. - mat) @ %def The asymptotic likelihood ratio test shows stronger significance than the $t$--test: @ <<>>= anova( lmm1.b, lmm0.b, test="Chisq" ) ## Balanced data anova( lmm1.i, lmm0.i, test="Chisq" ) ## Imbalanced data @ %def \section{Kenward--Roger approach} \label{sec:kenw-roger-appr} The Kenward--Roger approximation is exact for the balanced data in the sense that it produces the same result as the paired $t$--test. @ <<>>= ( kr.b<-KRmodcomp(lmm1.b, lmm0.b) ) @ %def @ <<>>= summary( kr.b ) @ %def Relevant information can be retrieved with @ <<>>= getKR(kr.b, "ddf") @ %def For the imbalanced data we get @ <<>>= ( kr.i<-KRmodcomp(lmm1.i, lmm0.i) ) @ %def Notice that this result is similar to but not identical to the paired $t$--test when the two relevant boys are removed: @ <<>>= shoes2 <- list(A=shoes$A[-(1:2)], B=shoes$B[-(1:2)]) t.test(shoes2$A, shoes2$B, paired=T) @ %def \section{Parametric bootstrap} \label{sec:parametric-bootstrap} Parametric bootstrap provides an alternative but many simulations are often needed to provide credible results (also many more than shown here; in this connection it can be useful to exploit that computings can be made en parallel, see the documentation): @ <<>>= ( pb.b <- PBmodcomp(lmm1.b, lmm0.b, nsim=500) ) @ %def @ <<>>= summary( pb.b ) @ %def For the imbalanced data, the result is similar to the result from the paired $t$ test. @ <<>>= ( pb.i<-PBmodcomp(lmm1.i, lmm0.i, nsim=500) ) @ %def @ <<>>= summary( pb.i ) @ %def \appendix \section{Matrices for random effects} \label{sec:matr-rand-effects} The matrices involved in the random effects can be obtained with @ <<>>= shoe3 <- subset(shoe.b, boy<=5) shoe3 <- shoe3[order(shoe3$boy), ] lmm1 <- lmer( wear ~ mat + (1|boyf), data=shoe3 ) str( SG <- get_SigmaG( lmm1 ), max=2) @ %def @ <<>>= round( SG$Sigma*10 ) @ %def @ <<>>= SG$G @ %def \end{document} % \section{With linear models} % \label{sec:with-linear-models} % @ % <<>>= % lm1.b <- lm( wear ~ mat + boyf, data=shoe.b ) % lm0.b <- update( lm1.b, .~. - mat ) % anova( lm1.b, lm0.b ) % @ %def % @ % <<>>= % lm1.i <- lm( wear ~ mat + boyf, data=shoedf2 ) % lm0.i <- update( lm1.i, .~. - mat ) % anova( lm1.i, lm0.i ) % @ %def pbkrtest/inst/doc/pbkrtest-introduction.R0000644000175100001440000001201112652165060020346 0ustar hornikusers### R code from vignette source 'pbkrtest-introduction.Rnw' ### Encoding: UTF-8 ################################################### ### code chunk number 1: pbkrtest-introduction.Rnw:19-22 ################################################### require( pbkrtest ) prettyVersion <- packageDescription("pbkrtest")$Version prettyDate <- format(Sys.Date()) ################################################### ### code chunk number 2: pbkrtest-introduction.Rnw:65-67 ################################################### options(prompt = "R> ", continue = "+ ", width = 80, useFancyQuotes=FALSE) dir.create("figures") ################################################### ### code chunk number 3: pbkrtest-introduction.Rnw:72-73 ################################################### library(pbkrtest) ################################################### ### code chunk number 4: pbkrtest-introduction.Rnw:82-84 ################################################### data(shoes, package="MASS") shoes ################################################### ### code chunk number 5: pbkrtest-introduction.Rnw:90-93 ################################################### plot(A~1, data=shoes, col="red",lwd=2, pch=1, ylab="wear", xlab="boy") points(B~1, data=shoes, col="blue", lwd=2, pch=2) points(I((A+B)/2)~1, data=shoes, pch="-", lwd=2) ################################################### ### code chunk number 6: pbkrtest-introduction.Rnw:101-104 ################################################### r1<-t.test(shoes$A, shoes$B, paired=T) r2<-t.test(shoes$A-shoes$B) r1 ################################################### ### code chunk number 7: pbkrtest-introduction.Rnw:112-120 ################################################### boy <- rep(1:10,2) boyf<- factor(letters[boy]) mat <- factor(c(rep("A", 10), rep("B",10))) ## Balanced data: shoe.b <- data.frame(wear=unlist(shoes), boy=boy, boyf=boyf, mat=mat) head(shoe.b) ## Imbalanced data; delete (boy=1, mat=1) and (boy=2, mat=b) shoe.i <- shoe.b[-c(1,12),] ################################################### ### code chunk number 8: pbkrtest-introduction.Rnw:126-130 ################################################### lmm1.b <- lmer( wear ~ mat + (1|boyf), data=shoe.b ) lmm0.b <- update( lmm1.b, .~. - mat) lmm1.i <- lmer( wear ~ mat + (1|boyf), data=shoe.i ) lmm0.i <- update(lmm1.i, .~. - mat) ################################################### ### code chunk number 9: pbkrtest-introduction.Rnw:137-139 ################################################### anova( lmm1.b, lmm0.b, test="Chisq" ) ## Balanced data anova( lmm1.i, lmm0.i, test="Chisq" ) ## Imbalanced data ################################################### ### code chunk number 10: pbkrtest-introduction.Rnw:150-151 ################################################### ( kr.b<-KRmodcomp(lmm1.b, lmm0.b) ) ################################################### ### code chunk number 11: pbkrtest-introduction.Rnw:155-156 ################################################### summary( kr.b ) ################################################### ### code chunk number 12: pbkrtest-introduction.Rnw:162-163 ################################################### getKR(kr.b, "ddf") ################################################### ### code chunk number 13: pbkrtest-introduction.Rnw:168-169 ################################################### ( kr.i<-KRmodcomp(lmm1.i, lmm0.i) ) ################################################### ### code chunk number 14: pbkrtest-introduction.Rnw:176-178 ################################################### shoes2 <- list(A=shoes$A[-(1:2)], B=shoes$B[-(1:2)]) t.test(shoes2$A, shoes2$B, paired=T) ################################################### ### code chunk number 15: pbkrtest-introduction.Rnw:191-192 ################################################### ( pb.b <- PBmodcomp(lmm1.b, lmm0.b, nsim=500) ) ################################################### ### code chunk number 16: pbkrtest-introduction.Rnw:196-197 ################################################### summary( pb.b ) ################################################### ### code chunk number 17: pbkrtest-introduction.Rnw:205-206 ################################################### ( pb.i<-PBmodcomp(lmm1.i, lmm0.i, nsim=500) ) ################################################### ### code chunk number 18: pbkrtest-introduction.Rnw:210-211 ################################################### summary( pb.i ) ################################################### ### code chunk number 19: pbkrtest-introduction.Rnw:223-227 ################################################### shoe3 <- subset(shoe.b, boy<=5) shoe3 <- shoe3[order(shoe3$boy), ] lmm1 <- lmer( wear ~ mat + (1|boyf), data=shoe3 ) str( SG <- get_SigmaG( lmm1 ), max=2) ################################################### ### code chunk number 20: pbkrtest-introduction.Rnw:231-232 ################################################### round( SG$Sigma*10 ) ################################################### ### code chunk number 21: pbkrtest-introduction.Rnw:236-237 ################################################### SG$G pbkrtest/inst/doc/pbkrtest-introduction.pdf0000644000175100001440000037330412652165060020735 0ustar hornikusers%PDF-1.5 % 4 0 obj << /Length 973 /Filter /FlateDecode >> stream xڵVKo7W,(pAM H`8JZawmcigAJ,%,y?a?Y!K LTFA$R$M|>R8 ٷ埈$Pr 琎7]LG󌲬z=)Nl0P$T[rEeBQ^rwyńlenuU>\}L$XAEQ$)/./&3iY\vUx1*̋\!qd)XD*drDN -M,FKVd.0KK668ܮ{Ǒ)A1$ͽG~?.iDm,-eD$<oLop95}׷@S!Y'm!Lyl@Ş77\1f%J^2‹VZbA(b"ܟp7ZqNÌtt/ N66|N*'m]$:M3^`lyuߴݙ-#:삹onh{ݩ>'77m'UҥJ ]WO }s0^MF j~Fa-ۇڸ'$||i3ePP3r,Ur[+ΙtO|rP1Bk|v}e$K :7<~oK)tPQfA*ED)"m9o3=ÄQF bCD̲Q-^1R:v\+I5Nwխ&O 'Y*~SǀOsjsz=NtlM=f3=7s> z?\jO1i41?6ա,+V2=q)^oc[i: <{TA!ĒsiYg_zHBG endstream endobj 16 0 obj << /Length 1085 /Filter /FlateDecode >> stream xڵVMsFWPJg>UJvksIE--`;[lEN)~={zHޒDžV/|ˏo &ZG;,(tPK.yt'.o*D"emq mnڿquؗM}.&{e}OMz޴eZud]v:^liܹٚzA{SZ%B17fNFp jO E-?!ˢ D3$;O8$hhCvlMmy@> egIۑkfCQ]:]sDQ+%[bbi7-b+C[X{T|g71kr9#{uswdrO04Ei<]?U9 YHQbyJW9Iѹ؍֗]Ŋ!\dPpsƒ "%TRƛsixˆO8q8|s ie-_" g.B/!ۅ+Q> /ExtGState << >>/ColorSpace << /sRGB 21 0 R >>>> /Length 885 /Filter /FlateDecode >> stream xW=OA WgnA!R"NJ(B yvC@n|yNHSXʞC QOtt6;uϳ/6:z/A׃X}WÇcr_̡ ҍRI=nifVÉKwZNw1U.pGZv.SN-^{0M'wG,I$s^Cճh݋u5A:-֫fsd:s(4gb]'s{)G/~k|xacUcyNB6`t4ocQR:l!p6m5Mtز[}5xl"GS\߸~+X;hv~ԣ?Zp7h o̼ (9yFh(uMJz(:L0" ]k=qiZxwY(|ǟ}_d-c5 k` endstream endobj 23 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 26 0 obj << /Length 1312 /Filter /FlateDecode >> stream xXMoFWɡS\I:4)PzhzXK($eHMVd-vHξ]yF89KŬlor`3NG#"'d0>#>bH _Cɂt2ƂʙY> t7܌<޹!ݘJiUޣ# $aPP,aH˰LUᬯnTn0Y~u4_<5ѽ1{H਒H $I[,_}E\X ;lWoݮzF^^'Y6A&FIʫlU啞h(.ܑSPfFȸD4 B@GYazfmPZϟD-qL[t!aO\3't!oG[n;joE͛yM>{=߾։l,{;B;+&ں4Kkwɯ(6qvL" $8z^>&1 $@{AlLZ/ iB8Bs9aaU{q7!9ʻŎ w$@kCFIn Cb]I_$]! q7Xt' "PL=4Km`N`c7x-±y-Z1ZwM+L6N[/v{,|`I֟d[~4'^9hMn$pr.].@ϧ>Z\My_IB+bl+bDڐuِ'nhnҍ'51=IOmY0W,K7C:Led2M] VL}zC(U"- ?I9n+ ӇQxUis> ۇQ_}X[?e4˧<[5r+kV>m(t-ޓ&@~Hzlr?!tZ ItzK*f=P@*Цy-je@ْ}:yʉZ%h.bQ{B?@NcT/RԕJS|,SUW\E6lP颫s{f'Ȧ=us?DrāHKJJVfvJE~ Xe endstream endobj 30 0 obj << /Length 1543 /Filter /FlateDecode >> stream xXmo6_a&w+%̀X xާdœyGJxw<>/,l& `;]:| , ,"xLwm+<Ιj@gAHyȱ .ybqlsP_M\ՙniLká ()xR1{Հr!$C&cШ=J=lOx`Ϩ9"f)Q,QØ~+v10o`f$VY^qu8חa4\Ag }1U3/"/j]7euM#59,7=_ԇPo(sowݺEl)ѰK{eg7t| L`C#HY04^ݠVSJeZ zYڥu/x 1qA :[ eYN!Fr33 oP{]]Mn+SgwyfE}RWl hBk.uJ{ CCe}vnܠ-Ӣ<3F ^Iʌdv}@v"-*\Œ8~( "YFfnxiОxD{=)xjihv_t(6/"mhj=ͪj7=rܫ >i1\C1viabUᜡc%_ FVW)uTH·TcGoe{ צŮ'av[V';0@FOw۰c&fnCKRdyC33wERckx]IJU6or9d8D49|d1"cKN7P-^jH6oKiZ7ZQ;uZE_{ܧ*YkH:[:7c=`C2 y$x>0Q,4M]A{qˑ1⼚o0:]p`u>)#u8L8BqSss|*9\4\h(Cg]5n zbs5%Q4xZȀh{2=`A({_ؗSТz~J\P6X̗ ZlHHVX3]Qnh JG[8Sx3i!]+LGy_[>V/՟vE!YާL34 |B/ǬmDPɯF2dKDxW[,OoVCj5*H8`M{^*} q=_ Rc$uzhlTp vOЮG枨 endstream endobj 33 0 obj << /Length 1232 /Filter /FlateDecode >> stream xXkkH_aJa4S#fYBoiXƶ숕,#MQ,GA `_{_!9)d=%EDƃlp9}?T ҥSTEޥ^M'UM7hr>> stream xˎ0y +I՜YtѪT( 4ШH`; TsAe)] (IUe6ǽOG$HOC ($/H4OGwmNVJvq<4XE@Bߙ! v"-gGC?8 _IC/rnYZj/L ,V5Ae]˺P:j@&ur^W|a{Qe;$|NȄ,P?jl{N9͇2]'t[XẶV]9vY S9Q4,x Tkq_ΥbEs_br˃-5@;s@)l B;sD^ i$w79 `[;˩6kŢn?MV.}Xף_ 'Tx6C&S|՗h݈TҖkHXx-kGy*#W ?ė3yVz RgnuJY6zDfUB<ĵ:4~ )WPR)o+_!&<w/<|7l\ endstream endobj 47 0 obj << /Length1 1847 /Length2 13612 /Length3 0 /Length 14766 /Filter /FlateDecode >> stream xڍP-%KpwwIp0.wwww';8{ϹޫVjY{wCN,D/hlcvgf` 33XXɕAU k06w5@ `aab01qhc1pdR6@8ra[7{{?ܜt #k꽢%@ttT|f<... V 6_. G3"h 4! g`K9@ /=nC%IW[2":3G"FF6Vn kS *&H06h``ol40|'ٺ@LP`/}F [GH~̢6VV@kG?ݍ˵qv72Y!ɖQdnf t311qrpvl:0ktzL?p@Fpc#h ;h/~ W1I}Œm-yŌjJbBISHNgag03s8<;N%Ml~zdP6Ԁ g>@dY9YZ7Yxg'ݐyB6t4xAkS#A 49k} -A@y/=3w~W+%El={77p{wpg~_Rc럳 `dq|qF?L"NV'70q1F,F w߈ h70R&!{ mN1d03d?{V(ޭ?{q@w?m+JFǿ~hfҎ.6x?d.#'{W ~@WҼy} =$jz%vG$xʴC=(;T7D/'uA- OzъS{pXy'}/vRYvN\H9.⮵}%+{ %*aھنs$ `h.]gong2'ވi !s J%m0aX9@M*<O#ͼw(C%uf~0$zMrg4:jjY%2Ϭ{ϳ%[^ a9yQptۙm)gau;WLQ\8T)LV>Gϻ^>hJ{K\Fۋ݉J^zTJ).td5K),~!TqfzP aqzW٘{V`3/{VĨA4Yi s 2a<4,.*Uʳ'sTb+uVV-2з)e3XIRBG>x{c:߆]bUre&Q$=74g8StJ H,9OeE85: ~ğ0}kn 5/1@_~N_8i YT$5T|DI" uqA󱳟 DNW [[/2@$xPg`)bLtfa*O+KbhK7CL;#7ʪUmzQAZ@tKmg0_ݮ`/_:?3 Yb'S(ܦ6Ί3#Ho`L0kxOh8q"~,@}*BRL٪+_nxbVaFc:4X$ l6h{fs2{AUf"yBq&EcCJԽF"Rr#1ʆ\~; `*\=ť7]][=+*]g*׬B \>SɲUuahh 8ۈͤPb,5)= )|t3{&t]Em\-ׄ_@Nڴt|*3tJ-!u:Y+C:!O Y4*YVVwK@ /khxMG1?>&nج"btRͦXn2k;r [u_&c#GyI˭z*2S+n1RE#՘gbl'vCF\jw,MH[Dt秆;D2 9v&ˇ SJ5-"i.Zbg/,vD76 ~i鵋č?0g,STB>(bn^EYאnMTk; :{'@bo #Qs,{C#8P ϲsU$sMdާ/b㡽?c̑3_Qq!b+903| I| 4XRbN{tA$Gnu.Qtq~^—1^ۊ1mtx/$~Ke B҆%JGE*S#W"g~w9Zs~ vK#03ֶ F,L[2RFx5~` "#-Uxz?{JQ璶n=Q')S<-~la@ 4U.j7C){">c{;4~&&rdvQWgMD^NQ ^!!sGv߈6zʥSRp@t.XijZ>rWK _Brs/!ϛbu9$,:t3@"$KKˋyնJM G0-;,C@fS1#,9#'a#cYb3HI9ɃÇZ}wq/@esR{(.6y're%\`pa[zgdc#/q/ti bOqy)q??`wQcP+0!'ㅕ&)vh4Y5b *~c@7:tta,<:{{B(QߧI*X]\{1m ѩ(SGzQcID<9tQ^d<+ ͮQj# dԑ)4#/RazN:L ~ `uGUfR҄ODFw^!̀#ﻺ}l/C3q_ 06n/Y!709||.E-!W^=-nr^OfmLew,ZZMsرhKzo&u ReqJqAn1sK}xFշ!w DR )D]-QVuSxhl$ݴ؄nP{q&6cJzf9?G-quyXS9Kb ŧY  ]&Ԕl?&JETǵ;y!O!Ácu~r~IGejǤ1gkZTũ7Av% wR?WqW!*e29Ȱ,EvA1o'o/Zԟ%I]'M̪kܥ LFn;qǀwkԯMS()M *> %!M[xU':3Ot7)#<5 b鈈T;1A@") Y~(&3;\$u5Zp߯^ u5 C+GMU /3#Sن %1& “QYBB]EjE{!/M-#aIy_  (jz,㧻r|z96 3"W7 g@H t-g6d% (@ea~%Z* NSN/yF-d䂥ܻBN"kdY] S hPYϭ:H鞛/Ĝ<@9 :ci$-ֽ~ >``,fL;yi̬W?|vIO?Cl- { /)6C-;t1m ,;;ڈ(F.L.Wp$ w&u4}?oF|QQm&(!@跥ӲE[ ŻhYuIJ窴TFX̆@{Thpn;rG.)XRR{+sŖ_BP臃@8o-R|FF%fhb^8%;'Q1IFr֡S sy8L.lʯZ I Sőf_~]5$΃ޝeC !eC%z9M9vt.֕c4έ68w_⮺Ke_ qŨDB_)`D#(6 >T!ȹ$YҎsU|#}ӻ5g٠ IbF PunF/M%Zկ{9UY̸lK%y3Džى謊/YNYexv Hn8`G|n^Zpa'eN ht .RZawcqN3Ί@Ӵ&Pj'"xC]Gփ|0&KFNPPCR  `i }hͪ7=#t4/N^wv2qH8eQ Mul\EInGFiT>pUB!n[ X'OD/9HnK%,O[ /T⣏"챜d]Ek"[gr td36D>D_ui3}iYwӔڟ\`ئMxsLE u"mH5U4=J#/j W㷚Sn0:HՀQuvZ=jLp^$xl__[KMW pyu6R~c%8 Qň?mN)LEhŕ83=HFfjDu!FMqȟH8PH ]*[8v޶Bp|0~R~08YraRp-,K2FK E#COƯ12ɔ1& };o5ߚ %1AY1)_ez^ڐ ]8ax2 +{oB5. VL܌Ya> +P&}i/+7+>']f5ton>o㳉& d碔eWD~U߇gf Xxz$֟tӚȗnX HS}40MpgUrQPx}V Z "$f ?v\Q>QQ=: stӥa9|;ZY>-ER[r/UsӞښ݊g,SbXlPin9;=#٦yx|Y )B̅n$lʷKU{e/f>< }.GxK48DyH%a|BpyH̋/&ë-K%hR7pUY=P%Y**hߢ(4݋keآ?d&#fgTo;Xg/%Դ~wGdWmp`3qٗDI,mB;3o&xT},A*C*XXPhV aKWO"~Wz6TƩ -]m?$<)4{YTAqYz˵ڞ6w:FJyC  CM`b^Vu{h5>KuK{Fly<n/[v<5ujNO4Vh)2T=~k:jqgΖliqv0vSJ$)F?Z? :ѮQaf{>O4>H Y Iٲ> rxf?D_;+f s>&J%[N-mJ&Ӯ'5@^zA'uH Sƛ.1}*w.&'2]2֓M sݎ>慈%*.2S4_ V){r8图ϻG!meJ9"l'0I며s#)ٜ&;`ɖ_+yGY0c&l-ȥl\UAyzuͲ*$|%~lk+]V[S;GaR$& M?mVF1}Uv|+pU_*,qRw:֓vJȄ%YdѠ֜2͸,/84a?|dF}Qs#tAk6׶DܣLEpL^´*H!bH]d@%L]K` b™0ƥr$+s1"V#B4=>.sTXnQM^oNڟxѣ xRRgVM,;J]KíLGFSflEt.8|x .7duyӧ03FHҐe^wj!JT*4DOZzlN򐅳 r AKׅyt{] Wܷ|Feo85}D~-͕$]v7Җn ~ 7xy`؋FL7*tg5?\xD\XyG.12Q;RE }VꗬNы"?b(Zu8!BBN>?9~nB3 uɷ9~32gxAY0Jl܌]p%ЇQ`v@V$%,OO{ ˡ8`P3a6`4FIӇ2Aa@]Cga`'U&\9^ {k!gGKi?zGх} Wd&{+N8iPts4 qffrC3x׆k#٤5ٴaߪJ<ݾx >59?+.lj|*O͖"+Qaw3uzԼ'%w)p^GҪ0!c m?Dyq-2;\Y~Tx8ntE/, GLjwJ^h| øm֩wlj=7t%B%Rb7szB|J [mo|Wzӯ <[*TUR?\ڗ1 T u籦R2G(9 "Гqn֖BuTcpHP8: 6ˁp7ȆtguNeAp ̴% C9h~9q`jl̠\t=n力e SurcL(h䳱< \e _e9.ϑ @^Sâ]1abS~{uqJEn7jyPGxMYc2| |NՅcGGڍsqvVDQS(F7rdI.*+^YgTN \%` žϏC&-;V,xaՙn{ /<n;a$d +5\W@̸@E{U!)<-K0eϨDDBp3L2^Mp@$z**;-!csb<*`))pFa 73 oC02N+q.w!EK[?'>*Æ3h{Y؋^'ɜ.- ÿ[.qXnD$ڱkz.a1EDQmAjKJ.JlbIno'YD~Jga6$œbM?mMCC}]igXMO'hq?Ew=4 egaqio'Uh*O1+L$U(L2(};$Z `@̾k/K to@U%mq Y qVA[߭g4PP/r؁E[kƑl|UBR68aWMsnj3NSNJz_Ӓ9,9&# evunR3޼|uɴ-bیqW[DhXsl/B~7);Kgˍ,G^2d 51C1\gzsypN(MAd=$tOw_ ۹_6 x`HY?"t`+/u01O"Tc8^YFid8Gds~G0?Qnd!6TE1 |sMJd\iq ) :EU|TapG{$%r}` Eջ~f?JJo 8(pW(TY5w4DYf/eo7EYQXDؚz]\?9N /C^_v,DhQfXI<&쓧@q0Ԑ]l% >ҘYԚ `+o[!Cl:Q ]%jSEΤUWĻKQc@\C,ES^^Ίli/&el^HF f1#c3DV-2ndNb>tM@8oS,k\J%5OioRzDk,~E3tʘ7n.$yr:p؆ЂZSBotuWJUE:,#;&i*s!.Pσ9ߏ:X\h/D$&3XR6)e< endstream endobj 49 0 obj << /Length1 1827 /Length2 11328 /Length3 0 /Length 12465 /Filter /FlateDecode >> stream xڍP n!oFwwK!Np'cΝ{Uݽ^[9{jrU fqs{S=ąM $`cdac@؂kG99!bH:.6)+Qwsyyll%; n`s @rFwt[Z_=p l.V ׊f@[?)脬\\XYYv,N"Lw@ rr PځƂB д;ǡaot^ `35brVh)T@C`u8vG"0` X, " 1u@WŸ2j¿99\Yhd#1KC%@g?;^ݓ˵ػC,s?d:jA 98&l 7/?yYQ@_o{ū / t\\Av/Bag\ K0f;=l`? 3zCYeTeTSB `fsx?@_ݱQba&oey6n6/Kg#ߎd\mmځm=bγn(ٿnRu@Yh {[sn8c;ˀ=@`3 o5-Rwul^׻z]-) 17c8y@''' qps_lXY .!Wq {'?n*?*7^ W߈ _`5_ rl/k)kſ k ߱+k/CWc/k_+9 X];b']+]_ g\^?|A 򂽙`uMH]8;΄,N =S=b"}נu-ik':j>;(KSx$̚b>O>ځ6Нَ|od=jK-V(>0Ҋ66Gc1O@LĀ}9w}35B&ψ{[o#׏2M.B*B=Rkio$yEXB RFvL#W5yPQ@̭X3Mj[Zo3Oy(j{Ox^Qs_El\U9S{l߅\Ӊ"t'-,%/qw{=Џ;`x}''e!HWE4H)#VY&Ǚ:C/6"şaǪ;0^z3͂EWvl,:j,胦cҬ!p )94rgHb)AهVIDMWnUI&ꦋg"P+%|JNBG(aVN(N3J9u>uEM]vʳ,V̑ h* Qԋ8) f&mS4YwX3h=Wo/d4K'1÷ 3 S ~svMf@d⇴c8& V:nve,0ۢ:L'9X*e:x^}(em.\Lg#Sa^ ⯫q^PmDd"z B/Rz̕Is:+ Ih'M 9~g *eI4\{3L-%2fU|6VG{u`N}Pr \Y7T,s)BǶSb@vmFyǸƳY6 rF[r ~c_H27"K)oRw>y` ڼ!DazWaT:%R{͏?I68qr.!-. {"ʩ:_DdlMt2foSUn?$z5VB7t.݀g\] "?ѷ=|s5]VghUobJ; uspZU?.24͍ | g!qIlRly\}]<=\5`I΄3Ҿ)Cm SБvPa\ ӑn9|]!<ۭ5`=RU,z*F]?w~U{J;/Vs}C1 쎼nqHga߆9x>`Fn ,\mk wLoĒ J{KzNSI|ٝj@d9?E$&Yg<,eՔt"/rjӿ&-iso~ƬKM1jR`GO)7>g8Y\~3z4OZv0YGQ`DRiN-W"}`S='HD5ra\#tYդM,<#f.jOHaa&(P:St*|P$S]2( 3} yYrk B5895 coBEgpJn(\9D™꾓4%=oCJznf5Z]TN,]zJ5dE(%ZUIɉhteQƼ#>c:9xd ('vזo9%q pۇ'a(&벝&?n;EX ncJha:\`."hR)nѐzavXb(v co TiEڶ EMl&|7Id3zE\_$^[c?ܮUb(EL<.Zo[ G{P=KJ>W]MrcNz[It! --m9Wr>eM]F[7t*22`~Z>fN5fW;|,:qak|䢵Z?tEoGq(+*(/e y$F}_HHhNM)ޫ!ȫщouoP wзr [*j?o.!Zp;$WzT"-jY0 %Gbv]MQ|Bc cO1-;ӺDBH]R F%_Oڝr(~QKGbþ| ~|ey܏{,76]BC=ɢ;T[fua?!mp [i988|V1]53~7ќ0h\a|Y`+@@3@<+/rV^|':8 Ɯ֧`Ázzj%otA{Hmig3Wzv}5{$`lEmu3JdOz2fv(}c; 4?ZԿG<ڀJ̅DSG[ȿiJ1wT%]7Z Re>E;> Dy 8fX >49#PZcPHp/w9Mgk#>Sm(Y~+ `@W]}u~E=q˩}sJʣ޷8nC\!\+1@O{0#^o&1O\vJ9[o&გǚyaQS,WW? + [U^AZO4n7}+NIUQO&=>gBF-gM J#s"[SV`崎˙Xo[`WP4uSC;$zM/P~Œv`bX+] J'U.f}UOhu#eLyf7Mo\S߭dw|֑fQ8U.(R`:C#O㦑Rό烬y"7w kLi[nw~:R>#:<5숦8\ 5}'{NxXX\ $elbğd,~бR УAzSymx!=:v=#m.x8n(QJgF)G*#mܸjfJn O/lBCM=ږN.L+7 ۧ3i#.!tRM& 3b*_]iCIZ-Z1?QڀQ&{npˆ2)T"oR v!$(g${:<]!`F|g}d|7+\W/$*k>-We,(SY}?(RO 2n46ݭDH8tW'DXSbcWa> e   ٪uw$g7}BXn8,TB#MÏ8- 䖬&(vT$NB!?lyσ*|V gcyNpYkt UHD2ϒ+9j ax}TK8$pgeМ̅Xs/~m6+fKXc.f&h-e,C 3\P .TBUD/Cp49CYNlN]RVbr&^e2t[4 l m –6jPJ75{|[rNc f˱rj+9mlaGFct{6 w_LspA$44-0@1sDЮԘ00!eNX3%Zc4L޾;A:d8kR~L n OXǠGdç!xR),j_SI;<…7{VnCvsEVZB:I.PL[dwE{F)c#iKFRXD!UNJ &]1\][[i?kTDzK*:HӭsC -r͑Xxd+Xma՟2zps'z7gxAG9wkZQ{7BC F4'8ZpiH 4opJdNKY`bv?$OiA  9 c]IFPtY>?T̜IH8p BL;{5flTTuVQ~ZH,)}:,RONkΜ`hJ~r.فí[VPx:ep60GH"^rJ%Zs4XAv9Gh Qݱ&0 |ڛ>M<3aԁWSgƺZ`I޼K;d37h$ ᭱eKHD(R'=~'7o<篹[#\C96f'κO ڲDXncQE)o-&J15 Wbs?|^<ͶSG ~@̺|&_%1hp[a~!QZo)c}'3TTd.xks<մz.d},zA ,S/ ݫ^hJ!OG)l[I5WB/^y|z[EuV^,D_UzRHsS}КѺtf86ǰK3YEc7aZ>&gcTJ+vΖHh1q'6|u[owtO+=͜w(a)1^v?CfmaD AOYe# 7](y : oi0y pA H2YHK.}?0zuR0('wgUwآ0}0<]J+ffl(ꞹlEjۑ C-@]kUBp}7ElZN0mdiehjF,,XPe^M4nCZHK9F |ߤw\ت`KK\&{#iCeo'o${Z#%qC8cU~R~ :nkd#iikr Rd!ѽ5X< df,bN**h_ s Aۖ{D)]ӼCB_g1CiBs:Oj aiy$C7F D( VΛ{}v#-2ZmC1.tZsgfeLSG3g̀]MAS>Õga-"WIi,K˝=_I.iEQQ~z oS>zJ`#y$ƟB&} _ߏp=u1Nw+j+J9oBW@Xx7(^ɡ1g%,PWlat6)).+ܑSYI3UT)uh) {2BN#y=ZNSvBL;0WΫނt^f2Wg9uN)ԞAS6ToO@*yDz`vN8|NNTX'ataO+on,}GI s57>!dU'в0:^#7u.dE'CMm]i9oVEp=zIaɭozT M49LʰfyVDrI-H/{y3G7C~ Xp Z~`JAC2Mn&s/kg*?0iaə[g}QƘD,:"ۡ%J^Gm}{-5x]̛(zɝU ab7K~u ZULϡx^/Mɲ4^O[(簆l kDS[Oi-QU<$#6-y6N?ZGAAP)|%=0+wӥeíEx"c ;ӈVTauNUU>%Ⱦzz6g:AEz!$ɪS%P^|MMļ~^Mj -Z%/8S?uTHkqNiUFW-Xsaen.s=^63hhR o*8\0x >ӸY$ܑji o+2REv)|I?{{Ox\Ʀ zta+.چ{H\aUZJS˴8h𫃂  %Sr&v˜rbؤ#N?Lq*b ֛`nh%[KV&έCRjD6Y*O՝1/やO"*ϧшܰvk&f[7{X/+-*_,mBs"TǓ/z-'OsϷo`g:Hj&C|"Zh0@AHXH[)Ėn:<aupa(.LF/ݫ)uwus(!cTOeּnN\I7YH ?25]zY.nY `XN\AG@z|v|; "]JmY<#˞;mB5ʞ; jgZx@+To_K"_le -I8XOBkMgڃorpяN(.|ޚm9mKO(ڽ8r x &*yX6mnjT'pr %"LDĻ`"/X Q;ZaoLRfNR7dt)KÙVt)`@m3E ZGl}$0ĜHvkax?w9"Ϧ3hwtHHm=G]~_?7'o{6bwe|R'A ۤ2q%iKjԵ/wx¿+2s+؀Y1y[ > stream xڍwT]6R*)2*P)S3H !Ht* J  )!t|c<>}k֚9gk}}{o1R p 'TA@(& Rqs"pTp BB650G!:] 1HRt[Q tPH8[ p:/P>HZp}0 FLPPrN8ZFDSFac<0O5a*nary1p‘XB}$ Lh87X7@r aп BQnh0t8 \C =aNF~X!F!F0~X(aןE~!\:rs#qXSC`P½{i {@~ҀG!j0տmp@(u[LJwN"? z῜f?4 p Ѐ!*,a|!8@R;; w'X ??ZC!] bm]#]=K?TQAy|DB@(.MX3Ͽnow?Hg,7?37|0@ [@ ?Of_'ҸnW?á"!W& 2ґ t!0P@xaw8o1 B W~E|fBx` =c ޟ{8ayu$90"H {<@DB~gA Iy1B_ {kp/8jb  vn9TfZ#L;,u'dgM>Әi:̌,pz qj8rB/&i$zlr]Et#ReMWuDO:!-%YzL_? K~v{mjqSW*vwUTå-Pl/ 'W~{g@4a]gR mn&vOr}qСU0yˑO9a$ = Xt뙲.:a!ޓCs?j[O?+]W2!Eu,5?'\S!VRiN- EStbb=ifWD\,?{ڪ3^Lf<>WE=}+mzP~e7ost(gӵf戛e:J 2FQyFO׉3TZ<ٳ;We͇%{tQ+LWhN5 wSՏ53 tbHsb1iyC}&40f QuWwV;smv1p~boJ|BAz/'=S%$v+#nԥ Qp/T/#v˥un׍ˆ6]zA3(o XQ; ȼ9>ӗ-䡟D 󄷷SYfK/l*(2L.֚}Em{fP]τ7mRlSF4pbf>x/8/ 1"yOUPKARO`_|"#/zm)vaW:I!9:E %,{uJW2z%ee;*]o~ {LB3s %D0g7C͵Y*I$y07#p!g롢6Px~_|\~-& '[WZUֻFx2Ա uFzH ?+.V{SRKw~w5/D򩨟npμiEO"Œm3 τ5Zwc*I<_2,jqē0ûCp5=WV ;] XFŏwgkΝ3ÌUUS}4lU=P%hXFQ=rwT8!l[rnb=BIn#A|HB9Oޥ7%Gu>RV 5 U2jxIA}ԥ:eW^\kx~뱩{/r;n}L: Tؤ/. yY4?BEe{/'q}%&qwrz%R} Xn7}sFW~4k:>5:,׏8{\!yVLqmi+yb}z&>OiݟY ݻr=g]JcWa$'0(B@m&d1QfZlBwK;߲V[ZιѠ97xƺ:(k fUߜq#3 As-`sɚ@#OMA(wƔGf]y.]hz{IiGu幛0?I)t'&B CGɔW4Ze+`-7)iEG;d"v@AUzᝅ-zgj|9~BltLǿe٪샘G 2on,s_ ]!JzjeY(>B0*9Iεs$c9(H{iÎ/^ΨV rT[y. /=miN 8Se9t{-<@UOe}BL<{74{c%&0fS!ӆ{WVJ/Sah憹 UQD}iTa͌h KmT ɾ͉UL⹳ż[*էBt.-/rS\ wO^^/wV+Pky^H;= 1mT͊,=߿UAMn9|*妌E k5L>PҊmOȢYt% }nel笯,@$mhb55{5̊%٬?ԫ,'N-݉B8wzvB%3g9 ?F/ +wCPYi];.B6xG郀w.\J'){\ֺO*2[4@"M`-{#Ľ34;-KYV쵙1Rܬ"ӕ rT5]&@zݠ ?!/J__ה}qϥ" A)?T^;<Yg6<͸\h: x3S1!6ࣵ[X~@6CIF悚Ix L<r#Qr䖔kwk[OkVecl[0zZ";+Ook:6a9Rڻg+A2~ Cw#^*%`آKyTO$*Q-x!*#͟_hxTF;X`pfv:k +q#Px_goϴI!mh{GO6Gi[]:as^{ ml0ӄvOeNߺ\F~eEYJ!zԻ8e$FRm`[ho<]578܁PZ"j;YPf8wqq=Ff:˥oլH syCoyNЃjn #u7+# b7&R8Wv5Nh/b9Ϟ(:j&50鉄vh N/k7R(?Ofru/nK7e$k8*A)ߩmcҶ0^or);}~˖S#Ck=>xzL]h&ӅGc/]V/wu)(!vd㣑9 B+'X]knt|tN2Z]ճ/;gIJOQ!Qc&ɒks&a5ӋRbHxҩEZZIBhf`;)Swt홆!?;|7R1욊`N8+6;!k-='ܮ]`%Q펪uk.swL}uwI=S6m 2O 6_l%~Y|C*!ÔkE[;(CI\D÷V$k71Y<2àKuēr9QrVn\p3I5?=xmAVsE-UZ+JNx{ |=N/Lj nd:߬%Zdea.qWuasYEv]牴ÆK~̏mi_=7#{}!E䂔bb%51DVjIm,n%@)|ts4e0܍})$m)֫ij瑇"!)(G!Vj/=&ZvAXÀ 5\>H,)ZUA0 %woa^BY?41UmCGw+ !e,X8F=pii|o{<[lΣW rX#@yU7%,>2_]r&G.~vgjcWGlj7\|*ztx^::s6cۣesUf#)yMo?w+mx5zꮗN:' E؟:ǜC}qlD }еa-Vμٓ4t𘓟KvPIǧ#xDPoX) ē>Ƈɻ 5 +k>,Lث^"zxnQT,)Fq 3Õ8S CP-qaC/./tc-YJt5657P"~LE6inMKۏ1SR/OaN%1kz<2w#;[ ` aĺ3/+}01z#j, 1{d)yyǟ/0KO"7}]Kx,\"3:[5an9LW;.*S|wjYlNC>OSzWy\<O`N- ~Ȩ?[ 砐W|k_ry#ÀBarIrF* 4\ңntUiP%Or`ܱnMCmW\a1gޙaRЈssS +ϧ2Mi VnFRP)!# #f^J:Kqx EY/;MZu񄵟/p.;h~_vsp5Kl4٥}n=bC}0y#$*+,-n|:㢁:UBP@n0J}2C/b_-} ǧ}~}]nְjd 5%JS/涎kQ/{{ K`>F{f|V8zl,jڰ562a"THkyy H}3c*^ɧAOŜ짔C=|( >Dt(sVMnC5 SRl[J&@qNh*ľwSCgs:Njo79-άy)HU %> stream xڌp[\m۶tltlVǶձvUTVgs9I iMLli²J f:&hRRKgkIL,l0v45t:\F6.Fv. "&Y:4g|()4mL- m6 vƖ͍ٞƉќflP2u2ut55E ghc/ftФ Kɕ̜ MkKcS[O[SGgr @_227F:_,mv64675YZdݝi&Z;}ZZ}]!@LP`I-흝,HW.ښؘ:;AUg=u_ml ,mM"abOjkb*)oO?2sSg+;'3`nlAWx{ӿ?x{>Iz[~r2t58;z{_04v[BSlj/ymc0/2󥗒RRꄄ^, Z&V_Caۀ[`h(ikfǂ+C rvl guX??/.(o s[MGmhcioQvq\ YZeYSKt6\A[sID_3S omik`de<\8㯟Y2ܧM)jklg1  =??79>y:Q6V_!6;^i)8E~ &?@bЫq~"gg"Og#aaKbc_ݤ72ML̟Rft'"_z;?}?K3g?-?Z?Q'5?gvCY?O_ϗ)㿥?sKh;HiOZN4'S=,OK4$%-Mgnv8|v-?gV?dL=I.>?zeΘ;Ȫ>VǍ`w@=kűK2eMV`h(Ž*ik×жDooJ3CS?piU;|S -Em@`xa 4[,mj6Z EY40i B @$s9Y;D[4tt¢Nm$}ؒkR۵rɷ;EɣT&l|FoB{䛅Kâ׾<2>Tx ܲlHf@Y}! f݈a% @~V"}u'(S> !O9+Jp`c5w e p[1"H4 /e }}+#߾daQRՑ~wyUu>:@ 3g]$51{#.MjohT~yNEB@![?WIU- Ū zQƁ+Yb_o\*!uEw*dwʀ?ckOj!a )(|ܻ=C$^tH|iItA 2†|4U|\0`cƖR0tR@ӯ͝@Ҫ`ħ*F6 (RdF?VS^CٶX< 6 ~{R7zMR󏱦6^5 l9._HYlȢȈQ;uP+j)/$8}=di  ਐkW&K7&{yHW8;'oDes[k6P)X1iSBAA1אDYdGOK +@d=2-,Wf]r9<%r=n[w7]ʳaY ܒerؘ"0D>:nXȚzljhȸ)⍏;W(aQf. 9\n]/V^nh|=GfHkAGҜGܧ.Sm<Wft=}0SK]ozBK8Il[4_MK9ʅGJq'ZP@,GFso{=NB|ۢ*OD B)u)i5VbstM1qRNs`w)З`-EIɕmg҂RJ/ ݼb3h]'oK:V;GҔXtCEVkLJսG(dښHLpW֫D8}gkaDv*CҀl?~'2unc(2 sTXP5\# $~4;i7MmֹhURTU gy`Iy̓ҹ\,ic"њ3L^qI]?eG\bE&AoCVx47>'X4.X &zd_ 6SV<Lv`󨈄Uw='4GC>Śիd)5;.L]m8Ppuʙo  =<:Qs ܯSd/Лy3od,#/KA:"7u2Oܢ97Dj51L(u)/9:C}Z?y+_ﯻN Ma\؂ߟ5'Hgm@bf6Tae-jqD/k;uYXG5i[M/5o xmyu os }cg^I!Dk.y' `-N忂d7_d?Vqx8ޤl&@y;Szo.d4+7 {)}6X֛m~f(t>mۗtt,e6 Dt霹$ 0X&Ia*SR.c$SdEu/έ]3Rkh`p0wŴgIXzqCƐ*}̫U>r\vdl׸hNAv/!>l卌aXѨkAā;zP4[*x/k~21H#s{ZWKi>AC)iAQr6ןCz:oT hc;rFfk]A9vDP+%P3'1q. by3<(/- /T #,L}q,3n2zdLTo}`( o%lr@Jى~y(39=;~ԸK0+(˚zFY)=+IA;!'ZSfYį=Z#]<8 nmD^EO? asWVD '^ìI`,8"8{0QY>BwB]GR6l5P_$R,h{,,gEɣna/}gt\MDj[j[LcƐʈ1;HZAB77x\dJ^3|"(6( w:TϷ%@<ۇty";qK -8WiTz|,,wV>F]?gPV.Di1nD9Rr˲:9^i~seK#/ u<,fb"kt?T@(ghmݼi`´ZDѦja4aM=;fua5tUI8$.& Ct5 2ʷPI%>רC䵌yɬ9t=/e:R|U:F)ƁZFY}eakĊf-0LQVm@48{Q7P֍ӷe".?>A+e^E&ˉoRY:?poЍV1ޞAtbZrZs$'bE\aȏe3Ȝsi|C崶5 HC(>E>B\ Ze%)d +94+z-cW}_W 4 TZ?Z0o7UJ#&QqD[9Y;5∏xYwDL )dI$zʀ~pdrHvŗ];Ji7(;dia{ M5>M+l*̃r& &2ϜdK:GYDWhnBYA>d6U}T5^o&TRj%D;N#ÒE/ܕjIU q/TG!XbS:W(O "\$qwj蹿bLmaw8X*#$wp &… 8''%v_@xK)~&>|:v-42{4z&DEK2h:n73ʳԷJJ&"NS@|Ah1\KyWrd6ᵞVFK}?{CA[=2~RpBSM;y483vqҁKd'H8bϭw%7 Wr|/E/u/ P3'{y59w+mi]e#\|m/Dk{P07Unwԣv5HG eB4/ux½D;!"W4!5w,ᾶu:looke-{)Ҍ- +aRc~> 윘,%!34;fYvڏ1A87ˎ8JWV1hwrҦK3԰[UX~:gwGI%\*㋙ :Jq5iνmd6oG-LZ#MDP̿#66`D*ܳvybJkt df@ tϘA,X`Uέ`[g xg5R^+t";IT+^{} EY'$4SBr`bNz uE۪0  FY}¾o 20s?`ǒ% W|H]5qWMhYz}WI;G̖%b-4]yN!|*j+LxGTāsꔊFe L[ukf*S0%hYon6^ Pc   郡%Z8LmbC{-!쟜m{7[NoހDY!9#mYYV'ܼc_$# Kq˓D^"<ޣoa"۱{n&ZY!vce$/@d̞/ ([iM/ih=D sA\Sꗸ߁.oeˑh  R˧1dܤvb\m@=\Z!~7L~0'mU"$HtjM@VB#8A]n"X>-z_ڜO:MšU/rEz=@*m o~ p|TSlA˼Ԍp1ޚMgI"҂h޵d0Q@ЖbxJ)`$xGѭ(ѱJ`@{08iKs"jmxPA|ƈQ.(ISzbBhPCvrU /c5g&^ȯVĖ(>b播5irxZԦDu[iޟ@Q$.Q4h bnbNsv_߶$@3#G:I{+dp± #0+J]}r /:G%?Bj[Hq?ȺSjH>Wuub'fqTX@[&b,Y'2gHzY5>įR+RD?BF &bƢWy BRp:VD/f|ipu4ZS ꈥ;/0ظƪܩyzPzpO⠺#"!kSF R:fy& wr,oˈ3 !{Tt'!X2,ٮ^ӄb"wV(WZa &@Ǻjض`U0QC6sj4u/:ޟQ7>3Hbq Gkn^5 *w>@uF|QI AMᔖTW"`~5ŅS}مtxr՛V$6+d5,ĎqA{NڮE"31WY"4~`)>T$YhXibtm5W-5AA֙7ܖӛk{ˤEq~+muUXu!3nq>bL֑tɵ@ݚEj(7fǯ]~}r5AI<1Vt1#W3{)q|o-{U ׇRѵ77#96Dt*RDv_TB4Dl\OE`noJo0vkƺZX&G/ [Web@ KaSr^ثRаk{Gy{%xD1Ï\PK 8,<9Eœ߅@|6 qy G_.6CoFbA.3ܤW[3{HDќc}6$5T۹bS0U7V$Y;X;{7oRsq/&]"q֦ g"#%BG=9 N19sAdHNZW]H<"m[pOM/WjحhB26שLC ?~2>_АZ} : ފ5$Eä;wJ~C8ۋ~o VߘBޮj!5BfFIrf%|\䵝f޲J)8=H84'Z2fh*$5'}tՍ.h}>巸.gZn H%Ǝaq&&\AԅKPS 0kb҂zGam_Vy*T.ɨ=O[īSbȍg>`uG'bXie="b#Qv]L3r d&_\GǹG7SpER_/DIz':҇//;س{UZK<*1݁f86-F~SMP%i':mC uD>h{r0 -xIc |f]JQ${o7/N1!زa]z"S݄Aah$׀yaE!xPͼdWs4̸%ɨПfن\̪,4(N6Yn{c%Oߧ!y1 4>~ hwk?p(Y{U/`Pit8iX>S41#51h"CDŽKD@BM7VڠKrLY (xF^ $>;tptuÊHpqaRKJ5yP˳(p 0ˬ}"AjdeK]qْ^z?Q2ڊ+)MyJU%U*hW4Nm5wк1 ׁ(N,Ui3Me*D%AzlO:SHa4 *[jp;Pcc3Bc_.ñ^:[Po8:C[dD](ǖfMΌߘeu15}o1 ?dlb:4VլA5q4L%P'\8+BʖEIU#W!9#] (Jo2,tԟFC"qL gCav^l&U|ӂfքښ8'CB@h`/~%B`/hEi{^w-{nTdsyV(nek&m8-.!Aݎ{Nެ_ӄj\= x抑B+I΅]GG#&/|EzW&K̪ɉ-<Ϻ.5l 8=,w굍Z]Uo&EM9y~q}Gl2 L?"ƟoLhoZ%YP\ Uh,|$,!*h JBѭ%aɧGS0)6A*B07jRGδ L_\EFD86J\)# ?z8}K6Q/CVNNtF3!# kDNh9O/ۦzi4~l磣Iwkɯ7{$[߈21ZG|PA\&\SI~\J ? =َFxfZTLSZ&->iw̉4B:s+K8jv h:⎫ HA%}_TjEZ墚A(Ώ{>2&폘X|ЕASǹݽS\6^B"_ɷM _jo> PDĜSb$ y/\ BozO)e5g"Չ9!M5#x[`-Ȼͫ/`c^dژݪ5 j 㥠eX?ߞ3F{L("~U2?n@%q$~|l#̫B' 'ALI05J~QRxC9C BSC@{R,\K^^ & (l[5< dw93ZVo.nU.X7]!n;ثLy<Dn*3~,m2ۏ:]%c@tKJ3hF:^P[qdS>]6=i uU3:o,K2}V-{ݧ뾋oy]/CI7vp#I>j#d[իi >{X=IO!+ؐ $WAu`PhNJq*@. 蒛 LK^<!%qKy! SudEroP~R`/dީ`xl%*ZOv|x"')my={^|fI(vlQRhJ|qyl䱟Y#clq;뽛(aobs >,i(bC-/-;SndFޝpBit]>^i[L" v/iOaLamp3P[9u&'-u鞕q3f|jS8# =J?&/}ktǍ,ܢ"D|(`I%;ƝǕGkgc\]ΌIc`rxHePg Կoa bBuX#Yc^Xp)T!QʕFsה1[vy:ׄ/A:vk""".x )1 &OcMx1&4S7`PGMYvu#(9!,HޭCh j sգP>7z*/#t9)XkjHl3nƷ[$Yqjo+ .N^XR[%`UyyzuuM {Ѱή]8t !Nop{r5I㹗_h e2KV;NMuEPdo"AF){7b}' 7ʢ5gu߱&64x7/;ʻ_ɡ 2T10fZJ&Ku~F n\/t]ÄI7zn;N;:4{g4^JZIKS'**R}nQRMH_FşCi>Xzu+UY]93 ;ͫ.J[F_RdhB#<]3Q#R0?-(sO=H<#i7_zx߃(-ML"xW h"Fy 24pL_8a?R&'XlkFW0y(N ZU]nj#mŖHbaT!@28~ >48V!PפjlYJԪJp"㚧Tc$t`%ݞ39# w?xLjoi#jzV,Yo R6ζMǤVg.)9a2Ars72JmSCș=4[bφnⶨ vs:xyd,zAQs&U ]H҈hՍ bdiN!~2*? Vy(4\G'&nbSD . %˯^R(3at=q77GH6ZVmw; +PV<{>DՑiZ1%-oQ3Ϻ[2+ْQQ|¢v6rkSQĄ ˴m^ )E>) a=h芅&73lZ:fa#O5 ȿvx=M碱t%"զ] j=|3e,LҶWhr+ tU.seQQf]{wyͥQI[uوR`Br" Hu+1޻(:L8K@1NyZ{T4\6Gc+@ӄc$ wU?q( ^| j/qA.^.*!3^~i֞9hYdgKy6iԁ-δcTjC:jӚhQbSAC~#Y/58fdvywg '- P.&jM^L? #QnƨEHFf7cGbj9焥wC#MټCSn߶qw2#^0Ǣ`oatm(lP_RyL1o)GI@ zR~~J9 G"yeޘWB2Dy+9=GRB`8QQD8/Ur>fB$>uB.CGN}99}S#פj;n\bW6_3I&{_)F;SCD7Fa*d&^|)'wE{ rkN|U(6L`'Xc˯x6eJ1"Id oFZ.uBuy 95͸Q[1ڒng8`oӸ2\|{ZwP!:ck8ԯ%::톌HЕbe1tLZݛ SARIO]lsif=ssXBg> stream xڍT-S8ECq'AZ]Kqww-Rw/ZBytfkV>gRME$cqf $5vvNVvvT--/3*+@ 2q~I8?)C . '#`gp'*2qY *li?f ??/q;lf(8[;4 g*A/d jbja` 'dMbb+* @ ] <lf s <7h+T@? `u6 +re.lbffo`C,`[@UFݙ`1hbdoj51}cr:_̠`g'V'ol<4\qvB= 2{>v?ob X!I8iC. yBM,Anvvv^~.r7b]^`L=z9P׿P@9` CPlY/ v?k`!qlڊ2JL2'!abpp||^nvWaU35?!?)<h 6T쟥 |}vnv/H*7@2.&v`[ϻP]П 2Wy;!#I2W;Y)sy[0fX{73p[JC7 5@e77 ? `c;?,졨o&il#~^?f7=9 |nb7]?Y pz~xylϓ lQUyCiLs<;ٚ8kfµ_|_s?;=y$g7xnOg 7sB_?Y< ; uaL0Ⱥ6ZčegBxfG7krPO}%M%H95AQNɏPHYvum[`hr]0qoeJBvwxJY#fiLFrf!{s5{u=3DDŽsYn#JS+WpƦh$yARto%m=wT4n? ii&_\k+G:[VXsbĬ~R@ϩGǯ}aTG%ͩ +رz"\2[]kh4&k۴̬u?XѢYv=Ws=b;4˰w2{eD _ݚ#D.嚿8*)3=A mȠv;CF~ۀm^vxUE._&G9&Ѝq/R8 aѿC/t+z/;/N X؅XK-5%Ulqe*Es(RleD>A z ,I3G(an=V}ݛc߃v+WFԮDjȁ:հ>1CWKM.٭y !}p;I|<| zHJ/`~bASs#ؼ NfPܑU I0PEʵ12e&l&xϙY/)BF"O\fTF;N+en,] L׭Bn~bة1orx;XYaL>D#{C;﫾8j{RЅBE2ZPz~ϗClCdžd/F ^n)dG։0dO 㥓i ?"zFq_;$5kh4boo-ƍ KfY(Mrwg+ޠ\Ѐ'ӄ!-с9^;P>aĊϛ@t6 _(b-7Yp&#JA U;c!J>0Ofk#Ŷ mv(lg@}kCŠ;?qCQ`uI|>i=eFqqV<]+.rt`8/STJKk1,w͙`$Asn0W:M (HT!5p ~0@M Ko`ta@t4t*QCt#v~~!g#NŷyUL s"f:xqإ :3?b(_Ã|u39O$`> _A)1pRjO" j<#fB Rۼ|J7 ,nJ# }ZU`Ŝ0-Ài1#Br ˳ pq]٥xIL񀄢Zx"vyK>PIlJaWy3!!;8fMv";%&IbRYk>>6HlټEd$!WBLy%km{gzߪ6>NJOPlJd.$m'SA8X(%61\X[_wC?tirE^aK. ֲ-P#TU(!x:GNW췤O%aoCSg)n90VJQjH0zCݕc Q;.+ͥͽCoZH{Ijµ: H {n̥S6sX}{)~4nlMhK y?vlm +JlZr #?-fKW,:Qɹ JO *K/%[E{m(5 1lB 4!`>@In?IC2SdQ_kꏱL#aCoCiݪ*\(jPƇJ]d7ُ}2]{2:pųy֗to/DFy"gv `Z@y6CXJ8;lzpDz ~."IBO*kUֺ{.Gmv!9gA߉(/](kﴵTG,c5cߚE KàlDF~w-|a®{N)O] "Ԅ!r=Z<j]GHsuזS7gP.&lı<4kxK}@T#-P>6]ݢ5%'ūӌl7GtXul {e:EK"kʆ>!J.n XQx]`H?E1x7U+w{s<)|\qB|jBmՑ%LZeXSC-f 봛:dM͎nU9z>I:+S'VGDi cԷ%('F3+v6Œ|+CA!Zb ዂrMeIJeu14 zDD RؙvE=~d4-tQâ;;&-ŏ|3 Jvt1~L ?`vZH GqA ߽$ܫv*H(C&vN9a+w 9]A^"Bk wvO<(j U[;jD4X411-;[D6țy8"#s9 >baFM[O%x{ Tw#~2Rr삍J$<]NI $ ̘"[G*wI[CnBXkA-a.k@*X3 :F/v.4M385L3}UcXR e vFFEX< Nrȉ !v\MG51Vv 7OE[ݘ< k8dVָob1$YB/U|-T}Ҭ%q4֑[BSs\_åb[7.xٲh-p pFзok`7|-)M$} <\ ,^@-~ ѩZBq@˻ʅ=s]W9BsO:6BB8mq?h6y?-xLּM=~\|:*ETO[|+tj4j!#"X IJSpiY gwVJh{"\`h;aC_FDG髡>Yzxq8݃4342'u¶I3bs`Φ\DZ⫆(b΍{[XX>Hɺ\Gx~~wƌd |hj.Ӻy?ʠM\ x-ia+ )a d[Kk:PS 5sBhJ<ׯ;vh q5B5lpýpc>o4879TͿtA;eʛy EBջGaEYMs'=^qF 9$X1*bV'zo)PX#( XK4t<(Q7en ֊czVc Dþa1 9Zm㭪VZ!ruSuaTŴq7J{)/u8y?7߯HLÄbXqSYky* &}'11+Ti(z}IyKm}ͱ,x>/8;I&&u_$[YzJq«sQ J MΟoK;]Nʕg-!*_ʥ췜qYUx9 S<9bN6 KKcld+XpXˌ4BMN)}tjn%"~A'w\!?4+]>yYouB.|vZꎤga`tZ߅+)c 14K+M)&JmRi>!;|GgXi15uOZ=cիɛ"9 7>^ "݉]N.ۅѧ)֚ݜXP%6ބ1PNdd0oi&`O@+\PjxZ݇jα#iteF4e!/ah6?4Rh.[*ft)% `"Ey)AԻ<3t4nR@*8}6`Rr,0?_1WphS7nb坆mAdRݑƍ.1jL.BeHX/g*'EVf~x25r- E8{v86ǘ.WC&KBrau}gy"<M@V/i}f^*֙wKXʫB?J)(}lz'Ao *hl՟2F*Yڝ|aK|=}?&U$(3-@1..š *|Nꬸ a|V41HNw7-Yfޞ&w(5~Lf*Ӱ-G{U2$|'yH9zكPLcKqD-&h\2;2_￩!ۤ航80u .^[JT3p܇ZneIAk`Nw? }}W_΢tu^ s7x-H.]9K'$bs+-ˈظlNp~p 4ۥ"] pgҏC/aBP{؟8S<|1oz*pS[024>*Ӡ(\80$(vX)bg>ϝ+0$K-sLX$q\ݣ;~K,=]$U=Ra TY [! w_ɤ{wLh귱C|[/u9%=s&e0ExiĤTUĞlu 0DzK)=<+(SԦg|RZ U瑬XR*79UBnRJX.omi蚻 _)}U-W%/16$]ٸq(%w@ D6\*_,M}4Ia9fVr(5\v[uؼE ޱ ݂!/9S|ٰb}358z?z8>*9x46p}_Fw5ڥ4۵a5! qYEKxR2LSN{$VEp ^O𳢰93sO˥ 橓Aqxw,I&ٝTÃ]=݉~cV -tWhXzR C}1"cٛN+z7ܗT)eqHm3^T! X 4YY" 6vͽ6oʭx}[^cաrH] hTP;Q"u!EUs5*!G>ƄP.]ni=ba89>CT;r;%>oqEŝ9_X nP%aʩ蟐s,d?Y .0Ip-dCKn12N0uXo#]vj|3_+#޽ٰ{3] 8g\m&xacp9DAxpp&< Y ?Z/Wa(1MS>UѦ!B7H,V(2-%P3oI8^6P2v=y"M5-e )3N$ks=W;-mɷUTЕV'z=U =iM"e$9$b peZ;ŸzT~=uޝV6V^ rM[9cy5iu(ѹKE!ʸQljY4%1jc;@[yW Mݻy3S;U[D_d$㜲X6?K< B'dX 31f~=5/.#dlф/_,x! .ƊHZ/! _H#`JAֳA%Kzo2v̛6ud,T$^PF>Wa K.FeQGQ5VF}P}$'IDZo重>6]|tDўVǍ Uƒ 1]f9+ҥ78ԓ0Cd_̢ꙹ8Ļ*ֆY$j+0CƬ(%>:,ceH(è*yk,`m Fb5?dl."HZn2xfwpOGٲ1&ЈP wbVLx;{[|!FOUwjc)GhU:'6gCb>4.߀q^@n Y:(HShL}npK ?nP4 :pW;dkVx!ww6QVK~AI\;ܮV6Z0q-wl^k2't.wx?"Mp Gʟ*jBxf#2P$EH%o0^msǸ F6!(dJ;VYe\2kk?4M$u.ʖv\?D-cc$;_Jd<2mV>?L~th ~8( vF>LRU[2Ҷ`,ۢQ:}>mlZJw>Q3oz7|bz~ 6KJˡ}[ }rNx3@YnY+I~ORhK!sl-ӆcP\Kk*p:)(SZ7}?K)6z1XP\zcÐ"_s-hV&ɾi,w[(O)suת6Z$3Hq#{vzT3ꓢ?F{b Z[p- endstream endobj 57 0 obj << /Length1 1577 /Length2 8297 /Length3 0 /Length 9325 /Filter /FlateDecode >> stream xڍP\[- ! Iݡ 5xpwww.ޙ3_^uUY}ՔJfPHWa01201RRè@{Q{sLN 8̬ffN&&  <1cg@ P)En Ke60sssiA%yESc0@j :5-# Br@3oc_P)j PsGc{ 9!N3=yq@X:{`f`7ݿ@?ƦPb0E 9GWG:1w1ol <ysc2YLA  oiwYb& BPhn5q fE92C@vN@iKCYLLLjj^';j 0PG{'?Pf SG Ash~>|{+@{ߟ?? 2*kKI~Ks""PW;=++ dx7˿K1wc4 KK߮{bh@d?-s'M'Iۀn<;y*ϳRM_,49oVy:!o#A 4S9Ze3=*A@=3>qx>?)8Sca2=ۋ39N틩}ǹϛ/r] PSʀrabQ)DzWHq4e~kq[Bd{ H_< U&vPzrzHPЫ }xkm̴szs-ZS44Ch>R=B72$m-#= 2-+vLTH(,Z]3P[ҵF 4veӁD~2}u!k\Tj (O:'W܎clP.m,WkJSqٙKJI+) O#y_]GJoލiKx=7#kzAVpiamǝ&}^(r-pxpI9{ury-D%}0/]kXUsrķiR{JzDW-n_fk Z I*à9"1-in!>G7_|?dX.wl#Ffj P ǵLD n:Y}#e0T/EEYsj᢫vl (!M:Th/ eA(gE7F-~(SA|O?ꓕ­̀ϢzDI_ `;/ sbc{ #b& }jGaCBw}K)>kIIp`M:J`+rN}Q,qgCӣh&1,؋MY),W9].՜B[e<ߟiI|/@(|l6].:A{g5͚#J71RJ БFHuJXR!a]*uA}C믙$;$TV 9>t6m}95MF֚p.?!MHJځdleXfɥ,y^H;v_F)aA7ǂ\M;svҜV֜v}R`X@w)rp^F'r2wz-P/Q+Y˃ɨu|As#ިra_>9^z :0' Ao5rQ|d357Z$-̌|-;ZOZr[o W%@H.~v-d7Pն@+F1̄ⷣQdX1aX2p»!,;V>'G2]+ҞrCUu[Ko-e~~)`&9- O`/yɔN iJѹv(pzw-i$X _QZ 6$MnTl׵17U)3uwI6l\9G0Dj%JvVMmP󃡝 RjnIl݉~ &>J-AV6/KoCO^/KpGyM[w{P=`t ?ަf'KpL^(VNN!Wiq"uexb;br~.H6`; PT!!z/2~#N is""u|T8_ hlw&[T ䷟xh{?3.|PHS&^/ @7^j  -:o-I&鉑|5^F%uߦR{g 9"S(OaLԟ'sK7 Oe_2F_Ya+ R@qjW9hnxb!\M,;uLxə`ܤ41T#1z1ï /gf[7Y9R/ ^`1^4SUjxNk-*H8': PRfax۱ө6.EQg͐C; /X~Pxo*HbW;~c;jD+dA+Gv'$1|h]^-SK߇ ldi9TfTWg[\4mMP?!Q/}S A|g2aoU^}.vM("qe,а2?SЕA_F ^dy4M'2,ýlW^һt0L8ā װccM῕"! W t$On$$^x;`O) >"IEu6+*37;zJbMڄ~,΄,E=*`xF Gde`*qo䶆Z>t(#^VL>!8t$C'I".k~KVO}VFY$x\jQO:KAj~XTws_@%^qrQ7wnk-fu+!6XlJ0u5юֺzrHLmRA+lT,Vcl*z>ӹBj`MúK_jq3 >^荟hjN&af[O=aKaJ We+xXN:0F=j)>&\C-! #vea9@`r \udVh'y 0i{Ԁ 5({ҰgtgTZE3΢v|v]t-Vq:(آv U\1k _bX wT+[cK.)NhRp/^5Ia8I#c6KOxdQ+$LuvRצe1mdugy/8Qrֱ"ھuFX1/qLD do]gco^/=NtV%k$.CGN-έG-) U. 5orםX *ʿˡ|'Ş_HaQdv]45b%h3̟T7f3]I;t^\!p:ځ_[PmV I/-LڬUR?J<175zOYf"zԽ֎gMJ ~s:fY sgF,I"賴w dHsVIoEy--+CYÒ 9͚?zUvAm百9[QwTbpvAO3ϕQ yB:S=b{C ^%Fv\Ō] l[$oQD ?!%7?9i5Ud|u=ð M,־0d M)}.H֫D6ODh/WjL#46,LSÚ~3>#W;ȥoeHJݵF3?me_8ZWH՘)Bu嵋UG5@*\z%T0] >yز?bc>\0 $Z.vs^>hZy_s4ZT.+q6E~{Cw}ppQ%THz?׬;|V":N0Z ]eM_6aj*;i[' Qs ;^P63wF̭7Mj혥ٹj%եoMM*$3'"(; z=i+\QF{>{q煝wo-ORj2ZI-$2^ l"!'vݬs iȕ_9q)5;]Ȭ' A]ESa{f \ʰ߸ܔ:FnO0(l,{r;]Os&gcW(vb[hHfH11:[\ojFr aEq]ǕM#FdrBFwSMa೎(\Imc<j' ~ +\ ӫ_[  :}^wH]8╍iH$}~9ЁXۈheY+<[i dAGA1hAMxC vsaǥIFEjml,nl+.f?+L|1ruQHX~vHQJ͇U(m0|~mO||"g rޭ.͇D*Y/0G)-lٜ?y/[2=dbs4ƒj໼p4u*FJq{_SX='d:ٴ!ԦjGDXc.֝x -ރD!+*NNJjjl4u.+¹Um^|Is~f}twJ![4}k**XE A]glk2s}ƵD%_Q0 5c߾QB$z'a] *Fɕ͎@q#4WR y&cOUuFd_uL>ݹKYHh1 '%;pfXhR–_˰}x0x CJ8$j/W׋ Z72LsHT|_>=!8Cmu̫GfU{񊃅7FЇ~px#*חsVB imOlu">!6m`\aR7jy){U*k([K\V/A6A84=奛y=9b_z6SK'c0.2 Hh ^ '^F*:3jn!D<'&9:zyU *x𮯨#@%n'fvw vD5KAPVl'$QDps7ו9(GwW #,{ ԽuDG`a OXcm1jkU.C]|{ '.z\M^k|ɌӬӣpYj7#i#ei+*ļľ@ hnPh}tw&IvZT5w'Zg?t;; ]$<ӂyǨ?2l4XLD#x-4MD1,6SÛ%f\7FA|goiC^%c㧁 dR.0!ʹC%ztO-km}|~ST ~w?8k-͋0݄9#R0a{[[ >u?]_;(]O: uYH4ap_\x=,0AO^$>J&98W^ș+Z3% 2"i1,ó1D£&Yjv2à7٦{E(?WQJİ+iEw MX~86ԝ*0 ?~C{G&>vk֩IRR>/N\`ϔF#X?{ᄍpgLvS\ C/m"y?R+ e_.`+V¤.`Ud:fvXYtg5(} MR |xfxHk{_>EDbKTS!/cp XM e] s wWO5-L20ן~7lF3c xq0 UW,;vtn }c-"-gbp4wl77dsƇsmʑ ~+,gUhQE4؆7Dqʚ0iYXfߌ!J.wۂ]q@ꎓ_8%PLNѮy zl&F;m+M=lU/"t[`;ezx,)48Jv/729\*6r jZqK&Rd%v8]K5> _vlKЧp֮Z>$W%~l? î'SnNΟ0ơ#"6G 8RȁMhC_4 %4]wc-$McqXĴ)HRjHn:16 {e3䁎8BN)A)'ֵaksi|HSo͐ OͧQk/SNw![^9_ћA@|UI@ϵl #ڃ`fb'Ly,X_9H> stream xڌP\ c=vwnCCIݝ ;^s=*1\ko(0 ;'FV&>*+ J_92:h B 4r>9A @vig+;_C @`Ks 'HИXyyv&Fv9#' -$ @db tr4NN|̮LFL - t](lPcBZX:G2sr5 lg  *R{ec9V&W KLL@Fvv3K @AB͉`dg#obdicd 1t#~&`K{'G&GK82fq;S1->X&33\k;_4L,ŔNNv6t3`+=o%_boO{= Bmi|!{:N`g矊EȬSK'1wth ? Y?V_A6dg3k(JQQdpr7ʿo?O HK埽7<@ed1a|vE][zl-mldȁ js倦ζW+d9!"v66Q hhdbw 6v@E_ Gr8B 9QQdcF,bxBΨ)03ف .;oH8"̢7Y70q%~#V߈,A2F $ܿS7b0+F*Y7dPBbX M,!=1+`K oWE?\!Y`#k b[?l/D7@&oIlm(̦BvH ?` ̿y@ \!G oHf.K r3wDOH@F`no"Bbtw\6o=w!cr>~7  03w?XY!!9!OI.?-k650;.2gBwNHŎ@[οl.4Hm- )w c \A8@b8eHοM@?[RGHs8! w~݀& s @JbW1imDZFw{txڊTUH`Ҧ8E'æZXG C^R$F;^O^~ְMT<ٯo]{> VکAy,bW0Ce6K@HH cz;c\:3{ۗYRU6BJBmR+w{ߤxG HgeZ%nş#+b^8BRٍbhOWmUcBc~@M(T% Asg}JJz\cHl ywAtS7<OWUJegێgtd$ ׹T1WU9t*x[t;iu %~29WHt +'腍F L+7v`D ^o茐t.U8=ݩ=>6PYRN>T;Y~ ^ E;ﶘI9+&ϙÒuv;n\lgvpFИۯKtxq/O;`h`-P[M_zI֐Vh46xq6i=ZB^p{?L ̳"/E^j}Efw%?:bΘ&td r^XqwRZIx=EK=: 5J4!_u$>?հm2;ZB_YcZ|yW^ ~ꛇH:Vsכ],̌F%?<&YIi֒~]EkQ7pJYm|3ًveEx;k!Xed l.h "v,>A\ڳ(jzݵYeGBlxxm|cǛFWt49>\@g‰v~< u|tY0:DbXzƀ8?rj}!塜)&x!.*+7;JcnS+8x^ R.ZW@A,uD5+8~O#P: pX8EY˂}֤!T-M|45m=) 54PV<ܞg G6e\kŒf4?SܻcrH~uEq`oT\: _f?Z`XVv,[e#m>ef#uձoHu*C =˾,זX×"8H.5 }.TU(;0V}6ѯ_n3 6}, CWiJXvK2'K _"S;" !c;nwe|!8fIp^`aIm;p. Fs?m|R J5%Q*ܡy< fXU!( Ё'*km-SkhnmUw]n.g:Rڑɾhw=B u N]=IHWS`u,Zx;>둵&,\{G&_~uB5xG9‡o<&.TeamºBbbH ~WQ`Y2ts^|,CŀpJZhWOu%QMBW+5q2Yc5}szKֽ'L4yoHByV-h?Z1!)r\y8F7@Et5[6~%AC::ǎ"Zl2BCcU9P1}u EEydHUv5CU8I{<ʭ2ބTۯ+stXSD&>΍ӒT \{K!4sVqj |9bZdy|')+bӛ&~"n]Ej7a8g>;)x ͌8=6m鎛ZM "bO¦C㺼ikEcO}~P,YU]ݷěReoT#) 3Dr6މ't$?!ݤq$/0Yh6?;\5}j&XjXqSxLAyx9-x[aPIոNkS2{zv a&|-1>E)^nDutt"PtwM^4wHwBƸMsv4"b +\(FlXKJl1~%Kf 1iM*'%W X]'^v0"t bUs$Ji56ss%ZR2:w m7"ʊ#֖7۱hkNc _mFU=tYTQFɨD33Q_%?ӬB[\g$-d n;δ83nץ9LDPűf s̄moO~ كTI2خʪ۫v_äۻ-}6WwI@.t_ܓ7оZ昉pUxYFc%0f)3-3Ͽ4 XhE=W oO7M~TfƔz() %P6#ߵ?Ɵ2~m5R٠e=Ϡݶ[yoGr#Z I.eCxUY-Зj,I pFK;ɉ819[+nnp5;*sis MGښOn2+3kZZAc)n(qWjoBwS7U^W2ny%ھqGN,7-y坰I8[8nI"h{w⼢Й$ 2EqPO%!q0B"9(^O*XKA7C5d_3G"]c˗\3L& iݥ7[$+\KvHelvc/O_: E2d5gv1a gξԶ5CGJAS^}d3tx?$Lkuŷu7Em]f]LQSTw`܇Ptff0RVrƭaaI1 =I@MŖ=y$ 0keބE wIB4X{\Y9X%yD\ΚSZ")̨ 2 zKhqp4!34qzPFu0lbƼQ<=|>%l0 NM/~U(=#0ZF#LXD8uQaᮡhEk7Lt=r7)qr2 F I@P#99^1mXJ0vU@Rs=?,T">jY?=-0v\tb!Ҷ".LaNU̓q[Gw /uK*2a7Lؐ񱋉E+`P Ԉ τ}&Ĺn ~-c眖C3C]gd) ${pdsD@ fqoc2DeD2~Ώ"ߩ>i(}x.KknjF(gy6ʇ\1Wk`_JB/!K;Q~\G3J`X 7w?Lcg ~Xy'@SHxvoB9!X!#" ]"6&9NkT6&1և'jr2jW.44mj+}( w1c3;w u͂{p)v5־&HNz9̍N$S MfJٸ+^.(I6d6ƪV*7:zOGg7 iRQ㽼<_G=i͔#CKN[+j@ȃT"Z )n$q.gBl4$~/=o-V f3^yA z_j_+^MOiUpx#(E k8!MwV.g; ܢڂaVWI32chlQ[[hBD E u\.3C< Y^yu߫f}DSP+dIcSGr˨^SEI.vgx<><>YoK} W0@uT (:b[LP&u.vl&ty$ia-(n|Ӓ*s7[o2BTY9ɂiSJ vBpDQ@/ ]ds?vqJrum'S-ܞE m' A.9:ZyKtN}((Trb.6evwUV {V`Hi-^CKHEqG­ag_dlؚJ`N˕y#;x&lONe-#Sz|wqt Fַ9>R)$ ;7ܭ14!bRLƎP1m7d޶ 5^Tśm#ROr]aĢ=#GB\l/#OkGuIfƓ~ U*hh ץ.gׁ}1/KJďx]ڈi,. S縈}Nq0l6aX{C4~pDxۭBj0n*Kx#Y|JIv}AYy | y2@rdduNFP6y>|';]g caԅj:qM\F Z.no|;EZ [<쇈65,#D}{GB5EմF|"Y$cqP0PCvnHz:mWV} 7.jߚ\)rrTVǀm dDIu.E Yn&JP R b܉|Ms?aBj_]Mb+dp$deɦbuSՑkvV-`U4xph'Pe ~QM\Mvq ,'C߮*E_K&-c;[ƛB9WV8Zc|`uOvTg,7f9\[K[dV9 -I.g' pNF.!g^M٘qocCǭ@TuO(Pe5 Uqn|UPs[f,*WP0?t%9ץ#fG\rg+;p#kLgM7VJmUG'sS۶|*>|]vNܸUGp>@cR0XetY&Wg[cB+F0pv#(p#h}ڼϝF`<;WmV`͆HĜṊRhDUVl76QZNV31hI 8eOe7 Gg6ΝrC/Wr/4pvLB,$E%ǽԺCªD* yi2[/)sstj%ӱ mRZ%Gّ21n`VD'ڠJ*οѽzUusS93MTk+"pMzf*!g ϓc='--%YsK,]c=zF9 lm&)hx A!Z9;fr@=7@y K"9,41=uv 3#6HL8Li>WbpdLxʵπ L K>ڞeYa-;-Sd9yӜ}_zrsOI3+C_ΊCrȠ4=nmU/ MR6[fBW0inHYhz" xӜk5S:(e:4s )O[}fPFӥ8\Gqg0ME]HI]n;:M dGc+i'pj?ELۄȚ fa}(i-&8Lv5.0 -Գ a/tˡ]Gг/+)n[B>Z":˧\~C X7TȖ}{^_h=g1eԣokeDe?Z6q/; &(,˯#3<оG}`W7W𽝄>40|m)6>_jNʌWշ/+Xp%=!k/Dq26a+h^$33Ə~b6!+(Y4R%8r^4~&9J1t!;j_L>iŃ$Ԣ- :,.EEu,~ˤ$շ!ñ]_j I)Kpٯʼnux|(?ld I; 1M"N}.2Zfcv̞ v`iS,@/!/mIU<mq"~?uPP*CQL_4b'/.o-"L61Oɩw4|uX֨:Y zNB-oޭ{C Gy-sKQ[5}+Bʂ8R)b ;w##?St20eA#qu|x.f;~G7/7B#8I'1բ]C+-65~7"h+CݔZN GrΆ=?z8c]妯pckE6}*[ ,A;߬JnjȻ4芆ہA@3%vsn\P{!y1HO.ʍx䐌yY'I;5Bw(g3p=|;>]xr{8@Ɛ(=ЯtE_M7._{7iB; 9 @x}2hÔA)(%FH5a": k<8j.l>ZSyZ (EYI{쭴Fh(iXx-'}_FM1mUh<7Rʏg05x^=6 1:oCըQ}B9i`Ukl&9A7-p k:!sjaLuٴ|u]6 zsG9@\ PJɒjg! 4b,E|LocZ!\Y%ȿ0T#=ۧ`0ĭZ_Ә*}o^TN9ڧ_d82FAS&0V6궹#J:No~u19QnјyYÈ _GB>) (&[F s2ٲZiU>!piZ/(x,:'IΜa9 t`~nk:9yS, ejzx^(!:Ǜ/ u doW5bs]ĕi\&[Ny*B4^фJA.) 6-FeL=`tJQWGn`.Zv޷nA'!Sl0ِ֋N6L&NW3 Ny 8?Cl57^g=WBLr;`%L-׃2eZB :\2Pޕ8#D'bS:pɭ?n|ULd(rk5- s4rA22龻`S.FمQts%T]ç᭡YVILd\1Z(#$M=|娻QCv EsR SBцtJJ = Ă ZXuRyZkcǎIG"gSKectQ)jcHNRsjB] dq㨾Vp3Zh` 3sai*['B)jT/k '~%ߛb3. *K:8Š;̽|I8;= H%fzAeffC|qN#Gk*th0W D.5+*͠rU(T?D28Âe"\Wo5# &C@Õ2Zȼ.y#08H3N3)2Hd6i=J;fRrM ]1u1olƈd\Ki u_k|0FGx 4$>$A%Н(+< 5`" CB1^T;#d}ԙfl4 ;s5={=R1aPyoN Ζ$ёDIB!1Í%s[,Ft$gt3v[Y@,r1N2L#;̶8"͎T5V:/؛Dp?, q GGn^cFF"?( )rӼ~!we$ =MKSxaP#KIDrgŘܿQ}Ѿ^Q4'^3EP?kUE[.T8٪R#I"(^fJ{MOix/~~@$^TA@.hS59w`N]!35)6A{¨ζ'=*ea۷*nqy3%p F_kq'1b$LJ5O\CEWt/މrKBz_yC.{7C+춣5ҍvҜbٸe"<)("xMpy\t}ar]iSe:p@YRh6t89O(ݩv.k[CK-db(ܦ,>s;YXyM,~nX0rMI雄@L $hsWQ_8R^&CS+QbtE@zJa0&"z60,:Ϥ&ӯ髍h#{i0ao `([#ųR]]4uWJp]G,NY6=糕V2v<^Ś]I׊pv9>d"B%/B<2h+n).o*yՒᅌ% @>-)OUb^ 8ПcT>ƷL!~Y(R[֠r$' ⎥Uy~ΊO E3P;IJ!U[6\sW5xTiWg*hKd$¤o`ĸ)I`ͣSQ`Qy6-]i*Yᚤʉ΂ e0v@ 9WLpWkoLf*AD%ĘfPn\4+Eɗw¹Rn]!ēZ,!:01ewWRo{_Egn/tud)G֣vIOA|+:X&IO*-#8GbӈK=8h]\4%}/AHqi\I @9q< د[? ]L“` .Hٿt>s\"9|A%~#e!}{5]>M#fIXfS_(Y;}]cؿ‡nnΛC6 @ł ¬F^Hb}=m)E@>ס%|3"7@ϴɫ. |QQ{j` GA)I1DjQ7L$Lz'HaLj6\}=sR~<)ʳH&bN;txiK6ׁ%K2׽Q}ӷȺ`j"B$7/Gٸtv`9gdv[Y\t]e4p?7Bbi2q@qI$6ZSwoboa@A2i[r Q9=5(\$'vm )) Ev!vu&q钳o,>^)0n"`F(NK а{Pxuly,zL}ݎJvg%!P5fO\H)˹[>4Jt)1l[\`]3MÛ\u{ޖNo^8++4);~%.뵾=ṬS`"'pշ^ŤE[w/ ׄ=0Nv1=W?PdH+x{+n|uخ5=Fg--Ef8MK,\'}!knZeMCgo"|"X.?T|;ߒU[_b: `e\Qc{!rY/P5{R6;?U56U V+$.YQ"%n+.S#O "adTo\UOtdڕAq ɴu*3ACasJ4׮->R7%=ݖFE* =5 ビ Viwc|^ \`hJr)RƺLFF_'牥2ҽ- u;DlAZJf3ry|x!I)q U_'R2DY;3 _6ӏx38bԈE.D1U=5II}Ipcf= 2H,%R0!]O>fjVBhz4v^"-kVRQL$d.Ѱ6^j<]Sn~ϩ( ԚEwy)Dwg672[taXFh endstream endobj 61 0 obj << /Length1 1480 /Length2 2231 /Length3 0 /Length 3173 /Filter /FlateDecode >> stream xڍT 8TN$Q qbŒ=R1s\̘Ō䟭"E(H YJR )-ZDh.ig=;Hg7Ms2a9X$c Fh!HwCHņt,ȁ}VD $0=`!V0@"@dt@Z2,ȟʁxTIj@Oc>0YHD ;4A@N%Tx(b`iH"1Dz(D( l(9 f"D#s3\& &bC925[ɖ a#g@|RUFJ\HPֱщűގʹ94KZuOlޚck=;J߹+CO6zz J[K4ɾW&'= b)8L2>X*b^YxmD\4m]w^iE^2iB*^|rz¤?&5u (E&VUŎ+Kg: Sx(by%2Zr󅜚3otETݻP,Eg8fJXgAOIn O^غZryoaڗ/˞H3 vDre.WN`E#'JB=_NIE!2/|V~j]b~DFJ#~p},qG8IbXdt=ln󺤽#*(ʯ Eu=C)6ej!]ْ_jn"Fw;ĢTsF{ O]3NUD%U_̋.Vy1 {bfVIb@(#a[V&[_5Z>cQA[9aq#t$tz+j-E$>ROl}}u/_`vbW{=)(X gl-]A۪kgVе)_͚#^Cߎ;H@} ?/oڶ.;yYm"/mY$${iodךZM12-WpluDD`Åĵ9LjRoi e{ס;R0beVnړQn *Yx-%}}' sǦ;Wb+]W b|F*6$VꂂĴvIz,hVrQӽb_."SD^J<*w)Jlḱw_ db35+qOf@h59埻U/f?JN <N(x7S&6rC=v#g7z@q_^dShrԲ}K=ǎ'h6םi &DkXsox@3I_x^{h*k(2wҳ l XV5y/vDtf|Hu{#5^"C% Vhȫ:jڰنQVH1rt )G}-.w ˋ=,!xĚ>!Y8Q7=dG6BV`ghV-_,ZT$ڿDv(Җk'䦣_D4=X,n%mu1܇Rwy)/3iB|X/F60ѿ4JaIYd٬v%ȮQDWB{#ExE<0qU5Hm+& "Z55A.SWG${pθ?wİzd6$t$`R|ܣ`C2*}׊jpǝPԒFF#"R_5)ٔۼbcR̮Uқn-[!3ڼPPWH@]E6wls\MSѧhEKd"x~>SGvDb endstream endobj 63 0 obj << /Length1 725 /Length2 16161 /Length3 0 /Length 16663 /Filter /FlateDecode >> stream xlc.]-\ze۶m۶mۮe۶˶97g2XcȘ3V&)#-#@YLE@ CF&djbio'bbP75(:L 0da{O'Ks 1տ5CK[K'Mٕɕ$eSS) ,))'Sڙ:\l,2ƦvΦT3{'09?̜m*br*Qaza @Ft;gM]\_l W2_N`&.#SsK;&igf`\r&fDښ(m\]L&NvqdB m-m<O?dڙCLb& .jF?pϩxʿףQ"[N&k[??XW5tqh3D=iXlFfVF35vur2s71ƪ1wUzkXh|8**#L6尅5΃ N;\ɇbxSUR*s; z7`jضr`.A ,yyc *:v֗ĩt)P~Lhj-Bn7@ nɰ-*µ 5%0Evwݪㆷ!2Wt G!oywe syTwyY|#^fu(\f)twEa`l6W\d'9&Q+-O1ۣo΋>ym )e@l]ځmڝAK%U2=1['",ݚκpv8R [2g5 y &\5_Ү#K\TEzW<2ҷJ5< UxKʠzS!O,>8c;Oz^W/MrBFN*A81u_oݭ2̽췸ڪDP0 !e 3-GK^eGqsGx^䀍^R\D K$}u󾃬?FDsuVw(BVŏbqz6+?1w~*eM^n@wתJ.ޖD:cqtzgz -U<8#)-{íAi\y-!wY}ɖX7nkK Fvg(KI N94ġBFhvvyRC8EWW2?c}aagQxb]c~E990RFD4>:+=(s qwtUm[<8"\cX`FyCrPܪsmgSiTB'vk?q';-4^ܑ&l dr1CwDwPڋ.hutJ9Ro,eE Em\9͕Z%W OIo=2=Qg9'>cn G `1L7~&96zv3CCHl ȊFg-N"}РQDU*eԢB~Jmp!%+NIiAnWO%iwI0[9^<91N/ʏ,[<,gScjEj=Z9]= Ͳcsg呇Vz 9ۋoضUK(j0p0%$9uyV |ė֙2P)M:bswmc=N̩@^t{#2FF,8$Y;(>.A>I#ūN9_L}T(qGMhѧYu۷k^م|:u,RNoXXgQdt8|cAt${ A]c -(*n&@rwaP[O+o2\7:^uaBߘR2ͭt ܪ 5ߚ#S?j7L$IK3;SAsaɃ!fES%p3iid6aKu0U˙Yg*.MR?g&O'2sʻ!A]icԸ!Ʊ${r:\i_@torڏ&cf"쑫~5']>oF(G #C+_o&װ-9n ]LͫJ^]:$4{+]^$ +ug!guCK6I3(hցAzk~jp{G*TvJ@olR'תyN&x41q@L8 4\ڠ}C$`agY$ p{lr>֫-ҩbPL;&,^Up$cu K0JMȓig4ÚoR W?hY/[Ь&UOxOkh!=P7GeûQt.>ԕgd!P\ -@?' OP_v@HH:eY,P+{P?aM|}P+jo e[ BW3f!83Ecs^ʊ,RMr?%ˠiQw'X7zwMStBufNH6G[.(fVAng*~afɦ !ƨ;EuKoUH BCp,eZoy DODeAcCCf&T= @L>`';ͩ^7n45߹&.gt@[O ق&(DSDIP*:LB}eJܕdƯ*Hehq՚[pPe(=hejP'/ [XR@0'd}>,-BΉ{p3_tc.L[=ڣx!q :U >mx&܂EC)tk2U[-zaZ(k2nT 4^w%3K3̉{4!kjJ"nۦp2qo`k/?zH.T"*=2c4q&x2SOCb^Bq$t&ʃAZ̻N_,V/ty4~>2L+/{sRJ&/MK%/۳GBfKq)*XϪkGK8][LY/W~M>T^1gޟ!ø s$Ï22g"v|˔H 瘡܂YB$\ZXAs× pec(D g"Rmg۵J3 8+{KԒ~ O^FǓ::%*{bJw܂!.)O2~k{14f܋qy\'Zj*N:jnNelZ&VdC)tRޚh{fNLjܷ/B&a68={UXY q@F\ys\qa]sޞWihvP?9r@8K#=s?U3a3uA4<+dډB>'c8XTOPŀ14"c캱o kG@,K/t[*, W b͏KkvL-%DHqRe[]&sQr> thO&)U޸Fnsm4#GT.Ljkܑ/w%&"]#:F~$ o1 Uٓ_'`- AJl}~V|x.8슴vh/@Lq{E\V|HA[tsMf%0e65VxW P ^]g3!3źt r;NNjNFV[`Q Z,o1n0b>a?PtRձ%H坫}] ϫH.(9&o@K Sj<_$q_g!sI8nⅣRcf2+DT @*O"ѿFo!p6ST^”J:Ϙ4M88 ~M9|<1A F'h&r\S#K #޸jz^cY9ҝ,|=OB^0T!eq_"S4]ίSNdk8 !EBth㯎 ۪?0Gד-1t`,x្d;<$?65l\k<ۂ.c,L¿_?˱eӼSk/Rzs@Ҥ*H{u^2Е=m\Noµ--$R}ǒYxNHdRrlЃ]uaе!8&MQ,[ߜ3/}3)M65H"RvE$71IΟ6;7u][H} z!Mփ;H]_WQ@+OrjPU 1Re\Èe]qTдϟ*8WkaoM|DsDE8,{SPq=+:ÅmĚ~ö'ttMh,@_~ud[p *Ga3wP887;S޿FR`> LF헣正e!=.e_ yVRdxoqV}7P4P^vmt!ƥsMQL.6rYb[9^=xǪmeAqJP@CcXI`VqMv1΁;KZ52a$U[9G׆qN`F^䎥Th?:;n<9Ļ a& j$!d2jԇaZ,G)EL c kpIb(&{2":$<Ņ/ `r&_Q-l|tu{hf۪=.|pԶ*|U.# 0u臜bI>9G@'2;xˢd2z|*QabSUgM^Ò{Tp]1@AުiuXpٟ'?M-lwK!+gB1?LcJ,hƙ+B#^^.Iv]LO֟|Wa]}_H 7㖲5܏XV^P^ C{xt'ܳYb] m-Zrn7c]{Dj`O/X/~[-m'.s Gl]z(SriЮA̚Ź21\,fg~ⶤxb~6N*PY0'uU%|O QpϘ`=3h'Gj9ރ#6&H^Rݘ]t> æb`6  'nYL^55ӈQ:]ҍ֢L=r2,mf\ҷOړ,Ncyb"CHnpԛpqnaoUrsK+,-R Z-gohG=Bv!-ߔ/FZ>yo:ird,mO]Q&ri?1I bRI\Iłx5Ʒ)n.6j}%&4s6Bf'~UoCyLtR9lՠQ 12^˸,߈g SbJcv/)w 7pmA÷f&A.Ye#.'0&MBа,ƑkIne_Bˠy%W^q7 |L%*{meu RERxIfLsû块e[VxޗTOtk RtuY ATBj18O^S"9L__[)jYbM}V˹`W}X-f{aϺ\jͶbْnjϬTӚ|6o|cO%x!|ǹR$[tH*_~@e*"`;I KT>B`5IwlRz7dRDM8ږ17]fA!AĄ#NEH C#F/f`t ^>?ɓ\N"v x."r]U6vG;ԘmbaMY0(Nks9iE;^I(y)[ % q줦 e\yT]{xҊz]ن=_yB~܄e%Wj#$;"ߋs-jӽ@lLbl挵8h e?{_I |s^x/4rf;vEO_|_P]MH'3ZT@0K3';KyBNWtwC<;HXih/A)yc: gBT_&/#jxJMEw/F(h Rf#yYIrZvV^*+PivLǣIx y= ,r[Co3M#&F-}T*KM^45QjRЌE<;O'r[FpO{؄qfIHPDV&ErwQ<s#3cBuz9=s-7D~Q!V%m%s=N]4h52zxOĔ)S jK_8rFqZ_t[-%F݉dy˝>1 лUƷav$zjoĺn$"1h}95 #R]<32"%c#׵P~>4+k^-WY(gjNB%^oZ+?'鳯AB@t`cz.4;,>TT=x|;nl g$lY/1e{=xr_İ%9<}&%{lre1<7i4ʎUďs]Y.6\zD8̄ yn:'!͖EGѻX5:El.'KJ1j"Kc.a[uMk,G Yb^b7Gm8Ub f 9Ԏ|; w<~$ [V%ȑ~hnQ.A $yݱjeMkM?/xۻH~8кH,V808~>:A]R)78WNWBh4r7X }AM?:Ug-3vb@zv5XDPT'|K{kZIlGr&v1K⅞%!pVq3(xT[gu~G! <̨ys6uF2$ ȗk!3fpjUE_vTPԊ>~AW> ā;돉c[ǹr>1%lc:k dN@B8NpT@eq'x%sfw-G#P'q!ZfA  :d9w)K_s!-++,2{s3 Ԇ8lm=+}B>{ZoV`DKA#L9&%[V/5muC@-&]%%bgc1Yfc?ي+,)3(e7}.ʳqQN{kr}j.6GլҏGݟuDŽr!'S ٯqx,q͂=)ioyA<اxۂC]aU+˖}HJ&Ø\4u_w߿\v0uiwZ0zm85u\l2mَiđ58ȩ9R{ySTm+Z^9Ow򴥉2f+һb]obͦ>%] 2R5X3%z󙮴0)^\M]@S3=,Cro3tá٘ߐA3t<ȁh")gxB0~Or:,R*bD{srF͵ڍ&[I ,P\HWե֝]x/G} Zm|j r"'rQbⲄTA̜hq1OeYr^5Vط#Gd.tk׸tw">,Z,9'#d, cddGVOYJ˅Ey٣ptK 5m3}C-#Mi)EK³{ L,PӶI =D- ``Xx6>!LF]YQ23<`l ga:e`}3+o"}/FtR6vZ 8WGY:S6-07,%Ke2au?,V؞:i\K{Np&awN}sG$][8*8#yif\ji>WN/_g?ҁ3<aio?XMİDrc)@ zl}Ob؎ [؂SцͷN)=%h$]m=a,M]DK*E:! [yMKԸFd$F\ 1 0aYu6߁"W+zs &ۃUᴍ&5zٯKcuq+AuͩdDJ#A<:6'ZW 8705gnHN>4x[ yN-_d Gk&Q.|[K$l${"*5!qSNKOeKk׭1>cll!2 d398)-e-9x[Yz5(@_ɜL} 7Q`syl-wJw 6"/hGA/@Òάo=4Wt c?~;}ت뤍=3EAlq%~ ˡ2hA:S=$9d\`>\IUf}X(ŵA13eA0%Kcu5]Q}\{ث6ș1 WkXKjm__ޡ$fkD?m 7e. >`.}U8Fai!apww8h’ާK sRyXlu%fr~!.U-qIr] ro񻮊 #MX,1^  ʺg45WcFQ-JXܐ7z Fᚢ ƁzlV=x҄X/[!Skrw~N]8UDCcg\kr"z)[Ml{M]%iTxFL@r괛j5 W֫{y c[=g#m %;ۥWsF-T(t\Ae/A<s$QO IGQQ'H+Ri8aM]>):wvVE#GKڎ&&dH@V{"qù@Cw ;N"1= Dm֮{kavzY ~JDlCiK* ?ـ" }%Yto=$ ^o]7U9|2oZƒ >˚_X))ˠ h0$P}:/7w-!i/IbTV!)?@DLlrنb@G<CSU v(FbQ tmPGE^'?/fރy+?^+Q*zw]4h-~t+9ݮ[ zpn3j"5Y(S,kvmu9#X ä9À \#HYd5HDbԿԣhL`y"*iH34e)<Δ Zn(}?E;7_U{w]>[-Μ~c~)Lz>3> 6?/P}pMv\ hu,'%Be_$nJ' 'mer 5:FH@fOIhYHy)lM\-$LCi0:=s`+4ӈCz%v΀oJLMn:rpkP,}~͸eeWPv5c{D&[7硼fs刀~q~c}}*y-7-jv8⢜LyOvUKF+h>wyShQPeP}m?ҟ\AIAv[B$=#Cfׅ\gH{=:&Fӄ?X[_L8RU."`kF#'Da&[|U 4ץkdM}AM 4+"%[j;c;5 jQXlS(nfwZցgw aYL6ZU̢Upܱ/Ęc}b&Dqy{ 粖?m7?ඹe^ҿ9D(.j竼T9o6-,}H2SL((eMU+qQ6TGp4CPEp MA!YAEW#:PMg ] :OCnV:W=L ~9DnSt4hVU/& pE?˝i4#[K j=4> endobj 12 0 obj << /Type /ObjStm /N 47 /First 356 /Length 2584 /Filter /FlateDecode >> stream xZ[o~ׯEAP8u4i ?-D3KI$%%VS;3;셴$ wD2I'JvD{O"N&^P3`@!X \P 2DjP@:ƈ>c 3DW=qD(+Id(Ii>CDh T+=r #F<#Trn8b5CL$jу& 0؅DX$qF``ҫW=zez=ȧU:J=O|^ <:ަ,?k bơ|d W=81`/`J] :HgE>H+r 3?<"2\&qӵ0H*˧I% [&xVeVrN>ݼͫ|H}ї/j]9vh M=k2A2 ?a6&U єs:~Ll 8̸kz|pC"R7 % (n9^eӽiȇ] p_!$K 8ϫtށ#,ˌ1`^tn~U6t |Jox`H2'0eV4-@7dy?b>'|>AY2Ho6w3N榘tOhk,RtcuQt2; l,ZnLtsm k!$ـZsӷ7kixSN?CԝéD뾩K''>N*C1L@3.YU%q ⛴6MlO"JU؃YpN,V 0TD74x,rb_[KGk: إzWvk z{SQB#L/ʋiPeL@xb5K=^9tPނ'F)3/~!.䎵&R(5AcSBȎX4mzrlD+B{u;v9AjUBx5LAFzY\R1֝ *#DmTye=PڀWiԻVifM]7codžeOE=r9Ej}ӤFb=uX\ӌ6)PKtf[:Up^êAV_#wThGC²>%6f,c=؎ZqvhXqu67֣?Z:2j3 и $D6|.KVB=M4i/“|m{[^Xƞ0nJ<pVP%F JS.pW]~5ڊCDc 0}Րr1E ʠ[b{E.#[2W. Y d)žVkGyqd-[`j\J1lhZkQR5ܤ.0bi 'tc}IKig P: Ýa@*Y^+ F6B]쉒3a]$kcc[b_m $4ț'iQf%lEn endstream endobj 67 0 obj << /Type /XRef /Index [0 68] /Size 68 /W [1 3 1] /Root 65 0 R /Info 66 0 R /ID [ ] /Length 185 /Filter /FlateDecode >> stream x%9AQnyy{Pv ـDN.6H SE|{K/Q H W EOt@MEPxǵ[_x#|/DlmO"D[\ĈfR$fGDZdDVD^DQhfU!o*qZՈªN9ߚ!g"O/ w? endstream endobj startxref 128272 %%EOF pbkrtest/NAMESPACE0000644000175100001440000000462012632737264013363 0ustar hornikusersexportPattern("^[^\\.]") import(lme4) importFrom(MASS, ginv) importFrom(parallel, clusterCall, clusterExport, clusterSetRNGStream) importClassesFrom(Matrix, Matrix) importFrom(Matrix, Matrix, sparseMatrix, rankMatrix) importMethodsFrom(Matrix, t, isSymmetric, "%*%", solve, diag, chol, chol2inv, forceSymmetric, "*") importFrom("graphics", "abline", "legend", "lines", "plot") importFrom("methods", "as", "is") importFrom("stats", "as.formula", "family", "formula", "getCall", "logLik", "model.matrix", "pchisq", "pf", "pgamma", "printCoefmat", "quantile", "simulate", "terms", "update", "update.formula", "var", "vcov") if(getRversion() >= "3.3.0") importFrom("stats", "sigma") S3method( getLRT, mer ) S3method( get_SigmaG, mer ) S3method( KRmodcomp_init, mer ) S3method( KRmodcomp, mer ) S3method( model2restrictionMatrix, mer ) S3method( PBmodcomp, mer ) S3method( PBrefdist, mer ) S3method( restrictionMatrix2model, mer ) S3method( vcovAdj, mer ) S3method( as.data.frame, XXmodcomp ) S3method( get_ddf_Lb, lmerMod ) S3method( get_Lb_ddf, lmerMod ) S3method( getLRT, lm ) S3method( getLRT, merMod ) S3method( get_SigmaG, lmerMod ) S3method( KRmodcomp_init, lmerMod ) S3method( KRmodcomp, lmerMod ) S3method( model2restrictionMatrix, lm ) S3method( model2restrictionMatrix, merMod ) S3method( PBmodcomp, lm ) S3method( PBmodcomp, merMod ) S3method( PBrefdist, lm ) S3method( PBrefdist, merMod ) S3method( plot, PBmodcomp ) S3method( print, KRmodcomp ) S3method( print, PBmodcomp ) S3method( print, summaryPB ) S3method( restrictionMatrix2model, lm ) S3method( restrictionMatrix2model, merMod ) S3method( summary, KRmodcomp ) S3method( summary, PBmodcomp ) S3method( vcovAdj, lmerMod ) pbkrtest/data/0000755000175100001440000000000012652165060013042 5ustar hornikuserspbkrtest/data/budworm.txt.gz0000644000175100001440000000016212652165060015700 0ustar hornikusers]1 S!N L6C__jc(cky9cfZ_"fI^-9C%#}.fޒ.XE]YIܕpbkrtest/data/beets.txt.gz0000644000175100001440000000041312652165060015322 0ustar hornikusers}I0 E8Sr&Qܞ8MOlv}s,ޗ#=Ma 7okA| :@]Bڠǡ lue 6[:)00@ -%:5D5]8[TVD$ĉх~]~-")؜& Ũ-.+ ҍ:4|:2zIiE[VБӺ7CUr/S"pbkrtest/R/0000755000175100001440000000000012652165060012332 5ustar hornikuserspbkrtest/R/get_ddf_Lb.R0000644000175100001440000001164512643433712014477 0ustar hornikusersget_ddf_Lb <- function(object, Lcoef){ UseMethod("get_ddf_Lb") } get_ddf_Lb.lmerMod <- function(object, Lcoef){ ddf_Lb(vcovAdj(object), Lcoef, vcov(object)) } ddf_Lb <- function(VVa, Lcoef, VV0=VVa){ .spur = function(U){ sum(diag(U)) } .divZero = function(x,y,tol=1e-14){ ## ratio x/y is set to 1 if both |x| and |y| are below tol x.y = if( abs(x)0) #' } LRTstat <- getLRT(largeModel, smallModel) ans <- .finalizePB(LRTstat, ref) .padPB( ans, LRTstat, ref, f.large, f.small) } .padPB <- function(ans, LRTstat, ref, f.large, f.small){ ans$LRTstat <- LRTstat ans$ref <- ref ans$f.large <- f.large ans$f.small <- f.small ans } PBmodcomp.lm <- function(largeModel, smallModel, nsim=1000, ref=NULL, seed=NULL, cl=NULL, details=0){ ok.fam <- c("binomial","gaussian","Gamma","inverse.gaussian","poisson") f.large <- formula(largeModel) attributes(f.large) <- NULL if (inherits(smallModel, c("Matrix", "matrix"))){ f.small <- smallModel smallModel <- restrictionMatrix2model(largeModel, smallModel) } else { f.small <- formula(smallModel) attributes(f.small) <- NULL } if (!all.equal((fam.l <- family(largeModel)), (fam.s <- family(smallModel)))) stop("Models do not have identical identical family\n") if (!(fam.l$family %in% ok.fam)){ stop(sprintf("family must be of type %s", toString(ok.fam))) } if (is.null(ref)){ ref <- PBrefdist(largeModel, smallModel, nsim=nsim, seed=seed, cl=cl, details=details) } LRTstat <- getLRT(largeModel, smallModel) ans <- .finalizePB(LRTstat, ref) .padPB( ans, LRTstat, ref, f.large, f.small) } .finalizePB <- function(LRTstat, ref){ tobs <- unname(LRTstat[1]) ndf <- unname(LRTstat[2]) refpos <- ref[ref>0] nsim <- length(ref) npos <- length(refpos) ##cat(sprintf("EE=%f VV=%f\n", EE, VV)) p.chi <- 1-pchisq(tobs, df=ndf) ## Direct computation of tail probability n.extreme <- sum(tobs < refpos) p.PB <- (1+n.extreme) / (1+npos) test = list( LRT = c(stat=tobs, df=ndf, p.value=p.chi), PBtest = c(stat=tobs, df=NA, p.value=p.PB)) test <- as.data.frame(do.call(rbind, test)) ans <- list(test=test, type="X2test", samples=c(nsim=nsim, npos=npos), n.extreme=n.extreme, ctime=attr(ref,"ctime")) class(ans) <- c("PBmodcomp") ans } .summarizePB <- function(LRTstat, ref){ tobs <- unname(LRTstat[1]) ndf <- unname(LRTstat[2]) refpos <- ref[ref>0] nsim <- length(ref) npos <- length(refpos) EE <- mean(refpos) VV <- var(refpos) ##cat(sprintf("EE=%f VV=%f\n", EE, VV)) p.chi <- 1-pchisq(tobs, df=ndf) ## Direct computation of tail probability n.extreme <- sum(tobs < refpos) ##p.PB <- n.extreme / npos p.PB <- (1+n.extreme) / (1+npos) p.PB.all <- (1+n.extreme) / (1+nsim) se <- round(sqrt(p.PB*(1-p.PB)/npos),4) ci <- round(c(-1.96, 1.96)*se + p.PB,4) ## Kernel density estimate ##dd <- density(ref) ##p.KD <- sum(dd$y[dd$x>=tobs])/sum(dd$y) ## Bartlett correction - X2 distribution BCstat <- ndf * tobs/EE ##cat(sprintf("BCval=%f\n", ndf/EE)) p.BC <- 1-pchisq(BCstat,df=ndf) ## Fit to gamma distribution scale <- VV/EE shape <- EE^2/VV p.Ga <- 1-pgamma(tobs, shape=shape, scale=scale) ## Fit T/d to F-distribution (1. moment) ## FIXME: Think the formula is 2*EE/(EE-1) ##ddf <- 2*EE/(EE-ndf) ddf <- 2*EE/(EE-1) Fobs <- tobs/ndf if (ddf>0) p.FF <- 1-pf(Fobs, df1=ndf, df2=ddf) else p.FF <- NA ## Fit T/d to F-distribution (1. AND 2. moment) #' EE2 <- EE/ndf #' VV2 <- VV/ndf^2 #' rho <- VV2/(2*EE2^2) #' ddf2 <- 4 + (ndf+2)/(rho*ndf-1) #' lam2 <- (ddf/EE2*(ddf-2)) #' Fobs2 <- lam2 * tobs/ndf #' if (ddf2>0) #' p.FF2 <- 1-pf(Fobs2, df1=ndf, df2=ddf2) #' else #' p.FF2 <- NA #' cat(sprintf("PB: EE=%f, ndf=%f VV=%f, ddf=%f\n", EE, ndf, VV, ddf)) test = list( PBtest = c(stat=tobs, df=NA, ddf=NA, p.value=p.PB), Gamma = c(stat=tobs, df=NA, ddf=NA, p.value=p.Ga), Bartlett = c(stat=BCstat, df=ndf, ddf=NA, p.value=p.BC), F = c(stat=Fobs, df=ndf, ddf=ddf, p.value=p.FF), LRT = c(stat=tobs, df=ndf, ddf=NA, p.value=p.chi) ) ## PBkd = c(stat=tobs, df=NA, ddf=NA, p.value=p.KD), ##F2 = c(stat=Fobs2, df=ndf, ddf=ddf2, p.value=p.FF2), #, #PBtest.all = c(stat=tobs, df=NA, ddf=NA, p.value=p.PB.all), #Bartlett.all = c(stat=BCstat.all, df=ndf, ddf=NA, p.value=p.BC.all) ##F2 = c(stat=Fobs2, df=ndf, p.value=p.FF2, ddf=ddf2) test <- as.data.frame(do.call(rbind, test)) ans <- list(test=test, type="X2test", moment = c(mean=EE, var=VV), samples= c(nsim=nsim, npos=npos), gamma = c(scale=scale, shape=shape), ref = ref, ci = ci, se = se, n.extreme = n.extreme, ctime = attr(ref, "ctime") ) class(ans) <- c("PBmodcomp") ans } ## rho <- VV/(2*EE^2) ## ddf2 <- (ndf*(4*rho+1) - 2)/(rho*ndf-1) ## lam2 <- (ddf/(ddf-2))/(EE/ndf) ## cat(sprintf("EE=%f, VV=%f, rho=%f, lam2=%f\n", ## EE, VV, rho, lam2)) ## ddf2 <- 4 + (ndf+2)/(rho*ndf-1) ## Fobs2 <- lam2 * tobs/ndf ## if (ddf2>0) ## p.FF2 <- 1-pf(Fobs2, df1=ndf, df2=ddf2) ## else ## p.FF2 <- NA ### ########################################################### ### ### Utilities ### ### ########################################################### .PBcommon <- function(x){ cat(sprintf("Parametric bootstrap test; ")) if (!is.null((zz<- x$ctime))){ cat(sprintf("time: %.2f sec; ", round(zz,2))) } if (!is.null((sam <- x$samples))){ cat(sprintf("samples: %d extremes: %d;", sam[1], x$n.extreme)) } cat("\n") if (!is.null((sam <- x$samples))){ if (sam[2]0) ## p.FF2 <- 1-pf(Fobs2, df1=ndf, df2=ddf2) ## else ## p.FF2 <- NA pbkrtest/R/KR-utils.R0000644000175100001440000000326612643434000014127 0ustar hornikusers.makeSparse<-function(X) { X <- as.matrix( X ) w <- cbind( c(row(X)), c(col(X)), c(X)) w <- w[ abs( w[,3] ) > 1e-16, ,drop = FALSE] Y <- sparseMatrix( w[,1], w[,2], x=w[,3], dims=dim(X)) } ##if A is a N x N matrix A[i,j] ## and R=c(A[1,1],A[1,2]...A[1,n],A[2,1]..A[2,n],, A[n,n] ## A[i,j]=R[r] .ij2r<-function(i,j,N) (i-1)*N+j .indexSymmat2vec <- function(i,j,N) { ## S[i,j] symetric N times N matrix ## r the vector of upper triangular element in row major order: ## r= c(S[1,1],S[1,2]...,S[1,j], S[1,N], S[2,2],...S[N,N] ##Result: k: index of k-th element of r k <-if (i<=j) { (i-1)*(N-i/2)+j } else { (j-1)*(N-j/2)+i } } .indexVec2Symmat<-function(k,N) { ## inverse of indexSymmat2vec ## result: index pair (i,j) with i>=j ## k: element in the vector of upper triangular elements ## example: N=3: k=1 -> (1,1), k=2 -> (1,2), k=3 -> (1,3), k=4 -> (2,2) aa <- cumsum(N:1) aaLow <- c(0,aa[-length(aa)]) i <- which( aaLow={Bb| b in Lb=0} ## if (!is.matrix(L)) ## L <- matrix(L, nrow=1) if ( !inherits(L, c("matrix", "Matrix")) ) L <- matrix(L, nrow=1) L <- as(L, "matrix") if ( ncol(B) != ncol(L) ) { print(c( ncol(B), ncol(L) )) stop('Number of columns of B and L not equal \n') } A <- B %*% .orthComplement(t(L)) A } .restrictionMatrixBA<-function(B,A) { ## in ## determine L such that ={Bb| b in Lb=0} d <- rankMatrix(cbind(A,B)) - rankMatrix(B) if (d > 0) { stop('Error: not subspace of \n') } Q <- qr.Q(qr(cbind(A,B))) Q2 <- Q[,(rankMatrix(A)+1):rankMatrix(B)] L <- t(Q2) %*% B ##make rows of L2 orthogonal L <-t(qr.Q(qr(t(L)))) L } .model2restrictionMatrix <- function (largeModel, smallModel) { L <- if(is.matrix(smallModel)) { ## ensures that L is of full row rank: LL <- smallModel q <- rankMatrix(LL) if (q < nrow(LL) ){ t(qr.Q(qr(t(LL)))[,1:qr(LL)$rank]) } else { smallModel } } else { #smallModel is mer model .restrictionMatrixBA(getME(largeModel,'X'), getME(smallModel,'X')) } L<-.makeSparse(L) L } model2restrictionMatrix <- function (largeModel, smallModel) { UseMethod("model2restrictionMatrix") } model2restrictionMatrix.merMod <- model2restrictionMatrix.mer <- function (largeModel, smallModel) { L <- if(is.matrix(smallModel)) { ## ensures that L is of full row rank: LL <- smallModel q <- rankMatrix(LL) if (q < nrow(LL) ){ t(qr.Q(qr(t(LL)))[,1:qr(LL)$rank]) } else { smallModel } } else { #smallModel is mer model .restrictionMatrixBA(getME(largeModel,'X'), getME(smallModel,'X')) } L<-.makeSparse(L) L } model2restrictionMatrix.lm <- function (largeModel, smallModel) { L <- if(is.matrix(smallModel)) { ## ensures that L is of full row rank: LL <- smallModel q <- rankMatrix(LL) if (q < nrow(LL) ){ t(qr.Q(qr(t(LL)))[,1:qr(LL)$rank]) } else { smallModel } } else { #smallModel is mer model .restrictionMatrixBA(model.matrix( largeModel ), model.matrix( smallModel )) } L<-.makeSparse(L) L } .formula2list <- function(form){ lhs <- form[[2]] tt <- terms(form) tl <- attr(tt, "term.labels") r.idx <- grep("\\|", tl) if (length(r.idx)){ rane <- paste("(", tl[r.idx], ")") f.idx <- (1:length(tl))[-r.idx] if (length(f.idx)) fixe <- tl[f.idx] else fixe <- NULL } else { rane <- NULL fixe <- tl } ans <- list(lhs=deparse(lhs), rhs.fix=fixe, rhs.ran=rane) ans } restrictionMatrix2model <- function(largeModel, LL){ UseMethod("restrictionMatrix2model") } restrictionMatrix2model.merMod <- restrictionMatrix2model.mer <- function(largeModel, LL){ XX.lg <- getME(largeModel, "X") form <- as.formula(formula(largeModel)) attributes(XX.lg)[-1] <- NULL XX.sm <- .restrictedModelMatrix(XX.lg, LL) ncX.sm <- ncol(XX.sm) colnames(XX.sm) <- paste(".X", 1:ncX.sm, sep='') rhs.fix2 <- paste(".X", 1:ncX.sm, sep='', collapse="+") fff <- .formula2list(form) new.formula <- as.formula(paste(fff$lhs, "~ -1+", rhs.fix2, "+", fff$rhs.ran)) new.data <- cbind(XX.sm, eval(largeModel@call$data)) ## ans <- lmer(eval(new.formula), data=new.data, REML=getME(largeModel, "is_REML")) ans <- update(largeModel, eval(new.formula), data=new.data) ans } restrictionMatrix2model.lm <- function(largeModel, LL){ form <- as.formula(formula(largeModel)) XX.lg <- model.matrix(largeModel) attributes(XX.lg)[-1] <- NULL XX.sm <- zapsmall( .restrictedModelMatrix(XX.lg, LL) ) ncX.sm <- ncol(XX.sm) colnames(XX.sm) <- paste(".X", 1:ncX.sm, sep='') rhs.fix2 <- paste(".X", 1:ncX.sm, sep='', collapse="+") fff <- .formula2list(form) new.formula <- as.formula(paste(fff$lhs, "~ -1+", rhs.fix2)) new.data <- as.data.frame(cbind(XX.sm, eval(largeModel$model))) #print(new.data) ans <- update(largeModel, eval(new.formula), data=new.data) ans } pbkrtest/R/PB-anova.R0000644000175100001440000000301612643434051014057 0ustar hornikusers ### ########################################################### ### ### PBanova ### ### ########################################################### .PBanova <- function(largeModel, smallModel=NULL, nsim=200, cl=NULL){ if (is.null(smallModel)){ fixef.name <- rev(attr(terms(largeModel),"term.labels")) ans1 <- list() ans2 <- list() for (kk in seq_along(fixef.name)){ dropped <- fixef.name[kk] newf <- as.formula(paste(".~.-", dropped)) smallModel <- update(largeModel, newf) #cat(sprintf("dropped: %s\n", dropped)) rr <- PBrefdist(largeModel, smallModel, nsim=nsim, cl=cl) ans1[[kk]] <- PBmodcomp(largeModel, smallModel, ref=rr) #ans2[[kk]] <- .FFmodcomp(largeModel, smallModel, ref=rr) largeModel <- smallModel } ans12 <- lapply(ans1, as.data.frame) ans22 <- lapply(ans2, as.data.frame) ans3 <- list() for (kk in seq_along(fixef.name)){ dropped <- fixef.name[kk] ans3[[kk]] <- rbind( cbind(term=dropped, test=rownames(ans12[[kk]]), ans12[[kk]],df2=NA), cbind(term=dropped, test=rownames(ans22[[kk]][2,,drop=FALSE]), ans22[[kk]][2,,drop=FALSE])) } ans3 <- rev(ans3) ans4 <- do.call(rbind, ans3) rownames(ans4) <- NULL ans4$p<-round(ans4$p,options("digits")$digits) ans4$tobs<-round(ans4$tobs,options("digits")$digits) ans4 } else { } } pbkrtest/R/KR-linearAlgebra.R0000644000175100001440000000257712643433747015544 0ustar hornikusers.spur<-function(U){ sum(diag(U)) } .orthComplement<-function(W) { ##orthogonal complement of : orth= rW <- rankMatrix(W) Worth <- qr.Q(qr(cbind(W)), complete=TRUE)[,-c(1:rW),drop=FALSE] Worth } ## Old UHH-code below ## Completely obsolete ## .spurAB<-function(A,B){ ## sum(A*t.default(B)) ## } ## # if A eller B er symmetrisk så er trace(AB)=sum(A*B) ## .matrixNullSpace<-function(B,L) { ## ## find A such that ={Bb| b in Lb=0} ## if ( ncol(B) != ncol(L) ) { ## stop('Number of columns of B and L not equal \n') ## } ## A <- B %*% .orthComplement(t(L)) ## # makes columns of A orthonormal: ## A <- qr.Q(qr(A))[,1:rankMatrix(A)] ## A ## } ## .colSpaceCompare<-function(X1,X2) { ## ## X1 X2: matrices with the ssme number of rows ## ## results r (Ci column space of Xi) ## ## r=1 C1 < C2 ## ## r=2 C2 < C1 ## ## r=3 C1==C2 ## ## r=4 C1 intersect C2 NOTempty but neither the one contained in the other ## ## r=5 C1 intersect C2 = empty ## if (nrow(X1)!= nrow(X2)){ ## stop("\n number of rows of X1 and X2 must be equal") } ## r1 <-rankMatrix(X1) ## r2 <-rankMatrix(X2) ## r12<-rankMatrix(cbind(X1,X2)) ## r <- ## if (r12 <= pmax(r1,r2)) { ## if (r1==r2) 3 else { ## if (r1>r2) 2 else 1 ## } ## } else { ## if (r12==(r1+r2)) 5 else 4 ## } ## r ## } pbkrtest/R/KR-vcovAdj0.R0000644000175100001440000000731312643434021014443 0ustar hornikusers ## -------------------------------------------------------------------- ## Calculate the adjusted covariance matrix for a mixed model ## -------------------------------------------------------------------- vcovAdj0 <- function(object, details=0) { DB <- details > 0 ## debugging only if(!.is.lmm(object)) { cat("Error in vccovAdj\n") cat(sprintf("model is not a linear mixed moxed model fitted with lmer\n")) stop() } if (!(getME(object, "is_REML"))){ #cat("\n object has been refitted with REML=TRUE \n") object <- update(object, .~., REML=TRUE) } ## Ready to go... X <- getME(object,"X") Phi <- vcov(object) SigmaG <- LMM_Sigma_G( object, details ) SigmaInv <- chol2inv( chol( forceSymmetric(SigmaG$Sigma) ) ) if(DB){cat(sprintf("Finding SigmaInv: %10.5f\n", (proc.time()-t0)[1] )); t0 <- proc.time()} ## Finding, TT, HH, 00 n.ggamma <- SigmaG$n.ggamma TT <- SigmaInv %*% X HH <- OO <- vector("list", n.ggamma) for (ii in 1:n.ggamma) { .DUM<-SigmaG$G[[ii]] %*% SigmaInv HH[[ii]] <- .DUM OO[[ii]] <- .DUM %*% X } if(DB){cat(sprintf("Finding TT,HH,OO %10.5f\n", (proc.time()-t0)[1] )); t0 <- proc.time()} ## Finding PP, QQ PP <- QQ <- NULL for (rr in 1:n.ggamma) { OrTrans <- t(OO[[rr]]) PP <- c(PP, list(forceSymmetric( -1 * OrTrans %*% TT))) for (ss in rr:n.ggamma) { QQ <- c(QQ,list(OrTrans %*% SigmaInv %*% OO[[ss]] )) }} if(DB){cat(sprintf("Finding PP,QQ: %10.5f\n", (proc.time()-t0)[1] )); t0 <- proc.time()} Ktrace <- matrix( NA, nrow=n.ggamma, ncol=n.ggamma ) for (rr in 1:n.ggamma) { HrTrans <- t( HH[[rr]] ) for (ss in rr:n.ggamma){ Ktrace[rr,ss] <- Ktrace[ss,rr]<- sum( HrTrans * HH[[ss]] ) }} if(DB){cat(sprintf("Finding Ktrace: %10.5f\n", (proc.time()-t0)[1] )); t0 <- proc.time()} ## Finding information matrix IE2 <- matrix( NA, nrow=n.ggamma, ncol=n.ggamma ) for (ii in 1:n.ggamma) { Phi.P.ii <- Phi %*% PP[[ii]] for (jj in c(ii:n.ggamma)) { www <- .indexSymmat2vec( ii, jj, n.ggamma ) IE2[ii,jj]<- IE2[jj,ii] <- Ktrace[ii,jj] - 2 * sum(Phi*QQ[[ www ]]) + sum( Phi.P.ii * ( PP[[jj]] %*% Phi)) }} if(DB){cat(sprintf("Finding IE2: %10.5f\n", (proc.time()-t0)[1] )); t0 <- proc.time()} eigenIE2 <- eigen(IE2,only.values=TRUE)$values condi <- min(abs(eigenIE2)) W <- if(condi>1e-10) forceSymmetric(2* solve(IE2)) else forceSymmetric(2* ginv(IE2)) U <- matrix(0, nrow=ncol(X), ncol=ncol(X)) for (ii in 1:(n.ggamma-1)) { for (jj in c((ii+1):n.ggamma)) { www <- .indexSymmat2vec( ii, jj, n.ggamma ) U <- U + W[ii,jj] * (QQ[[ www ]] - PP[[ii]] %*% Phi %*% PP[[jj]]) }} ### FIXME: Ulrich: Er det ikke sådan, at du her får beregnet diagonalen med to gange??? U <- U + t(U) for (ii in 1:n.ggamma) { www <- .indexSymmat2vec( ii, ii, n.ggamma ) U<- U + W[ii,ii] * (QQ[[ www ]] - PP[[ii]] %*% Phi %*% PP[[ii]]) } GGAMMA <- Phi %*% U %*% Phi PhiA <- Phi + 2 * GGAMMA attr(PhiA, "P") <-PP attr(PhiA, "W") <-W attr(PhiA, "condi") <- condi PhiA } ## Nov. 24. 2011; SHD ## Alternative computation of Ktrace. Seems to be no faster than the one above but please do ## not delete ## Ktrace2 <- matrix(NA,n.ggamma,n.ggamma) ## for (rr in 1:n.ggamma) { ## HrTrans<-t(H[[rr]]) ## Ktrace2[rr,rr] <- sum( HrTrans * t(HrTrans)) ## if (rr < n.ggamma){ ## for (ss in (rr+1):n.ggamma) { ## Ktrace2[rr,ss] <- Ktrace2[ss,rr]<- sum( HrTrans * H[[ss]]) ## }}} ## cat(sprintf("Finding Ktrace(2): %10.5f\n", (proc.time()-t0)[1] )); t0 <- proc.time() ## print(Ktrace) ## print(Ktrace2) ## print(Ktrace2-Ktrace) pbkrtest/R/KR-vcovAdj16.R0000644000175100001440000001021312645140272014527 0ustar hornikusers.vcovAdj16 <- function(object, details=0){ if (!(getME(object, "is_REML"))) { object <- update(object, . ~ ., REML = TRUE) } Phi <- vcov(object) SigmaG <- get_SigmaG( object, details ) X <- getME(object,"X") vcovAdj16_internal( Phi, SigmaG, X, details=details) } vcovAdj16_internal <- function(Phi, SigmaG, X, details=0){ details=0 DB <- details > 0 ## debugging only t0 <- proc.time() ##Sigma <- SigmaG$Sigma n.ggamma <- SigmaG$n.ggamma M <- cbind(do.call(cbind, SigmaG$G), X) if(DB){cat(sprintf("M etc: %10.5f\n", (proc.time()-t0)[1] )); t0 <- proc.time()} ##SinvM <- solve(SigmaG$Sigma, M, sparse=TRUE) SinvM <- chol2inv(chol( forceSymmetric( SigmaG$Sigma ))) %*% M ##SigmaInv <- chol2inv( chol( forceSymmetric(SigmaG$Sigma) ) ) if(DB){cat(sprintf("SinvM etc: %10.5f\n", (proc.time()-t0)[1] )); t0 <- proc.time()} v <- c(rep(1:length(SigmaG$G), each=nrow(SinvM)), rep(length(SigmaG$G)+1, ncol(X))) idx <- lapply(unique.default(v), function(i) which(v==i)) SinvG <- lapply(idx, function(z) SinvM[,z]) ## List of SinvG1, SinvG2,... SinvGr, SinvX SinvX <- SinvG[[length(SinvG)]] ## Kaldes TT andre steder SinvG[length(SinvG)] <- NULL ## Er HH^t if(DB){cat(sprintf("SinvG etc: %10.5f\n", (proc.time()-t0)[1] )); t0 <- proc.time()} ##stat <<- list(SigmaG=SigmaG, X=X, M=M) OO <- lapply(1:n.ggamma, function(i) { SigmaG$G[[i]] %*% SinvX ## G_i \Sigma\inv X; n \times p }) if(DB){cat(sprintf("Finding OO: %10.5f\n", (proc.time()-t0)[1] )); t0 <- proc.time()} PP <- vector("list", n.ggamma) QQ <- vector("list", n.ggamma * (n.ggamma + 1) / 2 ) index <- 1 for (r in 1:n.ggamma) { OOt.r <- t( OO[[ r ]] ) #str(list("dim(OOt.r)"=dim(OOt.r), "dim(SinvX)"=dim(SinvX))) ##PP[[r]] <- forceSymmetric( -1 * OOt.r %*% SinvX) ## PP : p \times p PP[[r]] <- -1 * (OOt.r %*% SinvX) ## PP : p \times p for (s in r:n.ggamma) { QQ[[index]] <- OOt.r %*% ( SinvG[[s]] %*% SinvX ) index <- index + 1; } } ##stat16 <<- list(Phi=Phi, OO=OO, PP=PP,QQ=QQ) if(DB){cat(sprintf("Finding PP,QQ: %10.5f\n", (proc.time()-t0)[1] )); t0 <- proc.time()} Ktrace <- matrix( NA, nrow=n.ggamma, ncol=n.ggamma ) for (r in 1:n.ggamma) { HHr <- SinvG[[r]] for (s in r:n.ggamma){ Ktrace[r,s] <- Ktrace[s,r] <- sum( HHr * SinvG[[s]] ) }} if(DB){cat(sprintf("Finding Ktrace: %10.5f\n", (proc.time()-t0)[1] )); t0 <- proc.time()} ## Finding information matrix IE2 <- matrix(0, nrow=n.ggamma, ncol=n.ggamma ) for (ii in 1:n.ggamma) { Phi.P.ii <- Phi %*% PP[[ii]] for (jj in c(ii:n.ggamma)) { www <- .indexSymmat2vec( ii, jj, n.ggamma ) IE2[ii,jj]<- IE2[jj,ii] <- Ktrace[ii,jj] - 2 * sum(Phi * QQ[[ www ]]) + sum( Phi.P.ii * ( PP[[jj]] %*% Phi)) }} if(DB){cat(sprintf("Finding IE2: %10.5f\n", (proc.time()-t0)[1] )); t0 <- proc.time()} eigenIE2 <- eigen( IE2, only.values=TRUE )$values condi <- min( abs( eigenIE2 ) ) WW <- if ( condi > 1e-10 ) forceSymmetric(2 * solve(IE2)) else forceSymmetric(2 * ginv(IE2)) ## print("vcovAdj") UU <- matrix(0, nrow=ncol(X), ncol=ncol(X)) ## print(UU) for (ii in 1:(n.ggamma-1)) { for (jj in c((ii+1):n.ggamma)) { www <- .indexSymmat2vec( ii, jj, n.ggamma ) UU <- UU + WW[ii,jj] * (QQ[[ www ]] - PP[[ii]] %*% Phi %*% PP[[jj]]) }} ## print(UU) UU <- UU + t(UU) for (ii in 1:n.ggamma) { www <- .indexSymmat2vec( ii, ii, n.ggamma ) UU <- UU + WW[ii,ii] * (QQ[[ www ]] - PP[[ii]] %*% Phi %*% PP[[ii]]) } if(DB){cat(sprintf("Finding UU: %10.5f\n", (proc.time()-t0)[1] )); t0 <- proc.time()} ## print(UU) GGAMMA <- Phi %*% UU %*% Phi PhiA <- Phi + 2 * GGAMMA attr(PhiA, "P") <- PP attr(PhiA, "W") <- WW attr(PhiA, "condi") <- condi PhiA } pbkrtest/R/KR-Sigma-G.R0000644000175100001440000001241512643433764014227 0ustar hornikusers## ############################################################################## ## ## LMM_Sigma_G: Returns VAR(Y) = Sigma and the G matrices ## ## ############################################################################## LMM_Sigma_G <- function(object, details=0) { DB <- details > 0 ## For debugging only if (!.is.lmm(object)) stop("'object' is not Gaussian linear mixed model") GGamma <- VarCorr(object) ## Indexing of the covariance matrix; ## this is somewhat technical and tedious Nindex <- .get_indices(object) ## number of random effects in each groupFac; note: residual error excluded! n.groupFac <- Nindex$n.groupFac ## the number of random effects for each grouping factor nn.groupFacLevels <- Nindex$nn.groupFacLevels ## size of the symmetric variance Gamma_i for reach groupFac nn.GGamma <- Nindex$nn.GGamma ## number of variance parameters of each GGamma_i mm.GGamma <- Nindex$mm.GGamma ## not sure what this is... group.index <- Nindex$group.index ## writing the covariance parameters for the random effects into a vector: ggamma <- NULL for ( ii in 1:(n.groupFac) ) { Lii <- GGamma[[ii]] nu <- ncol(Lii) ## Lii[lower.tri(Lii,diag=TRUE)= Lii[1,1],Lii[1,2],Lii[1,3]..Lii[1,nu], ## Lii[2,2], Lii[2,3] ... ggamma<-c(ggamma,Lii[lower.tri(Lii,diag=TRUE)]) } ## extend ggamma by the residuals variance such that everything random is included ggamma <- c( ggamma, sigma( object )^2 ) n.ggamma <- length(ggamma) ## Find G_r: Zt <- getME( object, "Zt" ) t0 <- proc.time() G <- NULL ##cat(sprintf("n.groupFac=%i\n", n.groupFac)) for (ss in 1:n.groupFac) { ZZ <- .get_Zt_group(ss, Zt, object) ##cat("ZZ\n"); print(ZZ) n.levels <- nn.groupFacLevels[ss] ##cat(sprintf("n.levels=%i\n", n.levels)) Ig <- sparseMatrix(1:n.levels, 1:n.levels, x=1) ##print(Ig) for (rr in 1:mm.GGamma[ss]) { ii.jj <- .indexVec2Symmat(rr,nn.GGamma[ss]) ##cat("ii.jj:"); print(ii.jj) ii.jj <- unique(ii.jj) if (length(ii.jj)==1){ EE <- sparseMatrix(ii.jj, ii.jj, x=1, dims=rep(nn.GGamma[ss],2)) } else { EE <- sparseMatrix(ii.jj, ii.jj[2:1], dims=rep(nn.GGamma[ss],2)) } ##cat("EE:\n");print(EE) EE <- Ig %x% EE ## Kronecker product G <- c( G, list( t(ZZ) %*% EE %*% ZZ ) ) } } ## Extend by the indentity for the residual nobs <- nrow(getME(object,'X')) G <- c( G, list(sparseMatrix(1:nobs, 1:nobs, x=1 )) ) if(DB){cat(sprintf("Finding G %10.5f\n", (proc.time()-t0)[1] )); t0 <- proc.time()} Sigma <- ggamma[1] * G[[1]] for (ii in 2:n.ggamma) { Sigma <- Sigma + ggamma[ii] * G[[ii]] } if(DB){cat(sprintf("Finding Sigma: %10.5f\n", (proc.time()-t0)[1] )); t0 <- proc.time()} SigmaG <- list(Sigma=Sigma, G=G, n.ggamma=n.ggamma) SigmaG } .get_indices <-function(object) { ## ff = number of random effects terms (..|F1) + (..|F1) are group factors! ## without the residual variance output: list of several indices ## we need the number of random-term factors Gp <- getME(object,"Gp") ff <- length(Gp)-1 gg <- sapply(getME(object,"flist"), function(x)length(levels(x))) qq <- .get.RT.dim.by.RT( object ) ##; cat("qq:\n"); print(qq) ## number of variance parameters of each GGamma_i ss <- qq * (qq+1) / 2 ## numb of random effects per level of random-term-factor nn.groupFac <- diff(Gp) ##cat("nn.groupFac:\n"); print(nn.groupFac) ## number of levels for each random-term-factor; residual error here excluded! nn.groupFacLevels <- nn.groupFac / qq ## this is the number of random term factors, should possible get a more approriate name list(n.groupFac = ff, nn.groupFacLevelsNew = gg, # length of different grouping factors nn.groupFacLevels = nn.groupFacLevels, # vector of the numb. levels for each random-term-factor nn.GGamma = qq, mm.GGamma = ss, group.index = Gp) } .get_Zt_group <- function(ii.group, Zt, object) { ## ii.group : the index number of a grouping factor ## Zt : the transpose of the random factors design matrix Z ## object : A mer or lmerMod model ##output : submatrix of Zt belongig to grouping factor ii.group Nindex <- .get_indices(object) nn.groupFacLevels <- Nindex$nn.groupFacLevels nn.GGamma <- Nindex$nn.GGamma group.index <- Nindex$group.index .cc <- class(object) ## cat(".get_Zt_group\n"); ## print(group.index) ## print(ii.group) zIndex.sub <- if (.cc %in% "mer") { Nindex$group.index[ii.group]+ 1+c(0:(nn.GGamma[ii.group]-1))*nn.groupFacLevels[ii.group] + rep(0:(nn.groupFacLevels[ii.group]-1),each=nn.GGamma[ii.group]) } else { if (.cc %in% "lmerMod" ) { c((group.index[ii.group]+1) : group.index[ii.group+1]) } } ZZ <- Zt[ zIndex.sub , ] return(ZZ) } pbkrtest/R/KR-Sigma-G2.R0000644000175100001440000001145012643433772014306 0ustar hornikusers## ############################################################################## ## ## LMM_Sigma_G: Returns VAR(Y) = Sigma and the G matrices ## ## Re-implemented in Banff, Canada, August 2013 by Søren Højsgaard ## ## ############################################################################## get_SigmaG <- function(object, details=0) { UseMethod("get_SigmaG") } get_SigmaG.lmerMod <- function(object, details=0) { .get_SigmaG( object, details ) } get_SigmaG.mer <- function(object, details=0) { LMM_Sigma_G( object, details ) } .get_SigmaG <- function(object, details=0) { DB <- details > 0 ## For debugging only if (!.is.lmm(object)) stop("'object' is not Gaussian linear mixed model") GGamma <- VarCorr(object) SS <- .shgetME( object ) ## Put covariance parameters for the random effects into a vector: ## Fixme: It is a bit ugly to throw everything into one long vector here; a list would be more elegant ggamma <- NULL for ( ii in 1:( SS$n.RT )) { Lii <- GGamma[[ii]] ggamma <- c(ggamma, Lii[ lower.tri( Lii, diag=TRUE ) ] ) } ggamma <- c( ggamma, sigma( object )^2 ) ## Extend ggamma by the residuals variance n.ggamma <- length(ggamma) ## Find G_r: G <- NULL Zt <- getME( object, "Zt" ) for (ss in 1:SS$n.RT) { ZZ <- .shget_Zt_group( ss, Zt, SS$Gp ) n.lev <- SS$n.lev.by.RT2[ ss ] ## ; cat(sprintf("n.lev=%i\n", n.lev)) Ig <- sparseMatrix(1:n.lev, 1:n.lev, x=1) for (rr in 1:SS$n.parm.by.RT[ ss ]) { ## This is takes care of the case where there is random regression and several matrices have to be constructed. ## FIXME: I am not sure this is correct if there is a random quadratic term. The '2' below looks suspicious. ii.jj <- .index2UpperTriEntry( rr, SS$n.comp.by.RT[ ss ] ) ##; cat("ii.jj:"); print(ii.jj) ii.jj <- unique(ii.jj) if (length(ii.jj)==1){ EE <- sparseMatrix(ii.jj, ii.jj, x=1, dims=rep(SS$n.comp.by.RT[ ss ], 2)) } else { EE <- sparseMatrix(ii.jj, ii.jj[2:1], dims=rep(SS$n.comp.by.RT[ ss ], 2)) } EE <- Ig %x% EE ## Kronecker product G <- c( G, list( t(ZZ) %*% EE %*% ZZ ) ) } } ## Extend by the indentity for the residual n.obs <- nrow(getME(object,'X')) G <- c( G, list(sparseMatrix(1:n.obs, 1:n.obs, x=1 )) ) Sigma <- ggamma[1] * G[[1]] for (ii in 2:n.ggamma) { Sigma <- Sigma + ggamma[ii] * G[[ii]] } SigmaG <- list(Sigma=Sigma, G=G, n.ggamma=n.ggamma) SigmaG } .shgetME <- function( object ){ Gp <- getME( object, "Gp" ) n.RT <- length( Gp ) - 1 ## Number of random terms ( i.e. of (|)'s ) n.lev.by.RT <- sapply(getME(object, "flist"), function(x) length(levels(x))) n.comp.by.RT <- .get.RT.dim.by.RT( object ) n.parm.by.RT <- (n.comp.by.RT + 1) * n.comp.by.RT / 2 n.RE.by.RT <- diff( Gp ) n.lev.by.RT2 <- n.RE.by.RT / n.comp.by.RT ## Same as n.lev.by.RT2 ??? list(Gp = Gp, ## group.index n.RT = n.RT, ## n.groupFac n.lev.by.RT = n.lev.by.RT, ## nn.groupFacLevelsNew n.comp.by.RT = n.comp.by.RT, ## nn.GGamma n.parm.by.RT = n.parm.by.RT, ## mm.GGamma n.RE.by.RT = n.RE.by.RT, ## ... Not returned before n.lev.by.RT2 = n.lev.by.RT2, ## nn.groupFacLevels n_rtrms = getME( object, "n_rtrms") ) } .getME.all <- function(obj) { nmME <- eval(formals(getME)$name) sapply(nmME, function(nm) try(getME(obj, nm)), simplify=FALSE) } ## Alternative to .get_Zt_group .shget_Zt_group <- function( ii.group, Zt, Gp, ... ){ zIndex.sub <- (Gp[ii.group]+1) : Gp[ii.group+1] ZZ <- Zt[ zIndex.sub , ] return(ZZ) } ## ## Modular implementation ## .get_GI_parms <- function( object ){ GGamma <- VarCorr(object) parmList <- lapply(GGamma, function(Lii){ Lii[ lower.tri( Lii, diag=TRUE ) ] }) parmList <- c( parmList, sigma( object )^2 ) parmList } .get_GI_matrices <- function( object ){ SS <- .shgetME( object ) Zt <- getME( object, "Zt" ) G <- NULL G <- vector("list", SS$n.RT+1) for (ss in 1:SS$n.RT) { ZZ <- .shget_Zt_group( ss, Zt, SS$Gp ) n.lev <- SS$n.lev.by.RT2[ ss ] ## ; cat(sprintf("n.lev=%i\n", n.lev)) Ig <- sparseMatrix(1:n.lev, 1:n.lev, x=1) UU <- vector("list", SS$n.parm.by.RT) for (rr in 1:SS$n.parm.by.RT[ ss ]) { ii.jj <- .index2UpperTriEntry( rr, SS$n.comp.by.RT[ ss ] ) ii.jj <- unique(ii.jj) if (length(ii.jj)==1){ EE <- sparseMatrix(ii.jj, ii.jj, x=1, dims=rep(SS$n.comp.by.RT[ ss ], 2)) } else { EE <- sparseMatrix(ii.jj, ii.jj[2:1], dims=rep(SS$n.comp.by.RT[ ss ], 2)) } EE <- Ig %x% EE ## Kronecker product UU[[ rr ]] <- t(ZZ) %*% EE %*% ZZ } G[[ ss ]] <- UU } n.obs <- nrow(getME(object,'X')) G[[ length( G ) ]] <- sparseMatrix(1:n.obs, 1:n.obs, x=1 ) G } pbkrtest/R/KR-modcomp.R0000644000175100001440000001627412645154715014446 0ustar hornikusersKRmodcomp <- function(largeModel, smallModel,betaH=0, details=0){ UseMethod("KRmodcomp") } KRmodcomp.lmerMod<- KRmodcomp.mer<- function(largeModel, smallModel, betaH=0, details=0) { ## 'smallModel' can either be an lmerMod (linear mixed) model or a restriction matrix L. w <- KRmodcomp_init(largeModel, smallModel, matrixOK = TRUE) if (w==-1) { stop('Models have either equal fixed mean stucture or are not nested') } else { if (w==0){ ##stop('First given model is submodel of second; exchange the models\n') tmp <- largeModel largeModel <- smallModel smallModel <- tmp } } ## Refit large model with REML if necessary if (!(getME(largeModel, "is_REML"))){ largeModel <- update(largeModel,.~.,REML=TRUE) } ## All computations are based on 'largeModel' and the restriction matrix 'L' ## ------------------------------------------------------------------------- t0 <- proc.time() L <- .model2restrictionMatrix(largeModel, smallModel) PhiA <- vcovAdj(largeModel, details) stats <- .KR_adjust(PhiA, Phi=vcov(largeModel), L, beta=fixef(largeModel), betaH) stats <- lapply(stats, c) ## To get rid of all sorts of attributes ans <- .finalizeKR(stats) f.small <- if (.is.lmm(smallModel)){ .zzz <- formula(smallModel) attributes(.zzz) <- NULL .zzz } else { list(L=L, betaH=betaH) } f.large <- formula(largeModel) attributes(f.large) <- NULL ans$f.large <- f.large ans$f.small <- f.small ans$ctime <- (proc.time()-t0)[1] ans$L <- L ans } .finalizeKR <- function(stats){ test = list( Ftest = c(stat=stats$Fstat, ndf=stats$ndf, ddf=stats$ddf, F.scaling=stats$F.scaling, p.value=stats$p.value), FtestU = c(stat=stats$FstatU, ndf=stats$ndf, ddf=stats$ddf, F.scaling=NA, p.value=stats$p.valueU)) test <- as.data.frame(do.call(rbind, test)) test$ndf <- as.integer(test$ndf) ans <- list(test=test, type="F", aux=stats$aux, stats=stats) ## Notice: stats are carried to the output. They are used for get getKR function... class(ans)<-c("KRmodcomp") ans } KRmodcomp_internal <- function(largeModel, LL, betaH=0, details=0){ PhiA <- vcovAdj(largeModel, details) stats <- .KR_adjust(PhiA, Phi=vcov(largeModel), LL, beta=fixef(largeModel), betaH) stats <- lapply(stats, c) ## To get rid of all sorts of attributes ans <- .finalizeKR(stats) ans } ## -------------------------------------------------------------------- ## This is the function that calculates the Kenward-Roger approximation ## -------------------------------------------------------------------- .KR_adjust <- function(PhiA, Phi, L, beta, betaH){ Theta <- t(L) %*% solve( L %*% Phi %*% t(L), L) P <- attr( PhiA, "P" ) W <- attr( PhiA, "W" ) A1 <- A2 <- 0 ThetaPhi <- Theta %*% Phi n.ggamma <- length(P) for (ii in 1:n.ggamma) { for (jj in c(ii:n.ggamma)) { e <- ifelse(ii==jj, 1, 2) ui <- ThetaPhi %*% P[[ii]] %*% Phi uj <- ThetaPhi %*% P[[jj]] %*% Phi A1 <- A1 + e* W[ii,jj] * (.spur(ui) * .spur(uj)) A2 <- A2 + e* W[ii,jj] * sum(ui * t(uj)) } } q <- rankMatrix(L) B <- (1/(2*q)) * (A1+6*A2) g <- ( (q+1)*A1 - (q+4)*A2 ) / ((q+2)*A2) c1<- g/(3*q+ 2*(1-g)) c2<- (q-g) / (3*q + 2*(1-g)) c3<- (q+2-g) / ( 3*q+2*(1-g)) ## cat(sprintf("q=%i B=%f A1=%f A2=%f\n", q, B, A1, A2)) ## cat(sprintf("g=%f, c1=%f, c2=%f, c3=%f\n", g, c1, c2, c3)) ###orgDef: E<-1/(1-A2/q) ###orgDef: V<- 2/q * (1+c1*B) / ( (1-c2*B)^2 * (1-c3*B) ) ##EE <- 1/(1-A2/q) ##VV <- (2/q) * (1+c1*B) / ( (1-c2*B)^2 * (1-c3*B) ) EE <- 1 + (A2/q) VV <- (2/q)*(1+B) EEstar <- 1/(1-A2/q) VVstar <- (2/q)*((1+c1*B)/((1-c2*B)^2 * (1-c3*B))) ## cat(sprintf("EE=%f VV=%f EEstar=%f VVstar=%f\n", EE, VV, EEstar, VVstar)) V0<-1+c1*B V1<-1-c2*B V2<-1-c3*B V0<-ifelse(abs(V0)<1e-10,0,V0) ## cat(sprintf("V0=%f V1=%f V2=%f\n", V0, V1, V2)) ###orgDef: V<- 2/q* V0 /(V1^2*V2) ###orgDef: rho <- V/(2*E^2) rho <- 1/q * (.divZero(1-A2/q,V1))^2 * V0/V2 df2 <- 4 + (q+2)/ (q*rho-1) ## Here are the adjusted degrees of freedom. ###orgDef: F.scaling <- df2 /(E*(df2-2)) ###altCalc F.scaling<- df2 * .divZero(1-A2/q,df2-2,tol=1e-12) ## this does not work because df2-2 can be about 0.1 F.scaling<-ifelse( abs(df2-2)<1e-2, 1 , df2*(1-A2/q)/(df2-2)) ##cat(sprintf("KR: rho=%f, df2=%f F.scaling=%f\n", rho, df2, F.scaling)) ## Vector of auxilary values; just for checking etc... aux <- c(A1=A1, A2=A2, V0=V0, V1=V1, V2=V2, rho=rho, F.scaling=F.scaling) ### The F-statistic; scaled and unscaled betaDiff <- cbind( beta - betaH ) Wald <- as.numeric(t(betaDiff) %*% t(L) %*% solve(L%*%PhiA%*%t(L), L%*%betaDiff)) WaldU <- as.numeric(t(betaDiff) %*% t(L) %*% solve(L%*%Phi%*%t(L), L%*%betaDiff)) FstatU <- Wald/q pvalU <- pf(FstatU,df1=q,df2=df2,lower.tail=FALSE) Fstat <- F.scaling * FstatU pval <- pf(Fstat,df1=q,df2=df2,lower.tail=FALSE) stats<-list(ndf=q, ddf=df2, Fstat = Fstat, p.value=pval, F.scaling=F.scaling, FstatU = FstatU, p.valueU = pvalU, aux = aux) stats } .KRcommon <- function(x){ cat(sprintf("F-test with Kenward-Roger approximation; computing time: %.2f sec.\n", x$ctime)) cat("large : ") print(x$f.large) if (inherits(x$f.small,"call")){ cat("small : ") print(x$f.small) } else { formSmall <- x$f.small cat("small : L beta = L betaH \n") cat('L=\n') print(formSmall$L) cat('betaH=\n') print(formSmall$betaH) } } print.KRmodcomp <- function(x,...){ .KRcommon(x) FF.thresh <- 0.2 F.scale <- x$aux['F.scaling'] tab <- x$test if (max(F.scale)>FF.thresh){ printCoefmat(tab[1,,drop=FALSE], tst.ind=c(1,2,3), na.print='', has.Pvalue=TRUE) } else { printCoefmat(tab[2,,drop=FALSE], tst.ind=c(1,2,3), na.print='', has.Pvalue=TRUE) } return(invisible(x)) } summary.KRmodcomp <- function(object,...){ .KRcommon(object) FF.thresh <- 0.2 F.scale <- object$aux['F.scaling'] tab <- object$test printCoefmat(tab, tst.ind=c(1,2,3), na.print='', has.Pvalue=TRUE) if (F.scale<0.2 & F.scale>0) { cat('Note: The scaling factor for the F-statistic is smaller than 0.2 \n') cat('The Unscaled statistic might be more reliable \n ') } else { if (F.scale<=0){ cat('Note: The scaling factor for the F-statistic is negative \n') cat('Use the Unscaled statistic instead. \n ') } } } #stats <- .KRmodcompPrimitive(largeModel, L, betaH, details) ## .KRmodcompPrimitive<-function(largeModel, L, betaH, details) { ## PhiA<-vcovAdj(largeModel, details) ## .KR_adjust(PhiA, Phi=vcov(largeModel), L, beta=fixef(largeModel), betaH ) ## } ### SHD addition: calculate bartlett correction and gamma approximation ### ## ## Bartlett correction - X2 distribution ## BCval <- 1 / EE ## BCstat <- BCval * Wald ## p.BC <- 1-pchisq(BCstat,df=q) ## # cat(sprintf("Wald=%f BCval=%f BC.stat=%f p.BC=%f\n", Wald, BCval, BCstat, p.BC)) ## ## Gamma distribution ## scale <- q*VV/EE ## shape <- EE^2/VV ## p.Ga <- 1-pgamma(Wald, shape=shape, scale=scale) ## # cat(sprintf("shape=%f scale=%f p.Ga=%f\n", shape, scale, p.Ga)) pbkrtest/R/KR-vcovAdj.R0000644000175100001440000001022312645140164014361 0ustar hornikusers ## -------------------------------------------------------------------- ## Calculate the adjusted covariance matrix for a mixed model ## ## Implemented in Banff, august 2013; Søren Højsgaard ## -------------------------------------------------------------------- vcovAdj <- function(object, details=0){ UseMethod("vcovAdj") } vcovAdj.lmerMod <- vcovAdj.mer <- function(object, details=0){ if (!(getME(object, "is_REML"))) { object <- update(object, . ~ ., REML = TRUE) } Phi <- vcov(object) SigmaG <- get_SigmaG( object, details ) X <- getME(object,"X") vcovAdj16_internal( Phi, SigmaG, X, details=details) } .vcovAdj_internal <- function(Phi, SigmaG, X, details=0){ ##cat("vcovAdj_internal\n") ##SG<<-SigmaG DB <- details > 0 ## debugging only #print("HHHHHHHHHHHHHHH") #print(system.time({chol( forceSymmetric(SigmaG$Sigma) )})) #print(system.time({chol2inv( chol( forceSymmetric(SigmaG$Sigma) ) )})) ## print("HHHHHHHHHHHHHHH") ## Sig <- forceSymmetric( SigmaG$Sigma ) ## print("HHHHHHHHHHHHHHH") ## print(system.time({Sig.chol <- chol( Sig )})) ## print(system.time({chol2inv( Sig.chol )})) t0 <- proc.time() ## print("HHHHHHHHHHHHHHH") SigmaInv <- chol2inv( chol( forceSymmetric(SigmaG$Sigma) ) ) ## print("DONE --- HHHHHHHHHHHHHHH") if(DB){ cat(sprintf("Finding SigmaInv: %10.5f\n", (proc.time()-t0)[1] )); t0 <- proc.time() } ##print("iiiiiiiiiiiii") t0 <- proc.time() ## Finding, TT, HH, 00 n.ggamma <- SigmaG$n.ggamma TT <- SigmaInv %*% X HH <- OO <- vector("list", n.ggamma) for (ii in 1:n.ggamma) { .tmp <- SigmaG$G[[ii]] %*% SigmaInv HH[[ ii ]] <- .tmp OO[[ ii ]] <- .tmp %*% X } if(DB){cat(sprintf("Finding TT,HH,OO %10.5f\n", (proc.time()-t0)[1] )); t0 <- proc.time()} ## if(DB){ ## cat("HH:\n"); print(HH); HH <<- HH ## cat("OO:\n"); print(OO); OO <<- OO ## } ## Finding PP, QQ PP <- QQ <- NULL for (rr in 1:n.ggamma) { OrTrans <- t( OO[[ rr ]] ) PP <- c(PP, list(forceSymmetric( -1 * OrTrans %*% TT))) for (ss in rr:n.ggamma) { QQ <- c(QQ,list(OrTrans %*% SigmaInv %*% OO[[ss]] )) }} if(DB){cat(sprintf("Finding PP,QQ: %10.5f\n", (proc.time()-t0)[1] )); t0 <- proc.time()} ## if(DB){ ## cat("PP:\n"); print(PP); PP2 <<- PP ## cat("QP:\n"); print(QQ); QQ2 <<- QQ ## } Ktrace <- matrix( NA, nrow=n.ggamma, ncol=n.ggamma ) for (rr in 1:n.ggamma) { HrTrans <- t( HH[[rr]] ) for (ss in rr:n.ggamma){ Ktrace[rr,ss] <- Ktrace[ss,rr]<- sum( HrTrans * HH[[ss]] ) }} if(DB){cat(sprintf("Finding Ktrace: %10.5f\n", (proc.time()-t0)[1] )); t0 <- proc.time()} ## Finding information matrix IE2 <- matrix( NA, nrow=n.ggamma, ncol=n.ggamma ) for (ii in 1:n.ggamma) { Phi.P.ii <- Phi %*% PP[[ii]] for (jj in c(ii:n.ggamma)) { www <- .indexSymmat2vec( ii, jj, n.ggamma ) IE2[ii,jj]<- IE2[jj,ii] <- Ktrace[ii,jj] - 2 * sum(Phi*QQ[[ www ]]) + sum( Phi.P.ii * ( PP[[jj]] %*% Phi)) }} if(DB){cat(sprintf("Finding IE2: %10.5f\n", (proc.time()-t0)[1] )); t0 <- proc.time()} eigenIE2 <- eigen(IE2,only.values=TRUE)$values condi <- min(abs(eigenIE2)) WW <- if(condi>1e-10) forceSymmetric(2* solve(IE2)) else forceSymmetric(2* ginv(IE2)) ## print("vcovAdj") UU <- matrix(0, nrow=ncol(X), ncol=ncol(X)) ## print(UU) for (ii in 1:(n.ggamma-1)) { for (jj in c((ii+1):n.ggamma)) { www <- .indexSymmat2vec( ii, jj, n.ggamma ) UU <- UU + WW[ii,jj] * (QQ[[ www ]] - PP[[ii]] %*% Phi %*% PP[[jj]]) }} ## print(UU) UU <- UU + t(UU) ## UU <<- UU for (ii in 1:n.ggamma) { www <- .indexSymmat2vec( ii, ii, n.ggamma ) UU<- UU + WW[ii,ii] * (QQ[[ www ]] - PP[[ii]] %*% Phi %*% PP[[ii]]) } ## print(UU) GGAMMA <- Phi %*% UU %*% Phi PhiA <- Phi + 2 * GGAMMA attr(PhiA, "P") <-PP attr(PhiA, "W") <-WW attr(PhiA, "condi") <- condi PhiA } pbkrtest/R/KR-init-modcomp.R0000644000175100001440000000406512643433740015376 0ustar hornikusersKRmodcomp_init <- function(m1, m2, matrixOK=FALSE){ UseMethod("KRmodcomp_init") } KRmodcomp_init.lmerMod <- KRmodcomp_init.mer <- function(m1, m2, matrixOK=FALSE) { ##comparison of the mean structures of the models ## it is tested for that (1) m1 is mer and (2) m2 is either mer or a matrix mers<- if ( .is.lmm(m1) & (.is.lmm(m2) | is.matrix(m2) ) ) TRUE else FALSE if (!mers) { cat("Error in modcomp_init\n") cat(paste("either model ",substitute(m1), "\n is not a linear mixed of class mer(CRAN) or lmerMod (GitHub)\n \n",sep=' ')) cat(paste("or model ", substitute(m2),"\n is neither of that class nor a matrix",sep='')) stop() } ##checking matrixcOK is FALSE but m2 is a matrix if (!matrixOK & is.matrix(m2)) { cat ('Error in modcomp_init \n') cat (paste('matrixOK =FALSE but the second model: ', substitute(m2), '\n is specified via a restriction matrix \n \n',sep='')) stop() } Xlarge <- getME(m1, "X") rlarge <- rankMatrix(Xlarge) ##code <- if ('mer' %in% class(m2)) { ##code <- if ('lmerMod' %in% class(m2)) { code <- if (.is.lmm(m2)){ Xsmall <- getME(m2,"X") rsmall <- rankMatrix(Xsmall) rboth <- rankMatrix(cbind(Xlarge,Xsmall)) if (rboth == pmax(rlarge,rsmall)) { if (rsmall< rlarge) { 1 } else { if (rsmall > rlarge) { 0 } else { -1 } } } else { -1 } } else { ##now model m2 is a restriction matrix if (rankMatrix(rbind(Xlarge,m2)) > rlarge) { -1 } else { 1 } } code } pbkrtest/R/KR-vcovAdj15.R0000644000175100001440000000665312645140216014541 0ustar hornikusers ## Work november, 2015 - to gain speed .vcovAdj15 <- function(object, details=0){ if (!(getME(object, "is_REML"))) { object <- update(object, . ~ ., REML = TRUE) } Phi <- vcov(object) SigmaG <- get_SigmaG( object, details ) X <- getME(object,"X") .vcovAdj15_internal( Phi, SigmaG, X, details=details) } .vcovAdj15_internal <- function(Phi, SigmaG, X, details=0){ details=0 DB <- details > 0 ## debugging only t0 <- proc.time() SigmaInv <- chol2inv( chol( forceSymmetric(SigmaG$Sigma) ) ) if(DB){ cat(sprintf("Finding SigmaInv: %10.5f\n", (proc.time()-t0)[1] )); t0 <- proc.time() } t0 <- proc.time() ## Finding, TT, HH, 00 n.ggamma <- SigmaG$n.ggamma TT <- SigmaInv %*% X HH <- OO <- vector("list", n.ggamma) #mat <<- list(SigmaG=SigmaG, SigmaInv=SigmaInv, X=X) t0 <- proc.time() ## Finding, TT, HH, 00 n.ggamma <- SigmaG$n.ggamma TT <- SigmaInv %*% X HH <- OO <- vector("list", n.ggamma) for (ii in 1:n.ggamma) { .tmp <- SigmaG$G[[ii]] %*% SigmaInv HH[[ ii ]] <- .tmp OO[[ ii ]] <- .tmp %*% X } if(DB){cat(sprintf("Finding TT,HH,OO %10.5f\n", (proc.time()-t0)[1] )); t0 <- proc.time()} ## Finding PP, QQ PP <- QQ <- NULL for (rr in 1:n.ggamma) { OrTrans <- t( OO[[ rr ]] ) PP <- c(PP, list(forceSymmetric( -1 * OrTrans %*% TT))) for (ss in rr:n.ggamma) { QQ <- c(QQ,list(OrTrans %*% SigmaInv %*% OO[[ss]] )) }} if(DB){cat(sprintf("Finding PP,QQ: %10.5f\n", (proc.time()-t0)[1] )); t0 <- proc.time()} ##stat15 <<- list(HH=HH, OO=OO, PP=PP, Phi=Phi, QQ=QQ) Ktrace <- matrix( NA, nrow=n.ggamma, ncol=n.ggamma ) for (rr in 1:n.ggamma) { HrTrans <- t( HH[[rr]] ) for (ss in rr:n.ggamma){ Ktrace[rr,ss] <- Ktrace[ss,rr]<- sum( HrTrans * HH[[ss]] ) }} if(DB){cat(sprintf("Finding Ktrace: %10.5f\n", (proc.time()-t0)[1] )); t0 <- proc.time()} ## Finding information matrix IE2 <- matrix( NA, nrow=n.ggamma, ncol=n.ggamma ) for (ii in 1:n.ggamma) { Phi.P.ii <- Phi %*% PP[[ii]] for (jj in c(ii:n.ggamma)) { www <- .indexSymmat2vec( ii, jj, n.ggamma ) IE2[ii,jj]<- IE2[jj,ii] <- Ktrace[ii,jj] - 2 * sum(Phi*QQ[[ www ]]) + sum( Phi.P.ii * ( PP[[jj]] %*% Phi)) }} if(DB){cat(sprintf("Finding IE2: %10.5f\n", (proc.time()-t0)[1] )); t0 <- proc.time()} eigenIE2 <- eigen(IE2,only.values=TRUE)$values condi <- min(abs(eigenIE2)) WW <- if(condi>1e-10) forceSymmetric(2* solve(IE2)) else forceSymmetric(2* ginv(IE2)) ## print("vcovAdj") UU <- matrix(0, nrow=ncol(X), ncol=ncol(X)) ## print(UU) for (ii in 1:(n.ggamma-1)) { for (jj in c((ii+1):n.ggamma)) { www <- .indexSymmat2vec( ii, jj, n.ggamma ) UU <- UU + WW[ii,jj] * (QQ[[ www ]] - PP[[ii]] %*% Phi %*% PP[[jj]]) }} ## print(UU) UU <- UU + t(UU) ## UU <<- UU for (ii in 1:n.ggamma) { www <- .indexSymmat2vec( ii, ii, n.ggamma ) UU<- UU + WW[ii,ii] * (QQ[[ www ]] - PP[[ii]] %*% Phi %*% PP[[ii]]) } ## print(UU) GGAMMA <- Phi %*% UU %*% Phi PhiA <- Phi + 2 * GGAMMA attr(PhiA, "P") <-PP attr(PhiA, "W") <-WW attr(PhiA, "condi") <- condi PhiA } pbkrtest/R/PB-utils.R0000644000175100001440000000154312643434074014123 0ustar hornikusers ########################################################## ### ### Likelihood ratio statistic ### ########################################################## getLRT <- function(largeModel, smallModel){ UseMethod("getLRT") } getLRT.merMod <- getLRT.mer <- function(largeModel, smallModel){ ll.small <- logLik(smallModel, REML=FALSE) ll.large <- logLik(largeModel, REML=FALSE) tobs <- 2*(ll.large-ll.small) df11 <- attr(ll.large, "df") - attr(ll.small, "df") p.X2 <- 1-pchisq(tobs, df11) c(tobs=tobs, df=df11, p.value=p.X2) } getLRT.lm <- function(largeModel, smallModel){ ll.small <- logLik(smallModel) ll.large <- logLik(largeModel) tobs <- 2*(ll.large-ll.small) df11 <- attr(ll.large, "df") - attr(ll.small, "df") p.X2 <- 1-pchisq(tobs, df11) c(tobs=tobs, df=df11, p.value=p.X2) } pbkrtest/R/PB-refdist.R0000644000175100001440000000602312645172535014424 0ustar hornikusers### ########################################################### ### ### Parallel computing of reference distribution ### ### ########################################################### PBrefdist <- function(largeModel, smallModel, nsim=1000, seed=NULL, cl=NULL, details=0){ UseMethod("PBrefdist") } PBrefdist.lm <- function(largeModel, smallModel, nsim=1000, seed=NULL, cl=NULL, details=0){ ##cat(".....PBrefdist.lm\n") t0 <- proc.time() .is.cluster <- !is.null(cl) && inherits(cl, "cluster") if (!.is.cluster){ ref <- .lm_refDist(largeModel, smallModel, nsim, seed=seed) } else { nsim2 <- round(nsim/length(cl)) if (details>=1) cat(sprintf("* Using %i clusters and %i samples per cluster\n", length(cl), nsim2)) clusterExport(cl, ls(envir=.GlobalEnv), envir = .GlobalEnv) clusterSetRNGStream(cl) ref <- unlist(clusterCall(cl, .lm_refDist, largeModel, smallModel, nsim2)) } ref <- ref[ref>0] ctime <- (proc.time()-t0)[3] attr(ref,"ctime") <- ctime if (details>0) cat(sprintf("Reference distribution with %i samples; computing time: %5.2f secs. \n", length(ref), ctime)) ref } .lm_refDist <- function(lg, sm, nsim=20, seed=NULL, simdata=simulate(sm, nsim=nsim, seed=seed)){ ##simdata <- simulate(sm, nsim, seed=seed) ee <- new.env() ee$simdata <- simdata ff.lg <- update.formula(formula(lg),simdata[,ii]~.) ff.sm <- update.formula(formula(sm),simdata[,ii]~.) environment(ff.lg) <- environment(ff.sm) <- ee cl.lg <- getCall(lg) cl.sm <- getCall(sm) cl.lg$formula <- ff.lg cl.sm$formula <- ff.sm ref <- rep.int(NA, nsim) for (ii in 1:nsim){ ref[ii] <- 2*(logLik(eval(cl.lg))-logLik(eval(cl.sm))) } ref } .merMod_refDist <- function(lg, sm, nsim=20, seed=NULL, simdata=simulate(sm, nsim=nsim, seed=seed)){ #simdata <- simulate(sm, nsim=nsim, seed=seed) unname(unlist(lapply(simdata, function(yyy){ sm2 <- refit(sm, newresp=yyy) lg2 <- refit(lg, newresp=yyy) 2*(logLik( lg2, REML=FALSE ) - logLik( sm2, REML=FALSE )) }))) } PBrefdist.mer <- PBrefdist.merMod <- function(largeModel, smallModel, nsim=1000, seed=NULL, cl=NULL, details=0){ t0 <- proc.time() if (getME(smallModel, "is_REML")) smallModel <- update( smallModel, REML=FALSE ) if (getME(largeModel, "is_REML")) largeModel <- update( largeModel, REML=FALSE ) .is.cluster <- !is.null(cl) && inherits(cl, "cluster") if (!.is.cluster){ ref <- .merMod_refDist(largeModel, smallModel, nsim=nsim, seed=seed) } else { nsim.cl <- nsim %/% length(cl) clusterSetRNGStream(cl) ref <- unlist( clusterCall(cl, fun=.merMod_refDist, largeModel, smallModel, nsim=nsim.cl) ) } ctime <- (proc.time()-t0)[3] attr(ref,"ctime") <- ctime attr(ref,"samples") <- c(nsim=nsim, npos=sum(ref>0)) if (details>0) cat(sprintf("Reference distribution with %5i samples; computing time: %5.2f secs. \n", length(ref), ctime)) ref } pbkrtest/vignettes/0000755000175100001440000000000012652165060014141 5ustar hornikuserspbkrtest/vignettes/pbkrtest-introduction.Rnw0000644000175100001440000001243112403523013021175 0ustar hornikusers%\VignetteIndexEntry{pbkrtest-introduction: Introduction to pbkrtest} %\VignettePackage{pbkrtest} \documentclass[11pt]{article} \usepackage{url,a4} \usepackage[latin1]{inputenc} %\usepackage{inputenx} \usepackage{boxedminipage,color} \usepackage[noae]{Sweave} \parindent0pt\parskip5pt \def\code#1{{\texttt{#1}}} \def\pkg#1{{\texttt{#1}}} \def\R{\texttt{R}} <>= require( pbkrtest ) prettyVersion <- packageDescription("pbkrtest")$Version prettyDate <- format(Sys.Date()) @ \title{On the usage of the \pkg{pbkrtest} package} \author{S{\o}ren H{\o}jsgaard and Ulrich Halekoh} \date{\pkg{pbkrtest} version \Sexpr{prettyVersion} as of \Sexpr{prettyDate}} \SweaveOpts{prefix.string=figures/pbkr, keep.source=T, height=4} \begin{document} \definecolor{darkred}{rgb}{.7,0,0} \definecolor{midnightblue}{rgb}{0.098,0.098,0.439} \DefineVerbatimEnvironment{Sinput}{Verbatim}{ fontfamily=tt, %%fontseries=b, %% xleftmargin=2em, formatcom={\color{midnightblue}} } \DefineVerbatimEnvironment{Soutput}{Verbatim}{ fontfamily=tt, %%fontseries=b, %% xleftmargin=2em, formatcom={\color{darkred}} } \DefineVerbatimEnvironment{Scode}{Verbatim}{ fontfamily=tt, %%fontseries=b, %% xleftmargin=2em, formatcom={\color{blue}} } \fvset{listparameters={\setlength{\topsep}{-2pt}}} \renewenvironment{Schunk}{\linespread{.90}}{} \maketitle \tableofcontents @ <>= options(prompt = "R> ", continue = "+ ", width = 80, useFancyQuotes=FALSE) dir.create("figures") @ %def %% useFancyQuotes = FALSE @ <>= library(pbkrtest) @ %def \section{Introduction} The \code{shoes} data is a list of two vectors, giving the wear of shoes of materials A and B for one foot each of ten boys. @ <<>>= data(shoes, package="MASS") shoes @ %def A plot clearly reveals that boys wear their shoes differently. @ <>= plot(A~1, data=shoes, col="red",lwd=2, pch=1, ylab="wear", xlab="boy") points(B~1, data=shoes, col="blue", lwd=2, pch=2) points(I((A+B)/2)~1, data=shoes, pch="-", lwd=2) @ %def One option for testing the effect of materials is to make a paired $t$--test. The following forms are equivalent: @ <<>>= r1<-t.test(shoes$A, shoes$B, paired=T) r2<-t.test(shoes$A-shoes$B) r1 @ %def To work with data in a mixed model setting we create a dataframe, and for later use we also create an imbalanced version of data: @ <<>>= boy <- rep(1:10,2) boyf<- factor(letters[boy]) mat <- factor(c(rep("A", 10), rep("B",10))) ## Balanced data: shoe.b <- data.frame(wear=unlist(shoes), boy=boy, boyf=boyf, mat=mat) head(shoe.b) ## Imbalanced data; delete (boy=1, mat=1) and (boy=2, mat=b) shoe.i <- shoe.b[-c(1,12),] @ %def We fit models to the two datasets: @ <<>>= lmm1.b <- lmer( wear ~ mat + (1|boyf), data=shoe.b ) lmm0.b <- update( lmm1.b, .~. - mat) lmm1.i <- lmer( wear ~ mat + (1|boyf), data=shoe.i ) lmm0.i <- update(lmm1.i, .~. - mat) @ %def The asymptotic likelihood ratio test shows stronger significance than the $t$--test: @ <<>>= anova( lmm1.b, lmm0.b, test="Chisq" ) ## Balanced data anova( lmm1.i, lmm0.i, test="Chisq" ) ## Imbalanced data @ %def \section{Kenward--Roger approach} \label{sec:kenw-roger-appr} The Kenward--Roger approximation is exact for the balanced data in the sense that it produces the same result as the paired $t$--test. @ <<>>= ( kr.b<-KRmodcomp(lmm1.b, lmm0.b) ) @ %def @ <<>>= summary( kr.b ) @ %def Relevant information can be retrieved with @ <<>>= getKR(kr.b, "ddf") @ %def For the imbalanced data we get @ <<>>= ( kr.i<-KRmodcomp(lmm1.i, lmm0.i) ) @ %def Notice that this result is similar to but not identical to the paired $t$--test when the two relevant boys are removed: @ <<>>= shoes2 <- list(A=shoes$A[-(1:2)], B=shoes$B[-(1:2)]) t.test(shoes2$A, shoes2$B, paired=T) @ %def \section{Parametric bootstrap} \label{sec:parametric-bootstrap} Parametric bootstrap provides an alternative but many simulations are often needed to provide credible results (also many more than shown here; in this connection it can be useful to exploit that computings can be made en parallel, see the documentation): @ <<>>= ( pb.b <- PBmodcomp(lmm1.b, lmm0.b, nsim=500) ) @ %def @ <<>>= summary( pb.b ) @ %def For the imbalanced data, the result is similar to the result from the paired $t$ test. @ <<>>= ( pb.i<-PBmodcomp(lmm1.i, lmm0.i, nsim=500) ) @ %def @ <<>>= summary( pb.i ) @ %def \appendix \section{Matrices for random effects} \label{sec:matr-rand-effects} The matrices involved in the random effects can be obtained with @ <<>>= shoe3 <- subset(shoe.b, boy<=5) shoe3 <- shoe3[order(shoe3$boy), ] lmm1 <- lmer( wear ~ mat + (1|boyf), data=shoe3 ) str( SG <- get_SigmaG( lmm1 ), max=2) @ %def @ <<>>= round( SG$Sigma*10 ) @ %def @ <<>>= SG$G @ %def \end{document} % \section{With linear models} % \label{sec:with-linear-models} % @ % <<>>= % lm1.b <- lm( wear ~ mat + boyf, data=shoe.b ) % lm0.b <- update( lm1.b, .~. - mat ) % anova( lm1.b, lm0.b ) % @ %def % @ % <<>>= % lm1.i <- lm( wear ~ mat + boyf, data=shoedf2 ) % lm0.i <- update( lm1.i, .~. - mat ) % anova( lm1.i, lm0.i ) % @ %def pbkrtest/MD50000644000175100001440000000377612652216416012460 0ustar hornikusers1cc3511e0aca4590f38419db012a81db *ChangeLog 0c550e25633337b82e5cdc7e20dc7877 *DESCRIPTION 0306a0a3d6dc0db3544e99f5bd4a45f6 *NAMESPACE 095d4304dfdb9afe65964055f0c9a3c6 *R/KR-Sigma-G.R 517beb9d97fc352d9a9aac571f8868fa *R/KR-Sigma-G2.R 498eac93b07f4c2b4068065367d60a40 *R/KR-across-versions.R 24635d0316b7d29eed62b4d499806133 *R/KR-init-modcomp.R dd3f6abc8d455f7be0826d239087ee2d *R/KR-linearAlgebra.R 1c50e32260193f6e94d23fd0bfaf34d7 *R/KR-modcomp.R 9272ff49aa07069570dc7dad214495a9 *R/KR-utils.R 35cdc68286d1f62b176a968e1c452caa *R/KR-vcovAdj.R 3f503d0ce3991fa539779c5c40e3da48 *R/KR-vcovAdj0.R 70fc88a09d7436716a47284417b131d9 *R/KR-vcovAdj15.R 00125b47d5c5666662acf4c2ebf7964e *R/KR-vcovAdj16.R 3ab1296598838e3cfd4844dbcca93b71 *R/PB-anova.R 51703277da128543d0b093b203d9a384 *R/PB-modcomp.R 92cfbf0de34a9d4ca0270a20ae615ca5 *R/PB-refdist.R d1e99cab83c891b9ed7677b155dc7a75 *R/PB-utils.R 57261f1a816a21cdd8c3015b6ea31fb9 *R/getKR.R f94cfa91eb479040e506ff05b7998f1f *R/get_ddf_Lb.R 0873d0a74e11a97e989813c4eb09cdee *R/modelCoercion.R 9a164a80859cf6612a80bb42f1c9e24d *build/vignette.rds d3f24c25654cfe9f89d758c3d37fc9ec *data/beets.txt.gz ca79449a9762e1884e18b4849bf5e4ed *data/budworm.txt.gz 6df259258a0503209da79d379f74c283 *inst/CITATION 0744819ce2231310e601c6d81d5e5b03 *inst/doc/pbkrtest-introduction.R 3c66cc717f0d3eeeff84ea73a99449ad *inst/doc/pbkrtest-introduction.Rnw e062fe1840adfdc11ebf4460ef03ac0c *inst/doc/pbkrtest-introduction.pdf 5fe2a5261aa8b6f2fd34d34908339c31 *man/DATA-beets.Rd 2f13b620f86eb546893a70c6175749a4 *man/DATA-budworm.Rd 38acefe47726a381d69fe03bdd91efaa *man/KRmodcomp.Rd 4e970ed7b3b744ac17c3000db01e2c08 *man/PBmodcomp.Rd af9382653678b7befdf4d7c5afde4d0a *man/PBrefdist.Rd acfb054c9c54a9bf7ed88f743a9e5aa5 *man/getKR.Rd 567951fbb123bf4ed262f6c654de688b *man/get_ddf_Lb.Rd b16a5778e8649a0213b3116a13cb6c4e *man/model2restrictionMatrix.Rd 79ef4444fb428a24ed99ad2638494b4f *man/pbkrtest-internal.Rd df0a247e38bb1fee3b0de0cd6470bca3 *man/vcovAdj.Rd 3c66cc717f0d3eeeff84ea73a99449ad *vignettes/pbkrtest-introduction.Rnw pbkrtest/build/0000755000175100001440000000000012652165060013230 5ustar hornikuserspbkrtest/build/vignette.rds0000644000175100001440000000033212652165060015565 0ustar hornikusersb```b`fbf"fa @ % JRKt3JSJK2cUhS(W)#Ξ4480XD90!icKM-F3% 5/$~hZ8S+`zP԰Aհe ,s\ܠL t7`~΢r=xA$Gs=ʕXVr7~5Hpbkrtest/DESCRIPTION0000644000175100001440000000164012652216416013642 0ustar hornikusersPackage: pbkrtest Version: 0.4-6 Title: Parametric Bootstrap and Kenward Roger Based Methods for Mixed Model Comparison Author: Ulrich Halekoh Sren Hjsgaard Maintainer: Sren Hjsgaard Description: Test in mixed effects models. . Attention is on mixed effects models as implemented in the 'lme4' package. . This package implements a parametric bootstrap test and a Kenward Roger modification of F-tests for linear mixed effects models and a parametric bootstrap test for generalized linear mixed models. URL: http://people.math.aau.dk/~sorenh/software/pbkrtest/ Depends: R (>= 3.2.3), lme4 (>= 1.1.10) Imports: Matrix (>= 1.2.3), parallel, MASS, methods Suggests: gplots Encoding: latin1 ZipData: no License: GPL (>= 2) NeedsCompilation: no Packaged: 2016-01-27 16:02:56 UTC; sorenh Repository: CRAN Date/Publication: 2016-01-27 20:39:58 pbkrtest/ChangeLog0000644000175100001440000001125612652154724013715 0ustar hornikusers2016-01-27 Sren Hjsgaard * Update of description file with correct version requirement. * Version 0.4-6 uploaded 2016-01-12 Sren Hjsgaard * Tunings of vcovAdj in an attempt to gain speed in larger problems. * Illustrated in man page how to mimic vcov using parametric bootstrap. * Updates of man pages * Version 0.4-5 uploaded 2015-12-11 Sren Hjsgaard * Updates to comply with R-devel * Version 0.4-4 uploaded 2015-07-12 Sren Hjsgaard * Updated explanation about the samples that are not used in PBmodcomp. * Bug fixed in calculating denominator degrees of freedom (ddf) for the F-test * Version 0.4-3 uploaded 2014-11-11 Sren Hjsgaard * Package no longer Depend(s) on MASS * Version 0.4-2 uploaded 2014-09-08 Sren Hjsgaard * vcovAdj was very slow on large problems. Thanks to John Fox for notification. Reason was that chol and chol2inv was not imported from the Matrix package. Fixed now. * get_Lb_ddf function and method for linear mixed models added. * Lb_ddf function added * Version 0.4-1 uploaded 2014-08-11 Sren Hjsgaard * Extended documentation of PBmodcomp * model2restrictionMatrix and restrictionMatrix2model functions have been added. * CITATION file added; references updated to include JSS paper * Version 0.4-0 uploaded 2013-11-19 Sren Hjsgaard * get_ddf_Lb and ddf_Lb functions added. They provide adjusted degrees of freedom for testing L'beta=0 * Version 0.3-8 uploaded 2013-09-26 Sren Hjsgaard * Major reorganizing of KR-related code; preparing for the new version of lme4 getting on CRAN * Package no longer Depends on Matrix, but Imports instead * Version 0.3-6 uploaded 2013-07-03 Sren Hjsgaard * Plot method for parametric bootstrap tests improved * Vignette improved * Version 0.3-5 uploaded 2012-12-03 Ulrich Halekoh * .get_indices() corrected nn.groupFaclevels the number of the levels for each random-term-factor was erroneoulsy only returned once if a grouping factor occurred several times as in (1|Subject) + (0+Days|Subject) * furthermore, the calculation of the number of random-term-factors n.groupFac was rolled back, due to an inconsistency in its definition via (getME(model,'n_rtrms') which yieled for the above random term 2 (CRAN) and 1 (FORGE) * compiled to Version 0.3-4 2012-11-20 Ulrich Halekoh * LMM_Sigma_G() added. Computes Sigma and the components of G * vcovAdj() rewritten for correct extraction of the submatrices of Zt for random effects for different grouping factors. * getKR function for extracting slots from KRmodcomp object * compiled to Version 0.3-3 2012-08-25 Sren Hjsgaard * Now uses the parallel package instead of snow * seed can be supplied to the random number generator * Version 0.3-2 uploaded. 2012-04-24 Sren Hjsgaard * Version 0.3-1 uploaded. 2012-02-26 Ulrich Halekoh * function vcovAdj() refits the large model if fitted with REML=FALSE and prints a warning * function KRmodcomp() refits the large model if fitted with REML=FALSE and prints a warning 2012-02-26 Ulrich Halekoh * function for linear algebra .fatBL changed to .matrixNullSpace and improved * function for linear algebra: .orthComplement simplified * function for linear algebra added .colSpaceCompare 2011-02-17 Sren Hjsgaard * Parametric bootstrap methods for lm/glm added * Minor changes in KR-code to meet requests of John Fox * Version 0.3.0 uploaded. 2011-01-17 Sren Hjsgaard * F-distribution estimate of reference distribution for parametric bootstrap corrected. * Version 0.2.1 uploaded. 2011-12-30 Sren Hjsgaard * F-distribution estimate of reference distribution for parametric bootstrap added. * Version 0.2.0 uploaded. 2011-12-08 Sren Hjsgaard * Density estimate of reference distribution for parametric bootstrap added. * Version 0.1.3 uploaded. 2011-12-03 Sren Hjsgaard * Important speedup of KRmodcomp * Version 0.1.2 uploaded. 2011-11-11 Sren Hjsgaard * Various changes * Version 0.1.1 uploaded 2011-10-23 Sren Hjsgaard * Version 0.1.0 uploaded pbkrtest/man/0000755000175100001440000000000012645172534012712 5ustar hornikuserspbkrtest/man/vcovAdj.Rd0000644000175100001440000000507412645154365014605 0ustar hornikusers\name{vcovAdj} \alias{vcovAdj} \alias{vcovAdj.lmerMod} \alias{vcovAdj_internal} \alias{vcovAdj0} \alias{vcovAdj2} \alias{vcovAdj.mer} \alias{LMM_Sigma_G} \alias{get_SigmaG} \alias{get_SigmaG.lmerMod} \alias{get_SigmaG.mer} \title{ Ajusted covariance matrix for linear mixed models according to Kenward and Roger } \description{ Kenward and Roger (1997) describbe an improved small sample approximation to the covariance matrix estimate of the fixed parameters in a linear mixed model. } \usage{ vcovAdj(object, details=0) LMM_Sigma_G(object, details=0) } \arguments{ \item{object}{An \code{lmer} model} \item{details}{If larger than 0 some timing details are printed.} } \value{ \item{phiA}{the estimated covariance matrix, this has attributed P, a list of matrices used in \code{KR_adjust} and the estimated matrix W of the variances of the covariance parameters of the random effetcs} \item{SigmaG}{list: Sigma: the covariance matrix of Y; G: the G matrices that sum up to Sigma; n.ggamma: the number (called M in the article) of G matrices) } } \references{ Ulrich Halekoh, Sren Hjsgaard (2014)., A Kenward-Roger Approximation and Parametric Bootstrap Methods for Tests in Linear Mixed Models - The R Package pbkrtest., Journal of Statistical Software, 58(10), 1-30., \url{http://www.jstatsoft.org/v59/i09/} Kenward, M. G. and Roger, J. H. (1997), \emph{Small Sample Inference for Fixed Effects from Restricted Maximum Likelihood}, Biometrics 53: 983-997. } \note{ If $N$ is the number of observations, then the \code{vcovAdj()} function involves inversion of an $N x N$ matrix, so the computations can be relatively slow. } \author{ Ulrich Halekoh \email{uhalekoh@health.sdu.dk}, Soren Hojsgaard \email{sorenh@math.aau.dk} } \seealso{ \code{\link{getKR}} \code{\link{KRmodcomp}} \code{\link{lmer}} \code{\link{PBmodcomp}} \code{\link{vcovAdj}} } \examples{ fm1 <- lmer(Reaction ~ Days + (Days|Subject), sleepstudy) ## Here the adjusted and unadjusted covariance matrices are identical, ## but that is not generally the case v1 <- vcov(fm1) v2 <- vcovAdj(fm1,detail=0) v2 / v1 ## For comparison, an alternative estimate of the variance-covariance ## matrix is based on parametric bootstrap (and this is easily ## parallelized): \dontrun{ nsim <- 100 sim <- simulate(fm.ml, nsim) B <- lapply(sim, function(newy) try(fixef(refit(fm.ml, newresp=newy)))) B <- do.call(rbind, B) v3 <- cov.wt(B)$cov v2/v1 v3/v1 } } \keyword{function} pbkrtest/man/PBrefdist.Rd0000644000175100001440000000664412625603622015070 0ustar hornikusers\name{PBrefdist} \alias{PBrefdist} \alias{PBrefdist.mer} \alias{PBrefdist.merMod} \alias{PBrefdist.lm} %- Also NEED an '\alias' for EACH other topic documented here. \title{ Calculate reference distribution using parametric bootstrap } \description{ Calculate reference distribution of likelihood ratio statistic in mixed effects models using parametric bootstrap } \usage{ PBrefdist(largeModel, smallModel, nsim = 1000, seed=NULL, cl = NULL, details = 0) %\method{PBrefdist}{lm}(largeModel, smallModel, nsim = 1000, seed=NULL, cl = NULL, details = 0) %\method{PBrefdist}{mer}(largeModel, smallModel, nsim = 1000, seed=NULL, cl = NULL, details = 0) %\method{PBrefdist}{merMod}(largeModel, smallModel, nsim = 1000, seed=NULL, cl = NULL, details = 0) } %- maybe also 'usage' for other objects documented here. \arguments{ \item{largeModel}{ A linear mixed effects model as fitted with the \code{lmer()} function in the \pkg{lme4} package. This model muse be larger than \code{smallModel} (see below). } \item{smallModel}{ A linear mixed effects model as fitted with the \code{lmer()} function in the \pkg{lme4} package. This model muse be smaller than \code{largeModel} (see above). } \item{nsim}{ The number of simulations to form the reference distribution. } \item{seed}{ Seed for the random number generation. } \item{cl}{ A vector identifying a cluster; used for calculating the reference distribution using several cores. See examples below. } \item{details}{ The amount of output produced. Mainly relevant for debugging purposes. } } \details{ The model \code{object} must be fitted with maximum likelihood (i.e. with \code{REML=FALSE}). If the object is fitted with restricted maximum likelihood (i.e. with \code{REML=TRUE}) then the model is refitted with \code{REML=FALSE} before the p-values are calculated. Put differently, the user needs not worry about this issue. } \value{ A numeric vector } %\references{ %% ~put references to the literature/web site here ~ %} \references{ Ulrich Halekoh, Sren Hjsgaard (2014)., A Kenward-Roger Approximation and Parametric Bootstrap Methods for Tests in Linear Mixed Models - The R Package pbkrtest., Journal of Statistical Software, 58(10), 1-30., \url{http://www.jstatsoft.org/v59/i09/} } \author{ Soren Hojsgaard \email{sorenh@math.aau.dk} } %\note{ %% ~~further notes~~ %} %% ~Make other sections like Warning with \section{Warning }{....} ~ \seealso{ \code{\link{PBmodcomp}}, % \code{\link{BCmodcomp}}, % \code{\link{makePBcluster}}, % \code{\link{stopPBcluster}}, \code{\link{KRmodcomp}} } \examples{ data(beets) head(beets) beet0<-lmer(sugpct~block+sow+harvest+(1|block:harvest), data=beets, REML=FALSE) beet_no.harv <- update(beet0, .~.-harvest) rr <- PBrefdist(beet0, beet_no.harv, nsim=20) rr ## Note clearly many more than 10 simulations must be made in practice. ## Computations can be made in parallel using several processors: \dontrun{ cl <- makeSOCKcluster(rep("localhost", 4)) clusterEvalQ(cl, library(lme4)) clusterSetupSPRNG(cl) rr <- PBrefdist(beet0, beet_no.harv, nsim=20) stopCluster(cl) } ## Above, 4 cpu's are used and 5 simulations are made on each cpu. } % Add one or more standard keywords, see file 'KEYWORDS' in the % R documentation directory. \keyword{utilities} \keyword{models} pbkrtest/man/DATA-beets.Rd0000644000175100001440000000333611662303761015013 0ustar hornikusers\name{beets} \alias{beets} \docType{data} \title{ Yield and sugar percentage in sugar beets from a split plot experiment. } \description{ Data is obtained from a split plot experiment. There are 3 blocks and in each of these the harvest time defines the "whole plot" and the sowing time defines the "split plot". Each plot was \eqn{25 m^2} and the yield is recorded in kg. See 'details' for the experimental layout. } \usage{data(beets)} \format{ The format is: chr "beets" } \details{ \preformatted{ Experimental plan Sowing times 1 4. april 2 12. april 3 21. april 4 29. april 5 18. may Harvest times 1 2. october 2 21. october Plot allocation: Block 1 Block 2 Block 3 +-----------|-----------|-----------+ Plot | 1 1 1 1 1 | 2 2 2 2 2 | 1 1 1 1 1 | Harvest time 1-15 | 3 4 5 2 1 | 3 2 4 5 1 | 5 2 3 4 1 | Sowing time |-----------|-----------|-----------| Plot | 2 2 2 2 2 | 1 1 1 1 1 | 2 2 2 2 2 | Harvest time 16-30 | 2 1 5 4 3 | 4 1 3 2 5 | 1 4 3 2 5 | Sowing time +-----------|-----------|-----------+ } } %\source{ %% ~~ reference to a publication or URL from which the data were obtained ~~ %} %\references{ %% ~~ possibly secondary sources and usages ~~ %} \examples{ data(beets) ## maybe str(beets) ; plot(beets) ... beets$bh <- with(beets, interaction(block, harvest)) summary(aov(yield~block+sow+harvest+Error(bh), beets)) summary(aov(sugpct~block+sow+harvest+Error(bh), beets)) } \keyword{datasets} pbkrtest/man/PBmodcomp.Rd0000644000175100001440000001747512645172534015077 0ustar hornikusers\name{PBmodcomp} \alias{PBmodcomp} \alias{PBmodcomp.lm} \alias{PBmodcomp.merMod} \alias{getLRT} \alias{getLRT.lm} \alias{getLRT.merMod} \alias{plot.XXmodcomp} \alias{PBmodcomp.mer} \alias{getLRT.mer} %- Also NEED an '\alias' for EACH other topic documented here. \title{ Model comparison using parametric bootstrap methods. } \description{ Model comparison of nested models using parametric bootstrap methods. Implemented for some commonly applied model types. } \usage{ PBmodcomp(largeModel, smallModel, nsim = 1000, ref = NULL, seed=NULL, cl = NULL, details = 0) } %- maybe also 'usage' for other objects documented here. \arguments{ \item{largeModel}{ A model object. Can be a linear mixed effects model or generalized linear mixed effects model (as fitted with \code{lmer()} and \code{glmer()} function in the \pkg{lme4} package) or a linear normal model or a generalized linear model. The \code{largeModel} must be larger than \code{smallModel} (see below). } \item{smallModel}{ A model of the same type as \code{largeModel} or a restriction matrix. } \item{nsim}{ The number of simulations to form the reference distribution. } \item{ref}{ Vector containing samples from the reference distribution. If NULL, this vector will be generated using PBrefdist(). } \item{seed}{ A seed that will be passed to the simulation of new datasets. } \item{cl}{ A vector identifying a cluster; used for calculating the reference distribution using several cores. See examples below. } \item{details}{ The amount of output produced. Mainly relevant for debugging purposes. } } \details{ The model \code{object} must be fitted with maximum likelihood (i.e. with \code{REML=FALSE}). If the object is fitted with restricted maximum likelihood (i.e. with \code{REML=TRUE}) then the model is refitted with \code{REML=FALSE} before the p-values are calculated. Put differently, the user needs not worry about this issue. Under the fitted hypothesis (i.e. under the fitted small model) \code{nsim} samples of the likelihood ratio test statistic (LRT) are generetated. Then p-values are calculated as follows: LRT: Assuming that LRT has a chi-square distribution. PBtest: The fraction of simulated LRT-values that are larger or equal to the observed LRT value. Bartlett: A Bartlett correction is of LRT is calculated from the mean of the simulated LRT-values Gamma: The reference distribution of LRT is assumed to be a gamma distribution with mean and variance determined as the sample mean and sample variance of the simulated LRT-values. F: The LRT divided by the number of degrees of freedom is assumed to be F-distributed, where the denominator degrees of freedom are determined by matching the first moment of the reference distribution. } %\value{ % ## To be added... %} %\references{ % ## To be added... %} \references{ Ulrich Halekoh, Sren Hjsgaard (2014)., A Kenward-Roger Approximation and Parametric Bootstrap Methods for Tests in Linear Mixed Models - The R Package pbkrtest., Journal of Statistical Software, 58(10), 1-30., \url{http://www.jstatsoft.org/v59/i09/} } \author{ Soren Hojsgaard \email{sorenh@math.aau.dk} } \note{It can happen that some values of the LRT statistic in the reference distribution are negative. When this happens one will see that the number of used samples (those where the LRT is positive) are reported (this number is smaller than the requested number of samples). In theory one can not have a negative value of the LRT statistic but in practice on can: We speculate that the reason is as follows: We simulate data under the small model and fit both the small and the large model to the simulated data. Therefore the large model represents - by definition - an overfit; the model has superfluous parameters in it. Therefore the fit of the two models will for some simulated datasets be very similar resulting in similar values of the log-likelihood. There is no guarantee that the the log-likelihood for the large model in practice always will be larger than for the small (convergence problems and other numerical issues can play a role here). To look further into the problem, one can use the \code{PBrefdist()} function for simulating the reference distribution (this reference distribution can be provided as input to \code{PBmodcomp()}). Inspection sometimes reveals that while many values are negative, they are numerically very small. In this case one may try to replace the negative values by a small positive value and then invoke \code{PBmodcomp()} to get some idea about how strong influence there is on the resulting p-values. (The p-values get smaller this way compared to the case when only the originally positive values are used). } %% ~Make other sections like Warning with \section{Warning }{....} ~ \seealso{ \code{\link{KRmodcomp}} \code{\link{PBrefdist}} } \examples{ data(beets, package="pbkrtest") head(beets) ## Linear mixed effects model: sug <- lmer(sugpct ~ block + sow + harvest + (1|block:harvest), data=beets, REML=FALSE) sug.h <- update(sug, .~. -harvest) sug.s <- update(sug, .~. -sow) anova(sug, sug.h) PBmodcomp(sug, sug.h, nsim=50) anova(sug, sug.h) PBmodcomp(sug, sug.s, nsim=50) ## Linear normal model: sug <- lm(sugpct ~ block + sow + harvest, data=beets) sug.h <- update(sug, .~. -harvest) sug.s <- update(sug, .~. -sow) anova(sug, sug.h) PBmodcomp(sug, sug.h, nsim=50) anova(sug, sug.s) PBmodcomp(sug, sug.s, nsim=50) ## Generalized linear model counts <- c(18,17,15,20,10,20,25,13,12) outcome <- gl(3,1,9) treatment <- gl(3,3) d.AD <- data.frame(treatment, outcome, counts) head(d.AD) glm.D93 <- glm(counts ~ outcome + treatment, family = poisson()) glm.D93.o <- update(glm.D93, .~. -outcome) glm.D93.t <- update(glm.D93, .~. -treatment) anova(glm.D93, glm.D93.o, test="Chisq") PBmodcomp(glm.D93, glm.D93.o, nsim=50) anova(glm.D93, glm.D93.t, test="Chisq") PBmodcomp(glm.D93, glm.D93.t, nsim=50) ## Generalized linear mixed model (it takes a while to fit these) \dontrun{ (gm1 <- glmer(cbind(incidence, size - incidence) ~ period + (1 | herd), data = cbpp, family = binomial)) (gm2 <- update(gm1, .~.-period)) anova(gm1, gm2) PBmodcomp(gm1, gm2) } \dontrun{ (fmLarge <- lmer(Reaction ~ Days + (Days|Subject), sleepstudy)) ## removing Days (fmSmall <- lmer(Reaction ~ 1 + (Days|Subject), sleepstudy)) anova(fmLarge, fmSmall) PBmodcomp(fmLarge, fmSmall) ## The same test using a restriction matrix L<-cbind(0,1) PBmodcomp(fmLarge, L) ## Vanilla PBmodcomp(beet0, beet_no.harv, nsim=1000) ## Simulate reference distribution separately: refdist <- PBrefdist(beet0, beet_no.harv, nsim=1000) PBmodcomp(beet0, beet_no.harv, ref=refdist) ## Do computations with multiple processors: ## Number of cores: (nc <- detectCores()) ## Create clusters cl <- makeCluster(rep("localhost", nc)) ## Then do: PBmodcomp(beet0, beet_no.harv, cl=cl) ## Or in two steps: refdist <- PBrefdist(beet0, beet_no.harv, nsim=1000, cl=cl) PBmodcomp(beet0, beet_no.harv, ref=refdist) ## It is recommended to stop the clusters before quitting R: stopCluster(cl) } } % Add one or more standard keywords, see file 'KEYWORDS' in the % R documentation directory. \keyword{utilities} \keyword{models}% __ONLY ONE__ keyword per line \keyword{inference} %\method{PBmodcomp}{lm}(largeModel, smallModel, nsim = 1000, ref = NULL, cl = NULL, details = 0) %\method{PBmodcomp}{mer}(largeModel, smallModel, nsim = 1000, ref = NULL, cl = NULL, details = 0) %\method{PBmodcomp}{lmerMod}(largeModel, smallModel, nsim = 1000, ref = NULL, cl = NULL, details = 0) pbkrtest/man/KRmodcomp.Rd0000644000175100001440000000761212645154570015102 0ustar hornikusers\name{KenwardRoger} \alias{KRmodcomp} \alias{KRmodcomp.lmerMod} \alias{KRmodcomp_internal} \alias{KRmodcomp.mer} \title{Ftest and degrees of freedom based on Kenward-Roger approximation} \description{ An approximate F-test based on the Kenward-Roger approach. } \usage{ KRmodcomp(largeModel, smallModel, betaH=0, details=0) %%\method{KRmodcomp}{mer}(largeModel, smallModel, betaH=0, details=0) \method{KRmodcomp}{lmerMod}(largeModel, smallModel, betaH=0, details=0) } \arguments{ \item{largeModel}{An \code{lmer} model} \item{smallModel}{An \code{lmer} model or a restriction matrix} \item{betaH}{A number or a vector of the beta of the hypothesis, e.g. L beta=L betaH. betaH=0 if modelSmall is a model not a restriction matrix.} \item{details}{If larger than 0 some timing details are printed.} \item{\dots}{Additional arguments to print function} } \details{ The model \code{object} must be fitted with restricted maximum likelihood (i.e. with \code{REML=TRUE}). If the object is fitted with maximum likelihood (i.e. with \code{REML=FALSE}) then the model is refitted with \code{REML=TRUE} before the p-values are calculated. Put differently, the user needs not worry about this issue. An F test is calculated according to the approach of Kenward and Roger (1997). The function works for linear mixed models fitted with the \code{lmer} function of the \pkg{lme4} package. Only models where the covariance structure is a sum of known matrices can be compared. The \code{largeModel} may be a model fitted with \code{lmer} either using \code{REML=TRUE} or \code{REML=FALSE}. The \code{smallModel} can be a model fitted with \code{lmer}. It must have the same covariance structure as \code{largeModel}. Furthermore, its linear space of expectation must be a subspace of the space for \code{largeModel}. The model \code{smallModel} can also be a restriction matrix \code{L} specifying the hypothesis \eqn{L \beta = L \beta_H}, where \eqn{L} is a \eqn{k \times p}{k X p} matrix and \eqn{\beta} is a \eqn{p} column vector the same length as \code{fixef(largeModel)}. The \eqn{\beta_H} is a \eqn{p} column vector. Notice: if you want to test a hypothesis \eqn{L \beta = c} with a \eqn{k} vector \eqn{c}, a suitable \eqn{\beta_H} is obtained via \eqn{\beta_H=L c} where \eqn{L_n} is a g-inverse of \eqn{L}. Notice: It cannot be guaranteed that the results agree with other implementations of the Kenward-Roger approach! } \references{ Ulrich Halekoh, Sren Hjsgaard (2014)., A Kenward-Roger Approximation and Parametric Bootstrap Methods for Tests in Linear Mixed Models - The R Package pbkrtest., Journal of Statistical Software, 58(10), 1-30., \url{http://www.jstatsoft.org/v59/i09/} Kenward, M. G. and Roger, J. H. (1997), \emph{Small Sample Inference for Fixed Effects from Restricted Maximum Likelihood}, Biometrics 53: 983-997. } \note{ This functionality is not thoroughly tested and should be used with care. Please do report bugs etc. } \author{ Ulrich Halekoh \email{ulrich.halekoh@agrsci.dk}, Soren Hojsgaard \email{sorenh@math.aau.dk} } \seealso{ \code{\link{getKR}} \code{\link{lmer}} \code{\link{vcovAdj}} \code{\link{PBmodcomp}} } \examples{ (fmLarge <- lmer(Reaction ~ Days + (Days|Subject), sleepstudy)) ## removing Days (fmSmall <- lmer(Reaction ~ 1 + (Days|Subject), sleepstudy)) anova(fmLarge,fmSmall) KRmodcomp(fmLarge,fmSmall) ## The same test using a restriction matrix L <- cbind(0,1) KRmodcomp(fmLarge, L) ## Same example, but with independent intercept and slope effects: m.large <- lmer(Reaction ~ Days + (1|Subject) + (0+Days|Subject), data = sleepstudy) m.small <- lmer(Reaction ~ 1 + (1|Subject) + (0+Days|Subject), data = sleepstudy) anova(m.large, m.small) KRmodcomp(m.large, m.small) } \keyword{function} pbkrtest/man/model2restrictionMatrix.Rd0000644000175100001440000000550112403424041020020 0ustar hornikusers\name{model2restrictionMatrix} \alias{model2restrictionMatrix} \alias{model2restrictionMatrix.lm} \alias{model2restrictionMatrix.mer} \alias{model2restrictionMatrix.merMod} \alias{restrictionMatrix2model} \alias{restrictionMatrix2model.lm} \alias{restrictionMatrix2model.mer} \alias{restrictionMatrix2model.merMod} \title{ Conversion between a model object and a restriction matrix } \description{ Testing a small model under a large model corresponds imposing restrictions on the model matrix of the larger model and these restrictions come in the form of a restriction matrix. These functions converts a model to a restriction matrix and vice versa. %% ~~ A concise (1-5 lines) description of what the function does. ~~ } \usage{ model2restrictionMatrix(largeModel, smallModel) restrictionMatrix2model(largeModel, LL) } %- maybe also 'usage' for other objects documented here. \arguments{ \item{largeModel, smallModel}{ Model objects of the same "type". Possible types are linear mixed effects models and linear models (including generalized linear models) } \item{LL}{ A restriction matrix. } } %\details{ %% ~~ If necessary, more details than the description above ~~ %} \value{ model2restrictionMatrix: A restriction matrix. restrictionMatrix2model: A model object. } \references{ Ulrich Halekoh, Sren Hjsgaard (2014)., A Kenward-Roger Approximation and Parametric Bootstrap Methods for Tests in Linear Mixed Models - The R Package pbkrtest., Journal of Statistical Software, 58(10), 1-30., \url{http://www.jstatsoft.org/v59/i09/} } \author{ Ulrich Halekoh \email{uhalekoh@health.sdu.dk}, Soren Hojsgaard \email{sorenh@math.aau.dk} } \note{ That these functions are visible is a recent addition; minor changes may occur. } %% ~Make other sections like Warning with \section{Warning }{....} ~ \seealso{ \code{\link{PBmodcomp}}, \code{\link{PBrefdist}}, \code{\link{KRmodcomp}} } \examples{ library(pbkrtest) data("beets", package = "pbkrtest") sug <- lm(sugpct ~ block + sow + harvest, data=beets) sug.h <- update(sug, .~. - harvest) sug.s <- update(sug, .~. - sow) ## Construct restriction matrices from models L.h <- model2restrictionMatrix(sug, sug.h); L.h L.s <- model2restrictionMatrix(sug, sug.s); L.s ## Construct submodels from restriction matrices mod.h <- restrictionMatrix2model(sug, L.h); mod.h mod.s <- restrictionMatrix2model(sug, L.s); mod.s ## The models have the same fitted values plot(fitted(mod.h), fitted(sug.h)) plot(fitted(mod.s), fitted(sug.s)) ## and the same log likelihood logLik(mod.h) logLik(sug.h) logLik(mod.s) logLik(sug.s) } % Add one or more standard keywords, see file 'KEYWORDS' in the % R documentation directory. \keyword{utilities} \keyword{models}% __ONLY ONE__ keyword per line pbkrtest/man/pbkrtest-internal.Rd0000644000175100001440000000112312645136354016646 0ustar hornikusers\name{pbkrtest-internal} \alias{print.PBmodcomp} \alias{print.summaryPB} \alias{summary.PBmodcomp} \alias{plot.PBmodcomp} \alias{summary.KRmodcomp} \alias{print.KRmodcomp} \alias{get_ddf_Lb} \alias{get_ddf_Lb.lmerMod} \alias{ddf_Lb} \alias{KRmodcomp_init} \alias{KRmodcomp_init.lmerMod} \alias{vcovAdj15} \alias{vcovAdj15_internal} \alias{vcovAdj16} \alias{vcovAdj16_internal} \alias{KRmodcomp_init.mer} \alias{as.data.frame.XXmodcomp} %% This must go!! \title{Internal functions in the pbkrtest package} \description{ Internal functions called by other functions. } \keyword{internal} pbkrtest/man/getKR.Rd0000644000175100001440000000402312403424004014174 0ustar hornikusers\name{getKR} \alias{getKR} %- Also NEED an '\alias' for EACH other topic documented here. \title{ Extract (or "get") components from a \code{KRmodcomp} object. } \description{ Extract (or "get") components from a \code{KRmodcomp} object, which is the result of the \code{KRmodcomp} function. %% ~~ A concise (1-5 lines) description of what the function does. ~~ } \usage{ getKR(object, name = c("ndf", "ddf", "Fstat", "p.value", "F.scaling", "FstatU", "p.valueU", "aux")) } %- maybe also 'usage' for other objects documented here. \arguments{ \item{object}{ A \code{KRmodcomp} object, which is the result of the \code{KRmodcomp} function } \item{name}{ The available slots. If \code{name} is missing or \code{NULL} then everything is returned. } } %\details{ %% ~~ If necessary, more details than the description above ~~ %} %\value{ %% ~Describe the value returned %% If it is a LIST, use %% \item{comp1 }{Description of 'comp1'} %% \item{comp2 }{Description of 'comp2'} %% ... %} %\references{ %% ~put references to the literature/web site here ~ %} \references{ Ulrich Halekoh, Sren Hjsgaard (2014)., A Kenward-Roger Approximation and Parametric Bootstrap Methods for Tests in Linear Mixed Models - The R Package pbkrtest., Journal of Statistical Software, 58(10), 1-30., \url{http://www.jstatsoft.org/v59/i09/} } \author{ Soren Hojsgaard \email{sorenh@math.aau.dk} } %\note{ %% ~~further notes~~ %} %% ~Make other sections like Warning with \section{Warning }{....} ~ \seealso{ \code{\link{KRmodcomp}} \code{\link{PBmodcomp}} \code{\link{vcovAdj}} } \examples{ data(beets, package='pbkrtest') lg <- lmer(sugpct ~ block + sow + harvest + (1|block:harvest), data=beets, REML=FALSE) sm <- update(lg, .~. - harvest) xx<-KRmodcomp(lg, sm) getKR(xx, "ddf") # get denominator degrees of freedom. } % Add one or more standard keywords, see file 'KEYWORDS' in the % R documentation directory. \keyword{models} pbkrtest/man/get_ddf_Lb.Rd0000644000175100001440000000436112404140160015175 0ustar hornikusers\name{get_Lb_ddf} \alias{get_Lb_ddf} \alias{get_Lb_ddf.lmerMod} \alias{Lb_ddf} %- Also NEED an '\alias' for EACH other topic documented here. \title{ Adjusted denomintor degress freedom for linear estimate for linear mixed model. } \description{ Get adjusted denomintor degress freedom for testing Lb=0 in a linear mixed model where L is a restriction matrix. } \usage{ get_Lb_ddf(object, L) Lb_ddf(L, V0, Vadj) } %- maybe also 'usage' for other objects documented here. \arguments{ \item{object}{ A linear mixed model object. } \item{L}{ A vector with the same length as \code{fixef(object)} or a matrix with the same number of columns as the length of \code{fixef(object)} } \item{V0, Vadj}{ Unadjusted and adjusted covariance matrix for the fixed effects parameters. Undjusted covariance matrix is obtained with \code{vcov()} and adjusted with \code{vcovAdj()}. } } %\details{ %% ~~ If necessary, more details than the description above ~~ %} \value{ Adjusted degrees of freedom (adjusment made by a Kenward-Roger approximation). } \references{ Ulrich Halekoh, Sren Hjsgaard (2014)., A Kenward-Roger Approximation and Parametric Bootstrap Methods for Tests in Linear Mixed Models - The R Package pbkrtest., Journal of Statistical Software, 58(10), 1-30., \url{http://www.jstatsoft.org/v59/i09/} } \author{ Soren Hojsgaard, \email{sorenh@math.aau.dk} } %% \note{ %% %% ~~further notes~~ %% } %% ~Make other sections like Warning with \section{Warning }{....} ~ \seealso{ \code{\link{KRmodcomp}}, \code{\link{vcovAdj}}, \code{\link{model2restrictionMatrix}}, \code{\link{restrictionMatrix2model}} } \examples{ (fmLarge <- lmer(Reaction ~ Days + (Days|Subject), sleepstudy)) ## removing Days (fmSmall <- lmer(Reaction ~ 1 + (Days|Subject), sleepstudy)) anova(fmLarge,fmSmall) KRmodcomp(fmLarge,fmSmall) ## 17 denominator df's get_Lb_ddf(fmLarge, c(0,1)) ## 17 denominator df's # Notice: The restriction matrix L corresponding to the test above # can be found with L<-model2restrictionMatrix(fmLarge, fmSmall) L } % Add one or more standard keywords, see file 'KEYWORDS' in the % R documentation directory. \keyword{utilities} pbkrtest/man/DATA-budworm.Rd0000644000175100001440000000335111541752507015367 0ustar hornikusers\name{budworm} \alias{budworm} \non_function{} \title{Effect of Insecticide on survivial of tobacco budworms} \usage{data(budworm)} \description{ number of killed budworms exposed to an insecticide } \format{ This data frame contains 12 rows and 4 columns: \describe{ \item{sex:}{sex of the budworm} \item{dose:}{dose of the insecticide trans-cypermethrin in [\eqn{\mu}{mu}g]} \item{ndead:}{budworms killed in a trial} \item{ntotal:}{total number of budworms exposed per trial } } } \details{ mortality of the moth tobacco budworm 'Heliothis virescens' for 6 doses of the pyrethroid trans-cypermethrin differentiated with respect to sex } \source{ Collet, D. (1991) Modelling Binary Data, Chapman & Hall, London, Example 3.7 } \references{ Venables, W.N; Ripley, B.D.(1999) Modern Applied Statistics with S-Plus, Heidelberg, Springer, 3rd edition, chapter 7.2 } \examples{ data(budworm) #function to caclulate the empirical logits empirical.logit<- function(nevent,ntotal) { y<-log ((nevent+0.5)/(ntotal-nevent+0.5)) y } #plot the empirical logits against log-dose log.dose<-log(budworm$dose) emp.logit<-empirical.logit(budworm$ndead,budworm$ntotal) plot(log.dose,emp.logit,type='n',xlab='log-dose',ylab='emprirical logit') title('budworm: emprirical logits of probability to die ') male<-budworm$sex=='male' female<-budworm$sex=='female' lines(log.dose[male],emp.logit[male],type='b',lty=1,col=1) lines(log.dose[female],emp.logit[female],type='b',lty=2,col=2) legend(0.5,2,legend=c('male','female'),lty=c(1,2),col=c(1,2)) \dontrun{ * SAS example; data budworm; infile 'budworm.txt' firstobs=2; input sex dose ndead ntotal; run; } } \keyword{datasets}