pbkrtest/0000755000175100001440000000000013062171005012121 5ustar hornikuserspbkrtest/inst/0000755000175100001440000000000013061325022013075 5ustar hornikuserspbkrtest/inst/CITATION0000644000175100001440000000153113027411347014242 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, Søren Højsgaard (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/0000755000175100001440000000000013061325022013642 5ustar hornikuserspbkrtest/inst/doc/pbkrtest-introduction.Rnw0000644000175100001440000001202013061325022020702 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.R0000644000175100001440000001201113061325022020335 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.pdf0000644000175100001440000033277313061325022020731 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*܋\!q))pK,"2 9 l " Jqئ{ %+z2]%Whln׽U uo?XδQǶ J2"^@鋇7 AIV񜚾[}DN YN)Ґ,ᓶ'pp& /Cvo֖]uWvn~Fc4=Tݛu`s*qJ.'YE9/l}[V[rƖCGm Rv>]\y~2((u*l-Sui'i>t~y9xOS(!5>Ծ 2 q%|_GEsq7HVr:L(H؀˃]F T"Y67יIʞaB(1vFed!NDf٨O/kp^;.ϕ$~yw~DьyMxtCpccPc@|99='w~:릞O[9y.^ͧ4hvUw OYX-4=ctTb9,pr/kBE 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 1311 /Filter /FlateDecode >> stream xXMoFWɡS\I:4)PzhzXK($eHMVd-8ξ]yF89KŬmr003NG#"'d0>#>bH _Cɂt2ƂʙY> t\yPͽs5!=JiUޣ# $aPP,aH˰~LUᬯ/Ÿ/g9X{~UD^"Jn"7W'm8~ 9#lpcnW]umxyfcC0%*UWz\sGNOQ3*BU:wUZV΂m^*,- xH=[0t5WJ x(8G tPz|6͌qh,D- @y\<۠?w01m9y( 6h}ʘ9\?c7gW~ˍ 9[n/R|K,=Volk9Ѕ`NesfwIwИ0w鯭KtvZMbCg$iɀMBXcr Ibo $'[& ď~9xVð qQ-v̜OK'X\{:07ĈHrkBDbvH"1ЌA\ ۇQ_}X[?e4˧<[5r+kV>m(t-ޓ&@~Hzlr?!tZZ^[zU1L-/pWA6kQ+ʖ崮ө/#TN-A+tpDvlx16VS|6\g*-Id󮀂@M]C6;xG6T[Y&#D2_RRJ2S(_Pc endstream endobj 30 0 obj << /Length 1542 /Filter /FlateDecode >> stream xXmo6_a&w+)̀X xާdœyGJxw<>/LMk6Q0ـ.^ >KOk#Mf*d\%E6u~2,r@gA,^r,EK^~\&*}|Sk+Wuc 0hh`AJh!fB/И[j1W 8.fM11M"i1Y$DưAsޜ1%P=?bw?ʘFcmTTa?*ԫ3."Y4B_LKin !ZMvy]a*%a9Ӧy /nV@C(7ܷ;n]rs)Iot~;\?|}ϲl lDɽ1 :«tjVi"LZa"/K"2#08&.(At7yYgܙ,9)dXncV~f Eĭ^WizJwc*vY]^m>F|W(zH)R?P:4YWk 2-7x@a$YZ;cTȃ5I3֮ҢȎ]^[e@<<+Y'ϐe@q2}t{O!7J?H{I/u,(SK{EۼžFCyiCSk\iVUٔ^eI"K ) \>:&X"`^nu!L &#re;| H[6=W-vM(=Z!o| =~-.?ٝp.wvDӬ}yhSj,>C{(?xcH'^gl 8'])'CPbr1 *矏Lt8fX$XҢMTAKWҭ[Үqڲ|֍V+boV-u,#?)qJ֚1;IfVγ Xp,!ؐ DBD1,krWpcr@8۫9NkW&0X޲O%o`f>P$pܔs\69 W9-+~cYovM$eÆ%Mv20Z챵FXJD+le5^w:3- B{`vF˂Z-6 $EK+KU7B }I-)"Vc1qq/; endstream endobj 33 0 obj << /Length 1226 /Filter /FlateDecode >> stream xXmo6_atCHɀeX mˎ02$Mb}GT,-Ço_= k]=a #ʁd45n;!dwxJɀ` F30bDĈt0.G<,U=v,hl-#W6ψHfqULĂJ7VKY83/LN6qÍ*E8VY7aK:up~3U[?U*m_bbϞ߂nn'hJU'(M>FRqXKA7YO7|(!؏DZB[v9c]l0DպȴQ~pt,vz fYq 2{{1ڏ(X1*M (./j^qgϐS6{%TxW=$aA4Ŭ(7 >A:ɒtdG'‘ndB; oLl;Sĝg?}Q&KJ'鰂DadUljJ068ol_yjЕE\^ :Pwe}y'"qddHdwтV0}%Ih~tRK3P%A ءcV tt|oe_Kx9\{RFm#\^ȪjAXѵytSo&/&;B)OO}#1[H(bS+nSQѝ {)uksA^(ʇ)qL |_/]bR~WPţ*EeY*~z8<)K^`Zp LΠg1FSS^;{ & U RQJ-Ȕ"2R6"`>2uifۡrc\aX|>+uzy176 ACm3]U=jJ_rW!M,J*~4 ݇D[^YLTgw>>n'O6B崔R}xHBNI_V5Kj`29u:}ka+DuTE~qNټJ܁}Xq?4pJ41y_EHjҀ҂6xVs} endstream endobj 36 0 obj << /Length 619 /Filter /FlateDecode >> 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 37 0 obj << /Length 97 /Filter /FlateDecode >> stream x31ӳP0P0T06P0P05WH1* ̡2ɹ\N\ \@a.}O_T.}gC.}hCX.OȠl\=% endstream endobj 49 0 obj << /Length1 1825 /Length2 13612 /Length3 0 /Length 14758 /Filter /FlateDecode >> stream xڍPY-%Kp..w <;!GLWWT]ڲ+ lx²BL&&V&&8rre%v8rUƚ a{M(kc r09x9y,LL&D AY5\dj^ߟ*#j377'ݟA+= khzhd` P1+-# j: t;HXGP69ˡdcb`,AF@k'kc=:@IRh/̿ttEdg`08: X:ؼ8, nT+K=сdF?ҼD@@swcr-m\L@&0veT9%E⼛LLL\jdGe7[N?+imbW߹l'{еؙϐ)#u#1'K?T"V K6`T5VW} hmjc9\ G#˿*,%(oi331},ޟ|_.)jmdcǖ߰%#v;:]b#{]'`0 aq%F>'Q? (7b0*q3 F\Fÿ7?ŌFߐ彝wf2 L@`mdw? %߻GnߋsߟkWG9!]l~N]5FN ~@+niƈ߼ƿJυ~o Z5}#tX|ze};U_ fN),;'.${^qھ=Jiip0mYl9l04hȳ73hoDRѴp,sʔYpp4 oF(܅>-m|^ \V!Ƕ/#ӉN֕bjoj4!$q /7 *Ky?(ŨӶwvtxDb0[~FHx~Xj0%.!ltY+RCx]V[6C9yG:O/+''C؋(!*LIIGW_t,Jӹ60U &Of^;JWN΀:3?m&|w3xlxUpDb5u gVa-ce(R\d Ma̶|RƳ̝+.tI^&+H]/4%.RDrjRx6N}Tg`dh`g_5rځN02 v|1mzb"⤪?D=vjRy3J1r=\LK.sv!)Mx0K3l /&(DHBSqvL/G=R_2_˥w{B@g8c X(VHD8=l=+d=`Y+b ,Z0@qB*Y9*:K+iG۔2ڙ t\Τ{z#[x zC=бjoC. xx_Bsc~(KZRSHTD)xt:%]$֜2 "rmP?CKk&C@+_t'EdZ*?HdR!N0 kmbN}:9~{9NsgF Y%uD27d,-JK0sfvtm,ְ̩,4bJGC{|&*A4$qPCXihycֳtZvbÏW8U3KPmvH'h݊(N8gdY1@MIXZ&*=aԱHbUgR=ktr"FGz~E˗MN̬V}6ojT{LJHMTDP(DP-f@mQ2_g-1 a;zReP 5^mhƏ_Zy(#eȔw3,V =˼DOYE5(s#}^fJ xYOGsNx>5ot[B/w'O/NWU,m*>lqA}HO"'\-m`EM ~a3w1BewN%1%{!zle*J{=P  6bb3[ܯnc0V/ )LnSgؙ7R0j&`!{h)lUa G/IoApE10s#ޱPQ W64PX9󏠪@P3vP|8"1!%X^[DT͘ eC.rɝA@bK.R{ꮮ-͞  vpkO C.)udrm4mfR(E1Bh>^ocJ=t:." 6Ek/ @nmZt@ka~XP: ~Z!zЧuUr[C+G;% D54&GyGM[L7lW Tp1B[Wf,7 ~9tZ1zj#|$Vk=j3S16q`n;!KB?.;M}&vvKq\lSȝS" ܜ;yM]Chuz˖K4vS3vZd;"@NXJ?ʴE rC)J!s17kO&5W?7ّ9 if y@Xsg=!~g9j*CXB&T[1 ACș1F>y^Q?F@BLDQ,)1\M=bN :(z?/Xm6:s?ڥ2ipDO!iÒ~%#Ϣ ϑ+HkԻ9?ny}b`;q_O؂mkÆs# {p-X)#?N[D*<ԟIS(sI[r7؞(}q)Bz?6n0 * !ᔀ=\]Aq屽[k92twY MB+PYV^"/ / E'hrv"bX:JUǪąמYE3*L^8Zx:ׯ8V'9gh3%*$OXjRLi.~^ile 9/HCp^iFYBVG XJ),/4Dly;Z'Q#Z8dPQlVaBj|nCu,*#x/h>InFalITeoDh=E}Y)GKB8| ,Y-%/^!u9ʹM f]j{ UM E!8js^D]pݬi nĐRN>>q+eXlb4/? x{%su Du'67ﱤ}'$⋕O;nS0 "gjyyJ6[)QDRBd=ox0Nv[G[VӍyMT׏\030={Q :|6&^&1zKD5W:ErԱ&%Y%"oz 9cIG#iTJ 2EuWH^BJ2)<8\_pS36UC;_-9X%7ZV:OH X{88kf9шbo< aې;)Sc}r\(T)\<@46nyXlBA78{OgN=#f疸Oe,mu멜%1Rz…Ӭ\[}ݮojSgݢRZܝVQHӱS:WsU9䣲hsNc阏3q õC-BTޛOZj|M;8n+яLPŋOв}doƏe~;7s~ٷl񒤮&fU5Ҏ&p~ם8c5צ)LcEBXY^W;`rI3'=ј2]-s+@ZqF/j8+6]s[ERFyΗϦV!?hGu$HX5&HDyYں: 6s<_urD+0^;&<),oנUͫ gɶ> LEΘ/4rrHTvk0PSDm##C |Ou-^(;:/w|X?XÀ IqM|bq,2BAe 5W iGr,?\@.bOO :[-d8W/úQGŕãꦪIj퇩lj_ Zńkl|RIج~!!c"=@規0ä<Ã/`=rH]Of>F~ʫ蛆3ldHIb3W~Ln2IܒER;n:&@koQ9\78e&s~@HncAXaض7Q<@,C'n !{&%fV@ml#o-==DXб]cc]n*t~5^N X}ryaR)7 {W9/z "7!ϞN @ng{VHWG#1Ȋor~ h8uipOx6>7Cz{lR V\P8/{0q9Ή^{@',bnj1`Mw](gA۱tfM@]h?Vd=>K9 ݨA.+ 6"8G|o>:U#F }gEkX4,-HI{CrKIKJ?Ւ3ΠfͮabJE-C]L2°bw-)X'˗Qp<FrR]!QXx'n5,.Q)z4(ѬVvtMbN _idi}h}Wʱ4?gXc0Q3I{4fV +UIr_b퇧!dd=r|CSC„6˃hEYM mD|wAF{ig&+zPo;:ľ@M#]_X(6 tsZlRiYʢ-]|Ό֬:bYsUZ*#,l| fZ *4nf#QRWqCوOvv)H_Ľb˂/us(x 7D )> p#K@MI3Q41/ocC$f|L# 9Щ?)? ]f,oK0)t%C#"󑎡'׈IoW doͅ ,N]f2lf=Q}{mⅮd0<|{ŷ? Қcw+&_nF`Wr,cwlLa`fWo( 4ӗ _?ڛ|{o.M3:7h7`wsQ2+dsS"?CYYC33,z܆atkG{Z;BCy((|hҰ>[, і"p-T*@R9iFmn3nA )l`@|,C6}4l<<@>,llBmuW? ۥ*nｲf3 y@>#e%kb`^!cz8 !T,b(4[i0U+'G?+=* FSoTiזpb烶P,,PZmOl;a#ǂVZ N&H01^= ld ۥ=O#` JD{7IByڭG;:zyz5 +Ŕ w~ayJѸ~@gKS8pDizg;`)e %sytM`qh0=탧gtv_,$dlMBF^< O[g3js9_fKƀUD%D-v6%isl /C ޓ:$Ƅ)MMolnZb>;vfd[I&nG{ BVbY)}ѯlX+=9M~죇2%{6PLRˤTعv˔lNSS_dKtg⯕<ۣ,JpؖyR6Ū<=у ?Ⱥfz >ڒ`DuRZ.-gs0)ZwpE6PǘN˾yTÂPʪn[zL8/wx8pqImHIIldҒ,O2hP}kNfs^}]>2 L9J k5Lk[ DXQM& "d8Z\/ aZ1$dS.Or2UxAP%0o1HhzB9l]йu FsR 9P ,7騦]7Ïb`MQ'aOBQSu s~ OnSQk[jDLP##\<3peJ/Y!9-w;V_"?,G3i9c~ص巻_e3%:g:݅ddlkːCtq125k"!G0_` .dLCл^-܄@Zulp)zɌT1hh+!O߈ؽ-h ;Ne"yW8,9PLp9c Z~O:P_<O$i2/;tD%xKble-WU6'yYo7>"?ؖJ.};$0P*YR pVWQ섫9K‘HrȒ&Nj}Z>q;n3![t}cS p5ÝF wWǁ1qC`$@I`: _S' 0E凴l 'h bETDzl+%} lMޝmU']\937 LEAwbaY~hfҘ-S &'yxMiJݧY\Ylvb˼m2fV/N/y(מ$l[ wJMI*/tEX')!K<$MLyu8f` A{l 2<؂XC܏RiK7wfK\ר:J=j;^Nm8/#iok8fealXKMn7ʢ~#Q~l5OWon~>a6Ի ^ck)Qx}qH=PO!>f6շa+We܇I-M*?d.˘`_XSOdg] B#w{wFU7tkKW*_` 1^8$(T]@ldC3:ܲ ~DFJ\8lZfڒs!՜API48r0d56zfR.t`yc:u|wSE) wQ :ձw&_4dXɲGrdrpaQvB0zg{xOc=^:8o"7ʂ^IJL]F±̀rcF98+?u)V E9dkA^ok3*'`0ja!EC+qfĝ|-Y[O_@Dw0 C^grVfi5ɗg7 [Uն8LzR}ED,8AZm+ ֳ?(mw(dA-ߵHo6>x*_G !gUk}z975')G%=w덋{įiT܄2ku;BT2wB7>Tt[ܜ =pl-zP d͝}CZіIFt]­H;9g K:'vNh) wnQk' ~!# )I,k~!1A'EB'aSfMq,B0YޔwE99eD{U"bĬ{?X}m, #;wYc)CS0f&" "?AM>3kK$6ZJ,U`ĕa >{%hh$K[0PB)*gS{4e؋{6i ^{ +}Dܪ֌ngʤMYCs* `j|).*yOawyK>8:ޟnX.m*D侭ۓ0ca5ņer`,( [FͷJY(F!3Y7خa##WYme#Au:a) "MM8ϞX="*L :bƙao >údZG m+-e"f K@MNǗF~?RxE女e#/o 2z˜eyH~8gr'& 2q];Y/Qz G\ݯz<0} $zZh:@J0 [Yu:al'h1 C,Yn#42E]Έn#U29?#FnyXGO&%iwg}˴8U ur[*>W0|}z| TKԾ~Ae"]l__k~%D%z7[LHdp8K[+KLW;,37^V⢬(,VT"lMf.CDqBb!m/;"(3S,$YgTSq8UjHzΌ.sQe~si,|jM~Dp͕޷А`6(.|rᩢVgҪ_{vݥz1 T`m")/_/gEoqB4H6G/t$# kɱK"7 2'bj`M1]ZVp`& ߷)A5.%B`[܁ʴ]=5Z?k}~i:HPeLp7Ah`T<9mG8lCcehAg)A+"CIYg 4eAIqHGR,QQGzv~ŗL"iQ)ifzq& endstream endobj 51 0 obj << /Length1 1805 /Length2 11328 /Length3 0 /Length 12457 /Filter /FlateDecode >> stream xڍP- \B.%Khqw` 5Np}df{Uݽ^YP)1l!NLl̬q1m6v++3++;2:;2&l CtzI^ 5 `geց t#2hMl||<Dm@` tټT4ZlM 'JA+hd qdu0c, G {d"hTu 5[3'Wb /!S:@MFdIpll+w"0` <#1MZ;ھ]`k ց)Qe¿s4q992;;1KBLmml@'GI@&/ZAl]!Af`1LX4 `{g_?6sL,X~Pwdm~`2lzAtN o;!L&Nc9O3Or`7.?Q-W",!;lL\&v.6y`'Vbf ݗsO.iw.E]Yw#)gk??~ /Ƌr^@e Kb֦q(c;J@`'?]Y! e[G?2zy>_4 <]Rbbk{ع@;2닔عl/h rCfKe8o6x,#?)za*xY, v߈ XA|YL, K;/-Ey)e| 0d}0;e K/6J _%ߐ҇ݿK%JN8Y8r,N x9B˃Dz/2A^^5 j%reڙx7KB|HW9`Z4qsuKJd!J׃aN+C~$b&u]G{/M+fNYl{g^t7}n%_BvTv+PJf>jDQg;1 ca]]beM>1 {}`5Lݱ@ klSl?Ioѳ F6$`QhYMֹ,X2:}_ck:$DeJlZ-+p0Qc#|Cӱ2{hjo۠+ZaE%܁~>g_%v'nOq+sIibc!)(a Yq@ֳ4QWrc벝Ͻ&+DP_m,ګ8-肦,e!rjU bXce A5[]=vT_#/|gN1qk)sO.!M ^J:V =Z=C٧Ja\h\1yGltU}|}p::$6^&xAձ2z6!P!>Ԅ;ǨzfK mJ}>+Ə˻0ahGhVvIͪXM%R xGTh0Z&-t=PڝD6EN6JG»j>á(_A7uަ~}kr9ASB2"uNkE.ɮ$!G&lA鰖 '?0K\Lg?M)<]~QA^~#CcxV=Qb:0m>Zkm,P7r<˔ lj(~m4P!?FyǸƓI6֢RF23>C!ވR_˅vS$6 r~j#@d?E`UPOAPk5:X>$,&l ɹPd۶X4 6(~!ғ5qMehXx tZQw Q\/w]ڴ!)|{x\ kڜ%p\obP$^Gv4b-k`$HXo#@\$Dl7s$r_79(S;h},48?{}c'#Q¡tE}&+hw{ﻥh3upH.7,S+uH18 Ü|\I1:k)ʢo\-;}Kzby$R>Jfsz Peu΄_4ۭdcdvA䷧kXȜ L{CrN]Qtɕr-_hK; ֫6J'Xa&Acм:1gI51}BnŹkv[10~JB?fm?^fevA 2 OsX^#WDIt붟-]=E1L߭Uxa(C#Gx9.& 0\,ˇ⣯k}z=/qY\-=;̝^4u8XZҦ&ECG@~~U}5Wzagywƾ>'ddPQ= 뎽卒J:y2:fQ`NnZ/C+"=/.bxeѽa!&YML$GJm0r֤%|s͐kݘU}ߣ7fRP~H.PZҙǶ KB=.Deut8{rju>rB{F^< ڀ)SD'-,%N>BğeM*rtơ$LZm A?Vt AL xgk ;8rNڣY:!&37tTxKrfJ*77suLuv߬ gTf(u+k\dzk|L t:L9F k+F*зU)OO~Iͱ A%bNɲW6~8_yÕ%:p~9?U+JJ_r:qD_t)^\l(pR cLa!G4y]z!흯MG2z3@͔*u᪠[)(2BRw艀t߮x^IW>}A%buxOPŸr+3&+0MbE<4մ $&l2b0[gA[KQYf)!zWTk)055 1pU _'teS݀$ˊ5@vEYz,UP=cisS(׃c}G/-: ob-Pb^i=Io4 o˂T1n}7KG ~х %7_>DĞ򮓂8kފl,(')&*k8UٕHjR5hE09RUQpdeQƼ>>C:hx+TFa-7sn g ψwa[CoQ"sX>Kw֮R+ߚvxA7.R@x-nFL2Os6WXÖ 6HIf5na}U⻤(&[[ʶouO+Ҷ0-j."3y׽wGӴW=!T#>z0_ᷳѧ+;@/oVW=w2Ejr-3frV;dOO~K{Qz|E]lr9uM|Lvf[S Zp04\g2fb^~[Ì/c@P9[)VSX aX֚XU<^8*2bjӚ>Hqɘ0q^:abƑk"7n1=s@/cT>sxj x0_U^Z4đ%a5daQ/Th\,Jdql+e8jbu>yK 1ʽsYęcOKMIqktoAOJH N׼n8ؒ'Keg<>Zen Ҡ5/Y [3սw{n秎}q )X&7؟ K|T=-_d/ ĩ 5o9 t߯⪍ Ԍ|AJVc [׬J]g0$7Q6ƂW!s1>Xw'th 4lDc?-ÛւQަ,ҐOU\Ӫ",f*ޥ#]C>K[d0YӱWQfy~ 4)'܆,_<-ƇOY§~Yժy<ˆzL;D7lG|_C*ZHՃRPTNliٗ0OR;@nF}gJNFN.&^VׇVȇo7ͥ{1=TkLPs# <۪'w-8CݖJ$Eߞw4vʑpحݹ:>骢ˠ!k߄]t¸n4AA)R&Ԁ-^ۓvW!OEOQO'tfQڪSPy'Yx8wD?; >p"-7tUP=G[*) =苢uկ zr~XS<5 +%r{_wR1ӺnPQRt<=>^24 uM|Z}cJ5=B.s#G3BreS0+k&[y!]p ,b>07L(pph:L9Njd4֣((s"VWV8mr.QGr( ,ֳhcdьI&}Aξ^5Ͷ`0D_$,1\ CԒg.`NS^ c,8&u5(a3ӺKsn>F@C<{{*#p|lȪFtn ]bۦ]KZq[gv^Jm~#cfu:+ˏ4;ɓm= ISp5ytN:5:ƽWUùLdtyKyx1cn[I!")x]4wF<1> )ۢ}NkhudH ~p_=.RK>L(FTe5P&0G"Ц]Ry15^m !]y+fL>>=/ 3]qK!?%}2>Ǿn֖| j5ϲV)~- %K}ЁyHo:-03ZtLZ _y))+a$kz)^ ?1/< Xؚĸo:cqR~3d/.tBw?mlTHhS,-VYѢ{+YSJqhMl-?XZFln8[o )5H(Oj+.͏iyZhR:n}3޶Oi 0>!H PD|>ŐV:gNgɡ]Z ^#Z5lƥڜpr5}'<{Lq $ٟXDIq}c$GWmt \~=h$t%Kn9b#sD*̟1p,MXdwթlȫ7ܱ0Y A(d 7pqh~YKrm#˞A2*(u0]>-)+N?M@o<>K ͲUa Xx7 mBnEM>pTI_1x{!MμWF>cmn h[H"P1v&6C5b֟'r+JK.NsZC8paCڵchFU+_h?PL ٳ/ThxQ1Qpq^^x~{f|{`%Эm سr7otȁ W}:>AK"dq:#y;`J3M0qYW %Q ,7;r0h^vToYO?2Tu.xu̓d773|g44+>,\>wٜUk}Ff а2RܞU8Ni|v,S}c}18.8mdHEp ,Jr G==m} n.D` ι;Qhz%>5J%knv}ek2~ ?(҇P8 %xst,_*4o\Fc=;Rjh@nƻ)j_I{z !T%OdW@Cwl}jOG'}&]AHW*qleO>jj(8#}7 I_CߧH4+ֲ0m&8&HOjE;ɘM>BP6!ن+N2<3V*`5sKvQm1 [&9% W9Wx]$e8VӧrB;9'-7yPWy KV\AFY/~&_%{. "ۈLAGG[ eNC/gԩV:nBrY]{$>ۅki=REvEzϚn $|J<sRn8[x؞즑6];;M.mqbDO`o m\KKb3G>I=R6`( (Pfru2 /|'[mex;݄e4\lUF7t*m-;9l϶54c)譱Sn~*G;~݄i䯗 SLmv(d,Reϗ}N"\jN$(p]3"Bګ[&,ϔu\o-(|<(RGJc`hL~r*ށͥKZ@x:ep:0C@4o"rQ }D \rH&\s8XAz9Gh VݱMT'~vgkozR7HτA*NMy>+&*(rC=kUi&yv.ȭ4Hƚ5E,mV3"cPtLhSP<tOS7Ř-{;>/jJo`A?'1T)P+X061xm#o -(~ ;uEJl+Jn):܆Hl{.Xs72CƆZw[&6\4L;xi +It DTZG7X/J{nz),:ϼM%\ hQo=-Yz2]UIu9OmԫD1yÖ́ Ogf*iSE+X}Z[B1ZoD[t(oxWU. _| .sRp"m" CЌk# J%Cps = 1ފBtyR/+_D_B0)Gpހ *S<ԻqFKlIeQcwGmAkCq%;aȹZIW~Mkj } )ڴa:?g(J]oI*N>g߼c|0^iE+DWR=A&33&_~lY(|"@kj;?D"S GxzB,jAf`R1ga%dZ1Pі@AT5f~8bUM‡>;MkeMCU({$4m?q`ޭmX^j4?3>&.>#SԄz]$TA I5NV?G_ômnGۙR53ָ/x<|=${6[.8WY%jPx'i;s^規zR'r^uEfnK),Dk*38Z(7v# -imv.ʴvx y1EE1?d؜G 4*W{]<6Ws!$z4mNU"ؔmZu- $4H&?DI sK @-a}3x?S]|Dî$HК(p 8j4䐆9!a4%w3!韫FQAgfiZ:/y˻e~A2S=l U&[]uɈ@_v\ho9NNū[uaO kɭn.ͽG|cs7#t3rqp{hXmfM&d`.5 Uo!|C@2K;Re!"A:Fuv2̙(nɱ|X\!Ȝ@3Dۢqnߌ}vo0'\~!?'ӱQӨnH a\Xrx-(cMojXsfs/NvڃǶ^Ѿ3mշ*.Md0N/Ur0l!"K0~ureL8^ᧄdij 2-}s}_ {”\)GȗXJn&fi!-^+<ܐ҈;riSS=6R5 ;f׼ss84wёomNߡxFju/]q^ⅲO5!OMYmR3etsy.|wݭJ,q::)Kx~?9Ԭyr'DZAMBh]N߮eؤsMψ jTh9Gv~r]Y#1*~0 ;fTP EOa8fK)V5MP83*ͫ=gxxֈcg%)OK%yܨbxÃW׻oǢTx*:~\Y.#$l@]; uYi\Zv 6ACQwe͡߻$(/L-BW4w]H yDvt?% : J]jLl`OWϱ,{T^i1'^rncf20 ֬UWoAݻkDv9@2"D#D9Wfjidf;S_T@>[ V MКk$mæa5 JѝzsRSV`H! Ǫd0`Rg*_+[aSg6+z:X DIHyiaJVWIADiʅ}o6[Ë_ƣ/ xlbbSPVfVf#[ӍqΣcuu^4H =U. *ƅ]Qf ]ְ~נqXJn*M}DRCvJ4mhƒI1gx5u>pa `Eޛ@j[u?"uML&H*Ȇ?<㗃TC"1@'yϩ˕tAon,E`W|I"KLAsIr/b>vbo >uP?nH E~043G6p?釐0>F4F$_ڄiG4@T4>㸑uif~ogqwë 敧qB}R|PՒ'E7ʀE_E}XW̧Ygt΀YK7M,ٌPtn ;!;@cs3qoAuuGA :u} `1}|{ Bq+]%立1gu)"d5ǨLE^ib$)R[oPόGy܎'x'q UMv4fE0-/]qHRtƬf( LNyz]_^_2NP$Eq<2чδ^/h*6q0zg$8la[mB|`DN Q͌ͺv;z$:4Qe4Sp%~M$h",iiKpܙx0I9Kސj( e\}w.wuH%Ep m;0> stream xڍwT6ҡ")/!0CIw4JNC 3#1 ]"-J ")!t|cZ߷f{} /mSa D!q ,@@"@5/[Ok`( 0p0S@{ dAd@(7=0@cyPh GddnPqcP0`9 `7) |_Cˊzyyݱ"(M 0cO8 e!5j^3`ry1pAᆀ‘X=$ LuFh87X7&@"3 `pDF"8oM aQ'J4U`BB14+EQg5k aj(ww8Y:Gp](/ߒ# sZQ!s@[Ғ u eTzEGBp#C{8=)Q@@N$p2a7Hɖ0 o[ i_FUU7WX\ ,& Ҁ[?#:HGg.=φE.o%P_.?2+Ҽ7?uk`",򿡖߻k!U& ҉@iaPDxa8o֛\87~E| Jx` mc +5ȟ2TC E~n} 'H_aMap_ Q8 г?9hH G\= !I8 R@AB\jCUؽ6Ą(q= 9SzAv.;Ku\>\N\ I'hY^-挦R9U>ɋLnha{guY>3ŗO&Hٲ._y/Df^דo?N蟦|`y' G!ϡ.AQe1]pG^F&/DQydN pyi{Ö?Cc =ͤ/\} "iSL:Zte _>3552^ gK_xz:UJ!Ĝ-\3:n)f-fX2-hE/.~^i~YsE}_YN{*ߔGU42!?_7Yx$Qr_^sG?ŷK~ArwDIJF^q;bZq<0n^T8gYPt8`HǓ߾"g1$WCCw4@] wЩxD SoPs B(%#eZgaƏq0%>iSmɋazL!RD]q'vl\\s-Uۖ׹/5dojbBx7ab-^1Ϟi+mQ~I蹓rk} neSe%[[ /N&Ԛ蒼UkEtЉ1ݙմ)?Lxtq>aw["Mv;8cUuxԄKH̐@\_FjiVÇ7b [J0`*:#I1hShd~ˆZ4*[$I$Ivݱ5 LQ%u@f:݌j:]mq0kn I~xtPpzBN UL+j؜W"أ" 9n֣ U}w(#nǵm~םǖ.CfQ;8+X>Qٛ ߷AlLȸwSCma?ʑY(?>08To+slA:ZeZt*u !ḕ)=p! +#aҤ&cV)>W䳱b.)Fvm t紆*NJWT=VsG-y+?^}ufPbR/R.w;#v Jq9 ՞Nɵݽ$#ןAV쩩waQ(`l~5xS'|\X#i,vW\%_ֈ/jZM"o1~ ϔnB}sMטg>_h}}'ҋ`P`CwHyLRz;k$R-P|- n&F}SJZ}'ۓ90O,7U뻼RܝJdȺ/t\(cwnEE0i4ܸ`P%s54da |OӚ?GQQ0K,(kz[ne([Ų{GXWJ*ɽFˎ޽ ӿcqE*zxoȅYQcܵ6۪S?Q_yZ~" L9z 7= U!ΎBs rl3V-A3|)lZA a"2r}#:hyJߋM:Jy{sRPz<=IqMqѥ[watU\׎ȅ]!@IGkGVbf1޶+<+:lrǰ^7pK7c*K2|a9P0*0:,#ls{fJ }W *WL !6]RLL bwqI]9ҫi6жb]pN3 _4,xGVV {BH1Q8= EJnM430UICn5r*9n(w})#|$=׶vUMr`ۼ9?97)N>vYQDw KۼiT]YHJX_Ã&qyٻՅ B"*ts~ naW渄PۼiSl]V_X<E/fT?bo_sR7 Zv+/eF.5G3LJghw:p)m=Fyv;"q ܜ2"ˍ}!(~Xk// j)t=q~.ZՂ%*czk$QneލRd6Mf0ccr}a{@+U#r2|he4z8d3ZN_ةNaVx:)Ɨ^:1<Z1h/o+ߩ _!y evxI V<كAYࠫis-bR &y3趖!- qU+BJvEeht~,GQs0a$33ȧɥŒ|*e+|or7X8\՚,)f7+VN:x7(2{M{0뀅|86+3'aDr5#:Bh5^>Is=l&]?og.XY?FvɹgGt=QRz XӊHVݶ]N[2y[G}-av.70^M/"4}z";G6g ydK/}$zFowٱcKi$wybn+0%Ӕr(wjc: imן`I9֫Զ fV7&rIm=HQU)ǷZҏ^*Q|`lJ;wqSq+V/Z΀ TDEʠXoDuEń'O&П /xMdOc<ܿ)劼/k<ޗ3kx@֙aa8+.[ZHYvzpk-<0+^Gb|d(̀H8=4J uy::GbX&΂ƹz0׆}Q^[TWf0#LnOlg:2 9z:/JhPwLWns)͜+ige DblxĨx'cD'D?&k$vIdDMf<: >D~M7zɈp]! V!G)y-X")\"x>^)V麷Zy$=l2*ӍZI.ӵ 8p`@ߛvkso4SpTFyą ޵ŭ=dSޗد('ѝ U,/=%JఎQOAnYb# >Oq}څ"9f*|+>Ͽ2{ JNJܙaIbոX~5 l 6Pd {W sDZ1ﻶM+AC oxhnaww9 EK0 5| M3 mJMy9 }b %SAKbTR<pin)}7|@?==q91[حZBw;Tcj:)n=#}t-4וFڞκ'M%/9 ]b!˂ ~$ CЭi5VޢՋ4|K&kvpYǺ#xdp:X .{K뷈(g-N:]$zpnY\*)AqM83K#0- #oDY+븃&PୡAle6i^][Ǐ 3RϏf0SI|w2NE 0Řpb=K'lJ?*dˉtd\iV`i;r2i L_U NeHqk ~epVQY'Z4I^r P7#fkMF˾IF8nH{`|`⁀i}k?($$YRJgC0U"8)%^h] <{7t#FKhaE- _7}=U;ybZܘ?ָثӲ)uxDOxٰOևoISшs s-ǹG]3-/錊xnGQr˖E S0Y N+q1ˆO7loyi@Tޖn!BlÀz_S&"S򱇫gjz6{GlXMxvRՋ3(|W\?"1CJA|%=|+?> stream xڌp۶ b۶mضݱѱmc;>{9_uo ?c1')23-#@XVLMJblm14-ŽΟ2CO;Y;[5`b`C;G. @ egkM*lghin>ƔFNNv6ƆYCg SόƆe;cKSg͍ٞƉќflP2u2ut55E ghc3:hR?re;3g7CGS,)7Xz`coxogCcc;{C[K[s)@^Lݙ`hk򗡡ݧѧߕCى/첨_X:݃jkf`fikb {zU[KSI|:X9Swc «x؛dK`I)OFЌKcg-?Ŧfwth3|#᯿~~ǿ/?sxѲ0hX `h25pSgb c}N)!a`e0a< -Ho5 >sd>&.6W+lm?\-5UsZ~}ϫs$V~nN)jklg׊1  =??w!9>y:Q6V_^迈@//qEz"O?^_W8?3ѿ3i#aaKbc_ݤ72ML̟Rft7"_z;?}?K3g?-?Z?Q'5?gvCYO_;_)şav4ţw~4'-Y>,O_4&%-Mgnv8|v-?gV?dL=k]?;}}_.SSwScE;c ZA7ڃI94JZN/ɔ5Y[ɣ}{^ _B_+C/OM ă¥U8M+h+pi w'qk!5l0o峴ѪQ:%F DδxTWsȹSRgE^ZL1 *LN=X$XZx3d^B)RK^ECp~-^ cC!mOc{%nTk\x =ꦒ4o<^B/، Zy߮c亶瑖ݐu?>S ,E B(3E{7cM鯶D<dvYIX$G#t<9 .ԪTX  "i'G8Lw**~٩=_U 쨰w)8ɧ F?-C4"MєKJ ,RԏU'~T)DCuJ9ڬv[GY;6Pϙ=/*7kT:u<Ҟ_/EToMU7Uܺ!ӭq0!/ |g2M"jԏ]lj'M{ ^M`-07Yw|E }Ť¥h& : "_J(`HcHH=rԑؔk%f| Z:$rӂR5t+R@R@d^qluj=  8ecbKnDbIna$j>y&&Sa`f |xʾAlh~^ ڪX[?e˞r?u¸w<$͖(5CU2A¹~f1>ΖåN[!<+vd5ohCƑ [x7Rϲ 㱮^l[I:O\ "f,GФlYMiui̓Q^ 1i/0a-!Nh|<5 i~&y9j6I_/-=OؐXKdLIF5RX4.v>L. ylTTp}p3ݓ[IƔ?wtsb^m!TN:;HLt[2 'Wԙ 9eLfpN}Fx^ z5 jS9% l]\A'Wm &.}Fgےb??$i,5LN|gBˠ\u2(Zesopft*φf)P^f2rK68^șbcZo WpSc!kCmVO'!꯷7>\nF`4Xpu[!z㾢m!ksaHs @ZBVgs?NntWo\E&%L-w OX,s 'Amf|p.7 ~,*:)] 7]s2h/B%wQ ̽Sd8 m#g8?yo%ԩQ<NX XwR4I";΁@_NfG%3h'P`r*|3Ug.f@,=<`2&72kOCy&Kz3yN"\ ~*1d b(:$>1uKc=9~A`a26iHj3mǢ̷AsMSe\آeP;I1`Ug{$&$WI ?RzK)Ⱥ,&ma~iϯ5_k8o&J@R@΀jkZig{~n SS fX:{)v%1F)oVk *q.H+cPX NWf>I!̈́vFfr>LǾ [Of @J䰧Gk ~gXhn|$mRha!B tZ( h'1(Me]\gk;_P)ٮ bI[/e[afO ,~yhN5p/"j1 ݱܾ>HUhC<1L=q1K 6:у^D4Sܕ);iWrL$; s(p겡xTSZ6bE{P/PS2>uU*[Ruxz% Ƿު0x{p%{ TLo|QQBbaYwdnEZ`1QvݿKmYPV6%2\]O?x5'}(;vTZ(ttw&/غ[>>eOHSsc }4e,rX{}g0:+T cܓmhk 1eI_U[rsxpl]e5ةKEӞ= > L0R)cAs$m6r(ז7 #$RZjX\UJ!PU3?S4N %!5JrIDkZ_3yV%uq!ķsmHڊ!2嚴>ʎ= Y e `Ѹ`e3@~ [3OY|0ͣ"VSVkj򧾦VZpfޘQyf47ߓ4P KH3u@ S+g5$㺞F1&,pO 0CoͼyxxH,Li|:14ʗr5ra ~t ew󟵽UP ~邾!ԁd)nb!K m5 YUKZn4)y%}I䝴7<փ_8 j|g[NxqmmOCsJSGyh%q%ܴOhR?9ݖ&f^jmT't9G<˽% 8-Jt~6t{}"+oa5T jkwaԸXL5{;z| z%6LUЬܜӂtXWR`YoU\ml_RL0`KҥүocslYWl " @3)my *nayh|&tVҀtɾhb|.{$p`$EG"LIdq7 xO]թ8vhJ-ˣ,Fka`'o`gha Czl893W#p5]9}nؽg872AVcGރM_lCblkE.͵^[E)x Z&e?hW DM\f Rw}KCC?E B~gH,)rFf%lGs5omm3%Ž#C*##0f i I Dssē*yb/:Gzxؠ0P=N":p.liي#F-1̷\VFHk-R_?.6uk[!:(w/s{uAYŸiJQ,"t{%o$' zU.1>`(kn0TR[l/Bw4[Į-PSu~ ӒkEyфV7mbՁnZv>[s CG?ӽ7:T5[$FBph""$Azר+(B1'$7\2%˾XJaVh\BjQ֋e9JO4ym+֚u0/0EYNvp Ҡ{DUCA_Z7N߂ dQ"l:J/cax4/'Ie@ǯ½A7>[{{Fӹˊqf(SwZuLoq)>ioP7 SjqqYioA <\`kuPrBʬ!O?s~3*SX"DAT>SED%:Vkza8r H Ї{CZN~Lݢ ݂;:)!Dl4M# #S?&:+ցsobl1(,,h{=O3o.L4 d[_ NNܭ&Px#5g%p捛Gl,A/UA]pīv:&+{~=YCVƪ5axg_nf% ^pVRZ6_ CJY˿J\q 5{عrԸ$>S7Sr0WHN[oc#RH0ItIJK^t g6j j@JfiHq]hPM=@ib"'cag 0ɰekt:w:˥X [՘U8]$n1 V ^/&X;=9}]pxYl-zq#FhkeW sŇ!? s^Yٗ, 6h: A0wЧ7pɶ'oh w3'(7|NoDh 8`q䫗-ը.dkOʒ9TQe)(@o[tѸ47u6/YgftOYh.I'Ӧ-ld<dSrz)F8fhL$6 l3V?G,de_}].,Sikh],2ET*kDl݃da"Ԉ#>e9Nn1)y $͓,V);"ɛ!IU_vTl^~I2}ɞ$:XoB7k#GG lېfT;tYDC283bzôww e]]E=ϒ4ӀsFԵ{Xz`CrmcY0bo[^Z(?_Caa5P ݱ3D$&8?WwTx%kD& A,u҉⛍31}jzˏ] ѕײ;ᨡ0v*CN!+UTcu0J+٧,>;4q =P66ք4|e߆P2~pʂܛp0K52^.kUmuJղg`;uњܩ.Jh>I ԰/nuD%(Q&^끟,%' $Qt6/*ևh-JQqt%'T@Jn@[U'; ob:А[ѩIJā_Qz(7F4Zlv5wC[NYcBgcd>iL0I#5F(i$@} =xN0YImu'5p^SU>Vq)ѣ#tg2xG5ckZ I !KKHt*Gr~퀓=HVsƁCn♟4A7CV* ?:ъ4 a}`F/&LU0Gy}}¦s"v*gj[jیU^cUf*Z*.xlw,7Rj .U tY%x>IcxUÉ3o ahH~[L6ߊ`_ò$8p"k 2I ݡ9+!옹dypQ k?_`.;Bp(5K_[$oJ^z/wpPniTaPFLz%p /f2ޖ>*Jդ:stMx_0i4A3">،wڀp(qW%K2Ϸb1 xik-p=c%ֳ`5T9^m) ΞPK=rztәdh$Q ^nx*f՟"$L Ɂ}7zs0o;i*71 l/ 0.z!;doj ÿ5ˀZ0Gw:%HK:b(^iP!Epw3цg_mT|4e]%U@̓7 R3[2Ԋz SӀG2C@w9H1I60R#ΑS*=-\0mnQRNJ얠e]YJ@FAz)tC%P8.tķ2 oVh 2ы| r~z!Rl;ye@dgYs}-h0, .OJy|{lv칙he؍L%3{`l6ῤm5tLsMM_~ -Gv`?9:0z$l,H.ƀ G8sڵwˋs-M'j{pMhl 2ìWmVH`#ѩY'6.kX GJw1ξ]oAS`e8%AKNj8P"d"DhbH}[4Bks>94V^Yr/P3$AfkIʽRs{ž}lQ@6/iжtn{DF5[]ȱ:ZʚN]zR4Jx'R5Ǵ"sGӮ6% >.R/.IE*2 "0qqO60})N(yb?u)v/$P|N!n\',SH[RGe`ϼ}݂ y?Ӈ"}[˙ݙ h/> ۷E}+a_agKf  tJ2 sYVcV58ga~IVt`s]/Q-tEq^7sP$cjCM*֋Mwׁ:LEㅾHlqMC}4-i̾ (ioWeqMC!P0I+ɿ/:XwGq N(H0i8~Z{[}F 5/q\yJI[ZxZjh V F73ũkaafy%tx%]!T~PM!.?/R3eB8Rxk~7Yc&H yגGA[*Hч"owFD2*MtPfl5+.勘ӺAM(w# G?Gmt>g$M eBi yd֢6Y꾮kT&ְd{![[ƣ鋚KiQ:f0mv4?{V `0G$_DRC" e(WU9ٙ~ےuόjw'!f8 6X(uNe<էR \fabzѵ\"MZgp[No-"<TBXc^$1EZG:%ukeܘ9r^yw|"$wǐZё3\͈.JMӶU:'h_J Fܖ|tȏxK&ѫHYUQ pq>9o,)UØ[ۭ: kch& `̏o=_Oi%$/M-xUcKAî9"~/?rA-yk+t;?H]"O.z.\B1.}պبCIp_mM!EsB=XPm7N jÐ"TpfPZdt`HAܼUHϥFmGSwY.3Ђh78tF\p#U;ju>^?w#̋ ꖓ#n=De<]7o\!@#c k(_h\2'X~BCj=(`$*cx+j֐Rܝ*_ n/Ku4*[~cZe?x֔ %ݛ7#t sve{ +"E МktUëPԜ UW7 d͆WOu VBrПoSk-p|w~ p*;N p}KR.AL)/¬}J ꑆ5~Z`P84KR%ZHL'F ?9Bm1N!7Nhv@{Qsai^,^{Duێ3ψ-2lqLI}D;|%mp\QeA5ԓ},_q,[kx0$CqGfVsFj326jG(;utďfQCOWWZ>A:v~i0 1^/!/¡TJg1>UA}kbPOČ3p{uV.}P"z. 5X=k.E1fQ,|Eyzgƫ8]#!OI+" I/)լkAm/Ϣ$kU6j,@-vcdKz9/Gh+{7)WֳW-^=|:œ֜cE>BxbL([@ 3\Nx8WwTŽZꎚ&K}荅ՎHa0,=3Ԭ4uE= 1ǀ0 :=_KP&XUbdXv/{3@˞c Np᤯ )+[ E'qW(W^ԞRlt1+kfj#Ȱ:S ǵc02%ڟRjv zW `[htjM RY:hkl:v`OJ ǢcO[Rj> QLž=qyAX꣯GQev:}Y=,ʻ*F-%JD Y9a;8F;h9~|o?lv8-U&ݭj&wyls:x~#7_JkACQ Pmp!sM'yp+64wsd;͛kQ2MjӚ~ָQٗ$|ƘE ~wHrG"5{đd>Co@#8w*<#G61ov1Ǽ@H4 #įGX-/d'i|چdJZy NFd, SxT|1MPuKׁhȎ#הh9<0]a\<-bDtgܺ]1y"z{:5fGBM7˵(!ik/B]*u @)r~cy{-3c~=W>kރR12'< M,?nY؉2'R*.N rTx=>n%ߊ7Y2| BesuNG$bϿr- F} h>!W'4֬=[o;l"S7D_RT{}j[kcv֘'a6*raIB,r|{&δ1棰Ƌ8U$sŒ0ƭ@3 RȂ<+3'(ًkIWWGn ~PJ )|_M Eu?J2Ns-Q8{Az},P`oo$ hYƻZϾU`t`2esGu`ooAl? "ve#$]-g.O+͠QDzEBmƙ-NwZ ")% Vlf,2[y2w.&w 5r$=QL&"ji[pbmUR҃xa$>TSzî\RcC\QyQC6Sd;)媎IOL+,_Kn~J2Y/yH"\ D LdOǙ/q,+LՑM[AJHyy=Dtb\j=  {]&ر^GI})UF`~fqVuaBnj}؋ j-D?[uwRO~ēyw ݒvMtlx] o1l'ؽg=3E@oedJԑw{V͘b5Oi$cćn+]M72vp:j8"%hKif aGrǁ_^#@< (%)^6-R}Z]HQNǒvGI)|<9+r} @*&cI3ZSƒH< >RUr9bJnIh[ KK҈y/\;R>p۹eS-Zv9vkץ;p y9/ޖS TZ!7k~h\. 2'f2OcLNoРxwWjZP{ru;;3&9~A|}#AAYGtTJ<b&6S-p matfyicuP!s`mњÔ~8b:'Ú Q%L+Y'Ga,42ҖfSr`BÂNy re1<'d~'Ff2` B+ `bډMeqOcŇ ϱt̃XJ*\K_Rui G+WWe\SHl\Kktۭ +xpߋ4sl%?L_'@F\`>5q4kH-r&iN!~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ڍP\.ݚqw@ X4]݂ ;3{UϷ|]uh4YM2PV6@RYrZ[_bTZ3*/I'˳LN Pppp8x8@'@ bPf(CΨNK+4y018@ >?v`' lb{hfb д7]<+;;3# b; TLvƆJ в8)״pq7q30jv<'h+T?4`u66; X@lU%6 M2j "0ϧ, 5C]Q'q='ڻC&]صGW_&"d`qZ?z;;,B,&n`+ߊFs l Y ? 0>s^P[/xrqX9y8 ~~QL UUjaY)`n0;3i84{~p?3?$jkGmb.WYe9.&{ !2O)d(XVr{,3ϋ)f7`d |&'ypwyv< wB=Q>No k@|vn7]9 /oٻ:K_n7~Y[ >Wj/`ro4&Q& Pjyt oRutTǻqhR<:W|5F;M@ mi,K$VL'X3WӸ9OT ̨1\Ek^+8I^S_LyK({:v%s2xmh8ю 0GE%ڕP'"qg|SX?k5ufQM<5h?4x"31iXoQ4al[<0>i,MaY]zǠ̩T&-ɅY}׏Qgs;#MM»msИɢ(\@d143s[o1fqG _]$^S˟S"{ >J(;. !4\|a+PRS ]6O?[5^x:/؋KD j`wo`)̿|Ne$ޱHhqR^ޑ^HD}HSHҥa3Pn%GN-o܀@qJɹ9ЪoOih$'. Ē|`1 m9H6? $1FyWB/#Se-YȦ;=Gs[lL6پFMhDB{,ͨ$ *enjV4B4o \[nY/3 <%%cةU0zmqz;XYaE]?`#@-O)+ߴ WcR։ꤗNyLe9@?a}U@G ק7Ø4NĻ χo¿M/ 7JXp:ܒ~˼?nPb/ Ct ѲxqVs1R%0m9(G Ə_j[lLjxQ҇9ދ2YP^M2K_~ClGǁd-E~)P]TȎnaPfЇ^N+yCsI|Ң}rG7h+ŋOa]({?"$4Rj%<& yg#5CQjINK$⻏I~E/VsStL6l2.+0PU1cdɻ }2gz)õ FWw1Jmg֓xy P8W&r)ܴ/7l;|huZ0N+(pq:LPw* /b{?(OLC[$̏kNH㳖&E J`PBAM `!M'`8{ʊޡrjۨohh@jǸx&VS u0L߂*#M"0T4' ɷ󙽶]RZL:kL+JOq.eIKͼ=(i+#zk7ɹ(Z/.5.H`r8(ˡJaNT5_LLn q6V(bKG xm2[+G"g $WO&9ZDJw:E]sq Ys'eԻp{?ϗk[!^TK["%036sZm[^s o6LZ {xy4X >3HW+Ps9 #*vnTk4(?ec[A >Q k%K>i~ ,pe]|aV?׉ʅ,nLKetѓL&]ʑ]Myӛl]0]3Mu{2ƬڿY.a}'>x-<4ºMk=e.]NLWݗ,YpPK#[ B<0}j/XܥM-~5C2cMUIӮ{;qN*T:DJpAn9Ldv.-*4ǩJd?L4 c% PjA%x~1NXvQ}R{i—\>4j.v.!˷Yvл4ҔEHM1gT]`ɒ4%vfȼ13Rr˫㍰8ԮR<&g X#}C_mk"CIbFaWi `3ȧ$ҤyRrk^!~vhlټ%d$&BAyeNWL뀯~5m^Op*]z*)HΆ 1J;K#x& )/6'8 2C9^־-Tu_Z`GmGn E+~}.})p{myUr.)U^)Gl;w4!@⳪$+xٺ0ȒGHct#i)[ڏ ?JŜ|ppr⇈".x!Det',Jkqi@P{L_)-6v#53t u`>ac4隡`ls$-x&7!m֔\,fa3RшmgEz8~Bj$93N?*Bd  9 :/+N|X;AYJ<GpImپq"/k5,ֺ;ɄKծ|7v\9NH@N1=lc>~zW fiÂ|KZpnE#I_ cbPY}BF~w+zaixN%TU@WC6jHVmo{Nao÷fl/u|E)7ѝ@um W(T$`j $ x(?u|5;#Q%"mFwJ- feg>i}w%= *b*b?\[m} \-9M"ҒyDNrEm> y7+3Kei8]ʘƛ0ئUֈ%l=*ޭ1c5ܰV(,w 2\(I1ArP_:喉Eai8U,v&*v@*ٸY)s6ūFIŰj2hcu#'AQR zʼ>9r:325A;t-`pFnTkntOH㦎fjA0oNPjϨ{5Ӷ2B\y GN~1:$Lt+?PA"$$B%GmKf]*'ֹQ| ⇈ZHZhʩjUu3y^޿32=# Q rO/~Y+| ƪA +P+/c*S2Hkqf2[xggcV*}x/8/g4_ sh>P]С\lQ蒁](͡GA*WYF*rX 'D_tt xgz~7YG ˾ N`>kWĈD;o $`rV#h6sG w}9s-P*-Rh^^\fh-{ BqS`ēyV#Ū0Su k$A Yo(v~ \nvl޿6=z9P<۴2,/7ccrCɽC3]FDۦme2`kGu_HTvm:e,EZHs&_b>-6 3mb/Qc\:(vbY qFMt2P"J긔jb:a1oe}k~>ϔ]3q4Z z ;/9_\ l;f,Ilݓ[>3G9\/5IRgˢRr*Á0#7e=VTi&7yHX=i=AdZ cZ>}45]H$s(wҠ)ی_}1/31,1}7Ts2Y 6o.7w_kFS]=ς?qNɷncSVΚV:epH IVR(\ZVVm2ϑV0tⰡcfhbAfo_2\AQ~x~86WytN*ˤ-r ȴ%٥k9ȍX{ZSCH%sPA ƴd|Xj5- ~LN m: $^8{)7ߓ=L%̅j6bYzfꘄ5{G@z\w*A/7`dxQ/ ٰƦUT(6{v |pOwDxxEC=gJ Vb'$fjHD`5~~p:@]TSvċb :½LVs@fvuҝjL|:{ض`A&Yk4[-Z_=L*760fYiO:3Ar=C8\cgg~AlH̃DbtX o& LuWUV Lz-:lCۧQbw%Nk)pgձ `v7Ft )$]~mfTGꯖX7W!)D_Id}'|>;.Wq0|!zsf}^2'L#:,,- V A&3j#_>I)|q^rbb8c넷G(Ӕ0Z[GG&zh4`(Y|חxmaLM=ޯ6TMRnL'&.oǯZ0"^;\#{Z~s$N 5Evs I|kR8 -9jvN5)D9:K<j,BF.eҽ{ >iiBZ!غ\^92"zq+*Uq[ņ2=2EzN+Fg[gKs/ԑ7ʧ В;&uT++~ڌmij%sHшvhNϛwTqWV۝#dy6KV'֚U'0/pE>۝ +c}_DjU].0dJNՐU3hk~Ў`;#mjdx_8Y!|⢁TlZXG/'vV| ʙXv햗g_0:yNG"octuMw'E^#tw`=ou37ƓA½'2h3\9 `}|'Q46bJׯt>Sh.q5^G4ChىFIbsD2ޘӢuI,;cr%0˜w-xHiRgx3$MtlMuf\BgmH>xfu xZp_.ï\374yI6MO;u5l)|u8mU̾#\[ aPyȦ1ꉃ2m9$BIxj#vs_Gx̓0,'iP-i3F)SeYYo9={{lBm\`/Mٻx G9?{Jw݄{0SwҳAGnFjo=_ 0FGrE7_-Yf"_4Z;g@vrVgh2tϱz2N fԩ㷑R-Klۻ^iU+}]5YS,-Yq7q3Z+aHLmȫ$sKNS"᠘6|ZoxI)(]޸[h?EeZ&1ze e ^uT0#X넢r_hЖ?bkJ;mhH=ӄU':2,RBj1@uS~ ^՞ݵX ̊ gAjN@>F(,!o"@~2a%'L/;x(X@nK3ƭҊֶYQ^C7`D;+1[RhUx^ ]Bւb$)r>^Z4ʗ&f*B8GI~=0.:vc.^2U)pzz]H5Iip'03 ucl/}E :"I˾3Ni-N"{2Rk]DXר Ei[T?b&+l4Nu!4M-Ė"(X;5ʢxwkWF(ѩtOT¹ 0 ui)Kd9tčf!sw S;}_x8Q]%- IMA'AWLU3O$/IEU: 9#4xjZe_@"tH.CV ˩Eq";,ZZ|H =o^@Z<( L 8ѦWVz4#zXv~;!<`!RSy ҅~!Ry)*W˦ͼ[yBjpWYm/N3Gf}*\KN^Rh H֩ | B,6AHGx]h}{.mz(R'ى#5jW}Ĭl {j8o ؇0մ^,1Z[XS ҤsYx|tM@~BNdsP_;TJpY7OִCd^ŷW`r Msn[6:þz=Y"AErA^1ޱu߱㹯xB0v+Ũ"}5>҇XÃ=NҺf.&M/Wl2ޭh6^>C:}C 'kr\ ЄOHIMnpgzԆ+YT4j?Ui]}@+ɇ;r5bLg[aSrQ;:`q ɽϬ@jV1 ;Gǧfk(;[X~GC__.4_.$|Zd_Ep Or+Mc|_駰j?7AFprZwa`cJbն/(01dju=z9x,#qTRbz >űW0H\&4w֭QTkd1=pt̸Xr_1.O|rn¸ƊEԘԩpj\cR690@T; ʭl,ՓN,Yjэ \GyVH, QohЦWd *<:<-Q=݂=eob{asnf[ . vD4pCAHƎ`W8px'X{ܝ"EYu)>Ü4ߴt[F<08J]t+O&W` ㏗,#ȏپ Hq KCFMA^݆c‰Mn8d5.±P4(mb&nJ )8.xьv<ҐZׂYl -#iRCPcvY]}t46I<# ,(BPbCT;OM ^ؤmH~R`8l" endstream endobj 59 0 obj << /Length1 1555 /Length2 8297 /Length3 0 /Length 9319 /Filter /FlateDecode >> stream xڍP\- ! Iݡ 5xpwww.{jWcXk5檦$WR6%Gzf& 3'R mF;mbƎqP@ `f0s0s01X; (J) uYX:>/O) O:@h25-6+PS(,my]\\m4t%@w~ P0U*%@]jbl< S 9 b0?+O4p?ncg:9>_< 5@3z@bwA W/eW=d`uULL{,SY\%!P07vCez ;;ỳ4 `d@Sy̡Oqs}FcYlFgb@f&#l`t0:>3;S'{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ڌT S-#tw ]C%( Hwt7 w>l=u7*" cΉ &`aagbaaCRtL;Z FNA9@`ccaW|0r41Av@Gd*1; ?4&V^^n"@@h hbdPX=3+#l.Dpt(`)௔FRcBZX:2sr5 lg  *R{e#8V&!KLL@Fvv3K @AB͉`dg#obdicd ;t#?9--mʑ/32ۙlmvN 4ݝZہ\<,LJٞY( 7daaag@7 fEiAz[!_ȞF.@'2++ ` 4CmBCt@Ə_z 3ٸ2I_( `dcgpsxkE(Д3x,J g=hkK[ p@U_V_F$lc7??|#[K$ s9d?+4t\)'#.ؙ[HKG K7߳_{fciT9ZuY,,Y.kp, dwף %cF,IbxB@N$;oWK8"̢7Y70q%~#V߈,A 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*KxrlXݣjAvB&sZb, 1x(DN/ɻ(xw p{Cz0BbJӂl0pk Ib% Wo5Eq$S^؄z[U@zSaB>1W %s}Wƒ?3M.)TTQŲO]o+k90veg;/}&2blCXN l]/EUU4)M [`_v7syp6ciǩX(nr)`ɬJr\Zr6]O $P!-2>'\Bμų1z+vS[ 0ixȝ kn@X]W3tϚQ7KT*IroE*۞G&Rgy6eHK[K$c2Q#FgQ hDA<[&Be!fzTeo{?ҭo\M}Pj>⛫ZݢQӭ0(YUh(alKr]KG.;͎(ֹWzwF(84Hn,޳jN]p \nd 5Hx8|+,p(8;N]w5lNQݽVz-6;[8i9PJʝI д54Crڜe8|*ۿTB<'R'n+Qe{OZ[(YKXNǮ!{(& r@NMR6Ѧz1#ӃB,r=v03dQǑZ{n %3> Ds.Yhbz, >L¯g"Glp`|ƯFŜƙ@ks|=3˲ 8[vZVbsŵ9;/真Гf!V',QAKi{ vڪc%6K_8"plȅꯐaҒݐ8c'EG9$j(6BtQ uhZSz.}nō0Kq~HfgCm:BVQiJph:LrN cBw&|(ҊwIE[tXT]%i5 \.d{WbtYPưu!{5|8Wu[ s@mjoEW()k=5 X\ 9+z~hqDǺM_PAmFkUeaYv[ Y8Րwi b)g±K dݸp?2C&c/?\Ǖ+(=!NO,vk(:] |~g#9zmkcduP+kcQͣr%z>MrnZ"z;t C8:<ʳi )llAZN"*sԡ%6NChy~YR hٵ4Cr7KHa NGzO =Uy6K1h5# H+8֨ )P#I-Pqۯ"yd\>'w{(47G~!lJE![Xamt{F[>}7O1p.di`XM`almsG@uVS(Ň=߀!bs<ݢ1$DO&2^}RQ*M2˷<6nkAtde=Ҫ|rCЁ^1Q`d}YuO>9r Q=trtXRA6+$"EWuPC(u7_=G|޼9"kaN+4bm L+w'(JUi #+]R@lZGʘ:>y{ H* \"oݘOB(܁a!1O1l 2oM4'f0JpZ7\}fk"{a+Xo*$,>$zwTJ&[9e, > :8. 6C%tdš+q6G O6&7Ħt[ ,p% PjZAh 0?hdd4V}wݧ\ Y l0*#K2%*'1rO[C#?z_ebP%G:;Hz/$QwAT;RV }2%{|^ (%ƺ,9YoEF#%T) SՑěL"Q}{m7f2=fT|N\/RԨ>_NJ7Ąg\6*Uupw{Egqv2zK$q%9r+U%gi%>F*7֌UxJa.֙=\ՑkVTApIQ~RepD4kFL6+e&y]>F*ap=gXg4RXer3Bm>{w;00i 2,/cz%0 =b،ɸ40/bxtaMA(hHJ}IJ;QVSyf!7UkZDօbJwF3 `i<*}Íwő3λ%jznzN=kW)b6!60O@}-I#CcKXHϤg쎷ȁvYd帗b&eq;"Gvmq=E^K˛)ktOI_(ÿ7W~Y>Q\Aʽ6nj^ύE~(P@Rxy `B0=H{[6ߛ~o1䭡\Gdƻ5B[#m!Ϡ1h}#|~hmiN;g :܋b\(q$UFT+EloQ$͔^ś^?JH&3B>* 't] %Tm ksBg(kRgm=z4YQmOz*CU ¶oU(P+fJhN c:޻Ų9IZ)jV4Z^5Tk善\oDW_AOVmGkʱ9sq˦EEy0S~FQD*j=ҹ>o4B5+)京Ӧ:u60-mDbqr(PSMY\[HwQnM/.`1:VYr}ΡvR,Y +EQ,`ʛ7 ,ҷ;70]H˷Tp8<M処V<|鶋aMDlaXtIMJ_[W"Ga83uF+ /QF"gY򧻴)׻hd j 5Y um&MS{4og+dl=3y05Ồ+r|nFEb7Ʒ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[t@Z endstream endobj 63 0 obj << /Length1 1458 /Length2 2231 /Length3 0 /Length 3169 /Filter /FlateDecode >> stream xڍT 8ToHE%ĭ-f.Ae113f1#gH!%J(%Eք%EE C-%[9 snx & P1`D =b2D^7DGAw>``afA1m?ff >54@ʴSf]pYˎÐ&|\I;hq Z-k@ ~.$C\6"S7FBl+ :ύs:AtЁn@Eo6Lk-$yNd8mbI8H$(:tB.s[Xbh7S@2aVZLm͙7he`s =E $!1H>?Ի4jǎN,s}g>wGvӪ75|+ݵ3k^LR;d 豭I'{)uM4Sn=omX;CYT%*pQV ƆJ|[Iщőގʹ4In}8c=?J߹- C5zj˻ܛ:ʗj}HNHi `mRMgx4Q{o7f I;J;TgbYQUgSxZ'^gOu{Y#vs˄ 뜪}"UոlD>.}`beEF♔]y2GK?rODusn}czWL?U*]7=a@Sue38-As5~(r6ySRd+>qݓJ73W4^KVzn|ta}|]&O ,* džN|y{4% uvB7S_lԲj#Vd/4y|ď3/CS[ԭm*6\;ietumZpp$Q:"ZTP3TndUb~w2ё-%ꖑ'ntC>p=}S!UKb4lq}(#v;тFv<5Z>cQQŒ;YUA Ira;4"W; R/?}vQ):Nviw<^߿Upɩ}>$ 붫))`7[0{}mށYAg<իb D{ +;j+M)/N ,yImîɛb:fc<2566_vw004"F:-JM~zX7Qr,ϣ&Ʋ@C{+Z {l u$M S/>;z}:܎Vcz0{иʾ%;0睘 E*ϰ o}d <EggxАŃ{QFksy#ϑWu^X,Ripqd/lZH5n.ů )]ϱ62N-uڑ'Y5oa2pL@[k"##V$kl榴<*pkP"%m)k87mHޚrG]I,?t_E0h'ӱ[(y%ud5У&5K5OuiM{,sޥ(7Mق&Etl:r6vE9Ϳp/f?RT =O ,i{=7SFVr㺵Og6}kp!gR| 7޺@Q_*_d}hfjYC>%Ԟ15gdZ5 9GDt#L<~n4 ׻뵏>Va]}P\jMk,*%#|Sh~ qՖzE8G0{ٿ)IM,QUSS3;:t¸n:("eݡ%. _y#`qݜ#!\^q. fkrDM>ʷ°{ vobv΂ =%bCO67Y;9'7t8hΎ% S endstream endobj 66 0 obj << /Producer (pdfTeX-1.40.16) /Creator (TeX) /CreationDate (D:20170312210538+01'00') /ModDate (D:20170312210538+01'00') /Trapped /False /PTEX.Fullbanner (This is pdfTeX, Version 3.14159265-2.6-1.40.16 (TeX Live 2015/Debian) kpathsea version 6.2.1) >> endobj 12 0 obj << /Type /ObjStm /N 47 /First 356 /Length 2585 /Filter /FlateDecode >> stream xZ[s۶~ׯc3g"wL3'Ƶ:mˬ%Q!)'?EXqOg̙XX]\N\B"1, )`$!Y '9$q $, 8% *@L  T$ u |x~w$&9#9r0pTiA?J $lhip D(4D3ˈN8Ix #F&Xb`JXBk"67@s~be0,-x1_tt?W~^Dgz|Y| '~{g!@W^У}dC`UKɊ?kflr^fPBt͗%q~\敟teI{-g7SVt,^x`J:A$8eV< it.瓴XΦ鲢$;:JQ^HGn)ǒ|(g߿ӏ┣ =%F6s}zH\{d$:F '; F _vౖ>6fm2*=I"CIP VU >O (Z}sf fEYߦmzmY ;e^4KC8<@vV@h*\ DFlȮ&'?ݙ(nrcxR I1pRe||K8P,abnj%YSm.a-̋mka>|Ê(U4=]3E[6(BnjCB S㱝z skBx-_E8ߨW^赣}AVGEz;1ku(T;rႼht ұmr2L8+N!̡LŐߨ8 ch-18cJ*r0BHD BuD!}ٍR=;,D,$t*%rWG4aK1’,6di9[Y3bY[ZJU4cljZьD7=1̆;rHKh*ұ37H e(p[*Z+XF"a5qX,~1W9x5 ϲђP_1m-eY@0s8@fcF1{PF,`! @0Ik}H6\P󚌭X6m 1Nᛅzm{;Qwƞ0Rf:J뱈P%@I89D怫.zkj!1%)D RcXb{E4`dt-+*|JDÞVkZ6U\UA9qKP Mh(3B]نg>h*hn1<01pU.L *OPuJbʶzMːvO,65͡m{ jn[fJ"n ryջ6rTd*/(^.8;?{4Ť}Kz4y4Fw%lx~x-Dw`X˘ 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 [<59D7E3746BE38E8388705FBF2E54AEA4> <59D7E3746BE38E8388705FBF2E54AEA4>] /Length 192 /Filter /FlateDecode >> stream x%9nQ*}V>1!!\C8 r 9%I>z-='? 8l."DD|ۍEXDDTD^IJ$ wicQdDhmY{Xyb>ڮ$ʢ"&ኺhhn˪C|ޭ>ڪK<<lvn呇?XgXSL endstream endobj startxref 111680 %%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/0000755000175100001440000000000013061325022013031 5ustar hornikuserspbkrtest/data/beets.RData0000644000175100001440000000067013027644130015061 0ustar hornikusersTKN0uJJ NP%),I@Њ]C/hI[KΛlz-BI(5Iic49603Bp8np),Nsuqkq8 c,HdT iXĂG?!C/u)OS;cڳU7z>1u0>]x*_W(u- U[0Np(V !^.W\֐|f;(B;SSs,IGpbkrtest/data/budworm.RData0000644000175100001440000000034713027644211015437 0ustar hornikusersP0 D!|>Od4X(}h`!&.ڮ׿5PJh2!j]dPP{::fe]%Rh=xSq%͏I/-m,Z ŽG882 ?u1\or /rI3NZʗ=Хs®Wj(Ga|+_4 ]GiFѶ\ppbkrtest/R/0000755000175100001440000000000013061325022012321 5ustar hornikuserspbkrtest/R/zzz-PB-anova-not-used.R0000644000175100001440000000335613027654001016451 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/get_ddf_Lb.R0000644000175100001440000001572413027653105014476 0ustar hornikusers#' @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. #' #' @name get_ddf_Lb #' #' @aliases get_Lb_ddf get_Lb_ddf.lmerMod Lb_ddf #' #' @param object A linear mixed model object. #' @param 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)} #' @param 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()}. #' @return Adjusted degrees of freedom (adjusment made by a Kenward-Roger #' approximation). #' #' @author Søren Højsgaard, \email{sorenh@@math.aau.dk} #' @seealso \code{\link{KRmodcomp}}, \code{\link{vcovAdj}}, #' \code{\link{model2restrictionMatrix}}, #' \code{\link{restrictionMatrix2model}} #' @references Ulrich Halekoh, Søren Højsgaard (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/} #' #' @keywords inference models #' @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 #' #' @rdname get_ddf_Lb get_Lb_ddf <- function(object, L){ UseMethod("get_Lb_ddf") } #' @rdname get_ddf_Lb get_Lb_ddf.lmerMod <- function(object, L){ Lb_ddf(L, vcov(object), vcovAdj(object)) } #' @rdname get_ddf_Lb Lb_ddf <- function(L, V0, Vadj) { if (!is.matrix(L)) L = matrix(L, nrow = 1) Theta <- t(L) %*% solve(L %*% V0 %*% t(L), L) P <- attr(Vadj, "P") W <- attr(Vadj, "W") A1 <- A2 <- 0 ThetaV0 <- Theta %*% V0 n.ggamma <- length(P) for (ii in 1:n.ggamma) { for (jj in c(ii:n.ggamma)) { e <- ifelse(ii == jj, 1, 2) ui <- ThetaV0 %*% P[[ii]] %*% V0 uj <- ThetaV0 %*% P[[jj]] %*% V0 A1 <- A1 + e * W[ii, jj] * (.spur(ui) * .spur(uj)) A2 <- A2 + e * W[ii, jj] * sum(ui * t(uj)) } } q <- nrow(L) # instead of finding rank 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)) 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))) V0 <- 1 + c1 * B V1 <- 1 - c2 * B V2 <- 1 - c3 * B V0 <- ifelse(abs(V0) < 1e-10, 0, V0) rho <- 1/q * (.divZero(1 - A2/q, V1))^2 * V0/V2 df2 <- 4 + (q + 2)/(q * rho - 1) df2 } #' @rdname get_ddf_Lb #' @param Lcoef Linear contrast matrix get_ddf_Lb <- function(object, Lcoef){ UseMethod("get_ddf_Lb") } #' @rdname get_ddf_Lb get_ddf_Lb.lmerMod <- function(object, Lcoef){ ddf_Lb(vcovAdj(object), Lcoef, vcov(object)) } #' @rdname get_ddf_Lb #' @param VVa Adjusted covariance matrix #' @param VV0 Unadjusted covariance matrix 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 } #' @rdname pb-modcomp 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 m2rm ## FIXME: restrictionMatrix2model -> rm2m #' @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. #' #' @name model-coerce #' #' @aliases model2restrictionMatrix model2restrictionMatrix.lm #' model2restrictionMatrix.mer model2restrictionMatrix.merMod #' restrictionMatrix2model restrictionMatrix2model.lm #' restrictionMatrix2model.mer restrictionMatrix2model.merMod #' #' @param largeModel,smallModel Model objects of the same "type". Possible types #' are linear mixed effects models and linear models (including generalized #' linear models) #' @param LL A restriction matrix. #' @return \code{model2restrictionMatrix}: A restriction matrix. #' \code{restrictionMatrix2model}: A model object. #' @note That these functions are visible is a recent addition; minor changes #' may occur. #' @author Ulrich Halekoh \email{uhalekoh@@health.sdu.dk}, Søren Højsgaard #' \email{sorenh@@math.aau.dk} #' @seealso \code{\link{PBmodcomp}}, \code{\link{PBrefdist}}, #' \code{\link{KRmodcomp}} #' @references Ulrich Halekoh, Søren Højsgaard (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/} #' @keywords utilities #' #' @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) #' #' @export model2restrictionMatrix #' @rdname model-coerce model2restrictionMatrix <- function (largeModel, smallModel) { UseMethod("model2restrictionMatrix") } #' @rdname model-coerce 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 } #' @rdname model-coerce 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 } #' @rdname model-coerce restrictionMatrix2model <- function(largeModel, LL){ UseMethod("restrictionMatrix2model") } #' @rdname model-coerce 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 } #' @rdname model-coerce 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 } .restrictedModelMatrix<-function(B,L) { ##cat("B:\n"); print(B); cat("L:\n"); print(L) ## find A such that ={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 } pbkrtest/R/KR-linearAlgebra.R0000644000175100001440000000260113027653407015522 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.R0000644000175100001440000001756113061316330014535 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) } ## DENNE DUER IKKE; Løber ud for hukommelse... ## FIXME vcovAdj16_internal is the function being used by vcovAdj vcovAdj16_internal <- function(Phi, SigmaG, X, details=0){ # save(SigmaG, file="SigmaG.RData") # return(19) 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("dim(M) : %s\n", toString(dim(M)))) ## M can have many many columns if(DB)cat(sprintf("dim(SigmaG) : %s\n", toString(dim(SigmaG)))) 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 } ## Dette er en kopi af '2015' udgaven vcovAdj16_internal <- function(Phi, SigmaG, X, details=0){ details=0 DB <- details > 0 ## debugging only t0 <- proc.time() if (DB){ cat("vcovAdj16_internal\n") cat(sprintf("dim(X) : %s\n", toString(dim(X)))) print(class(X)) cat(sprintf("dim(Sigma) : %s\n", toString(dim(SigmaG$Sigma)))) print(class(SigmaG$Sigma)) } ##SigmaInv <- chol2inv( chol( forceSymmetric(SigmaG$Sigma) ) ) SigmaInv <- chol2inv( chol( forceSymmetric(as(SigmaG$Sigma, "matrix")))) ##SigmaInv <- as(SigmaInv, "dpoMatrix") if(DB){ cat(sprintf("Finding SigmaInv: %10.5f\n", (proc.time()-t0)[1] )); t0 <- proc.time() } #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 HH[[ ii ]] <- SigmaG$G[[ii]] %*% SigmaInv OO[[ ii ]] <- HH[[ ii ]] %*% 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/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/pbkrtest-package.R0000644000175100001440000000065613027646544015723 0ustar hornikusers #' Internal functions in the pbkrtest package #' #' Internal functions called by other functions. #' #' #' @aliases print.PBmodcomp print.summaryPB summary.PBmodcomp plot.PBmodcomp #' summary.KRmodcomp print.KRmodcomp get_ddf_Lb get_ddf_Lb.lmerMod ddf_Lb #' KRmodcomp_init KRmodcomp_init.lmerMod vcovAdj15 vcovAdj15_internal vcovAdj16 #' vcovAdj16_internal KRmodcomp_init.mer as.data.frame.XXmodcomp #' @keywords internal 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.R0000644000175100001440000002650713027651440014436 0ustar hornikusers## ########################################################################## ## #' @title Ftest and degrees of freedom based on Kenward-Roger approximation #' #' @description An approximate F-test based on the Kenward-Roger approach. #' #' @name kr-modcomp #' ## ########################################################################## #' @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! #' #' @aliases KRmodcomp KRmodcomp.lmerMod KRmodcomp_internal KRmodcomp.mer #' @param largeModel An \code{lmer} model #' @param smallModel An \code{lmer} model or a restriction matrix #' @param 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. #' @param details If larger than 0 some timing details are printed. #' @param \dots Additional arguments to print function #' @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}, Søren Højsgaard #' \email{sorenh@@math.aau.dk} #' #' @seealso \code{\link{getKR}}, \code{\link{lmer}}, \code{\link{vcovAdj}}, #' \code{\link{PBmodcomp}} #' #' @references Ulrich Halekoh, Søren Højsgaard (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. #' #' @keywords models inference #' @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) #' #' #' @rdname kr-modcomp KRmodcomp <- function(largeModel, smallModel,betaH=0, details=0){ UseMethod("KRmodcomp") } #' @rdname kr-modcomp KRmodcomp.lmerMod <- 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 } #' @rdname kr-modcomp KRmodcomp.mer <- KRmodcomp.lmerMod .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.R0000644000175100001440000001526113027651715014374 0ustar hornikusers## -------------------------------------------------------------------- ## Calculate the adjusted covariance matrix for a mixed model ## ## Implemented in Banff, august 2013; Søren Højsgaard ## -------------------------------------------------------------------- #' @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. #' #' @name kr-vcov #' #' @aliases vcovAdj vcovAdj.lmerMod vcovAdj_internal vcovAdj0 vcovAdj2 #' vcovAdj.mer LMM_Sigma_G get_SigmaG get_SigmaG.lmerMod get_SigmaG.mer #' #' @param object An \code{lmer} model #' @param details If larger than 0 some timing details are printed. #' @return \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) } #' #' @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}, Søren Højsgaard #' \email{sorenh@@math.aau.dk} #' @seealso \code{\link{getKR}}, \code{\link{KRmodcomp}}, \code{\link{lmer}}, #' \code{\link{PBmodcomp}}, \code{\link{vcovAdj}} #' @references Ulrich Halekoh, Søren Højsgaard (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. #' #' @keywords inference models #' @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 #' } #' #' #' #' @export vcovAdj #' #' @rdname kr-vcov vcovAdj <- function(object, details=0){ UseMethod("vcovAdj") } #' @rdname kr-vcov 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.R0000644000175100001440000000155713027654216014127 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.R0000644000175100001440000001317313027653233014422 0ustar hornikusers### ########################################################### ### ### Computing of reference distribution; possibly in parallel ### ### ########################################################### #' @title Calculate reference distribution using parametric bootstrap #' #' @description Calculate reference distribution of likelihood ratio statistic #' in mixed effects models using parametric bootstrap #' #' @name pb-refdist #' #' @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. #' #' @aliases PBrefdist PBrefdist.mer PBrefdist.merMod PBrefdist.lm #' @param 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). #' @param 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). #' @param nsim The number of simulations to form the reference distribution. #' @param seed Seed for the random number generation. #' @param cl A vector identifying a cluster; used for calculating the reference #' distribution using several cores. See examples below. #' @param details The amount of output produced. Mainly relevant for debugging #' purposes. #' @return A numeric vector #' @author Søren Højsgaard \email{sorenh@@math.aau.dk} #' @seealso \code{\link{PBmodcomp}}, \code{\link{KRmodcomp}} #' @references Ulrich Halekoh, Søren Højsgaard (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/} #' @keywords models inference #' @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: Many more 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. #' #' @rdname pb-refdist PBrefdist <- function(largeModel, smallModel, nsim=1000, seed=NULL, cl=NULL, details=0){ UseMethod("PBrefdist") } #' @rdname pb-refdist 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 )) }))) } #' @rdname pb-refdist 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 } #' @rdname pb-refdist PBrefdist.mer <- PBrefdist.merMod pbkrtest/R/data-beets.R0000644000175100001440000000360313027650154014470 0ustar hornikusers#' @title beets data #' #' @description Yield and sugar percentage in sugar beets from a split plot #' experiment. 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. #' #' @name data-beets #' @docType data #' @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 #' +-----------|-----------|-----------+ #' } #' #' @references Ulrich Halekoh, Søren Højsgaard (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/} #' #' @keywords datasets #' #' @examples #' data(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)) #' "beets" pbkrtest/vignettes/0000755000175100001440000000000013061325022014130 5ustar hornikuserspbkrtest/vignettes/pbkrtest-introduction.Rnw0000644000175100001440000001202013027411536021200 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/README.md0000644000175100001440000000013313027655201013403 0ustar hornikusers# pbkrtest Parametric Bootstrap and Kenward Roger Based Methods for Mixed Model Comparison pbkrtest/MD50000644000175100001440000000431013062171005012427 0ustar hornikusers39a92d7405b38a84821348875d0eb2fe *ChangeLog aae04b2b92702152892e17c24df40efb *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 3e8a05ec7679de64db49603156ba4ed8 *R/KR-linearAlgebra.R 3091d683c6bf2b3b70360e7577302440 *R/KR-modcomp.R 9272ff49aa07069570dc7dad214495a9 *R/KR-utils.R a9d8ba829369ebfbba3aa720c1c81a88 *R/KR-vcovAdj.R 3f503d0ce3991fa539779c5c40e3da48 *R/KR-vcovAdj0.R 70fc88a09d7436716a47284417b131d9 *R/KR-vcovAdj15.R 34395aafa6235184a6aad013428f73a0 *R/KR-vcovAdj16.R 34ae06c1b1e308f81995f8a7fdd9f364 *R/PB-modcomp.R ebce97f4bfae4fdddd8af13593107fcb *R/PB-refdist.R 873ffab63d56478c6dbe8d522170420c *R/PB-utils.R 29dee00cc519eb4946d490d100726c0c *R/data-beets.R 94d64fd2f1ca6c7cb800ed79522fed60 *R/data-budworm.R 350885fcd916999b2c8fedd250995609 *R/getKR.R cd6afcd02cfe0ee64d347fa35eb899d4 *R/get_ddf_Lb.R 31a5c37e57535694cf9ebfa527cf7c9f *R/modelCoercion.R 5218e2c12061f1bd8460684c6d4287d4 *R/pbkrtest-package.R 8e71fac0cd8a96fd02c0fcc12b7709c7 *R/zzz-PB-anova-not-used.R 61b0b96bc95885219c28322223b4a8ff *README.md f8082fc0440a592cad891b44184360fb *build/vignette.rds 25a3a55d27aa15aa5472e6fc4d10310d *data/beets.RData 0bf3e5202394edbc9390961036629ad1 *data/budworm.RData 15b224179efc0f40c222cb38463ea34c *inst/CITATION 0744819ce2231310e601c6d81d5e5b03 *inst/doc/pbkrtest-introduction.R b2269613cc80640c998141269fa91bfd *inst/doc/pbkrtest-introduction.Rnw 3c4bbb5c953c0afe120a34ccce881e9e *inst/doc/pbkrtest-introduction.pdf 1d0661eb24fbc5e78bf446e9b7986da3 *man/data-beets.Rd 0caa812794e62ac5afd731b948a2b228 *man/data-budworm.Rd ec2ed7c184a4c4394fec980e5daf43bc *man/get_ddf_Lb.Rd 0cf337d9144d99ed7121aae7ed6013d2 *man/getkr.Rd 71953086e72b0ff3e9d77d2a4b77e6d8 *man/kr-modcomp.Rd 92832a49e76290de10a288e3a2ac49d3 *man/kr-vcov.Rd a35711f22b52d60f6e88af7c7e643d49 *man/model-coerce.Rd 217f6db1ecb5b30665c6826b279cb4ae *man/pb-modcomp.Rd af4b8600326d54741dce1ca41f90b625 *man/pb-refdist.Rd 8aa52272f769e5d8f168308f8a565e4e *man/pbkrtest-internal.Rd b2269613cc80640c998141269fa91bfd *vignettes/pbkrtest-introduction.Rnw pbkrtest/build/0000755000175100001440000000000013061325022013217 5ustar hornikuserspbkrtest/build/vignette.rds0000644000175100001440000000033213061325022015554 0ustar hornikusersb```b`fff`b2 1# ',H.*I-.+)O)M. +GSU'O$_8{ Rp+`e@„5/17,vԂԼ?iN,/AQU▙ 7$apq2݀a>9`~E\MI,F(WJbI^ZP? pbkrtest/DESCRIPTION0000644000175100001440000000165013062171005013631 0ustar hornikusersPackage: pbkrtest Version: 0.4-7 Title: Parametric Bootstrap and Kenward Roger Based Methods for Mixed Model Comparison Author: Ulrich Halekoh Søren Højsgaard Maintainer: Søren Højsgaard 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 Encoding: UTF-8 ZipData: no License: GPL (>= 2) RoxygenNote: 5.0.1 NeedsCompilation: no Packaged: 2017-03-12 20:05:38 UTC; sorenh Repository: CRAN Date/Publication: 2017-03-15 08:49:25 pbkrtest/ChangeLog0000644000175100001440000001123513027654425013712 0ustar hornikusers2016-12-27 Søren Højsgaard * Converted to roxygen format * Put on github * Version 0.4-7 NOT UPLOADED 2016-01-27 Søren Højsgaard * Update of description file with correct version requirement. * Version 0.4-6 uploaded 2016-01-12 Søren Højsgaard * 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 Søren Højsgaard * Updates to comply with R-devel * Version 0.4-4 uploaded 2015-07-12 Søren Højsgaard * 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 Søren Højsgaard * Package no longer Depend(s) on MASS * Version 0.4-2 uploaded 2014-09-08 Søren Højsgaard * 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 Søren Højsgaard * 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 Søren Højsgaard * 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 Søren Højsgaard * 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 Søren Højsgaard * 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 Søren Højsgaard * 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 Søren Højsgaard * 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 Søren Højsgaard * 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 Søren Højsgaard * F-distribution estimate of reference distribution for parametric bootstrap corrected. * Version 0.2.1 uploaded. 2011-12-30 Søren Højsgaard * F-distribution estimate of reference distribution for parametric bootstrap added. * Version 0.2.0 uploaded. 2011-12-08 Søren Højsgaard * Density estimate of reference distribution for parametric bootstrap added. * Version 0.1.3 uploaded. 2011-12-03 Søren Højsgaard * Important speedup of KRmodcomp * Version 0.1.2 uploaded. 2011-11-11 Søren Højsgaard * Various changes * Version 0.1.1 uploaded 2011-10-23 Søren Højsgaard * Version 0.1.0 uploaded pbkrtest/man/0000755000175100001440000000000013027646620012707 5ustar hornikuserspbkrtest/man/data-beets.Rd0000644000175100001440000000361213027650163015206 0ustar hornikusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/data-beets.R \docType{data} \name{data-beets} \alias{beets} \alias{data-beets} \title{beets data} \format{The format is: chr "beets"} \usage{ beets } \description{ Yield and sugar percentage in sugar beets from a split plot experiment. 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. } \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 +-----------|-----------|-----------+ } } \examples{ data(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)) } \references{ Ulrich Halekoh, Søren Højsgaard (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/} } \keyword{datasets} pbkrtest/man/data-budworm.Rd0000644000175100001440000000343313027650377015573 0ustar hornikusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/data-budworm.R \docType{data} \name{data-budworm} \alias{budworm} \alias{data-budworm} \title{budworm data} \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 } }} \source{ Collet, D. (1991) Modelling Binary Data, Chapman & Hall, London, Example 3.7 } \usage{ budworm } \description{ Effect of Insecticide on survivial of tobacco budworms number of killed budworms exposed to an insecticidepp mortality of the moth tobacco budworm 'Heliothis virescens' for 6 doses of the pyrethroid trans-cypermethrin differentiated with respect to sex } \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; } } \references{ Venables, W.N; Ripley, B.D.(1999) Modern Applied Statistics with S-Plus, Heidelberg, Springer, 3rd edition, chapter 7.2 } \keyword{datasets} pbkrtest/man/kr-vcov.Rd0000644000175100001440000000512413027652040014560 0ustar hornikusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/KR-vcovAdj.R \name{kr-vcov} \alias{LMM_Sigma_G} \alias{get_SigmaG} \alias{get_SigmaG.lmerMod} \alias{get_SigmaG.mer} \alias{kr-vcov} \alias{vcovAdj} \alias{vcovAdj.lmerMod} \alias{vcovAdj.mer} \alias{vcovAdj0} \alias{vcovAdj2} \alias{vcovAdj_internal} \title{Ajusted covariance matrix for linear mixed models according to Kenward and Roger} \usage{ vcovAdj(object, details = 0) \method{vcovAdj}{lmerMod}(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) } } \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. } \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. } \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 } } \author{ Ulrich Halekoh \email{uhalekoh@health.sdu.dk}, Søren Højsgaard \email{sorenh@math.aau.dk} } \references{ Ulrich Halekoh, Søren Højsgaard (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. } \seealso{ \code{\link{getKR}}, \code{\link{KRmodcomp}}, \code{\link{lmer}}, \code{\link{PBmodcomp}}, \code{\link{vcovAdj}} } \keyword{inference} \keyword{models} pbkrtest/man/model-coerce.Rd0000644000175100001440000000523313027652103015530 0ustar hornikusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/modelCoercion.R \name{model-coerce} \alias{model-coerce} \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} \usage{ model2restrictionMatrix(largeModel, smallModel) \method{model2restrictionMatrix}{merMod}(largeModel, smallModel) \method{model2restrictionMatrix}{lm}(largeModel, smallModel) restrictionMatrix2model(largeModel, LL) \method{restrictionMatrix2model}{merMod}(largeModel, LL) \method{restrictionMatrix2model}{lm}(largeModel, LL) } \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.} } \value{ \code{model2restrictionMatrix}: A restriction matrix. \code{restrictionMatrix2model}: A model object. } \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. } \note{ That these functions are visible is a recent addition; minor changes may occur. } \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) } \author{ Ulrich Halekoh \email{uhalekoh@health.sdu.dk}, Søren Højsgaard \email{sorenh@math.aau.dk} } \references{ Ulrich Halekoh, Søren Højsgaard (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/} } \seealso{ \code{\link{PBmodcomp}}, \code{\link{PBrefdist}}, \code{\link{KRmodcomp}} } \keyword{utilities} pbkrtest/man/pb-refdist.Rd0000644000175100001440000000560213027654241015236 0ustar hornikusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/PB-refdist.R \name{pb-refdist} \alias{PBrefdist} \alias{PBrefdist.lm} \alias{PBrefdist.mer} \alias{PBrefdist.merMod} \alias{pb-refdist} \title{Calculate reference distribution 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}{merMod}(largeModel, smallModel, nsim = 1000, seed = NULL, cl = NULL, details = 0) \method{PBrefdist}{mer}(largeModel, smallModel, nsim = 1000, seed = NULL, cl = NULL, details = 0) } \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.} } \value{ A numeric vector } \description{ Calculate reference distribution of likelihood ratio statistic in mixed effects models using parametric bootstrap } \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. } \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: Many more 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. } \author{ Søren Højsgaard \email{sorenh@math.aau.dk} } \references{ Ulrich Halekoh, Søren Højsgaard (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/} } \seealso{ \code{\link{PBmodcomp}}, \code{\link{KRmodcomp}} } \keyword{inference} \keyword{models} pbkrtest/man/getkr.Rd0000644000175100001440000000252613027651600014311 0ustar hornikusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/getKR.R \name{getkr} \alias{getKR} \alias{getkr} \title{Extract (or "get") components from a \code{KRmodcomp} object.} \usage{ getKR(object, name = c("ndf", "ddf", "Fstat", "p.value", "F.scaling", "FstatU", "p.valueU", "aux")) } \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.} } \description{ Extract (or "get") components from a \code{KRmodcomp} object, which is the result of the \code{KRmodcomp} function. } \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. } \author{ Søren Højsgaard \email{sorenh@math.aau.dk} } \references{ Ulrich Halekoh, Søren Højsgaard (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/} } \seealso{ \code{\link{KRmodcomp}}, \code{\link{PBmodcomp}}, \code{\link{vcovAdj}} } \keyword{utilities} pbkrtest/man/pbkrtest-internal.Rd0000644000175100001440000000113713027423033016637 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/kr-modcomp.Rd0000644000175100001440000000754213027651600015250 0ustar hornikusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/KR-modcomp.R \name{kr-modcomp} \alias{KRmodcomp} \alias{KRmodcomp.lmerMod} \alias{KRmodcomp.mer} \alias{KRmodcomp_internal} \alias{kr-modcomp} \title{Ftest and degrees of freedom based on Kenward-Roger approximation} \usage{ KRmodcomp(largeModel, smallModel, betaH = 0, details = 0) \method{KRmodcomp}{lmerMod}(largeModel, smallModel, betaH = 0, details = 0) \method{KRmodcomp}{mer}(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} } \description{ An approximate F-test based on the Kenward-Roger approach. } \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! } \note{ This functionality is not thoroughly tested and should be used with care. Please do report bugs etc. } \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) } \author{ Ulrich Halekoh \email{ulrich.halekoh@agrsci.dk}, Søren Højsgaard \email{sorenh@math.aau.dk} } \references{ Ulrich Halekoh, Søren Højsgaard (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. } \seealso{ \code{\link{getKR}}, \code{\link{lmer}}, \code{\link{vcovAdj}}, \code{\link{PBmodcomp}} } \keyword{inference} \keyword{models} pbkrtest/man/pb-modcomp.Rd0000644000175100001440000001606413027651600015234 0ustar hornikusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/PB-modcomp.R \name{pb-modcomp} \alias{PBmodcomp} \alias{PBmodcomp.lm} \alias{PBmodcomp.mer} \alias{PBmodcomp.merMod} \alias{getLRT} \alias{getLRT.lm} \alias{getLRT.mer} \alias{getLRT.merMod} \alias{pb-modcomp} \alias{plot.XXmodcomp} \title{Model comparison using parametric bootstrap methods.} \usage{ PBmodcomp(largeModel, smallModel, nsim = 1000, ref = NULL, seed = NULL, cl = NULL, details = 0) \method{PBmodcomp}{merMod}(largeModel, smallModel, nsim = 1000, ref = NULL, seed = NULL, cl = NULL, details = 0) \method{PBmodcomp}{lm}(largeModel, smallModel, nsim = 1000, ref = NULL, seed = NULL, cl = NULL, details = 0) } \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.} } \description{ Model comparison of nested models using parametric bootstrap methods. Implemented for some commonly applied model types. } \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. } \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). } \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) } } \author{ Søren Højsgaard \email{sorenh@math.aau.dk} } \references{ Ulrich Halekoh, Søren Højsgaard (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/} } \seealso{ \code{\link{KRmodcomp}}, \code{\link{PBrefdist}} } \keyword{inference} \keyword{models} pbkrtest/man/get_ddf_Lb.Rd0000644000175100001440000000423313027654241015207 0ustar hornikusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/get_ddf_Lb.R \name{get_ddf_Lb} \alias{Lb_ddf} \alias{ddf_Lb} \alias{get_Lb_ddf} \alias{get_Lb_ddf.lmerMod} \alias{get_ddf_Lb} \alias{get_ddf_Lb.lmerMod} \title{Adjusted denomintor degress freedom for linear estimate for linear mixed model.} \usage{ get_Lb_ddf(object, L) \method{get_Lb_ddf}{lmerMod}(object, L) Lb_ddf(L, V0, Vadj) get_ddf_Lb(object, Lcoef) \method{get_ddf_Lb}{lmerMod}(object, Lcoef) ddf_Lb(VVa, Lcoef, VV0 = VVa) } \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()}.} \item{Lcoef}{Linear contrast matrix} \item{VVa}{Adjusted covariance matrix} \item{VV0}{Unadjusted covariance matrix} } \value{ Adjusted degrees of freedom (adjusment made by a Kenward-Roger approximation). } \description{ Get adjusted denomintor degress freedom for testing Lb=0 in a linear mixed model where L is a restriction matrix. } \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 } \author{ Søren Højsgaard, \email{sorenh@math.aau.dk} } \references{ Ulrich Halekoh, Søren Højsgaard (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/} } \seealso{ \code{\link{KRmodcomp}}, \code{\link{vcovAdj}}, \code{\link{model2restrictionMatrix}}, \code{\link{restrictionMatrix2model}} } \keyword{inference} \keyword{models}