pbkrtest/0000755000176200001440000000000014021642320012102 5ustar liggesuserspbkrtest/NAMESPACE0000644000176200001440000000500414021623143013322 0ustar liggesusers# Generated by roxygen2: do not edit by hand S3method(KRmodcomp,lmerMod) S3method(PBmodcomp,lm) S3method(PBmodcomp,merMod) S3method(PBrefdist,lm) S3method(PBrefdist,merMod) S3method(SATmodcomp,lmerMod) S3method(as.data.frame,KRmodcomp) S3method(as.data.frame,PBmodcomp) S3method(as.data.frame,SATmodcomp) S3method(as.data.frame,XXmodcomp) S3method(get_Lb_ddf,lmerMod) S3method(get_SigmaG,lmerMod) S3method(model2remat,default) S3method(model2remat,lm) S3method(model2remat,merMod) S3method(plot,PBmodcomp) S3method(print,KRmodcomp) S3method(print,PBmodcomp) S3method(print,SATmodcomp) S3method(print,summaryPB) S3method(remat2model,default) S3method(remat2model,lm) S3method(remat2model,merMod) S3method(summary,KRmodcomp) S3method(summary,PBmodcomp) S3method(tidy,KRmodcomp) S3method(tidy,PBmodcomp) S3method(tidy,SATmodcomp) S3method(vcovAdj,lmerMod) export("%>%") export(KRmodcomp) export(Lb_ddf) export(PBmodcomp) export(PBrefdist) export(SATmodcomp) export(ddf_Lb) export(getKR) export(get_Lb_ddf) export(get_SigmaG) export(make_modelmat) export(make_remat) export(model2remat) export(remat2model) export(tidy) export(vcovAdj) export(vcovAdj.lmerMod) import(lme4) importClassesFrom(Matrix,Matrix) importFrom(MASS,ginv) importFrom(Matrix,Matrix) importFrom(Matrix,rankMatrix) importFrom(Matrix,sparseMatrix) importFrom(broom,tidy) importFrom(dplyr,as_tibble) importFrom(graphics,abline) importFrom(graphics,legend) importFrom(graphics,lines) importFrom(graphics,plot) importFrom(magrittr,"%>%") importFrom(methods,as) importFrom(methods,is) importFrom(parallel,clusterCall) importFrom(parallel,clusterExport) importFrom(parallel,clusterSetRNGStream) importFrom(parallel,detectCores) importFrom(parallel,makeCluster) importFrom(parallel,mclapply) importFrom(stats,as.formula) importFrom(stats,coef) importFrom(stats,family) importFrom(stats,formula) importFrom(stats,getCall) importFrom(stats,logLik) importFrom(stats,model.matrix) importFrom(stats,pchisq) importFrom(stats,pf) importFrom(stats,pgamma) importFrom(stats,printCoefmat) importFrom(stats,quantile) importFrom(stats,sigma) importFrom(stats,simulate) importFrom(stats,terms) importFrom(stats,update) importFrom(stats,update.formula) importFrom(stats,var) importFrom(stats,vcov) importFrom(utils,head) importMethodsFrom(Matrix,"%*%") importMethodsFrom(Matrix,"*") importMethodsFrom(Matrix,chol) importMethodsFrom(Matrix,chol2inv) importMethodsFrom(Matrix,diag) importMethodsFrom(Matrix,forceSymmetric) importMethodsFrom(Matrix,isSymmetric) importMethodsFrom(Matrix,solve) importMethodsFrom(Matrix,t) pbkrtest/ChangeLog0000644000176200001440000001146213712550526013674 0ustar liggesusers2019-12-28 Søren Højsgaard * Making refit more verbose 2017-03-12 Søren Højsgaard * Converted to roxygen format * Put on github * Certain internal computations reverted to earlier implementation. * Version 0.4-7 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/README.md0000644000176200001440000001233013766651571013407 0ustar liggesusers # `pbkrtest`: Parametric Bootstrap, Kenward-Roger and Satterthwaite Based Methods for Mixed Model Comparison Attention is on mixed effects models (as implemented in the ‘lme4’ package). For linear mixed models, ‘pbkrtest’ implements (1) a parametric bootstrap test, (2) a Kenward-Roger-type F-test and (3) a Satterthwaite-type F-test. The parametric bootstrap test is also implemented for generalized linear mixed models (as implemented in ‘lme4’) and for generalized linear models. The facilities of the package are documented in the paper by Halehoh and Højsgaard, (2012, ). Please see ‘citation(“pbkrtest”)’ for information about citing the paper and the package. If you use the package in your work, please do cite the 2012-paper. There are other packages that use ‘pbkrtest’ under the hood. If you use one of those packages, please do also cite our 2012 paper. Documents: 1. [Halekoh and Højsgaard (2012) A Kenward-Roger Approximation and Parametric Bootstrap Methods for Tests in Linear Mixed Models The R Package pbkrtest](https://www.jstatsoft.org/index.php/jss/article/view/v059i09/v59i09.pdf) 2. [Vignette: introduction to ‘pbkrtest’](https://cran.r-project.org/package=pbkrtest/vignettes/pbkrtest.pdf) 3. [Webpage for the package](https://people.math.aau.dk/~sorenh/software/pbkrtest/index.html) ## Installation `pbkrtest` is available on CRAN and can be installed as usual: install.packages('pbkrtest') To build and install from Github with vignettes run this command from within `R` (please install `remotes` first if not already installed): # install.packages('remotes') remotes::install_github("hojsgaard/pbkrtest", build_vignettes = TRUE) You can also install the package without vignettes if needed as follows: remotes::install_github("hojsgaard/pbkrtest", build_vignettes = FALSE) ## Development site See . ## Online documentation See . ## Brief introduction ``` r library(pbkrtest) library(ggplot2) ggplot(sleepstudy) + geom_line(aes(Days, Reaction, group=Subject, color=Subject)) ``` ![](README_files/figure-gfm/unnamed-chunk-2-1.png) ``` r fm0 <- lmer(Reaction ~ Days + (Days|Subject), data=sleepstudy) fm1 <- update(fm0, .~. - Days) p0 <- anova(fm0, fm1) p1 <- PBmodcomp(fm0, fm1) p2 <- KRmodcomp(fm0, fm1) p3 <- SATmodcomp(fm0, fm1) p0 #> Data: sleepstudy #> Models: #> fm1: Reaction ~ (Days | Subject) #> fm0: Reaction ~ Days + (Days | Subject) #> npar AIC BIC logLik deviance Chisq Df Pr(>Chisq) #> fm1 5 1785.5 1801.4 -887.74 1775.5 #> fm0 6 1763.9 1783.1 -875.97 1751.9 23.537 1 1.226e-06 *** #> --- #> Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 p1 #> Bootstrap test; time: 8.58 sec; samples: 1000; extremes: 0; #> Requested samples: 1000 Used samples: 994 Extremes: 0 #> large : Reaction ~ Days + (Days | Subject) #> Reaction ~ (Days | Subject) #> stat df p.value #> LRT 23.516 1 1.239e-06 *** #> PBtest 23.516 0.001005 ** #> --- #> Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 p2 #> large : Reaction ~ Days + (Days | Subject) #> small : Reaction ~ (Days | Subject) #> stat ndf ddf F.scaling p.value #> Ftest 45.853 1.000 17.000 1 3.264e-06 *** #> --- #> Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 p3 #> large : Reaction ~ Days + (Days | Subject) #> small (restriction matrix) : #> #> 0 1 #> statistic ndf ddf p.value #> [1,] 45.853 1.000 17 3.264e-06 *** #> --- #> Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 tidy(p0) #> Warning in tidy.anova(p0): The following column names in ANOVA output were not #> recognized or transformed: npar #> # A tibble: 2 x 9 #> term npar AIC BIC logLik deviance statistic df p.value #> #> 1 fm1 5 1785. 1801. -888. 1775. NA NA NA #> 2 fm0 6 1764. 1783. -876. 1752. 23.5 1 0.00000123 tidy(p1) #> # A tibble: 2 x 4 #> type stat df p.value #> #> 1 LRT 23.5 1 0.00000124 #> 2 PBtest 23.5 NA 0.00101 tidy(p2) #> # A tibble: 2 x 6 #> type stat ndf ddf F.scaling p.value #> #> 1 Ftest 45.9 1 17. 1 0.00000326 #> 2 FtestU 45.9 1 17. NA 0.00000326 tidy(p3) #> # A tibble: 1 x 5 #> type statistic ndf ddf p.value #> #> 1 Ftest 45.9 1 17.0 0.00000326 ``` Please find more examples in the other vignettes available at . pbkrtest/data/0000755000176200001440000000000013712550526013027 5ustar liggesuserspbkrtest/data/budworm.RData0000755000176200001440000000034713712550526015432 0ustar liggesusersP0 D!|>Od4X(}h`!&.ڮ׿5PJh2!j]dPP{::fe]%Rh=xSq%͏I/-m,Z ŽG882 ?u1\or /rI3NZʗ=Хs®Wj(Ga|+_4 ]GiFѶ\ppbkrtest/data/beets.RData0000755000176200001440000000067013712550526015054 0ustar liggesusersTKN0uJJ 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/man/0000755000176200001440000000000013712550526012671 5ustar liggesuserspbkrtest/man/internal-pbkrtest.Rd0000755000176200001440000000033113712550526016630 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/NAMESPACE.R \name{internal-pbkrtest} \alias{internal-pbkrtest} \alias{"\%>\%"} \title{pbkrtest internal} \description{ pbkrtest internal } pbkrtest/man/pb-modcomp.Rd0000755000176200001440000001777713766702721015250 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/PB-modcomp.R \name{pb-modcomp} \alias{pb-modcomp} \alias{PBmodcomp} \alias{PBmodcomp.lm} \alias{PBmodcomp.merMod} \alias{getLRT} \alias{getLRT.lm} \alias{getLRT.merMod} \alias{plot.XXmodcomp} \alias{PBmodcomp.mer} \alias{getLRT.mer} \alias{seqPBmodcomp} \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 ) seqPBmodcomp(largeModel, smallModel, h = 20, nsim = 1000, cl = 1) } \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.} \item{h}{For sequential computing for bootstrap p-values: The number of extreme cases needed to generate before the sampling proces stops.} } \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) NSIM <- 50 ## Simulations in parametric bootstrap ## 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=NSIM, cl=1) anova(sug, sug.h) PBmodcomp(sug, sug.s, nsim=NSIM, cl=1) ## 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=NSIM, cl=1) anova(sug, sug.s) PBmodcomp(sug, sug.s, nsim=NSIM, cl=1) ## 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=NSIM, cl=1) anova(glm.D93, glm.D93.t, test="Chisq") PBmodcomp(glm.D93, glm.D93.t, nsim=NSIM, cl=1) ## 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, cl=2) } \dontrun{ (fmLarge <- lmer(Reaction ~ Days + (Days|Subject), sleepstudy)) ## removing Days (fmSmall <- lmer(Reaction ~ 1 + (Days|Subject), sleepstudy)) anova(fmLarge, fmSmall) PBmodcomp(fmLarge, fmSmall, cl=1) ## The same test using a restriction matrix L <- cbind(0,1) PBmodcomp(fmLarge, L, cl=1) ## Vanilla PBmodcomp(beet0, beet_no.harv, nsim=NSIM, cl=1) ## Simulate reference distribution separately: refdist <- PBrefdist(beet0, beet_no.harv, nsim=1000) PBmodcomp(beet0, beet_no.harv, ref=refdist, cl=1) ## 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=NSIM, cl=cl) PBmodcomp(beet0, beet_no.harv, ref=refdist) ## It is recommended to stop the clusters before quitting R: stopCluster(cl) } ## Linear and generalized linear models: m11 <- lm(dist ~ speed + I(speed^2), data=cars) m10 <- update(m11, ~.-I(speed^2)) anova(m11, m10) PBmodcomp(m11, m10, cl=1, nsim=NSIM) PBmodcomp(m11, ~.-I(speed^2), cl=1, nsim=NSIM) PBmodcomp(m11, c(0, 0, 1), cl=1, nsim=NSIM) m21 <- glm(dist ~ speed + I(speed^2), family=Gamma("identity"), data=cars) m20 <- update(m21, ~.-I(speed^2)) anova(m21, m20, test="Chisq") PBmodcomp(m21, m20, cl=1, nsim=NSIM) PBmodcomp(m21, ~.-I(speed^2), cl=1, nsim=NSIM) PBmodcomp(m21, c(0, 0, 1), cl=1, nsim=NSIM) } \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{https://www.jstatsoft.org/v59/i09/} } \seealso{ \code{\link{KRmodcomp}}, \code{\link{PBrefdist}} } \author{ Søren Højsgaard \email{sorenh@math.aau.dk} } \keyword{inference} \keyword{models} pbkrtest/man/sat-modcomp.Rd0000644000176200001440000000416713766702721015420 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/SAT-modcomp.R \name{sat-modcomp} \alias{sat-modcomp} \alias{SATmodcomp} \alias{SATmodcomp.lmerMod} \title{F-test and degrees of freedom based on Satterthwaite approximation} \usage{ SATmodcomp( largeModel, smallModel, details = 0, eps = sqrt(.Machine$double.eps) ) \method{SATmodcomp}{lmerMod}( largeModel, smallModel, details = 0, eps = sqrt(.Machine$double.eps) ) } \arguments{ \item{largeModel}{An \code{lmerMod} model.} \item{smallModel}{An \code{lmerMod} model, a restriction matrix or a model formula. See example section.} \item{details}{If larger than 0 some timing details are printed.} \item{eps}{A small number.} } \description{ An approximate F-test based on the Satterthwaite approach. } \details{ Notice: It cannot be guaranteed that the results agree with other implementations of the Satterthwaite approach! } \note{ This code is greatly inspired by code in the lmerTest package. This is a recent addition to the pbkrtest package; please report unexpected behaviour. } \examples{ (fm1 <- lmer(Reaction ~ Days + (Days|Subject), sleepstudy)) L1 <- cbind(0,1) SATmodcomp(fm1, L1) (fm2 <- lmer(Reaction ~ Days + I(Days^2) + (Days|Subject), sleepstudy)) ## Test for no effect of Days. There are three ways of using the function: ## 1) Define 2-df contrast - since L has 2 (linearly independent) rows ## the F-test is on 2 (numerator) df: L2 <- rbind(c(0, 1, 0), c(0, 0, 1)) SATmodcomp(fm2, L2) ## 2) Use two model objects fm3 <- update(fm2, ~. - Days - I(Days^2)) SATmodcomp(fm2, fm3) ## 3) Specify restriction as formula SATmodcomp(fm2, ~. - Days - I(Days^2)) } \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{https://www.jstatsoft.org/v59/i09/} } \seealso{ \code{\link{getKR}}, \code{\link{lmer}}, \code{\link{vcovAdj}}, \code{\link{PBmodcomp}} } \author{ Søren Højsgaard, \email{sorenh@math.aau.dk} } \keyword{inference} \keyword{models} pbkrtest/man/kr-vcov.Rd0000755000176200001440000000514313761653250014557 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/KR-vcovAdj.R \name{kr-vcov} \alias{kr-vcov} \alias{vcovAdj} \alias{vcovAdj.lmerMod} \alias{vcovAdj_internal} \alias{vcovAdj0} \alias{vcovAdj2} \alias{vcovAdj.mer} \alias{LMM_Sigma_G} \alias{get_SigmaG} \alias{get_SigmaG.lmerMod} \alias{get_SigmaG.mer} \title{Ajusted covariance matrix for linear mixed models according to Kenward and Roger} \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) class(fm1) ## Here the adjusted and unadjusted covariance matrices are identical, ## but that is not generally the case: v1 <- vcov(fm1) v2 <- vcovAdj(fm1, details=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 } } \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{https://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}} } \author{ Ulrich Halekoh \email{uhalekoh@health.sdu.dk}, Søren Højsgaard \email{sorenh@math.aau.dk} } \keyword{inference} \keyword{models} pbkrtest/man/kr-modcomp.Rd0000755000176200001440000000734213761653250015243 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/KR-modcomp.R \name{kr-modcomp} \alias{kr-modcomp} \alias{KRmodcomp} \alias{KRmodcomp.lmerMod} \alias{KRmodcomp_internal} \alias{KRmodcomp.mer} \title{F-test 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) } \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.} } \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) } \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{https://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}} } \author{ Ulrich Halekoh \email{uhalekoh@health.sdu.dk}, Søren Højsgaard \email{sorenh@math.aau.dk} } \keyword{inference} \keyword{models} pbkrtest/man/compute_auxillary.Rd0000644000176200001440000000114013712550526016722 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/SAT-modcomp.R \name{compute_auxillary} \alias{compute_auxillary} \title{Compute_auxillary quantities needed for the Satterthwaite approximation.} \usage{ compute_auxillary(model, tol = 1e-06) } \arguments{ \item{model}{A linear mixed model object} \item{tol}{A tolerance} } \value{ A list } \description{ Computes vcov of variance parameters (theta, sigma), jacobian of each variance parameter etc. } \details{ The code is greatly inspired by code from the lmerTest package. } \author{ Søren Højsgaard } \keyword{internal} pbkrtest/man/internal.Rd0000755000176200001440000000103613766666573015022 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/internal-pbkrtest.R \name{internal} \alias{internal} \alias{\%>\%} \alias{print.PBmodcomp} \alias{print.summaryPB} \alias{summary.PBmodcomp} \alias{plot.PBmodcomp} \alias{summary.KRmodcomp} \alias{print.KRmodcomp} \alias{KRmodcomp_init} \alias{KRmodcomp_init.lmerMod} \alias{KRmodcomp_init.mer} \alias{as.data.frame.XXmodcomp} \alias{tidy} \title{Internal functions for the pbkrtest package} \description{ These functions are not intended to be called directly. } pbkrtest/man/devfun_vp.Rd0000644000176200001440000000136013712550526015154 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/SAT-modcomp.R \name{devfun_vp} \alias{devfun_vp} \title{Compute Deviance of an LMM as a Function of Variance Parameters} \usage{ devfun_vp(varpar, devfun, reml) } \arguments{ \item{varpar}{variance parameters; \code{varpar = c(theta, sigma)}.} \item{devfun}{deviance function as a function of theta only.} \item{reml}{if \code{TRUE} the REML deviance is computed; if \code{FALSE}, the ML deviance is computed.} } \value{ the REML or ML deviance. } \description{ This function is used for extracting the asymptotic variance-covariance matrix of the variance parameters. } \author{ Rune Haubo B. Christensen. Adapted to pbkrtest by Søren Højsgaard. } \keyword{internal} pbkrtest/man/get_covbeta.Rd0000644000176200001440000000123713712550526015445 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/SAT-modcomp.R \name{get_covbeta} \alias{get_covbeta} \title{Compute cov(beta) as a function of varpar of an LMM} \usage{ get_covbeta(varpar, devfun) } \arguments{ \item{varpar}{variance parameters; \code{varpar = c(theta, sigma)}.} \item{devfun}{deviance function as a function of theta only.} } \value{ cov(beta) at supplied varpar values. } \description{ At the optimum cov(beta) is available as vcov(lmer-model). This function computes cov(beta) at non (RE)ML estimates of \code{varpar}. } \author{ Rune Haubo B. Christensen. Adapted to pbkrtest by Søren Højsgaard. } \keyword{internal} pbkrtest/man/getkr.Rd0000755000176200001440000000254413761653250014306 0ustar liggesusers% 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) modcomp <- KRmodcomp(lg, sm) getKR(modcomp, "ddf") # get denominator degrees of freedom. } \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{https://www.jstatsoft.org/v59/i09/} } \seealso{ \code{\link{KRmodcomp}}, \code{\link{PBmodcomp}}, \code{\link{vcovAdj}} } \author{ Søren Højsgaard \email{sorenh@math.aau.dk} } \keyword{utilities} pbkrtest/man/model-coerce.Rd0000755000176200001440000000521113761653250015522 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/model-coerce.R \name{model-coerce} \alias{model-coerce} \alias{model2remat} \alias{remat2model} \alias{make_modelmat} \alias{make_remat} \title{Conversion between a model object and a restriction matrix} \usage{ model2remat(largeModel, smallModel, sparse = FALSE) remat2model(largeModel, L, REML = TRUE, ...) make_modelmat(X, L) make_remat(X, X2) } \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{sparse}{Should the restriction matrix be sparse or dense?} \item{L}{A restriction matrix; a full rank matrix with as many columns as `X` has.} \item{REML}{Controls if new model object should be fitted with REML or ML.} \item{...}{Additional arguments; not used.} \item{X, X2}{Model matrices. Must have same numer of rows.} } \value{ \code{model2remat}: A restriction matrix. \code{remat2model}: 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. } \details{ `make_remat` Make a restriction matrix. If span(X2) is in span(X) then the corresponding restriction matrix `L` is returned. } \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 <- model2remat(sug, sug.h); L.h L.s <- model2remat(sug, sug.s); L.s ## Construct submodels from restriction matrices mod.h <- remat2model(sug, L.h); mod.h mod.s <- remat2model(sug, L.s); mod.s ## Sanity check: The models have the same fitted values and log likelihood plot(fitted(mod.h), fitted(sug.h)) plot(fitted(mod.s), fitted(sug.s)) logLik(mod.h) logLik(sug.h) logLik(mod.s) logLik(sug.s) } \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{https://www.jstatsoft.org/v59/i09/} } \seealso{ \code{\link{PBmodcomp}}, \code{\link{PBrefdist}}, \code{\link{KRmodcomp}} } \author{ Ulrich Halekoh \email{uhalekoh@health.sdu.dk}, Søren Højsgaard \email{sorenh@math.aau.dk} } \keyword{utilities} pbkrtest/man/pb-refdist.Rd0000755000176200001440000001050513761653250015225 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/PB-refdist.R \name{pb-refdist} \alias{pb-refdist} \alias{PBrefdist} \alias{PBrefdist.merMod} \alias{PBrefdist.lm} \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 ) } \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}{Used for controlling parallel computations. See sections 'details' and '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. The argument 'cl' (originally short for 'cluster') is used for controlling parallel computations. 'cl' can be NULL (default), positive integer or a list of clusters. Special care must be taken on Windows platforms (described below) but the general picture is this: The recommended way of controlling cl is to specify the component \code{pbcl} in options() with e.g. \code{options("pbcl"=4)}. If cl is NULL, the function will look at if the pbcl has been set in the options list with \code{getOption("pbcl")} If cl=N then N cores will be used in the computations. If cl is NULL then the function will look for } \examples{ data(beets) head(beets) beet0 <- lmer(sugpct ~ block + sow + harvest + (1|block:harvest), data=beets, REML=FALSE) beet_no.harv <- update(beet0, . ~ . -harvest) rd <- PBrefdist(beet0, beet_no.harv, nsim=20, cl=1) rd \dontrun{ ## Note: Many more simulations must be made in practice. # Computations can be made in parallel using several processors: # 1: On OSs that fork processes (that is, not on windows): # -------------------------------------------------------- if (Sys.info()["sysname"] != "Windows"){ N <- 2 ## Or N <- parallel::detectCores() # N cores used in all calls to function in a session options("mc.cores"=N) rd <- PBrefdist(beet0, beet_no.harv, nsim=20) # N cores used just in one specific call (when cl is set, # options("mc.cores") is ignored): rd <- PBrefdist(beet0, beet_no.harv, nsim=20, cl=N) } # In fact, on Windows, the approach above also work but only when setting the # number of cores to 1 (so there is to parallel computing) # In all calls: # options("mc.cores"=1) # rd <- PBrefdist(beet0, beet_no.harv, nsim=20) # Just once # rd <- PBrefdist(beet0, beet_no.harv, nsim=20, cl=1) # 2. On all platforms (also on Windows) one can do # ------------------------------------------------ library(parallel) N <- 2 ## Or N <- detectCores() clus <- makeCluster(rep("localhost", N)) # In all calls in a session options("pb.cl"=clus) rd <- PBrefdist(beet0, beet_no.harv, nsim=20) # Just once: rd <- PBrefdist(beet0, beet_no.harv, nsim=20, cl=clus) stopCluster(clus) } } \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{https://www.jstatsoft.org/v59/i09/} } \seealso{ \code{\link{PBmodcomp}}, \code{\link{KRmodcomp}} } \author{ Søren Højsgaard \email{sorenh@math.aau.dk} } \keyword{inference} \keyword{models} pbkrtest/man/get_Fstat_ddf.Rd0000644000176200001440000000161313712550526015716 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/SAT-modcomp.R \name{get_Fstat_ddf} \alias{get_Fstat_ddf} \title{Compute denominator df for F-test} \usage{ get_Fstat_ddf(nu, tol = 1e-08) } \arguments{ \item{nu}{vector of denominator df for the t-statistics} \item{tol}{tolerance on the consequtive differences between elements of nu to determine if mean(nu) should be returned} } \value{ the denominator df; a numerical scalar } \description{ From a vector of denominator df from independent t-statistics (\code{nu}), the denominator df for the corresponding F-test is computed. } \details{ Note that if any \code{nu <= 2} then \code{2} is returned. Also, if all nu are within tol of each other the simple average of the nu-vector is returned. This is to avoid downward bias. } \author{ Rune Haubo B. Christensen. Adapted to pbkrtest by Søren Højsgaard. } \keyword{internal} pbkrtest/man/get_ddf_Lb.Rd0000755000176200001440000000417013761653250015200 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/get_ddf_Lb.R \name{get_ddf_Lb} \alias{get_ddf_Lb} \alias{get_Lb_ddf} \alias{get_Lb_ddf.lmerMod} \alias{Lb_ddf} \alias{get_ddf_Lb.lmerMod} \alias{ddf_Lb} \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) get_ddf_Lb(object, Lcoef) \method{get_ddf_Lb}{lmerMod}(object, Lcoef) Lb_ddf(L, V0, Vadj) 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{Lcoef}{Linear contrast matrix} \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{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 <- model2remat(fmLarge, fmSmall) L } \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{https://www.jstatsoft.org/v59/i09/} } \seealso{ \code{\link{KRmodcomp}}, \code{\link{vcovAdj}}, \code{\link{model2remat}}, \code{\link{remat2model}} } \author{ Søren Højsgaard, \email{sorenh@math.aau.dk} } \keyword{inference} \keyword{models} pbkrtest/man/data-budworm.Rd0000755000176200001440000000343413712550526015555 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/data-budworm.R \docType{data} \name{data-budworm} \alias{data-budworm} \alias{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/data-beets.Rd0000755000176200001440000000413714021623143015167 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/data-beets.R \docType{data} \name{data-beets} \alias{data-beets} \alias{beets} \title{Sugar beets data} \format{ A dataframe with 5 columns and 30 rows. } \usage{ beets } \description{ Yield and sugar percentage in sugar beets from a split plot experiment. The experimental layout was as follows: There were three blocks. In each block, 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. The data originates from a study carried out at The Danish Institute for Agricultural Sciences (the institute does not exist any longer; it became integrated in a Danish university). } \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{https://www.jstatsoft.org/v59/i09/} } \keyword{datasets} pbkrtest/DESCRIPTION0000644000176200001440000000315114021642320013610 0ustar liggesusersPackage: pbkrtest Version: 0.5.1 Title: Parametric Bootstrap, Kenward-Roger and Satterthwaite Based Methods for Test in Mixed Models Authors@R: c( person(given = "Ulrich", family = "Halekoh", email = "uhalekoh@health.sdu.dk", role = c("aut", "cph")), person(given = "Søren", family = "Højsgaard", email = "sorenh@math.aau.dk", role = c("aut", "cre", "cph")) ) Maintainer: Søren Højsgaard Description: Test in mixed effects models. Attention is on mixed effects models as implemented in the 'lme4' package. For linear mixed models, this package implements (1) a parametric bootstrap test, (2) a Kenward-Roger-typ modification of F-tests for linear mixed effects models and (3) a Satterthwaite-type modification of F-tests for linear mixed effects models. The package also implements a parametric bootstrap test for generalized linear mixed models. The facilities of the package are documented in the paper by Halehoh and Højsgaard, (2012, ). Please see 'citation("pbkrtest")' for citation details. URL: https://people.math.aau.dk/~sorenh/software/pbkrtest/ Depends: R (>= 3.5.0), lme4 (>= 1.1.10) Imports: broom, dplyr, magrittr, MASS, Matrix (>= 1.2.3), methods, numDeriv, parallel, knitr Encoding: UTF-8 ZipData: no License: GPL (>= 2) ByteCompile: Yes RoxygenNote: 7.1.1 LazyData: true VignetteBuilder: knitr NeedsCompilation: no Packaged: 2021-03-09 07:41:11 UTC; sorenh Author: Ulrich Halekoh [aut, cph], Søren Højsgaard [aut, cre, cph] Repository: CRAN Date/Publication: 2021-03-09 09:50:08 UTC pbkrtest/build/0000755000176200001440000000000014021623227013206 5ustar liggesuserspbkrtest/build/vignette.rds0000644000176200001440000000040314021623227015542 0ustar liggesusersu0ZvA={AEiͨUzh2Mc}#, .CƁp֤kSw k??_VA/0;qZz>= 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, cl=2) ) @ %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, cl=2) ) @ %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/vignettes/coercion.Rnw0000644000176200001440000000520113712550526016415 0ustar liggesusers%\VignetteIndexEntry{coercion: Model objects and restriction matrices} %\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{Coercion between model objects and restriction matrices in 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} Consider regression models for the `cars` dataset: <<>>= mod0 <- lm(dist ~ 1, data=cars); coef(mod0) mod1 <- update(mod0, .~. + speed); coef(mod1) mod2 <- update(mod1, .~. + I(speed^2)); coef(mod2) @ Reducing `mod2` to `mod0` corresponds to restricting the model space for `mod2` and so on: <<>>= L21 <- model2remat(mod2, mod1); L21 L20 <- model2remat(mod2, mod0); L20 L10 <- model2remat(mod1, mod0); L10 @ The other way around is that given a restriction matrix and a large model, we can construct the corresponding smaller model: <<>>= new1 <- remat2model(mod2, L21); coef(new1) new0a <- remat2model(mod2, L20); coef(new0a) new0b <- remat2model(mod1, L10); coef(new0b) @ It should be checked that the original and new model matrices span the same space. For now we will simply check that the fitted values are practically identical: <<>>= eps <- 1e-8 max(abs(fitted(new1) - fitted(mod1))) < eps max(abs(fitted(new0a) - fitted(mod0))) < eps max(abs(fitted(new0b) - fitted(mod0))) < eps @ \end{document} pbkrtest/NEWS0000644000176200001440000000204314021623065012605 0ustar liggesuserspbkrtest v0.5.1 (Release date: 2021-03-09) ============================================ Changes * Improved documentation pbkrtest v0.5-0.0 (Release date: 2020-08-04) ============================================ Changes * Satterthwaite approximation added via the SATmodcomp function. * Checks for models being nested is not performed for parametric bootstrap any longer. Reason is that the simr package use parametric bootstrap for testing variance components being zero. * doi added to DESCRIPTION file pbkrtest v0.4-8.6 (Release date: 2020-02-20) ============================================ Bug fixes: * documentation fixed ddf_Lb is now exported * mclapply issue for windows fixed * vcovAdj.lmerMod is exported to make emmeans work. Contact Russ Lenth to make emmeans used generic function vcovAdj. pbkrtest v0.4-8 (Release date: 2020-02-20) ========================================== Bug fixes: * Issue related to class() versus inherits() fixed. Changes: * NEWS file added * NAMESPACE file is now generated automatically pbkrtest/R/0000755000176200001440000000000014021622701012304 5ustar liggesuserspbkrtest/R/get_ddf_Lb.R0000644000176200001440000001632413753132371014460 0ustar liggesusers#' @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{model2remat}}, #' \code{\link{remat2model}} #' @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{https://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 <- model2remat(fmLarge, fmSmall) #' L #' #' @export #' @rdname get_ddf_Lb get_Lb_ddf <- function(object, L){ UseMethod("get_Lb_ddf") } #' @export #' @rdname get_ddf_Lb get_Lb_ddf.lmerMod <- function(object, L){ Lb_ddf(L, vcov(object), vcovAdj(object)) } ## COMES FROM RUSS LENTHS LSMEANS PACKAGE (he took it from pbkrtest) #' @rdname get_ddf_Lb #' @param Lcoef Linear contrast matrix get_ddf_Lb <- function(object, Lcoef){ UseMethod("get_ddf_Lb") } ## COMES FROM RUSS LENTHS LSMEANS PACKAGE (he took it from pbkrtest) #' @rdname get_ddf_Lb get_ddf_Lb.lmerMod <- function(object, Lcoef){ ddf_Lb(vcovAdj(object), Lcoef, vcov(object)) } #' @export #' @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 } ## COMES FROM RUSS LENTHS LSMEANS PACKAGE (he took it from pbkrtest) #' @rdname get_ddf_Lb #' @param VVa Adjusted covariance matrix #' @param VV0 Unadjusted covariance matrix #' @export ddf_Lb <- function(VVa, Lcoef, VV0=VVa){ if (!is.matrix(Lcoef)) Lcoef = matrix(Lcoef, ncol = 1) vlb = sum(Lcoef * (VV0 %*% Lcoef)) Theta = Matrix(as.numeric(outer(Lcoef, Lcoef) / vlb), nrow=length(Lcoef)) P = attr(VVa, "P") W = attr(VVa, "W") A1 = A2 = 0 ThetaVV0 = Theta%*%VV0 n.ggamma = length(P) for (ii in 1:n.ggamma) { for (jj in c(ii:n.ggamma)) { e = ifelse(ii==jj, 1, 2) ui = ThetaVV0 %*% P[[ii]] %*% VV0 uj = ThetaVV0 %*% P[[jj]] %*% VV0 A1 = A1 + e* W[ii,jj] * (.spur(ui) * .spur(uj)) A2 = A2 + e* W[ii,jj] * sum(ui * t(uj)) }} ## substituted q = 1 in pbkrtest code and simplified B = (A1 + 6 * A2) / 2 g = (2 * A1 - 5 * A2) / (3 * A2) c1 = g/(3 + 2 * (1 - g)) c2 = (1 - g) / (3 + 2 * (1 - g)) c3 = (3 - g) / (3 + 2 * (1 - g)) EE = 1 + A2 VV = 2 * (1 + B) EEstar = 1/(1 - A2) VVstar = 2 * ((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 = (.divZero(1 - A2, V1))^2 * V0/V2 df2 = 4 + 3 / (rho - 1) ## cat(sprintf("Lcoef: %s\n", toString(Lcoef))) ## cat(sprintf("df2: %f\n", df2)) df2 } ## .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) attr(ref, "stat") <- LRTstat attr(ref, "samples") <- c(nsim=nsim, npos=sum(ref > 0), n.extreme=sum(ref > LRTstat["tobs"]), pPB=(1 + sum(ref > LRTstat["tobs"])) / (1 + sum(ref > 0))) if (details>0) cat(sprintf("Reference distribution with %i samples; computing time: %5.2f secs. \n", length(ref), attr(ref, "ctime"))) ref } #' @rdname pb-refdist #' @export PBrefdist.merMod <- function(largeModel, smallModel, nsim=1000, seed=NULL, cl=NULL, details=0){ if (inherits(smallModel, "formula")) smallModel <- update(largeModel, smallModel) ## w <- modcomp_init(largeModel, smallModel, matrixOK = TRUE) ## if (w == -1) stop('Models have equal mean stucture or are not nested') ## if (w == 0){ ## ## First given model is submodel of second; exchange the models ## tmp <- largeModel; largeModel <- smallModel; smallModel <- tmp ## } if (is.numeric(smallModel) && !is.matrix(smallModel)) smallModel <- matrix(smallModel, nrow=1) if (inherits(smallModel, c("Matrix", "matrix"))){ formula.small <- smallModel smallModel <- remat2model(largeModel, smallModel, REML=FALSE) } else { formula.small <- formula(smallModel) attributes(formula.small) <- NULL } if (getME(smallModel, "is_REML")) smallModel <- update(smallModel, REML=FALSE) if (getME(largeModel, "is_REML")) largeModel <- update(largeModel, REML=FALSE) t0 <- proc.time() ref <- do_sampling(largeModel, smallModel, nsim, cl, details) LRTstat <- getLRT(largeModel, smallModel) attr(ref, "stat") <- LRTstat attr(ref, "samples") <- c(nsim=nsim, npos=sum(ref > 0), n.extreme=sum(ref > LRTstat["tobs"]), pPB=(1 + sum(ref > LRTstat["tobs"])) / (1 + sum(ref > 0))) class(ref) <- "refdist" if (details>0) cat(sprintf("Reference distribution with %5i samples; computing time: %5.2f secs. \n", length(ref), attr(ref, "ctime"))) ref } print.refdist <- function(x, n=6L, ...){ cat("values: \n") print(head(x, n=n)) cat("attributes: \n") print(attributes(x)[1:4]) invisible(x) } get_refdist <- function(lg){ UseMethod("get_refdist") } get_refdist.merMod <- function(lg){ .get_refdist_merMod } get_refdist.lm <- function(lg){ .get_refdist_lm } .get_refdist_lm <- 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 if (inherits(lg, "glm")){ cl.lg$start <- coef(lg) cl.sm$start <- coef(sm) } ref <- rep.int(NA, nsim) for (ii in 1:nsim){ ref[ii] <- 2 * (logLik(eval(cl.lg)) - logLik(eval(cl.sm))) } ref } .get_refdist_merMod <- 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 <- suppressMessages(refit(sm, newresp=yyy)) lg2 <- suppressMessages(refit(lg, newresp=yyy)) 2 * (logLik(lg2, REML=FALSE) - logLik(sm2, REML=FALSE)) }))) } get_cl <- function(cl){ .cat <- function(b, ...) {if (b) cat(...)} dd <- 2 if (Sys.info()["sysname"] == "Windows"){ ##cat("We are on windows; setting cl=1\n") cl <- 1 } if (!is.null(cl)){ if (inherits(cl, "cluster") || (is.numeric(cl) && length(cl) == 1 && cl >= 1)){ .cat(dd>3, "valid 'cl' specified in call \n") } else stop("invalid 'cl' specified in call \n") } else { .cat(dd>3, "trying to retrieve 'cl' from options('pb.cl') ... \n") cl <- getOption("pb.cl") if (!is.null(cl)){ if (!inherits(cl, "cluster")) stop("option 'cl' set but is not a list of clusters\n") .cat(dd>3," got 'cl' from options; length(cl) = ", length(cl), "\n") } if (is.null(cl)){ .cat(dd>3, "trying to retrieve 'cl' from options('mc.cores')... \n") cl <- getOption("mc.cores") if (!is.null(cl)) .cat(dd>3," got 'cl' from options(mc.cores); cl = ", cl, "\n") } } if (is.null(cl)){ .cat(dd > 3, "cl can not be retrieved anywhere; setting cl=1\n") cl <- 1 } cl } do_sampling <- function(largeModel, smallModel, nsim, cl, details=0){ t0 <- proc.time() .cat <- function(b, ...) {if (b) cat(...)} dd <- details get_fun <- get_refdist(largeModel) cl <- get_cl(cl) if (is.numeric(cl)){ if (!(length(cl) == 1 && cl >= 1)) stop("Invalid numeric cl\n") .cat(dd>3, "doing mclapply, cl = ", cl, "\n") nsim.cl <- nsim %/% cl ref <- unlist(mclapply(1:cl, function(i) { get_fun(largeModel, smallModel, nsim=nsim.cl)}, mc.cores=cl)) } else if (inherits(cl, "cluster")){ .cat(dd>3,"doing clusterCall, nclusters = ", length(cl), "\n") nsim.cl <- nsim %/% length(cl) clusterSetRNGStream(cl) ref <- unlist(clusterCall(cl, fun=get_fun, largeModel, smallModel, nsim=nsim.cl)) } else stop("Invalid 'cl'\n") attr(ref, "cl") <- cl attr(ref, "ctime") <- (proc.time() - t0)[3] ref } pbkrtest/R/getKR.R0000644000176200001440000000306213753132357013462 0ustar liggesusers#' @title Extract (or "get") components from a \code{KRmodcomp} object. #' #' @description Extract (or "get") components from a \code{KRmodcomp} object, #' which is the result of the \code{KRmodcomp} function. #' #' @name getkr #' #' @param object A \code{KRmodcomp} object, which is the result of the #' \code{KRmodcomp} function #' @param name The available slots. If \code{name} is missing or \code{NULL} #' then everything is returned. #' @author Søren Højsgaard \email{sorenh@@math.aau.dk} #' @seealso \code{\link{KRmodcomp}}, \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{https://www.jstatsoft.org/v59/i09/} #' @keywords utilities #' @examples #' #' data(beets, package='pbkrtest') #' lg <- lmer(sugpct ~ block + sow + harvest + (1|block:harvest), #' data=beets, REML=FALSE) #' sm <- update(lg, .~. - harvest) #' modcomp <- KRmodcomp(lg, sm) #' getKR(modcomp, "ddf") # get denominator degrees of freedom. #' #' #' @export #' @rdname getkr getKR <- function (object, name = c("ndf", "ddf", "Fstat", "p.value", "F.scaling", "FstatU", "p.valueU", "aux")) { stopifnot(is(object, "KRmodcomp")) if (missing(name) || is.null(name)){ return(object$stats) } else { stopifnot(length(name <- as.character(name)) == 1) name <- match.arg(name) object$stats[[name]] } } pbkrtest/R/KR-Sigma-G2.R0000644000176200001440000002471013712716557014276 0ustar liggesusers## ############################################################################## ## ## LMM_Sigma_G: Returns VAR(Y) = Sigma and the G matrices ## ## Re-implemented in Banff, Canada, August 2013 by Søren Højsgaard ## ## ############################################################################## #' @export get_SigmaG <- function(object, details=0) { UseMethod("get_SigmaG") } #' @export get_SigmaG.lmerMod <- function(object, details=0) { .get_SigmaG( 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 } ## #' @export ## get_SigmaG.mer <- function(object, details=0) { ## LMM_Sigma_G( object, details ) ## } ## ############################################################################## ## ## LMM_Sigma_G: Returns VAR(Y) = Sigma and the G matrices ## ## ############################################################################## ## LMM_Sigma_G <- function(object, details=0) { ## DB <- details > 0 ## For debugging only ## if (!.is.lmm(object)) ## stop("'object' is not Gaussian linear mixed model") ## GGamma <- VarCorr(object) ## ## Indexing of the covariance matrix; ## ## this is somewhat technical and tedious ## Nindex <- .get_indices(object) ## ## number of random effects in each groupFac; note: residual error excluded! ## n.groupFac <- Nindex$n.groupFac ## ## the number of random effects for each grouping factor ## nn.groupFacLevels <- Nindex$nn.groupFacLevels ## ## size of the symmetric variance Gamma_i for reach groupFac ## nn.GGamma <- Nindex$nn.GGamma ## ## number of variance parameters of each GGamma_i ## mm.GGamma <- Nindex$mm.GGamma ## ## not sure what this is... ## group.index <- Nindex$group.index ## ## writing the covariance parameters for the random effects into a vector: ## ggamma <- NULL ## for ( ii in 1:(n.groupFac) ) { ## Lii <- GGamma[[ii]] ## nu <- ncol(Lii) ## ## Lii[lower.tri(Lii,diag=TRUE)= Lii[1,1],Lii[1,2],Lii[1,3]..Lii[1,nu], ## ## Lii[2,2], Lii[2,3] ... ## ggamma<-c(ggamma,Lii[lower.tri(Lii,diag=TRUE)]) ## } ## ## extend ggamma by the residuals variance such that everything random is included ## ggamma <- c( ggamma, sigma( object )^2 ) ## n.ggamma <- length(ggamma) ## ## Find G_r: ## Zt <- getME( object, "Zt" ) ## t0 <- proc.time() ## G <- NULL ## ##cat(sprintf("n.groupFac=%i\n", n.groupFac)) ## for (ss in 1:n.groupFac) { ## ZZ <- .get_Zt_group(ss, Zt, object) ## ##cat("ZZ\n"); print(ZZ) ## n.levels <- nn.groupFacLevels[ss] ## ##cat(sprintf("n.levels=%i\n", n.levels)) ## Ig <- sparseMatrix(1:n.levels, 1:n.levels, x=1) ## ##print(Ig) ## for (rr in 1:mm.GGamma[ss]) { ## ii.jj <- .indexVec2Symmat(rr,nn.GGamma[ss]) ## ##cat("ii.jj:"); print(ii.jj) ## ii.jj <- unique(ii.jj) ## if (length(ii.jj)==1){ ## EE <- sparseMatrix(ii.jj, ii.jj, x=1, dims=rep(nn.GGamma[ss],2)) ## } else { ## EE <- sparseMatrix(ii.jj, ii.jj[2:1], dims=rep(nn.GGamma[ss],2)) ## } ## ##cat("EE:\n");print(EE) ## EE <- Ig %x% EE ## Kronecker product ## G <- c( G, list( t(ZZ) %*% EE %*% ZZ ) ) ## } ## } ## ## Extend by the indentity for the residual ## nobs <- nrow(getME(object,'X')) ## G <- c( G, list(sparseMatrix(1:nobs, 1:nobs, x=1 )) ) ## if(DB){cat(sprintf("Finding G %10.5f\n", (proc.time()-t0)[1] )); t0 <- proc.time()} ## Sigma <- ggamma[1] * G[[1]] ## for (ii in 2:n.ggamma) { ## Sigma <- Sigma + ggamma[ii] * G[[ii]] ## } ## if(DB){cat(sprintf("Finding Sigma: %10.5f\n", (proc.time()-t0)[1] )); ## t0 <- proc.time()} ## SigmaG <- list(Sigma=Sigma, G=G, n.ggamma=n.ggamma) ## SigmaG ## } ## .get_indices <-function(object) { ## ## ff = number of random effects terms (..|F1) + (..|F1) are group factors! ## ## without the residual variance output: list of several indices ## ## we need the number of random-term factors ## Gp <- getME(object,"Gp") ## ff <- length(Gp)-1 ## gg <- sapply(getME(object,"flist"), function(x)length(levels(x))) ## qq <- .get.RT.dim.by.RT( object ) ##; cat("qq:\n"); print(qq) ## ## number of variance parameters of each GGamma_i ## ss <- qq * (qq+1) / 2 ## ## numb of random effects per level of random-term-factor ## nn.groupFac <- diff(Gp) ## ##cat("nn.groupFac:\n"); print(nn.groupFac) ## ## number of levels for each random-term-factor; residual error here excluded! ## nn.groupFacLevels <- nn.groupFac / qq ## ## this is the number of random term factors, should possible get a more approriate name ## list(n.groupFac = ff, ## nn.groupFacLevelsNew = gg, # length of different grouping factors ## nn.groupFacLevels = nn.groupFacLevels, # vector of the numb. levels for each random-term-factor ## nn.GGamma = qq, ## mm.GGamma = ss, ## group.index = Gp) ## } ## .get_Zt_group <- function(ii.group, Zt, object) { ## ## ii.group : the index number of a grouping factor ## ## Zt : the transpose of the random factors design matrix Z ## ## object : A mer or lmerMod model ## ##output : submatrix of Zt belongig to grouping factor ii.group ## Nindex <- .get_indices(object) ## nn.groupFacLevels <- Nindex$nn.groupFacLevels ## nn.GGamma <- Nindex$nn.GGamma ## group.index <- Nindex$group.index ## .cc <- class(object) ## ## cat(".get_Zt_group\n"); ## ## print(group.index) ## ## print(ii.group) ## zIndex.sub <- ## if (.cc %in% "mer") { ## Nindex$group.index[ii.group]+ ## 1+c(0:(nn.GGamma[ii.group]-1))*nn.groupFacLevels[ii.group] + ## rep(0:(nn.groupFacLevels[ii.group]-1),each=nn.GGamma[ii.group]) ## } else { ## if (.cc %in% "lmerMod" ) { ## c((group.index[ii.group]+1) : group.index[ii.group+1]) ## } ## } ## ZZ <- Zt[ zIndex.sub , ] ## return(ZZ) ## } pbkrtest/R/KR-across-versions.R0000644000176200001440000000125413712550526016116 0ustar liggesusers## ####################################################################################### ## ## Functionality required to make pbkrtest work both on CRAN and devel versions of lme4 ## ## Banff, August 2013, Søren Højsgaard ## ## ####################################################################################### .get.RT.dim.by.RT <- function(object) { ## output: dimension (no of columns) of covariance matrix for random term ii ## .cc <- class(object) qq <- ##if (.cc %in% "mer") { if (inherits(object, "mer")){ sapply(object@ST,function(X) nrow(X)) } else { sapply(object@cnms, length) ## FIXME: use getME() } qq } pbkrtest/R/SAT-modcomp.R0000644000176200001440000004006513766676102014542 0ustar liggesusers## ########################################################################## ## #' @title F-test and degrees of freedom based on Satterthwaite approximation #' @description An approximate F-test based on the Satterthwaite approach. #' @name sat-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 Satterthwaite approach! #' #' @param largeModel An \code{lmerMod} model. #' @param smallModel An \code{lmerMod} model, a restriction matrix or #' a model formula. See example section. #' @param eps A small number. #' @param details If larger than 0 some timing details are printed. #' #' @note This code is greatly inspired by code in the lmerTest #' package. This is a recent addition to the pbkrtest package; #' please report unexpected behaviour. #' #' @author 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{https://www.jstatsoft.org/v59/i09/} #' #' @keywords models inference #' @examples #' #' (fm1 <- lmer(Reaction ~ Days + (Days|Subject), sleepstudy)) #' L1 <- cbind(0,1) #' SATmodcomp(fm1, L1) #' #' (fm2 <- lmer(Reaction ~ Days + I(Days^2) + (Days|Subject), sleepstudy)) #' #' ## Test for no effect of Days. There are three ways of using the function: #' #' ## 1) Define 2-df contrast - since L has 2 (linearly independent) rows #' ## the F-test is on 2 (numerator) df: #' L2 <- rbind(c(0, 1, 0), c(0, 0, 1)) #' SATmodcomp(fm2, L2) #' #' ## 2) Use two model objects #' fm3 <- update(fm2, ~. - Days - I(Days^2)) #' SATmodcomp(fm2, fm3) #' #' ## 3) Specify restriction as formula #' SATmodcomp(fm2, ~. - Days - I(Days^2)) #' @export #' @rdname sat-modcomp SATmodcomp <- function(largeModel, smallModel, details=0, eps=sqrt(.Machine$double.eps)){ UseMethod("SATmodcomp") } #' @export #' @rdname sat-modcomp SATmodcomp.lmerMod <- function(largeModel, smallModel, details=0, eps=sqrt(.Machine$double.eps)){ SATmodcomp_internal(largeModel=largeModel, smallModel=smallModel, eps=eps) } ## SATmodcomp_internal is inspired by code in the lmerTest package SATmodcomp_internal <- function(largeModel, smallModel, eps=sqrt(.Machine$double.eps)){ if (inherits(smallModel, "formula")) smallModel <- update(largeModel, smallModel) w <- modcomp_init(largeModel, smallModel, matrixOK = TRUE) if (w == -1) stop('Models have equal mean stucture or are not nested') if (w == 0){ ## First given model is submodel of second; exchange the models tmp <- largeModel; largeModel <- smallModel; smallModel <- tmp } ## All computations are based on 'largeModel' and the restriction matrix 'L' ## ------------------------------------------------------------------------- t0 <- proc.time() L <- model2remat(largeModel, smallModel) beta <- getME(largeModel, "beta") aux <- compute_auxillary(largeModel) vcov_Lbeta <- L %*% aux$vcov_beta %*% t(L) # Var(contrast) = Var(Lbeta) eig_vcov_Lbeta <- eigen(vcov_Lbeta) P <- eig_vcov_Lbeta$vectors d <- eig_vcov_Lbeta$values tol <- max(eps * d[1], 0) pos <- d > tol qq <- sum(pos) # rank(vcov_Lbeta) PtL <- crossprod(P, L)[1:qq,, drop=FALSE] ## print(PtL) t2 <- drop(PtL %*% beta)^2 / d[1:qq] Fvalue <- sum(t2) / qq grad_PLcov <- lapply(1:qq, function(m) { vapply(aux$jacobian_list, function(J) qform(PtL[m, ], J), numeric(1L)) }) ## 2D_m^2 / g'Ag nu_m <- vapply(1:qq, function(m) { 2*(d[m])^2 / qform(grad_PLcov[[m]], aux$vcov_varpar) }, numeric(1L)) ## Compute ddf for the F-value: ddf <- get_Fstat_ddf(nu_m, tol=1e-8) out <- list(test=data.frame(statistic=Fvalue, ndf=qq, ddf=ddf, p.value=1 - pf(Fvalue, df1=qq, df2=ddf)), sigma=getME(largeModel, "sigma"), formula.large=formula(largeModel), formula.small=L, ctime=(proc.time() - t0)[3], L=L ) class(out) <- "SATmodcomp" out } #' @export print.SATmodcomp <- function(x, ...){ cat("large : ") print(x$formula.large) if (inherits(x$formula.small, "formula")) cat("small : ") else cat("small (restriction matrix) : \n") prform(x$formula.small) dd <- as.data.frame(x$test[c("statistic", "ndf", "ddf", "p.value")]) printCoefmat(dd, has.Pvalue=TRUE) invisible(x) } prform <- function(form){ if (!inherits(form, c("formula", "matrix"))) stop("'form' must be formula or matrix") if (inherits(form, "formula")) print(form) else prmatrix(form, collab = rep_len("", ncol(form)), rowlab = rep_len("", ncol(form))) invisible(form) } ## #' @export ## tidy.KRmodcomp <- function (x, conf.int = FALSE, conf.level = 0.95, exponentiate = FALSE, ## ...) ## { ## ##co <- stats::coef(summary(x)) ## ## ret <- as_tidy_tibble(co, c("estimate", "std.error", "statistic", ## ## "p.value")[1:ncol(co)]) ## ret <- x$test ## rr <<- ret ## if (conf.int) { ## ci <- broom:::broom_confint_terms(x, level = conf.level) ## ret <- dplyr::left_join(ret, ci, by = "term") ## } ## ## if (exponentiate) { ## ## if (is.null(x$family) || (x$family$link != "logit" && ## ## x$family$link != "log")) { ## ## warning(paste("Exponentiating coefficients, but model did not use", ## ## "a log or logit link function")) ## ## } ## ## ret <- exponentiate(ret) ## ## } ## ret ## } #' @export tidy.PBmodcomp <- function(x, ...){ ret <- x$test as_tibble(cbind(type=rownames(ret), ret)) } #' @export tidy.KRmodcomp <- function(x, ...){ ret <- x$test as_tibble(cbind(type=rownames(ret), ret)) } #' @export tidy.SATmodcomp <- function(x, ...){ ret <- x$test as_tibble(cbind(type="Ftest", ret)) } #' @export as.data.frame.PBmodcomp <- function(x, ...){ x$test } #' @export as.data.frame.KRmodcomp <- function(x, ...){ x$test } #' @export as.data.frame.SATmodcomp <- function(x, ...){ x$test } ## #' @export ## summary.PBmodcomp <- function(object, ...){ ## ans <- .summarizePB(object$LRTstat, object$ref) ## ans$formula.large <- object$formula.large ## ans$formula.small <- object$formula.small ## class(ans) <- "summaryPB" ## ans ## } ## #' @export ## print.summaryPB <- function(x, ...){ ## .PBcommon(x) ## ans <- x$test ## printCoefmat(ans, tst.ind=1, na.print='', has.Pvalue=TRUE) ## cat("\n") ## ## ci <- x$ci ## ## cat(sprintf("95 pct CI for PBtest : [%s]\n", toString(ci))) ## ## mo <- x$moment ## ## cat(sprintf("Reference distribution : mean=%f var=%f\n", mo[1], mo[2])) ## ## ga <- x$gamma ## ## cat(sprintf("Gamma approximation : scale=%f shape=%f\n", ga[1], ga[2])) ## return(invisible(x)) ## } ## Returns the deviance function for a linear mixed model. get_devfun <- function(model){ if (!inherits(model, "lmerMod")) stop("'model' not an 'lmerMod'") mc <- model@call args <- as.list(mc) args$devFunOnly <- TRUE Call <- as.call(c(list(quote(lme4::lmer)), args[-1])) devfun <- eval.parent(Call) devfun } ## ####################################################### ## ####### compute_auxillary ## ####### ################################################ #' #' #' Compute_auxillary quantities needed for the Satterthwaite #' approximation. #' #' Computes vcov of variance parameters (theta, sigma), jacobian of #' each variance parameter etc. #' #' @param model A linear mixed model object #' @param tol A tolerance #' #' @author Søren Højsgaard #' #' @return A list #' @details The code is greatly inspired by code from the lmerTest #' package. #' @keywords internal compute_auxillary <- function(model, tol=1e-6){ if (!inherits(model, "lmerMod")) stop("'model' not an 'lmerMod'") devfun <- get_devfun(model) ## tmp <- list(Call=Call, devfun=devfun) ## SH ## assign("tmp", tmp, envir=.GlobalEnv) out <- list(sigma=NULL, vcov_beta=NULL, vcov_varpar=NULL, jacobian_list=NULL) out$sigma <- sigma(model) out$vcov_beta <- as.matrix(vcov(model)) ## The optimized variance parameters (theta, sigma) varpar_opt <- unname(c(getME(model, "theta"), getME(model, "sigma"))) ## Compute Hessian: ## ---------------- is_reml <- getME(model, "is_REML") h <- numDeriv::hessian(func=devfun_vp, x=varpar_opt, devfun=devfun, reml=is_reml) ## Eigen decompose the Hessian: eig_h <- eigen(h, symmetric=TRUE) evals <- eig_h$values neg <- evals < -tol pos <- evals > tol zero <- evals > -tol & evals < tol if(sum(neg) > 0) { # negative eigenvalues ##eval_chr <- if(sum(neg) > 1) "eigenvalues" else "eigenvalue" evals_num <- paste(sprintf("%1.1e", evals[neg]), collapse = " ") warning(sprintf("Model failed to converge with %d negative eigenvalue(s): %s", sum(neg), evals_num), call.=FALSE) } ## Note: we warn about negative AND zero eigenvalues: if(sum(zero) > 0) { # some eigenvalues are zero ##eval_chr <- if(sum(zero) > 1) "eigenvalues" else "eigenvalue" evals_num <- paste(sprintf("%1.1e", evals[zero]), collapse = " ") warning(sprintf("Model may not have converged with %d eigenvalue(s) close to zero: %s", sum(zero), evals_num)) } ## Compute vcov(varpar): ## --------------------- pos <- eig_h$values > tol q <- sum(pos) ## Moore-Penrose generalized inverse for h: h_inv <- with(eig_h, { vectors[, pos, drop=FALSE] %*% diag(1/values[pos], nrow=q) %*% t(vectors[, pos, drop=FALSE]) }) out$vcov_varpar <- 2 * h_inv # vcov(varpar) ## Compute Jacobian of cov(beta) ## ----------------------------- ## Compute Jacobian for each varpar and save in list: jac <- numDeriv::jacobian(func=get_covbeta, x=varpar_opt, devfun=devfun) ## List of jacobian matrices out$jacobian_list <- lapply(1:ncol(jac), function(i) array(jac[, i], dim=rep(length(getME(model, "beta")), 2))) out } qform <- function(x, A) { sum(x * (A %*% x)) } ## ############################################## ## ######## get_Fstat_ddf() ## ############################################## #' Compute denominator df for F-test #' #' From a vector of denominator df from independent t-statistics (\code{nu}), #' the denominator df for the corresponding F-test is computed. #' #' Note that if any \code{nu <= 2} then \code{2} is returned. Also, if all nu #' are within tol of each other the simple average of the nu-vector is returned. #' This is to avoid downward bias. #' #' @param nu vector of denominator df for the t-statistics #' @param tol tolerance on the consequtive differences between elements of nu to #' determine if mean(nu) should be returned #' #' @author Rune Haubo B. Christensen. Adapted to pbkrtest by Søren Højsgaard. #' #' @return the denominator df; a numerical scalar #' @keywords internal get_Fstat_ddf <- function(nu, tol=1e-8) { # Computes denominator df for an F-statistic that is derived from a sum of # squared t-statistics each with nu_m degrees of freedom. # # nu : vector of denominator df for the t-statistics # tol: tolerance on the consequtive differences between elements of nu to # determine if mean(nu) should be returned. # # Result: a numeric scalar # # Returns nu if length(nu) == 1. Returns mean(nu) if all(abs(diff(nu)) < tol; # otherwise ddf appears to be downward biased. fun <- function(nu) { if(any(nu <= 2)) 2 else { E <- sum(nu / (nu - 2)) 2 * E / (E - (length(nu))) # q = length(nu) : number of t-statistics } } stopifnot(length(nu) >= 1, # all(nu > 0), # returns 2 if any(nu < 2) all(sapply(nu, is.numeric))) if(length(nu) == 1L) return(nu) if(all(abs(diff(nu)) < tol)) return(mean(nu)) if(!is.list(nu)) fun(nu) else vapply(nu, fun, numeric(1L)) } ############################################## ######## devfun_vp() ############################################## #' Compute Deviance of an LMM as a Function of Variance Parameters #' #' This function is used for extracting the asymptotic variance-covariance matrix #' of the variance parameters. #' #' @param varpar variance parameters; \code{varpar = c(theta, sigma)}. #' @param devfun deviance function as a function of theta only. #' @param reml if \code{TRUE} the REML deviance is computed; #' if \code{FALSE}, the ML deviance is computed. #' #' @return the REML or ML deviance. #' @author Rune Haubo B. Christensen. Adapted to pbkrtest by Søren Højsgaard. #' @keywords internal devfun_vp <- function(varpar, devfun, reml) { nvarpar <- length(varpar) sigma2 <- varpar[nvarpar]^2 theta <- varpar[-nvarpar] df_envir <- environment(devfun) ## SH: call below not stored anywhere. Is it being used? devfun(theta) # Evaluate deviance function at varpar n <- nrow(df_envir$pp$V) # Compute deviance for ML: dev <- df_envir$pp$ldL2() + (df_envir$resp$wrss() + df_envir$pp$sqrL(1)) / sigma2 + n * log(2 * pi * sigma2) if (!reml) return(dev) ## Adjust if REML is used: RX <- df_envir$pp$RX() # X'V^{-1}X ~ crossprod(RX^{-1}) = cov(beta)^{-1} / sigma^2 dev + 2*c(determinant(RX)$modulus) - ncol(RX) * log(2 * pi * sigma2) } ############################################## ######## get_covbeta() ############################################## #' Compute cov(beta) as a function of varpar of an LMM #' #' At the optimum cov(beta) is available as vcov(lmer-model). This function #' computes cov(beta) at non (RE)ML estimates of \code{varpar}. #' #' @inheritParams devfun_vp #' #' @return cov(beta) at supplied varpar values. #' @author Rune Haubo B. Christensen. Adapted to pbkrtest by Søren Højsgaard. #' @keywords internal #' get_covbeta <- function(varpar, devfun) { nvarpar <- length(varpar) sigma <- varpar[nvarpar] # residual std.dev. theta <- varpar[-nvarpar] # ranef var-par devfun(theta) # evaluate REML or ML deviance 'criterion' df_envir <- environment(devfun) # extract model environment sigma^2 * tcrossprod(df_envir$pp$RXi()) # vcov(beta) } pbkrtest/R/PB-modcomp.R0000644000176200001440000005353613766773425014431 0ustar liggesusers########################################################## ### ### ### ########################################################## #' @title Model comparison using parametric bootstrap methods. #' #' @description Model comparison of nested models using parametric bootstrap #' methods. Implemented for some commonly applied model types. #' #' @name pb-modcomp #' #' @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. #' #' @aliases PBmodcomp PBmodcomp.lm PBmodcomp.merMod getLRT getLRT.lm #' getLRT.merMod plot.XXmodcomp PBmodcomp.mer getLRT.mer #' @param 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). #' @param smallModel A model of the same type as \code{largeModel} or #' a restriction matrix. #' @param nsim The number of simulations to form the reference #' distribution. #' @param ref Vector containing samples from the reference #' distribution. If NULL, this vector will be generated using #' PBrefdist(). #' @param seed A seed that will be passed to the simulation of new #' datasets. #' @param h For sequential computing for bootstrap p-values: The #' number of extreme cases needed to generate before the sampling #' proces stops. #' @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. #' @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). #' #' @author Søren Højsgaard \email{sorenh@@math.aau.dk} #' #' @seealso \code{\link{KRmodcomp}}, \code{\link{PBrefdist}} #' #' @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{https://www.jstatsoft.org/v59/i09/} #' @keywords models inference #' @examples #' #' data(beets, package="pbkrtest") #' head(beets) #' #' NSIM <- 50 ## Simulations in parametric bootstrap #' #' ## 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=NSIM, cl=1) #' anova(sug, sug.h) #' PBmodcomp(sug, sug.s, nsim=NSIM, cl=1) #' #' ## 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=NSIM, cl=1) #' anova(sug, sug.s) #' PBmodcomp(sug, sug.s, nsim=NSIM, cl=1) #' #' ## 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=NSIM, cl=1) #' anova(glm.D93, glm.D93.t, test="Chisq") #' PBmodcomp(glm.D93, glm.D93.t, nsim=NSIM, cl=1) #' #' ## 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, cl=2) #' } #' #' #' \dontrun{ #' (fmLarge <- lmer(Reaction ~ Days + (Days|Subject), sleepstudy)) #' ## removing Days #' (fmSmall <- lmer(Reaction ~ 1 + (Days|Subject), sleepstudy)) #' anova(fmLarge, fmSmall) #' PBmodcomp(fmLarge, fmSmall, cl=1) #' #' ## The same test using a restriction matrix #' L <- cbind(0,1) #' PBmodcomp(fmLarge, L, cl=1) #' #' ## Vanilla #' PBmodcomp(beet0, beet_no.harv, nsim=NSIM, cl=1) #' #' ## Simulate reference distribution separately: #' refdist <- PBrefdist(beet0, beet_no.harv, nsim=1000) #' PBmodcomp(beet0, beet_no.harv, ref=refdist, cl=1) #' #' ## 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=NSIM, cl=cl) #' PBmodcomp(beet0, beet_no.harv, ref=refdist) #' #' ## It is recommended to stop the clusters before quitting R: #' stopCluster(cl) #' } #' #' ## Linear and generalized linear models: #' #' m11 <- lm(dist ~ speed + I(speed^2), data=cars) #' m10 <- update(m11, ~.-I(speed^2)) #' anova(m11, m10) #' #' PBmodcomp(m11, m10, cl=1, nsim=NSIM) #' PBmodcomp(m11, ~.-I(speed^2), cl=1, nsim=NSIM) #' PBmodcomp(m11, c(0, 0, 1), cl=1, nsim=NSIM) #' #' m21 <- glm(dist ~ speed + I(speed^2), family=Gamma("identity"), data=cars) #' m20 <- update(m21, ~.-I(speed^2)) #' anova(m21, m20, test="Chisq") #' #' PBmodcomp(m21, m20, cl=1, nsim=NSIM) #' PBmodcomp(m21, ~.-I(speed^2), cl=1, nsim=NSIM) #' PBmodcomp(m21, c(0, 0, 1), cl=1, nsim=NSIM) #' #' @export PBmodcomp #' @export #' @rdname pb-modcomp PBmodcomp <- function(largeModel, smallModel, nsim=1000, ref=NULL, seed=NULL, cl=NULL, details=0){ UseMethod("PBmodcomp") } #' @export #' @rdname pb-modcomp PBmodcomp.merMod <- function(largeModel, smallModel, nsim=1000, ref=NULL, seed=NULL, cl=NULL, details=0){ if (inherits(smallModel, "formula")) smallModel <- update(largeModel, smallModel) ## w <- modcomp_init(largeModel, smallModel, matrixOK = TRUE) ## ss <<- smallModel ## ll <<- largeModel ## if (w == -1) stop('Models have equal mean stucture or are not nested') ## if (w == 0){ ## ## First given model is submodel of second; exchange the models ## tmp <- largeModel; ## largeModel <- smallModel; ## smallModel <- tmp ## } if (is.numeric(smallModel) && !is.matrix(smallModel)) smallModel <- matrix(smallModel, nrow=1) if (inherits(smallModel, c("Matrix", "matrix"))){ formula.small <- smallModel smallModel <- remat2model(largeModel, smallModel, REML=FALSE) } else { formula.small <- formula(smallModel) attributes(formula.small) <- NULL } ##cat("PBmodcomp.lmerMod\n") formula.large <- formula(largeModel) attributes(formula.large) <- NULL ## All computations are based on 'largeModel' and 'smallModel' ## ----------------------------------------------------------- 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, formula.large, formula.small) } ## #' @export ## PBmodcomp.mer <- PBmodcomp.merMod #' @export #' @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") if (inherits(smallModel, "formula")) smallModel <- update(largeModel, smallModel) if (is.numeric(smallModel) && !is.matrix(smallModel)) smallModel <- matrix(smallModel, nrow=1) formula.large <- formula(largeModel) attributes(formula.large) <- NULL if (inherits(smallModel, c("Matrix", "matrix"))){ formula.small <- smallModel smallModel <- remat2model(largeModel, smallModel) } else { formula.small <- formula(smallModel) attributes(formula.small) <- NULL } ## ss <<- smallModel ## print(smallModel) 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, formula.large, formula.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 } #' @rdname pb-modcomp seqPBmodcomp <- function(largeModel, smallModel, h = 20, nsim = 1000, cl=1) { t.start <- proc.time() chunk.size <- 200 nchunk <- nsim %/% chunk.size LRTstat <- getLRT(largeModel, smallModel) ref <- NULL for (ii in 1:nchunk) { ref <- c(ref, PBrefdist(largeModel, smallModel, nsim = chunk.size, cl=cl)) n.extreme <- sum(ref > LRTstat["tobs"]) if (n.extreme >= h) break } ans <- PBmodcomp(largeModel, smallModel, ref = ref) ans$ctime <- (proc.time() - t.start)[3] ans } ### dot-functions below here .padPB <- function(ans, LRTstat, ref, formula.large, formula.small){ ans$LRTstat <- LRTstat ans$ref <- ref ans$formula.large <- formula.large ans$formula.small <- formula.small 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( LRT = c(stat=tobs, df=ndf, ddf=NA, p.value=p.chi), 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) ) ## 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("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] < sam[1]){ cat(sprintf("Requested samples: %d Used samples: %d Extremes: %d\n", sam[1], sam[2], x$n.extreme)) } } if (!is.null(x$formula.large)){ cat("large : "); print(x$formula.large) } if (!is.null(x$formula.small)){ if (inherits(x$formula.small, "formula")) cat("small : ") else if (inherits(x$formula.small, "matrix")) cat("small : \n"); print(x$formula.small) } } #' @export print.PBmodcomp <- function(x, ...){ .PBcommon(x) tab <- x$test printCoefmat(tab, tst.ind=1, na.print='', has.Pvalue=TRUE) return(invisible(x)) } #' @export summary.PBmodcomp <- function(object, ...){ ans <- .summarizePB(object$LRTstat, object$ref) ans$formula.large <- object$formula.large ans$formula.small <- object$formula.small class(ans) <- "summaryPB" ans } #' @export print.summaryPB <- function(x, ...){ .PBcommon(x) ans <- x$test printCoefmat(ans, tst.ind=1, na.print='', has.Pvalue=TRUE) cat("\n") ## ci <- x$ci ## cat(sprintf("95 pct CI for PBtest : [%s]\n", toString(ci))) ## mo <- x$moment ## cat(sprintf("Reference distribution : mean=%f var=%f\n", mo[1], mo[2])) ## ga <- x$gamma ## cat(sprintf("Gamma approximation : scale=%f shape=%f\n", ga[1], ga[2])) return(invisible(x)) } #' @export plot.PBmodcomp <- function(x, ...){ ref <-x$ref ndf <- x$test$df[1] u <-summary(x) ddf <-u$test['F','ddf'] EE <- mean(ref) VV <- var(ref) sc <- var(ref) / mean(ref) sh <- mean(ref)^2 / var(ref) sc <- VV / EE sh <- EE^2 / VV B <- ndf / EE # if ref is the null distr, so should A*ref follow a chisq(df=ndf) distribution upper <- 0.20 #tail.prob <- c(0.0001, 0.001, 0.01, 0.05, 0.10, 0.20, 0.5) tail.prob <-seq(0.001, upper, length.out = 1111) PBquant <- quantile(ref, 1 - tail.prob) ## tail prob for PB dist pLR <- pchisq(PBquant, df=ndf, lower.tail=FALSE) pF <- pf(PBquant / ndf, df1=ndf, df2=ddf, lower.tail=FALSE) pGamma <- pgamma(PBquant, scale=sc, shape=sh, lower.tail=FALSE) pBart <- pchisq(B * PBquant, df=ndf, lower.tail=FALSE) sym.vec <- c(2,4,5,6) lwd <- 2 plot(pLR~tail.prob,type='l', lwd=lwd, #log="xy", xlab='Nominal p-value', ylab='True p-value', xlim=c(1e-3, upper), ylim=c(1e-3, upper), col=sym.vec[1], lty=sym.vec[1]) lines(pF~tail.prob,lwd=lwd, col=sym.vec[2], lty=sym.vec[2]) lines(pBart~tail.prob,lwd=lwd, col=sym.vec[3], lty=sym.vec[3]) lines(pGamma~tail.prob,lwd=lwd, col=sym.vec[4], lty=sym.vec[4]) abline(c(0,1)) ZF <-bquote(paste("F(1,",.(round(ddf,2)),")")) Zgamma <-bquote(paste("gamma(scale=",.(round(sc,2)),", shape=", .(round(sh,2)),")" )) ZLRT <-bquote(paste(chi[.(ndf)]^2)) ZBart <-bquote(paste("Bartlett scaled ", chi[.(ndf)]^2)) legend(0.001,upper,legend=as.expression(c(ZLRT, ZF, ZBart, Zgamma)), lty=sym.vec,col=sym.vec,lwd=lwd) } #' @export as.data.frame.XXmodcomp <- function(x, row.names = NULL, optional = FALSE, ...){ as.data.frame(do.call(rbind, x[-c(1:3)])) } ## seqPBmodcomp2 <- ## function(largeModel, smallModel, h = 20, nsim = 1000, seed=NULL, cl=NULL) { ## t.start <- proc.time() ## simdata=simulate(smallModel, nsim=nsim, seed=seed) ## ref <- rep(NA, nsim) ## LRTstat <- getLRT(largeModel, smallModel) ## t.obs <- LRTstat["tobs"] ## count <- 0 ## n.extreme <- 0 ## for (i in 1:nsim){ ## count <- i ## yyy <- simdata[,i] ## sm2 <- refit(smallModel, newresp=yyy) ## lg2 <- refit(largeModel, newresp=yyy) ## t.sim <- 2 * (logLik(lg2, REML=FALSE) - logLik(sm2, REML=FALSE)) ## ref[i] <- t.sim ## if (t.sim >= t.obs) ## n.extreme <- n.extreme + 1 ## if (n.extreme >= h) ## break ## } ## ref <- ref[1:count] ## ans <- PBmodcomp(largeModel, smallModel, ref = ref) ## ans$ctime <- (proc.time() - t.start)[3] ## ans ## } ## plot.XXmodcomp <- function(x, ...){ ## test <- x$test ## tobs <- test$LRT['stat'] ## ref <- attr(x,"ref") ## rr <- range(ref) ## xx <- seq(rr[1],rr[2],0.1) ## dd <- density(ref) ## sc <- var(ref)/mean(ref) ## sh <- mean(ref)^2/var(ref) ## hist(ref, prob=TRUE,nclass=20, main="Reference distribution") ## abline(v=tobs) ## lines(dd, lty=2, col=2, lwd=2) ## lines(xx,dchisq(xx,df=test$LRT['df']), lty=3, col=3, lwd=2) ## lines(xx,dgamma(xx,scale=sc, shape=sh), lty=4, col=4, lwd=2) ## lines(xx,df(xx,df1=test$F['df'], df2=test$F['ddf']), lty=5, col=5, lwd=2) ## smartlegend(x = 'right', y = 'top', ## legend = c("kernel density", "chi-square", "gamma","F"), ## col = 2:5, lty = 2:5) ## } ## samples <- attr(ref, "samples") ## if (!is.null(samples)){ ## nsim <- samples['nsim'] ## npos <- samples['npos'] ## } else { ## nsim <- length(ref) ## npos <- sum(ref>0) ## } ## 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 pbkrtest/R/KR-modcomp.R0000644000176200001440000002653213766335546014436 0ustar liggesusers## ########################################################################## ## #' @title F-test 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. #' @note This functionality is not thoroughly tested and should be used with #' care. Please do report bugs etc. #' #' @author Ulrich Halekoh \email{uhalekoh@@health.sdu.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{https://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) #' #' #' @export #' @rdname kr-modcomp KRmodcomp <- function(largeModel, smallModel, betaH=0, details=0){ UseMethod("KRmodcomp") } #' @export #' @rdname kr-modcomp KRmodcomp.lmerMod <- function(largeModel, smallModel, betaH=0, details=0) { if (inherits(smallModel, "formula")) smallModel <- update(largeModel, smallModel) w <- modcomp_init(largeModel, smallModel, matrixOK = TRUE) if (w == -1) stop('Models have equal mean stucture or are not nested') if (w == 0){ ## First given model is submodel of second; exchange the models 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 <- model2remat(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 out <- .finalizeKR(stats) formula.small <- if (.is.lmm(smallModel)){ .zzz <- formula(smallModel) attributes(.zzz) <- NULL .zzz } else { list(L=L, betaH=betaH) } formula.large <- formula(largeModel) attributes(formula.large) <- NULL out$formula.large <- formula.large out$formula.small <- formula.small out$ctime <- (proc.time() - t0)[3] out$L <- L out } ## #' @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) out <- 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(out) <- c("KRmodcomp") out } 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 out <- .finalizeKR(stats) out } ## -------------------------------------------------------------------- ## 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("large : ") print(x$formula.large) if (inherits(x$formula.small, "call")){ cat("small : ") print(x$formula.small) } else { formSmall <- x$formula.small cat("L = \n") print(formSmall$L) if (!all(formSmall$betaH == 0)){ cat('betaH=\n') print(formSmall$betaH) } } } #' @export print.KRmodcomp <- function(x, ...){ .KRcommon(x) FF.thresh <- 0.2 F.scale <- x$aux['F.scaling'] tab <- x$test ## ttt <<- tab if (max(F.scale) > FF.thresh) i <- 1 else i <- 2 printCoefmat(tab[i,, drop=FALSE], tst.ind=c(1,2,3), na.print='', has.Pvalue=TRUE) invisible(x) } #' @export summary.KRmodcomp <- function(object, ...){ cat(sprintf("F-test with Kenward-Roger approximation; time: %.2f sec\n", object$ctime)) .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 < FF.thresh & 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/internal-pbkrtest.R0000644000176200001440000000061213766666544016132 0ustar liggesusers #' @title Internal functions for the pbkrtest package #' #' @description These functions are not intended to be called directly. #' @name internal #' #' @aliases %>% print.PBmodcomp print.summaryPB summary.PBmodcomp #' plot.PBmodcomp summary.KRmodcomp print.KRmodcomp #' KRmodcomp_init KRmodcomp_init.lmerMod #' KRmodcomp_init.mer as.data.frame.XXmodcomp #' tidy #' NULL pbkrtest/R/NAMESPACE.R0000644000176200001440000000167713766666552013771 0ustar liggesusers #' @import lme4 #' @importFrom MASS ginv #' @importFrom magrittr "%>%" #' @export "%>%" #' #' @importFrom utils head #' @importFrom stats coef #' #' @importFrom parallel clusterCall clusterExport clusterSetRNGStream #' mclapply detectCores makeCluster #' #' @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 sigma #' #' @importFrom broom tidy #' @export tidy #' #' @importFrom dplyr as_tibble .dumfunction_afterimportFrom <- function(){} #' @title pbkrtest internal #' @description pbkrtest internal #' @name internal-pbkrtest #' #' @aliases "%>%" NULL pbkrtest/R/data-beets.R0000644000176200001440000000412114021622701014436 0ustar liggesusers#' Sugar beets data #' #' Yield and sugar percentage in sugar beets from a split plot #' experiment. The experimental layout was as follows: There were #' three blocks. In each block, 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. The data originates from #' a study carried out at The Danish Institute for Agricultural #' Sciences (the institute does not exist any longer; it became #' integrated in a Danish university). #' #' @name data-beets #' @docType data #' @format A dataframe with 5 columns and 30 rows. #' #' @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{https://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/R/KR-vcovAdj.R0000644000176200001440000002505413753132300014345 0ustar liggesusers################################################################################ #' #' @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 #' ################################################################################ ## Implemented in Banff, august 2013; Søren Højsgaard #' @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{https://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) #' class(fm1) #' #' ## Here the adjusted and unadjusted covariance matrices are identical, #' ## but that is not generally the case: #' #' v1 <- vcov(fm1) #' v2 <- vcovAdj(fm1, details=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") } #' @method vcovAdj lmerMod #' @rdname kr-vcov #' @export vcovAdj.lmerMod vcovAdj.lmerMod <- 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") vcovAdj_internal(Phi, SigmaG, X, details=details) } ## Needed to avoid emmeans choking. #' @export vcovAdj.lmerMod <- vcovAdj.lmerMod ## Dette er en kopi af '2015' udgaven vcovAdj_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 } ## #' @method vcovAdj mer ## #' @rdname kr-vcov ## #' @export ## vcovAdj.mer <- vcovAdj.lmerMod ## .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/PB-utils.R0000644000176200001440000000214513712550526014103 0ustar liggesusers ########################################################## ### ### 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) } as.data.frame.PBmodcomp <- function(x, ...){ out <- x$test attributes(out) <- c(attributes(out), x[-1]) out } as.data.frame.summaryPB <- function(x, ...){ out <- x$test attributes(out) <- c(attributes(out), x[-1]) out } pbkrtest/R/init-modcomp.R0000644000176200001440000000444413766774025015062 0ustar liggesusersmodcomp_init <- function(m1, m2, matrixOK=FALSE){ UseMethod("modcomp_init") } modcomp_init.merMod <- function(m1, m2, matrixOK = FALSE) { ## Comparison of the mean structures of the models ## It is tested for that (1) m1 is merMod and (2) m2 is either merMod or a matrix if (is.numeric(m2) && !is.matrix(m2)) m2 <- matrix(m2, nrow=1) if (!.is.mm(m1)) stop("Model m1 ", substitute(m1), " is not merMod\n") if (!(.is.mm(m2) | is.matrix(m2))) stop("Model m2 ", substitute(m2), " is not merMod or restriction matrix\n") ##checking matrixcOK is FALSE but m2 is a matrix if (!matrixOK & is.matrix(m2)) { cat ('Error in modcomp_init \n') cat (paste('matrixOK is 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) ## -1 : Models have identical mean structures or are not nested ## 0 : m1 is submodel of m2 ## 1 : m2 is submodel of m1 code <- if (.is.mm(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 } ##KRmodcomp_init.mer <- KRmodcomp_init.lmerMod ## 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() ## } pbkrtest/R/KR-utils.R0000644000176200001440000000461313766766124014134 0ustar liggesusers.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 } .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 } } ## FIXME indexVec2Symmat looks suspicious... .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 < k & k <= aa) j <- k - N * i + N - i * (3 - i) / 2 + i return(c(i, j)) } .index2UpperTriEntry <- .indexVec2Symmat .divZero <- function(x, y, tol=1e-14){ ## ratio x/y is set to 1 if both |x| and |y| are below tol if (abs(x) < tol & abs(y) < tol) 1 else x / y } .is.lmm <- function(object) { inherits(object, "lmerMod") } .is.mm <- function(object) { inherits(object, "merMod") } ## .is.lmm <- function(object) { ## ##if (class(object) %in% c("matrix","Matrix")){ ## if (inherits(object, c("matrix", "Matrix"))){ ## FALSE ## } else { ## lme4::isLMM(object) ## } ## } ## .is.lmm <- function(object) { ## ##if (class(object) %in% c("matrix","Matrix")){ ## if (inherits(object, c("matrix", "Matrix"))){ ## FALSE ## } else { ## lme4::isLMM(object) ## } ## } ## .is.lmm <- function(object) { ## ##checks whether object is ## ## - mer object AND ## ## - linear mixed model ## if (class(object) %in% "mer") { ## if (length(object@muEta)==0 ) ## TRUE ## else ## ## FALSE ## ## } else { ## ## FALSE ## ## } ## ## } pbkrtest/R/model-coerce.R0000644000176200001440000002077013753132403015001 0ustar liggesusers################################################################################ #' @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 ################################################################################ #' #' @param largeModel,smallModel Model objects of the same "type". Possible types #' are linear mixed effects models and linear models (including generalized #' linear models) #' @param L A restriction matrix. #' @param sparse Should the restriction matrix be sparse or dense? #' @param REML Controls if new model object should be fitted with REML or ML. #' @param ... Additional arguments; not used. #' #' @return \code{model2remat}: A restriction matrix. #' \code{remat2model}: 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{https://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 <- model2remat(sug, sug.h); L.h #' L.s <- model2remat(sug, sug.s); L.s #' #' ## Construct submodels from restriction matrices #' mod.h <- remat2model(sug, L.h); mod.h #' mod.s <- remat2model(sug, L.s); mod.s #' #' ## Sanity check: The models have the same fitted values and log likelihood #' plot(fitted(mod.h), fitted(sug.h)) #' plot(fitted(mod.s), fitted(sug.s)) #' logLik(mod.h) #' logLik(sug.h) #' logLik(mod.s) #' logLik(sug.s) #' @export model2remat #' @rdname model-coerce model2remat <- function (largeModel, smallModel, sparse=FALSE) { UseMethod("model2remat") } #' @export model2remat.default <- function (largeModel, smallModel, sparse=FALSE) { stop("No useful default method for 'model2remat'") } #' @method model2remat merMod #' @export model2remat.merMod <- function (largeModel, smallModel, sparse=FALSE) { ## cat("model2remat.merMod\n") ## print(smallModel) L <- if (is.numeric(smallModel)) { force_full_rank(smallModel) } else { #smallModel is lmerMod make_remat(getME(largeModel, 'X'), getME(smallModel, 'X')) } if (sparse) .makeSparse(L) else L } #' @method model2remat lm #' @export model2remat.lm <- function (largeModel, smallModel, sparse=FALSE) { L <- if (is.numeric(smallModel)) { force_full_rank(smallModel) } else { make_remat(model.matrix(largeModel), model.matrix(smallModel)) } if (sparse) .makeSparse(L) else L } #' @rdname model-coerce #' @export remat2model <- function(largeModel, L, REML=TRUE, ...){ UseMethod("remat2model") } #' @export remat2model.default <- function(largeModel, L, REML=TRUE, ...){ stop("No useful default method for 'remat2model'") } remat2model_internal <- function(largeModel, L, XX.lg){ form <- as.formula(formula(largeModel)) attributes(XX.lg)[-1] <- NULL XX.sm <- make_modelmat(XX.lg, L) ncX.sm <- ncol(XX.sm) colnames(XX.sm) <- paste(".X", 1:ncX.sm, sep='') rhs.fix2 <- paste(".X", 1:ncX.sm, sep='', collapse="+") new_form <- .formula2list(form) zzz <- list(new_form=new_form, rhs.fix2=rhs.fix2, XX.sm=XX.sm) zzz } ## #' @rdname model-coerce #' @export remat2model.merMod <- function(largeModel, L, REML=TRUE, ...){ zzz <- remat2model_internal(largeModel, L, getME(largeModel, "X")) new.formula <- as.formula(paste(zzz$new_form$lhs, "~ -1+", zzz$rhs.fix2, "+", zzz$new_form$rhs.ran)) new.data <- cbind(zzz$XX.sm, eval(largeModel@call$data)) ans <- update(largeModel, eval(new.formula), data=new.data) if (!REML) ans <- update(ans, REML=FALSE) ans } ## #' @rdname model-coerce #' @export remat2model.lm <- function(largeModel, L, ...){ zzz <- remat2model_internal(largeModel, L, model.matrix(largeModel)) new.formula <- as.formula(paste(zzz$new_form$lhs, "~ -1+", zzz$rhs.fix2)) new.data <- as.data.frame(cbind(zzz$XX.sm, eval(largeModel$model))) ans <- update(largeModel, eval(new.formula), data=new.data) ## Ugly below, but seems to be needed to store new.data in model ## object (rather than reference to new data)½ cl <- getCall(ans) cl$data <- eval(new.data) out <- eval(cl) out } ## ############################################################## ## X is model matrix for large model; L is a restriction matrix; ## Output X2 is the corresponding model matrix for the corresponding ## smaller model. #' @rdname model-coerce #' @param L A restriction matrix; a full rank matrix with as many columns as `X` has. #' @export make_modelmat <- function(X, L) { ##cat("X:\n"); print(X); cat("L:\n"); print(L) ## find A such that ={X b| b in Lb=0} if (!inherits(L, c("matrix", "Matrix")) ) L <- matrix(L, nrow=1) L <- as(L, "matrix") if (ncol(X) != ncol(L)) { print(c( ncol(X), ncol(L) )) stop('Number of columns of X and L not equal \n') } X2 <- X %*% .orthComplement(t(L)) X2 } ## ############################################################## ## X is model matrix for large model; X2 is model matrix for small ## model. Output is restriction matrix L #' @rdname model-coerce #' @param X,X2 Model matrices. Must have same numer of rows. #' @details `make_remat` Make a restriction matrix. If span(X2) is in #' span(X) then the corresponding restriction matrix `L` is #' returned. #' @export make_remat <- function(X, X2) { ## in ## determine L such that ={Xb| b in Lb=0} d <- rankMatrix(cbind(X2, X)) - rankMatrix(X) if (d > 0) { stop('Error: not subspace of \n') } Q <- qr.Q(qr(cbind(X2, X))) Q2 <- Q[, (rankMatrix(X2) + 1) : rankMatrix(X)] L <- t(Q2) %*% X ## Make rows of L2 orthogonal L <- t(qr.Q(qr(t(L)))) L } force_full_rank <- function(L){ ## ensures that restriction matrix L is of full row rank: if (is.numeric(L) && !is.matrix(L)) L <- matrix(L, nrow=1) q <- rankMatrix(L) if (q < nrow(L)){ t(qr.Q(qr(t(L)))[ ,1:qr(L)$rank]) } else { 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 } ## .rematBA <- 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 ## } ## ## 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 ## } ## ## 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 ## } ## ## common ## form <- as.formula(formula(largeModel)) ## attributes(XX.lg)[-1] <- NULL ## XX.sm <- zapsmall(make_modelmat(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="+") ## new_form <- .formula2list(form) ## ### !common pbkrtest/MD50000644000176200001440000000477614021642320012430 0ustar liggesusers3279c01f6caf536d363ded574523fef7 *ChangeLog 76bdb6ee388fe2d650941eb138b76263 *DESCRIPTION 6c9c5588ac5473db103c8de04338c904 *NAMESPACE 573e765dbaf9b92e72c2167fb561d8a2 *NEWS 015d4f88f384871659053b52d378b962 *R/KR-Sigma-G2.R 7f17aca2b6550f68b23c2faff800c3f8 *R/KR-across-versions.R 4babf9bf83a39ae02f42fb49d9f3c0dc *R/KR-modcomp.R e7f296cc5ecdbcbf583f9cea74b6245a *R/KR-utils.R 9cf9db472f6f3a5799e67439b3808d0e *R/KR-vcovAdj.R 2811cf1b83de66252b5ef6411c6f8b42 *R/NAMESPACE.R 5fb3a6458ff6279a9e32dc6909d3cf58 *R/PB-modcomp.R 896258c23ba2fdd6d7dcda164747dbea *R/PB-refdist.R 0b7feed23b7c977e4066547c0fe92d6b *R/PB-utils.R 9c1bac981405d1bf18a48f1c3218e8b5 *R/SAT-modcomp.R be8744773b3d0dbb9ebc4957921a54bf *R/data-beets.R 94d64fd2f1ca6c7cb800ed79522fed60 *R/data-budworm.R 1af8640e29be21efe84e65dccd908134 *R/getKR.R 5d1e277317ad81d659e16d37dd15ef89 *R/get_ddf_Lb.R 4776f35d0573157ce483bc44521e21d0 *R/init-modcomp.R 96415b1894fcad7a94222fadf028244a *R/internal-pbkrtest.R 9cbb49cf272cab01cddea35fdad9a313 *R/model-coerce.R 8863ab7f8803aaabe3ffe28b6cfbf82a *README.md 3e926d66211ab80c66456fdc8612e731 *build/vignette.rds 25a3a55d27aa15aa5472e6fc4d10310d *data/beets.RData 0bf3e5202394edbc9390961036629ad1 *data/budworm.RData 2f0435596b9735ee0852c2d135281569 *inst/CITATION a1f073d2a8539678ee0ee0f79184178d *inst/doc/coercion.R 46fc1f3ccebd87ff0988272385282ca2 *inst/doc/coercion.Rnw efb4ffd229ff9963390e1031d2007f25 *inst/doc/coercion.pdf 763cbfbf07cc25c593f104b1b5cb4b41 *inst/doc/pbkrtest.R 56750b6576c3a6c4fe8484b5aedbfeff *inst/doc/pbkrtest.Rnw 9c9620cef64f7aa61f3a67f550a1db7f *inst/doc/pbkrtest.pdf cd74378c3f739073feea6d88dc38fc18 *man/compute_auxillary.Rd 3f2dd16922eff9acf1da8c0cb05b0c2b *man/data-beets.Rd 1b5ad0a8036bad4511136fcb5120ed0d *man/data-budworm.Rd 6cbc3b21441a255670e66e0190ee92b2 *man/devfun_vp.Rd 10c50cfe579d9ea6bf4d0011ce7ed371 *man/get_Fstat_ddf.Rd 5d0b2785821736471c7ffdae8227bb6b *man/get_covbeta.Rd a47be8efd68bf4d303ba0ded6cea4ecd *man/get_ddf_Lb.Rd 7b89f7ee32cd21f0c1cf5563f319e34e *man/getkr.Rd b46405368093f698931e9b0ea81ff962 *man/internal-pbkrtest.Rd e8186025e845c03cf0879ab080e18d1f *man/internal.Rd 2345791082137beb3bc5ec8d481e6190 *man/kr-modcomp.Rd 1dc8efe9da169af8d16a7dd9a08e38e1 *man/kr-vcov.Rd ab4d97d8dfb5b26297e8a5806f49c28c *man/model-coerce.Rd 0a72ac8927ba191825054400b62b3095 *man/pb-modcomp.Rd 34496b88e1b3786b5cd8eb0d83a669fa *man/pb-refdist.Rd 5168806858a1173f871871d3b119830e *man/sat-modcomp.Rd 46fc1f3ccebd87ff0988272385282ca2 *vignettes/coercion.Rnw 56750b6576c3a6c4fe8484b5aedbfeff *vignettes/pbkrtest.Rnw pbkrtest/inst/0000755000176200001440000000000014021623227013064 5ustar liggesuserspbkrtest/inst/doc/0000755000176200001440000000000014021623227013631 5ustar liggesuserspbkrtest/inst/doc/pbkrtest.pdf0000644000176200001440000037436414021623227016203 0ustar liggesusers%PDF-1.5 % 4 0 obj << /Length 973 /Filter /FlateDecode >> stream xڵVKo7W,(pAM H`8JZawmci9|Ē]’ug 䔃r((dRdIχY*'xӻ 6[;*TquՑ<,+M\'֙7(Z*ŭA LR(/bB2F?{ӺXMNa ]d\} YDb0#nJP̝5mW5u特D3))+=(1T,, caReka ,S-%Kђ`-. z/"EXdsGJ !h>zWqL xl`j,#$ᑾx}cz[d ϩ黾GD" >i a:cB-ּ抁0kLQ @R^ط2 $ B &W_=ϵa~lH89=ӽ&8RѽsR8o ;I+d{+|lnUwaF{kgt;FC~X.|lWd=!.2xa]4wÍ_l:jN .|mi1dPP3r,UXr+ΙtO|rqNS(!5>>2 q%|GEs|F_0#  p/YJiQ,B`E$e0!rQ;22{Q'"l˧20\*\˱}%ɺ5w]iǼxۦ m<o*#OmpOΝlgf·f^CW=6 f<Ǧ:xª5S&`?._ꭳo ?MGg=*($r|8- >, |BK endstream endobj 16 0 obj << /Length 1086 /Filter /FlateDecode >> stream xڵVMoFWN w/5* M^9>P"B I ;ʤ7fvҹwq&U/(iqL1ff"LQ_P> /ExtGState << >>/ColorSpace << /sRGB 20 0 R >>>> /Length 1403 /Filter /FlateDecode >> stream xXn7 Whi/&H h"ȢMF""pRfGH8xsg>mo'uhS21[97qן^W9㖟~jvq͛<)7c G\%e!YMu6dlc48C^KM.x| Xԅ [({:~u?Vb@~yot>ЙMmʻ- Wm] i$ڲ]XbȋƢ+;㓳a@yhkd$E[Wqf1m m[SXp͛pNb+SX eȶûZ)SxکB&&w c'Qm[rW%@kcWY"3k˔g"-ںl_l3m[rW5$c$4OIQ^S&U[  r??rer齻\frS/pM˓~x"3QJ@~Hm)&UN*\Ħ=yr!K7\x ']m^ne&Թ4RQQ;\4.r)8/-XMjhjԾoR|6*u$J&t<[r7tXsxCYw_:ZjOꏿMtwt̐gt7zr̗kzeHk HC!n[,h4wxPo̭?,"?>ԡ6j/곅1wD %{>[ucLxb< ` ux' cYA#r|g ;5S-ܶ#!5(3[G-|bC#_NY |' c<,o1j;d:'ىW}c0|FUW}̱Ud#K(|D&"x' }5Q!`f($R2pBF@/$Sm:ǥdfوLE KcEOr20"/ endstream endobj 22 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 25 0 obj << /Length 1312 /Filter /FlateDecode >> stream xXKs6WhC)$A7LT4LUZ,NPHڎ'. )ʔ-4_X|wO)Qqv_&FhՈQЀ %#h:=‰ƮyGPL˵3ܴҩVN ˨*NDut2M(U\9I2r:vUy6QwJ_I 1i~rGƺb 5:z Dk _ nkMǍ~/7l88',UW I޸\KtNfV;EX9*VQY4zYnUYT dN|i<f3u F xQYHI/E%Hi|2p_HDW˸djSl_y3wH|hn%@kWqEǸF׀9B[|m?c[ln[d+I(u~zJ/TGMދw]iW_/Lif{}JtxFJ^)MF4󭬈 @pڦxgٙTJi2 <S儹+yY^$) 8D0ivƈTbNȆ, Oh#R50dþ~5>S _2 2:Tkc|Pkk|~4fʥۯpC&=K&6Xec. 7SZy83ˡzC$Z$M6IMɏqj c83< EnT.^pq+%FeQHkP(qV,,*7aj"*(l~24j0.@U͎k 3 V^]~_gۓ4t:K׊] $,le&ܖPL`zje@ՙ#/49!,LfȦs,Z ToPאVM(CԷ~W!OnyU^ L-AV?&5G[it2a4}T R7S=Dj/\v`FfZ ^cָ ӃoA endstream endobj 29 0 obj << /Length 1498 /Filter /FlateDecode >> stream xXmo6_a fg+%̀X d-щ0x4ذ߾#Hm:`H>/,WJgo9oDj}$3؏l1`l xNg-ޯ:PSv^f[PJMso`X2?'k2[ nB#~Ι\n|Oy h2'3`D}8SN E`}*QL'FXڏ;o`d(Y_5 btdD3 r!yVu۬*Qh6 ODsc6mդ}H2ͭh/]|PbMgllu_+Ѝ>uk.;s揳u伪q텡l62<T2NH<ؼ^yoϊ*Mbg;,AgYg-aOs]?ϥ5JN \GHSMufM q(%tKRj%k~šDYyqμ)o'ihQ,Q怾>mF|uA#lN-&} <DOb6K6.NcR֠6>oQtMVdih͞FU7<]p |^Zyt>!^w:qbtd2"g1I>!&XD6OqKLuڳGkyבD)Y9J:JF⭬A{.\1psQF#6ɚc;@8gEqe6~0g+jFe=^xpV@WXvq.q|S(NqO0tLDa>hgY$b*}:oM]\\*8nMu-Ͷ[S2vV{]6YV05qJ.8bE:1eV,,ϝYB1lP'e)H i¬.9`;3xXTWQgq1 V2T7.3,þ07 $ *>СM[J੽COqÆ%OcW#df4qO|Or~P *]a>wB&jc+I} ΐBEW2B*ha1A YX\QD .}I ԗ .;86kZ +ZzH57fQ˲_qWrso} .NI2Խs?Jkc̨42w>'"Bda1Yn%aQ5J8T⯔+x_Uw%Ya5&nD6!&қ-pn_NߓI-J| )T;E8$dSs8ک:hc1i|7ˣQ<ˣr@Z(`T|>0/uOֵ endstream endobj 32 0 obj << /Length 1215 /Filter /FlateDecode >> stream xXmkF_a:iWIBS@‘\(k[ND%H]ξɖcBkyvvvg02`ϙԷ;[.X9 G{G FK2@"h:WU۴ZGa52;"XQ+5 7\Y4yY oQD`Vo3f_R ?g,0w{Wf&x3Qh?bTSDL\<~)nbiz+T$CJRLJvN\TGƜ\mn$9O"elԅ BVxd^E`}o YI55l @N2,֙G0 ")Cb*z$8] Cb?|ş;4;!tSIwr&%9oA8Lhi}tAŪnxx GZ"Ac9)VP8O{i rñ*|Mj!$]Ys_8o&/B5d1rmx&+`[ikUhu"p)ay6YW, W?-kcFj:ʅ(ʒЎ n3 4w;)Ψ $"q,'jXV$p$k6kYC&Y 3ē>(K<+jb r!ӗ;t;[y'y)Bۣe_f_Q|͈ٳ뽈w/,Nv)fn0񜺹ڇ "Skw!QӰLd ż9oDF.r^1=m7*G6*&K{.wNj_Tu & C@5ܡNo1z녚 ;#ooMQdq\.?}*x9glGZ|{DV$3</8 endstream endobj 35 0 obj << /Length 601 /Filter /FlateDecode >> stream xڽW]o0}WX`>Li MK˛CT ֟?;"ډ}ϽQZ' la,1Q wqv(!G/ QA$Dlv-JL9vΩꕭwpJs(Gp_no_&h%7'.it;hu WAIѡK11I )98|x;J0@Ю/>nn!D endstream endobj 46 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 48 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-̟ -0{n`'( lEa,ptpA\;,A!+0wNZ[W_&"d @6kz:P?wzn =zC@gWP` 9 A'd'~>|g=6'gzY:B=1|YeTeopE W\ V?} v Rv|&-@ \@/gGQo߂]PpXЗKR -aIjmw>& [ms>2kn<o픧{ʋZ{+QW8:]ŭv_6mP2Mo5 3 F_S8cO L1E?co{-dvQ_Lzz:}1fKﵥ~wfLK3OOD '*PBę}$!wb}~RRGͭEǯe SOpbnYX,/54aJt[u[֤Z> w`;rZ:æ44 VJ1D&sBHC>3AmĨv!j:oLI"=Y؛&QW2k+8akᱏ:_G?2Yʬ5ıЕqsTcH{KZ}~J?yDfެܽm#y֪=DЇ ȡ1AbY'3CH1겓$dCН-pn,V=LoCW^SYw,QIJ CM?TlTLz]{6^]drA ~JJ?uP-g݈e6u Fx>%S*3lSFtyJ^#Y:I1 iA.V@KY"N*Ww!qZ/.ڜR{1e#TI D3c ͦ2SKW\,{U݅Kcz;c[|\n(ˌœED(V}/ElCdže-DYِωe^fЋ /L+G8)Y=W vZH#c-/nʄܓH!5:< iz6̑CJOָ*,x!^ |@UJf<ǘ!*c'+q<\Óhj.PZM&7 jxn<97uvUfLl2!v3ԝO.c{&d#~>1ܽ9iiqJIx|9vmU)e<IMi m\+fgH2.E~4r$ R@7@č'~@'1fWb5ZOT MǔFK]ÚQͲy~e=Ikҵ{=]b&OON"zv&qL sį:bz%3;?[_.,52H]gZE,JN-\pE)GyZf~S%nhPAM5=[6/[=}XB?,wTL?j.LR9L5+?`qs1tKUSr@AbK#eRzhzSa/Sg:h[HR<*FZ 阝vVouSF8"3;1s&q!&^2:IK"A.-1Qu475L1 X5<8¶Es3 2p;wk:׫/[1kd1Aōa>}Xݥfj&5prW*?gWX±Ձ}zWPb3&/6Y.l\;HL'YwvyM=XY.3\;X)ݪG2C>$U $Q5E[MJ*vS͹,q'UP1j4mn:HL`oF$2^27+Ţ|o_PӎJTqp0m̊'FG&ƀN\<%4 r]3{]iXuOՄs쳯^~S匰Ŋvw?PJ.'/x@b* ]LzdN薺T}nQ].7Cʄ ~Tt;?&<4d"[4aOZ:z['nI=3bkL舔Xj`{#*;NI~X#6$_/`S.á߬m8:9m&s" ``'(+J6+Lږc+%ugˑ]@Fn@ K bʯ p#g6Px_U_WgJFglrXD*'\:*,;R|p>qdzʆLv3xܥ/,#[8S-&a^5q@ȺU$_)}\#:1G}Zȑ#^p%x髜{1#+9YYDIO8Q+a^J}A,Rřpࠏj=q`-R=6 L%ҢFޒִ  -9\:V$֍엌ҾT"$۱HRzٞ$O|!FP8cylHW?B?027,"|g}G投3ZZ;H3@+B g  )_ETBp/%;Vs[eꍭN@+JWm׶K'D|Ή1`\u7ZZ*|K-#_ c`PX~FF׺wt+ze®{F%K]*؄/ϭ.k~i$ae-n蓐o %.A?ڞFg6H.:fښ %h8+D$=.3࿔bxg92D'U.,Aںd{kj(L>G .#ψuK\ b_<3JCZ91Yu(ؿ&lwǎlIwb(L5 0kX&ݕg{!I Y0LD#2 4Tn)[Cg G)cZQ?)4h?G*1 >s]VӿQ mBmѱOQ l8);\ 6et`4m,*k+}e7 kC]x)/aBHsӘ^'m4-4iFf$^.5İ,^zDai֎NB{4ʻ%jy,ԧ$jZEӨt;95GOr0t+™>KrP`,u2:<2ᯐ,%xJ Vl͐]GaAN^h0TbDm1Ps,u| ˣ͠s^bDCY:FWf1J!勥СR@*RZТ8./'[Q ]d&ܳJD{y;Ènc|s53Nܕ93\jfF٬{ uZkWĨSy_8W(: 5}i49Ӄ<=u +Sz~efy}jPc% ~"GqDy'SڧIB$g<7e?3}|ff]V,ʝ4Ϟ |rgp0EbݯG/" G3DKs> f38aVE8Y=ɠTFSs(W&E̱:T6)#$mR3d< {E%pϹ j~a4I27aF^f/ A)a?z¦'t4YH;S)t<wYURs )N)io cqshܩGVWhur^XaVWAtF. )+.%5Nbt_ q6x}YB6/Tr"r?!o$-l rئ 'rc22@/cfFP};Qqbp\`t^uWl4ᦷ`dP1vAQg>wbHRRUI~pߝ9gH!*lǪyuJr,5C+&֏U56!sҙ=Ci!~-`:^cҘbqi+ʫWz 3-C6<0P+qש~p]] Yd`2|+K(rwN)Rl֑;蚬+16nenY.BI /({>c ֲ頔ϞlɁ WҳDSuUA~.D:;"NόZ35B\1"a1d5x.}bO#oc>kEwYDG4H9 F*Ch0ƺ 6^<ߑQj Oz {^S`'])9iCІ4׳JW(Zt_V/$Y_{סzlxQ~/aM\]J軓/I$nciEud$ͫ!+MAK4Y [Q6&-}3 Z@Ds>jEs#|9$S WKO1]^%s$5eFo( Fb] ubmJp.UR!g2ju%V%8iDΆMrTx8z>xC82.tÜw- 'nluz;`fе^s)'W#Vӷ'a*19@sq>a]db`/"/[O?st &Zڱa{ MUxS&9鿏[e 7 X’+٤NoYZ@p`a+':6qQ'I?=!=!=\;f3| NgG_'&_se_!uU?%O8s[LӄδDRz3z}a~'Ct5({영}OYX=g:iy?-;nyP2;i%m,έľA?5Cleϊv׻?pА] <{Aq'}JMct<[GxJdx*Wk3W8.ˀ+*dr!#" 0l B!㛖yu@0vw_EЀr|/jSlfHi-h~D"dZt2r=77a4G =:XVs=R̈75?|}OFjQ^faed@̀K(:~l7 D\R:ʤc"? ۙo8l[l)4Iǣe$Q|RtYw7O˨g#&6 yzV#T4^@L6s~2m=PL!TDQ)>ҁR2'o@hV}7J~)MWv\a}ƯzMV,B5h7Hd2K4:զOs[${րMj]MYOH#sFLϧw ;n&mKʸ~XA< [ZG97_#?L-.J{WȴVk^1ܸY/5.*Ze{0,z|smRb-"BLOJVt[m2֥K#Nh.8 EHNz=W$ƻOF`gs7Tp]HWlJ-/Fi+ ذlܶ$[8Z\#}Unnj:-ha:  ihmSI8jLQyWaPRn;@L/{? fd-eU!9y* ʏHeTq*6+QkSSjtgS/aqse2ɠ0KGw-l~"N'U'rvJ8Jp[+ z/ BhTBPy+4[C6zgK7%b&Ր.#K5|7._Ӻ}ʗ#<,}} ;][%i h57X}˛$K+EG7#<^NU(Ib>ʘ}K2Ba>7G{}uWX fl, k}PۧIѷ`pwidcgl<N 2NK@KA.4!&iYnb䔡^[P$L "Ob=oQ<رP#30 Z}u4!®ۼr6$,q]Kzʍ9I &Ѹf]yr<6O_BqЇ졢#d#QZ dtȥ#?L¹ocWC<ˇP~D4ơ~ke5rաQ&H DGaΆԵk4 RVw<H(r0>#b}80:5mTy lU!3o{ec$3~6['aI^ Ú2|#|jRi-r]S獝l*jyxכ; hK 8[Jԑq-֎QmZGb% s̏^Ȯ4_`Ad:BV̬ipGaX5pquo~E;^Ba:8ӿEUrbK\_-նE.̱4xڗ"f݀kE-Ȣ~,sDoTN{0%4*6;tzᒂ]o@"g3JtzcZ^YNMziRϥcqcw Y<rA.F}a/h |2unSPv}Ztȳ *Ro՚ﺵZ$l@eZa`gNS+q'_;-AjŊB ?7m)tp; >K9v%w)1oQǙ4nUEn4Il&Ir,hn+afix&pWݤTM4:}K6P@)hEmnbV +*RcB9:\r&C2U[{ ZBp,_Ń*$cЏ5!*؋t Br`2f @<x}pCd' {Et,3Kg#m/NIy^WFj0kq(ۨǏZA&jng|!RPO6[p;BiA/J[u3f'SCɧ9aoh_N(]ߤY_SOXt2Oؾ(um5VWB Sz;8AB6> 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 60 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 62 0 obj << /Length1 725 /Length2 16161 /Length3 0 /Length 16663 /Filter /FlateDecode >> stream xlc.]-\ze۶m۶mۮe۶˶97g2XcȘ3V&)#-#@YLE@ CF&djbio'bbP75(:L 0da{O'Ks 1տ5CK[K'Mٕɕ$eSS) ,))'Sڙ:\l,2ƦvΦT3{'09?̜m*br*Qaza @Ft;gM]\_l W2_N`&.#SsK;&igf`\r&fDښ(m\]L&NvqdB m-m<O?dڙCLb& .jF?pϩxʿףQ"[N&k[??XW5tqh3D=iXlFfVF35vur2s71ƪ1wUzkXh|8**#L6尅5΃ N;\ɇbxSUR*s; z7`jضr`.A ,yyc *:v֗ĩt)P~Lhj-Bn7@ nɰ-*µ 5%0Evwݪㆷ!2Wt G!oywe syTwyY|#^fu(\f)twEa`l6W\d'9&Q+-O1ۣo΋>ym )e@l]ځmڝAK%U2=1['",ݚκpv8R [2g5 y &\5_Ү#K\TEzW<2ҷJ5< UxKʠzS!O,>8c;Oz^W/MrBFN*A81u_oݭ2̽췸ڪDP0 !e 3-GK^eGqsGx^䀍^R\D K$}u󾃬?FDsuVw(BVŏbqz6+?1w~*eM^n@wתJ.ޖD:cqtzgz -U<8#)-{íAi\y-!wY}ɖX7nkK Fvg(KI N94ġBFhvvyRC8EWW2?c}aagQxb]c~E990RFD4>:+=(s qwtUm[<8"\cX`FyCrPܪsmgSiTB'vk?q';-4^ܑ&l dr1CwDwPڋ.hutJ9Ro,eE Em\9͕Z%W OIo=2=Qg9'>cn G `1L7~&96zv3CCHl ȊFg-N"}РQDU*eԢB~Jmp!%+NIiAnWO%iwI0[9^<91N/ʏ,[<,gScjEj=Z9]= Ͳcsg呇Vz 9ۋoضUK(j0p0%$9uyV |ė֙2P)M:bswmc=N̩@^t{#2FF,8$Y;(>.A>I#ūN9_L}T(qGMhѧYu۷k^م|:u,RNoXXgQdt8|cAt${ A]c -(*n&@rwaP[O+o2\7:^uaBߘR2ͭt ܪ 5ߚ#S?j7L$IK3;SAsaɃ!fES%p3iid6aKu0U˙Yg*.MR?g&O'2sʻ!A]icԸ!Ʊ${r:\i_@torڏ&cf"쑫~5']>oF(G #C+_o&װ-9n ]LͫJ^]:$4{+]^$ +ug!guCK6I3(hցAzk~jp{G*TvJ@olR'תyN&x41q@L8 4\ڠ}C$`agY$ p{lr>֫-ҩbPL;&,^Up$cu K0JMȓig4ÚoR W?hY/[Ь&UOxOkh!=P7GeûQt.>ԕgd!P\ -@?' OP_v@HH:eY,P+{P?aM|}P+jo e[ BW3f!83Ecs^ʊ,RMr?%ˠiQw'X7zwMStBufNH6G[.(fVAng*~afɦ !ƨ;EuKoUH BCp,eZoy DODeAcCCf&T= @L>`';ͩ^7n45߹&.gt@[O ق&(DSDIP*:LB}eJܕdƯ*Hehq՚[pPe(=hejP'/ [XR@0'd}>,-BΉ{p3_tc.L[=ڣx!q :U >mx&܂EC)tk2U[-zaZ(k2nT 4^w%3K3̉{4!kjJ"nۦp2qo`k/?zH.T"*=2c4q&x2SOCb^Bq$t&ʃAZ̻N_,V/ty4~>2L+/{sRJ&/MK%/۳GBfKq)*XϪkGK8][LY/W~M>T^1gޟ!ø s$Ï22g"v|˔H 瘡܂YB$\ZXAs× pec(D g"Rmg۵J3 8+{KԒ~ O^FǓ::%*{bJw܂!.)O2~k{14f܋qy\'Zj*N:jnNelZ&VdC)tRޚh{fNLjܷ/B&a68={UXY q@F\ys\qa]sޞWihvP?9r@8K#=s?U3a3uA4<+dډB>'c8XTOPŀ14"c캱o kG@,K/t[*, W b͏KkvL-%DHqRe[]&sQr> thO&)U޸Fnsm4#GT.Ljkܑ/w%&"]#:F~$ o1 Uٓ_'`- AJl}~V|x.8슴vh/@Lq{E\V|HA[tsMf%0e65VxW P ^]g3!3źt r;NNjNFV[`Q Z,o1n0b>a?PtRձ%H坫}] ϫH.(9&o@K Sj<_$q_g!sI8nⅣRcf2+DT @*O"ѿFo!p6ST^”J:Ϙ4M88 ~M9|<1A F'h&r\S#K #޸jz^cY9ҝ,|=OB^0T!eq_"S4]ίSNdk8 !EBth㯎 ۪?0Gד-1t`,x្d;<$?65l\k<ۂ.c,L¿_?˱eӼSk/Rzs@Ҥ*H{u^2Е=m\Noµ--$R}ǒYxNHdRrlЃ]uaе!8&MQ,[ߜ3/}3)M65H"RvE$71IΟ6;7u][H} z!Mփ;H]_WQ@+OrjPU 1Re\Èe]qTдϟ*8WkaoM|DsDE8,{SPq=+:ÅmĚ~ö'ttMh,@_~ud[p *Ga3wP887;S޿FR`> LF헣正e!=.e_ yVRdxoqV}7P4P^vmt!ƥsMQL.6rYb[9^=xǪmeAqJP@CcXI`VqMv1΁;KZ52a$U[9G׆qN`F^䎥Th?:;n<9Ļ a& j$!d2jԇaZ,G)EL c kpIb(&{2":$<Ņ/ `r&_Q-l|tu{hf۪=.|pԶ*|U.# 0u臜bI>9G@'2;xˢd2z|*QabSUgM^Ò{Tp]1@AުiuXpٟ'?M-lwK!+gB1?LcJ,hƙ+B#^^.Iv]LO֟|Wa]}_H 7㖲5܏XV^P^ C{xt'ܳYb] m-Zrn7c]{Dj`O/X/~[-m'.s Gl]z(SriЮA̚Ź21\,fg~ⶤxb~6N*PY0'uU%|O QpϘ`=3h'Gj9ރ#6&H^Rݘ]t> æb`6  'nYL^55ӈQ:]ҍ֢L=r2,mf\ҷOړ,Ncyb"CHnpԛpqnaoUrsK+,-R Z-gohG=Bv!-ߔ/FZ>yo:ird,mO]Q&ri?1I bRI\Iłx5Ʒ)n.6j}%&4s6Bf'~UoCyLtR9lՠQ 12^˸,߈g SbJcv/)w 7pmA÷f&A.Ye#.'0&MBа,ƑkIne_Bˠy%W^q7 |L%*{meu RERxIfLsû块e[VxޗTOtk RtuY ATBj18O^S"9L__[)jYbM}V˹`W}X-f{aϺ\jͶbْnjϬTӚ|6o|cO%x!|ǹR$[tH*_~@e*"`;I KT>B`5IwlRz7dRDM8ږ17]fA!AĄ#NEH C#F/f`t ^>?ɓ\N"v x."r]U6vG;ԘmbaMY0(Nks9iE;^I(y)[ % q줦 e\yT]{xҊz]ن=_yB~܄e%Wj#$;"ߋs-jӽ@lLbl挵8h e?{_I |s^x/4rf;vEO_|_P]MH'3ZT@0K3';KyBNWtwC<;HXih/A)yc: gBT_&/#jxJMEw/F(h Rf#yYIrZvV^*+PivLǣIx y= ,r[Co3M#&F-}T*KM^45QjRЌE<;O'r[FpO{؄qfIHPDV&ErwQ<s#3cBuz9=s-7D~Q!V%m%s=N]4h52zxOĔ)S jK_8rFqZ_t[-%F݉dy˝>1 лUƷav$zjoĺn$"1h}95 #R]<32"%c#׵P~>4+k^-WY(gjNB%^oZ+?'鳯AB@t`cz.4;,>TT=x|;nl g$lY/1e{=xr_İ%9<}&%{lre1<7i4ʎUďs]Y.6\zD8̄ yn:'!͖EGѻX5:El.'KJ1j"Kc.a[uMk,G Yb^b7Gm8Ub f 9Ԏ|; w<~$ [V%ȑ~hnQ.A $yݱjeMkM?/xۻH~8кH,V808~>:A]R)78WNWBh4r7X }AM?:Ug-3vb@zv5XDPT'|K{kZIlGr&v1K⅞%!pVq3(xT[gu~G! <̨ys6uF2$ ȗk!3fpjUE_vTPԊ>~AW> ā;돉c[ǹr>1%lc:k dN@B8NpT@eq'x%sfw-G#P'q!ZfA  :d9w)K_s!-++,2{s3 Ԇ8lm=+}B>{ZoV`DKA#L9&%[V/5muC@-&]%%bgc1Yfc?ي+,)3(e7}.ʳqQN{kr}j.6GլҏGݟuDŽr!'S ٯqx,q͂=)ioyA<اxۂC]aU+˖}HJ&Ø\4u_w߿\v0uiwZ0zm85u\l2mَiđ58ȩ9R{ySTm+Z^9Ow򴥉2f+һb]obͦ>%] 2R5X3%z󙮴0)^\M]@S3=,Cro3tá٘ߐA3t<ȁh")gxB0~Or:,R*bD{srF͵ڍ&[I ,P\HWե֝]x/G} Zm|j r"'rQbⲄTA̜hq1OeYr^5Vط#Gd.tk׸tw">,Z,9'#d, cddGVOYJ˅Ey٣ptK 5m3}C-#Mi)EK³{ L,PӶI =D- ``Xx6>!LF]YQ23<`l ga:e`}3+o"}/FtR6vZ 8WGY:S6-07,%Ke2au?,V؞:i\K{Np&awN}sG$][8*8#yif\ji>WN/_g?ҁ3<aio?XMİDrc)@ zl}Ob؎ [؂SцͷN)=%h$]m=a,M]DK*E:! [yMKԸFd$F\ 1 0aYu6߁"W+zs &ۃUᴍ&5zٯKcuq+AuͩdDJ#A<:6'ZW 8705gnHN>4x[ yN-_d Gk&Q.|[K$l${"*5!qSNKOeKk׭1>cll!2 d398)-e-9x[Yz5(@_ɜL} 7Q`syl-wJw 6"/hGA/@Òάo=4Wt c?~;}ت뤍=3EAlq%~ ˡ2hA:S=$9d\`>\IUf}X(ŵA13eA0%Kcu5]Q}\{ث6ș1 WkXKjm__ޡ$fkD?m 7e. >`.}U8Fai!apww8h’ާK sRyXlu%fr~!.U-qIr] ro񻮊 #MX,1^  ʺg45WcFQ-JXܐ7z Fᚢ ƁzlV=x҄X/[!Skrw~N]8UDCcg\kr"z)[Ml{M]%iTxFL@r괛j5 W֫{y c[=g#m %;ۥWsF-T(t\Ae/A<s$QO IGQQ'H+Ri8aM]>):wvVE#GKڎ&&dH@V{"qù@Cw ;N"1= Dm֮{kavzY ~JDlCiK* ?ـ" }%Yto=$ ^o]7U9|2oZƒ >˚_X))ˠ h0$P}:/7w-!i/IbTV!)?@DLlrنb@G<CSU v(FbQ tmPGE^'?/fރy+?^+Q*zw]4h-~t+9ݮ[ zpn3j"5Y(S,kvmu9#X ä9À \#HYd5HDbԿԣhL`y"*iH34e)<Δ Zn(}?E;7_U{w]>[-Μ~c~)Lz>3> 6?/P}pMv\ hu,'%Be_$nJ' 'mer 5:FH@fOIhYHy)lM\-$LCi0:=s`+4ӈCz%v΀oJLMn:rpkP,}~͸eeWPv5c{D&[7硼fs刀~q~c}}*y-7-jv8⢜LyOvUKF+h>wyShQPeP}m?ҟ\AIAv[B$=#Cfׅ\gH{=:&Fӄ?X[_L8RU."`kF#'Da&[|U 4ץkdM}AM 4+"%[j;c;5 jQXlS(nfwZցgw aYL6ZU̢Upܱ/Ęc}b&Dqy{ 粖?m7?ඹe^ҿ9D(.j竼T9o6-,}H2SL((eMU+qQ6TGp4CPEp MA!YAEW#:PMg ] :OCnV:W=L ~9DnSt4hVU/& pE?˝i4#[K j=4> endobj 12 0 obj << /Type /ObjStm /N 46 /First 348 /Length 2564 /Filter /FlateDecode >> stream xZ[o~ׯEAP kuR;[5@KZr.%XqOZ|3Ғ0"gk"8'$( =h.h }XmPN$^˞p3se eA Rz"SH  'h(XOdW*$K`(Di L 9'H(X5NLp0L{b 1XA䉕G)[0Dq@1£!8d`$NiF zգ_f)g(|ZӪ$ @? -]:̒3f`yM0#O?ɇ zE!؃$N&hW$f`h^(A:=+EZk!,o4M\}QETY>=Hp/ggHˇ[.j =Hf٠$j6^AZ`곾|QʱE4DG/Ub#_ K4OߤǴI<l:d <$"xd-GӫlzZf.k:ɦxC?*wf`}YftT$)M*'w30dPSz[C@(y5Lh\7't8W4WΒAz!41&06ۇۿArˀ֤ E X !)|}ך]KFu'pкoIl@)W&D'gG).nYX;6MlO"JU؂YpN,V 0Tp\[i`Ķ0. u3T/WvAX^hmTdԮm!=SCрHra24^XzRr25G~~`(hoAK1J\38Ȋ ZcKjp4$,)e-1`zz@FcDWiйVViA{e Up wX'BFd,[ 4hZb~ O_lmyc[W¸%oW`E.1JPĞr#G-lnV2 2S.fAtK,ceX61rKF%!K! #Eس jQ^YZ-e#`,+ڻmjU= NaI fB#\on}x`` :-LHü0&d umhP!`5fK Sao-R|1)3HF7鼲8HAͪWý} :ɨ$*r셛KmK)n C_ ޤ(;d ^OG㔀* =\ApIWkzLO;zFiBoiJ0)1wp#zO3:S|-hI+ZiJO9O/-@[v[ 0h 4gwH.?y yw-Zv) H yAAML-b/\읁-LQla 1e]Cp4^.| dlȅtxgF@tY>Ct$Js'V'~i,vAϣo[rvCoYo 1oa2O_)f^0/Ljw YH%@iQ㽷Gc+8)dttlÚd!,;-W'g"zy5B_f,er޲K ߗd(o ")Y_'e/ o!Bt̤n~!MCwqi{ᇅhbo:ܦEɳtn^iOi"ףz]>ߒ}!b|o[bldv-N^xqqٵ* \b25b+ض <5B84850E906A68CBA17DABA633963DB0>] /Length 197 /Filter /FlateDecode >> stream x%;n`!!ظ8E% GH!t*74KifERg5}1$w7I fxxOk)ձHdDh-lY?X3vE^ċxE&J]xn*~J|Y뉥:q ,5xoINZϗ6uDL6 ϟã endstream endobj startxref 128820 %%EOF pbkrtest/inst/doc/coercion.pdf0000644000176200001440000017063414021623215016135 0ustar liggesusers%PDF-1.5 % 3 0 obj << /Length 1138 /Filter /FlateDecode >> stream xڵWKsF WHM-G_v4Ru&3;bȵ=$Ē&-v^:K | | A xyG޿N]ŁL@DJ1:XYkTֻEAX-yG5/.]5.*|eI+yиv!îYD2?_+dHIɔ]λf[8oa.i`,@Q{\xX@+bZf=VB$m&@ VL_oA&T%>d0(K]w}ydEq0sV )h>]״|hDyˎ@tkEA&9h!2bnKǧyʹgKyޛ*HD$Iך'H"|FK$u646);z(Qg 0Hk(r2Vx Qi}U./D'GY?3{sVZqa"z4M}=i˲2x~=FrGrNJ/zbWyq~ W-yoU 콺蘥ƖASbО*{:Ϋjh7FܶswgG}>T0ف;L<<7(ި)5&=H caH X+QZ QsV'xGQL endstream endobj 13 0 obj << /Length 503 /Filter /FlateDecode >> stream xTˎ0+t$Mi:2,m# u)%@,:ǹ'݌%vwf+< dJ 2O"IJ> stream xڍP\- wwwww@%$wwww<|{U\kU)IUE-̀R WFV&>+ RR bW3&aȹX\||,,6 tpHXr <2 1r3:ۘ@M6@W*A#`djl%Dq]@  LuO аqˮ`a ĺ 78@]VW2ljn`h Y,me)&WOW)@S;|SwS;S?DU ݞ -2Q}%A@ $l~9x|6 ?psd8e%y7c8YXXy@'ܚ^?;qtpX7n@?;,l]f@+?@˿;xY޵ `7wyY8 |$?>11O# ȸ_4+ t}{8h]K]@?"7`d1?Kϔ?Q&MHO7͟wѺw6UZظo 6.R6@ Ws])U\lVG|epy. s?F `l~>@?E `f9X:8q\f?L"n?,`Vq5x߫xf ^ppa'}`d0߉X@6򾓶|n/ `w;ߙ߇/.c/y9zGjw-w+hw]ߓ ~ÿ /_/ޏ?S/ř9;_ r zCmC[kE <w)wh}="| ^w2؅-Is#Ds#IqO coDp"{/NZA!Z(xU 0=z=/p#zVjtQAܠLR-x"102eبEGXwB 0vʚ0ɔj~GaֱYjuZڦ.N}{ Z6w<581ޅl.&`֏\Y$J*wС DeXr e&[uE|3w_UR ڼa[қY{E5IV8M~d8jUz`LH9F6DB~bYH`/B3*͟񜅪;'QAb!a=[bFXZUc75C?v(KF}z= gF~!Nj!=ك\VxQWP wpA6PMS [/{0,Xʬer_MZ_5 Ƚ7FI')| J8zv TہW4ёk Ku3}H1r_,Bc'225bz̷-lGfj5 A]pu OGp{\_r8: f A$gkL3 v2H~OLL)Oͦ2Z%BAatX̘߁{<LJœbJ6񎸓KgpsWd^sKLϋI b}t]P>ۜwxn*׵Jl;v q+i"B@9hlIvn\X͓ljTbzU9z@LP%S7a?}rcsmС{Pm",k=v/f&Ȋ b[6uܱ B* Uq_zP1OH{ߗ P'Ќ>[+=6(X!glvP )4iφWUٯQ,A=d''1[tgTd#US`(>(-\˶@!N$K Q[pHD1־`& 레`17J kG+"םk 2q>s6o^(ҽz/o?ǣ*Ⱥ䄪 Zbqb~Z+6x Ak%jſ~JCRf:9yXLGNյj^ ۍ{HPn.X_f]}Os˸6wO|?&N10g|.J@K!u42z2rΆ C+OqIwxUƣԽFSZBVPUugTU*iAl˃)*+N?wIdb"6 SU_7GgvQY\P$(K!`J$`E Rn=V-RrO X+oݝo^^ (` ae0,Nwx沃{1]ylUg#:3s/y$ӛ\ˊΔք#d;܎Ex[Fգ+IX脹+-)ҍw4ĢvMg&+ӵF }݋QWQ:I\$Lz`%jҘTʯI_dw*'z1.&UH'K|J'.7M$"Ж!YFDګaTlev{3la}'ʼfod_s1F WxG}L6PE EWb;H pka\hRNMcE&Q\OUd EvqÕp-%C9z XwK=l]7sz:3BN!&E~?ox"QG^q}cZDvٴH3ֹʏk4 g{ѷ3/]}W uewC.7f"> ^s$Q>8LzOΉXp@faV.*i5c3T (v- <L=)-JCH6ż"rïلgZa?]Gt뀛ç,GZy,sJx^` 6wXGNp)xV&n)^œ#P&,FYxU]sy~SƀlB5e,ԜS鞷Q[U 3Yw+2O,UdW!-$i >5 ^C.LO^մ6x]ڥQ =jbFDjbvǞߌu9Kj Ζ1#a0bV4>1m.$KPi̩P@ˬ죌U 2-YaU8_V`ڔ]E@)QPkFaV9}q1&ĵbk\+$5 Bv Ӵ߳/caZnv\!lE0=+HҰHZVu[֟Q"?G މj ΚOwJq*މfW ,Ta'~PgE`KQ\ bG{pPuQS\K۽f)R2]۳}] $Nrr@:. ;[:'Oy`^,Y|B)(8"kHz f<`]˸e PTѕ.'慌!4,Î  L\]JBi(@vr \IcZZdORC.Q{ ܑ4io.ؖ5QJxjM<x0 {LDIZ~Oc易z^@+}dc_O<ڿM&]VOm2 3C|Ԭc83Oi;O*v,;8Kb= ~2 aK=>pbeZZ83] Tpmo*l ʆ@FtC;mE8hge wjԲvy/u 7*]C'>В5icFA !L2xܼV(/SV[;usvzf?w k2T\),T^&*6z>m ˔3ױV>?I9BY[ZS=+>,MHsV@yܑuv:-e ^Eq Z5y~2zH$qsdA V HuEC/GCTbj0r(B/HYV[TNrF?_ko- x1^*{ƋzX/&n"}!+OHV>4d-q1xM>^@ԯD5j):1%&@޳T0 Ay* D; pMc! y_E}Bj9%qdT(|874Rv pgd.kEuhT2~m-4ǁ .fD{jt'6ޭA*o2]Ckr#]7a6îxRт 'C}V?]qb m_U (>Ï*QnCp5f6ݯOyeu- ˲&!_1H0mvLt-s#w,@.#QM-!W}jo .xK^|Z!cl_8l!@ BKZa~RhÈ̩r:A;TU{ "dK+mmIm`q%!7dsNƀ%ˇd?~HVi&dG};$"|t#5AO0 כjDu*'ys, _2e\ PYZPam tynga]C~?*U)5MYAjIߩȂ9ξN*K@%O 9_-RMqL 4>CM2<^>)5KbM_!"ĨAfn/[ /nrHgzvƄ@hFQ$6GJhΡr" = j?}K'=h@泀{ή{mG*bd(FetV2Jfq֣mF0 ߆-yqK 'k~V$Dxyim*_Չ{叻Ko߰`ub@Y֒.Q uA9oM IrY+߰/OpP|]lY'2E_#;&_FܻI|.ƿhg=g6诬 hvB/- Rn*\S SC=ד@uuȬLz]y@fD\խ],PN/j!+N`)m0lw2%ρO7$ψ7]5Z-Z.M҃ݳmbjDmaBFTwG{^j]R1a0c@V.:o6JՖ-=kMÑڀ~~D`66G$I> a?.u+ASύVU Gb%5;emer&*|Q#j}y&~JוP{ڝHcďc2bf,$JSRX;ֽ ^M2쪠]dk}lq*$ｹ`6WANi|Jz 8"ֈ(]t~SP2F3MA5!ܑ6U*w>|6ֲ= U"N!kQ/_9<^%O*8=J%?,4?m fPsHʜ}O%rpqK5;mԦ9tR95y+7ETvMRHN2< zky&ѐߚ\I'蟝Ӡ\e}&y\b7NM=ԓ/7ĞmGǢ~edv9u<ŧZXטU_"?.bWx'@uAsH+|D":%Om!hJoX>y9'T0ǵOY8\L`:`<#Kʟtn"Ed_ܣbU6^sNaC1.'\ɞNt7tJpB^şR/7KWc2Q/ZGVNOpiEtbaAbD:[T+,Y y+KMhU+;b>} 6Wmec5-Uᣜ6R:M];IUXӎi`u:Ҁd¬[>,SHH*UT?qR܌;GsܤpG1u]mhiϪIew~ը;0P9q~m('knWz#1l aܗY}~cst 7GWsb᠍+ dDog5e'"?WܧL\rb:1}J"+077W&a!zpzZaw:D@v: ,5&R}DujǷ+vxr}ᗓt$ikco޴X|qniy< 8LYV-Z4 4f~/=\V}NpepX{|#f],(sQa\Uqm 17?Ǭ' aPvyXMnaW5~ڣ\<@iv xsQd ,-=ШL8oI~9-'[lM'nqr9:q*j7RZlCUܕL}ߔn5Ȏa…f0 (8X%^b*@[GrRP}XM|wkn3 7-8ToPwls1I ӉXOJCQϙ}RzڭrAJɁ[iU0фϏcNbzz/<>?GeH,M˿H>ȳnu=sb)ݣE[}/_XeR}E WϮ\r 7TF)SA0EÏ?@&[oƏ@Y1Q'P yJGW]*}汕=K,S=HX\: ^wnHYկu>p_F&7iw1Lpd-F;߇_LMEJ89N)ʷ'Q诊O9#~E +Sj.wE퉤9^_ekk L!MG7␬Nw{A giXxO3/n` ^o'"ɲ_}y39 Sf%/D%댨͏o %lHvuJզCHlހ:$+jo8H,; _)-lC!j-֚޽MAdĹQT"V5y0k-)8sZk5F֭S,6K9~}`+Rg{ߓ=Z[%[~y֟/%;{ Cc3O{5HeW|DyOt\a'EP#vA5duq2I./YfUz%#@䐳7|ͦ>`w2\C;5P#fx. &| /w 7HD}{*jpZkYސ^ s\nF S|.IbzhQ&|{,[mM| W‚bp2 ƢR)gZ+XudZ5R gZr[" xuAy+dP:&>^hΛ J|l~e*uz(njD$Ui=& * J8vDShqbwYWZDivO |@U䩥|N(c/KT'G%- շa:+i-P fJf{`Iu z:.\AIPT*Ex>Kx:OT6&(<;` J"Ԓ!UΈ>ũ/^Wrf5d&/'ncFhD@mFp, ex]V3} ۞W;q*x7(d D|Μx۪ `/_bNW 6ӔH!CYJg&[]X0cuM_Gq/Ŏ{\+ x)%Lb< ͚{$N̝tnٳU])ٿ:PNdfUp{%lb_9rwNJ .~ lsE7bʝ/Y zW-s"z>.xhbGdD+n^ȡXR6QUθ/l_Q41KA4Ų޿gOe&, >+!Gl^"Ph@%lWn~1fQna2xQONCDˋ oL]i \gH;N<bRٔD7*< xn޴U-~ٽwqw1?4>YΚ7mu"d/GX]b%֯.ދ>vFuyrXW]C~O_4+$E;2[KB4i~%h "HV_qXF1O3ػ^P% gvrґ"=4 d&w%r0/Y&8pSɭsO?[gu?}}ˆeMѲB.ؿ?= ? RddWDwEBYб C1!@XD^mf_{.S>~)I'@{DrIߐh8t\-P߳>wf[M[0Km~`r[yNYU3hClMZ DLr#rw޷J CEI+|[nVP\(L!|_xL x]OMჾ2G w"Z0%)|/Qt/;n3X%{X|eȱ"<.~b (),cbdK-(2C(/F̀;ĠJ粶4A[fEIq*cK~Gw퇂!9'"ཋ|ܬO&AwaZcF&p5<وH>uƧP֖X.eʪR#P9M!q#frTݡC:M eUubTVx5: y=i<"*p%5!9oEK6%+1+ű)!nCEobd7h%IG 3JִCˎVQ8Ca[A,]?A*pSuc,k~̇)'lr#bB)Ŕ1\f׃s0Fn&[n^ݞd.mwǠWg/b}";Qk,aT^a5 Ap"0d:%Фv5s ~׷m<ˍdQgig(Y9ySkcNq\Niزw}G)IO6JKF{}nyCr9FnUcADI k˽Z.|%>W Xaz yK=2Û_w Ӈ, %E?ǢI:ۏkhs"]o47B6}#DTk>0[Bf9)&T;k FpDӣ'DlPίr2=Hr8"5]FJY#*DF8":[ SĦ ̖qWdgĒӤPa AF*N~|ㇼi6\!!iGpQ Cd5Fk$brCP_o:Ofdlu"s JMnrEqQvM %eG0{,}'ib|J,S*[,迶<坳%$mϝ/y|a!C "t~pdSyB68'-\mKu}:Yzh!V8lG0YEmR,ʇ0wd6v%|bFP}eV8pť<Kiib5?(&In>"^;LhY*'5 뼬vQ %ԮSbi")eH"k'[e@p>z9x FQ 04YbHIf OnGKjV_ `#N.`!H\N_ɋT᧫9;Nr5֑&L2wmI =\ ZjOc[}J?3~CWB8$VD|P')@2@MDŽ/fAMf*o_A-hIz< A.TDq[yq&B88#3'|IJN4x/o* 9;^-؄Se7kXeO=m7 [J8;oٴj-_ix)+fyO5.@yTbZp,]@jc`Ix92|f<1vN2h).6#3|xBhֺY6r\=\y''dzǏ1A#Ί@ZF3ZQ}0 ;3g/FeiEbk9D'{>\naDXV;W+#ތ:JZW%M<3,jhʹA@!QA:Ssʊ ߔu02ۉe,13s`xKmҁ~p~RP [P~{_`h\M.oHjxcIt; QafsH<|tVBMp2&;Y8P K"J?x=47NhdY;"<4#-gAJJb#y\&k.,&$i_u"~ 'ߋ4x'~ω~[Ez:3\t{$QASe8JxBu6xhŕ/coVp<ht^?fGI@'Q,꽘ל.i[DyRB*{0+k4]i,RX\| l)DX󨫠R9y@j ~N/sӲU>S^} q( IN.,k엱-Uvd&^Ԟ4t<*Z_oI-3wAՃ$ʱ&T%%-39ѯ+?t۞!׌]|u2w^cڠ>x@"`-nw짡'Z }fD t| N73*#%63fBa[;:x&G2[Uf]d6]J/VO"Vi.fV8+\w80 K5y=jO8Licg, aV8'D5ĕlQh. 樝U_◥6Y!_sF}]$jbJ\;{Qwhfh h8qVɄ{k}md%/ sy+^ صfi{V"Cpm &=Cw%> Ӊx-I`hWz̬~{9Jda~KF7uK8> stream xڍP-̟ -0{n`'( lEa,ptpA\;,A!+0wNZ[W_&"d @6kz:P?wzn =zC@gWP` 9 A'd'~>|g=6'gzY:B=1|YeTeopE W\ V?} v Rv|&-@ \@/gGQo߂]PpXЗKR -aIjmw>& [ms>2kn<o픧{ʋZ{+QW8:]ŭv_6mP2Mo5 3 F_S8cO L1E?co{-dvQ_Lzz:}1fKﵥ~wfLK3OOD '*PBę}$!wb}~RRGͭEǯe SOpbnYX,/54aJt[u[֤Z> w`;rZ:æ44 VJ1D&sBHC>3AmĨv!j:oLI"=Y؛&QW2k+8akᱏ:_G?2Yʬ5ıЕqsTcH{KZ}~J?yDfެܽm#y֪=DЇ ȡ1AbY'3CH1겓$dCН-pn,V=LoCW^SYw,QIJ CM?TlTLz]{6^]drA ~JJ?uP-g݈e6u Fx>%S*3lSFtyJ^#Y:I1 iA.V@KY"N*Ww!qZ/.ڜR{1e#TI D3c ͦ2SKW\,{U݅Kcz;c[|\n(ˌœED(V}/ElCdže-DYِωe^fЋ /L+G8)Y=W vZH#c-/nʄܓH!5:< iz6̑CJOָ*,x!^ |@UJf<ǘ!*c'+q<\Óhj.PZM&7 jxn<97uvUfLl2!v3ԝO.c{&d#~>1ܽ9iiqJIx|9vmU)e<IMi m\+fgH2.E~4r$ R@7@č'~@'1fWb5ZOT MǔFK]ÚQͲy~e=Ikҵ{=]b&OON"zv&qL sį:bz%3;?[_.,52H]gZE,JN-\pE)GyZf~S%nhPAM5=[6/[=}XB?,wTL?j.LR9L5+?`qs1tKUSr@AbK#eRzhzSa/Sg:h[HR<*FZ 阝vVouSF8"3;1s&q!&^2:IK"A.-1Qu475L1 X5<8¶Es3 2p;wk:׫/[1kd1Aōa>}Xݥfj&5prW*?gWX±Ձ}zWPb3&/6Y.l\;HL'YwvyM=XY.3\;X)ݪG2C>$U $Q5E[MJ*vS͹,q'UP1j4mn:HL`oF$2^27+Ţ|o_PӎJTqp0m̊'FG&ƀN\<%4 r]3{]iXuOՄs쳯^~S匰Ŋvw?PJ.'/x@b* ]LzdN薺T}nQ].7Cʄ ~Tt;?&<4d"[4aOZ:z['nI=3bkL舔Xj`{#*;NI~X#6$_/`S.á߬m8:9m&s" ``'(+J6+Lږc+%ugˑ]@Fn@ K bʯ p#g6Px_U_WgJFglrXD*'\:*,;R|p>qdzʆLv3xܥ/,#[8S-&a^5q@ȺU$_)}\#:1G}Zȑ#^p%x髜{1#+9YYDIO8Q+a^J}A,Rřpࠏj=q`-R=6 L%ҢFޒִ  -9\:V$֍엌ҾT"$۱HRzٞ$O|!FP8cylHW?B?027,"|g}G投3ZZ;H3@+B g  )_ETBp/%;Vs[eꍭN@+JWm׶K'D|Ή1`\u7ZZ*|K-#_ c`PX~FF׺wt+ze®{F%K]*؄/ϭ.k~i$ae-n蓐o %.A?ڞFg6H.:fښ %h8+D$=.3࿔bxg92D'U.,Aںd{kj(L>G .#ψuK\ b_<3JCZ91Yu(ؿ&lwǎlIwb(L5 0kX&ݕg{!I Y0LD#2 4Tn)[Cg G)cZQ?)4h?G*1 >s]VӿQ mBmѱOQ l8);\ 6et`4m,*k+}e7 kC]x)/aBHsӘ^'m4-4iFf$^.5İ,^zDai֎NB{4ʻ%jy,ԧ$jZEӨt;95GOr0t+™>KrP`,u2:<2ᯐ,%xJ Vl͐]GaAN^h0TbDm1Ps,u| ˣ͠s^bDCY:FWf1J!勥СR@*RZТ8./'[Q ]d&ܳJD{y;Ènc|s53Nܕ93\jfF٬{ uZkWĨSy_8W(: 5}i49Ӄ<=u +Sz~efy}jPc% ~"GqDy'SڧIB$g<7e?3}|ff]V,ʝ4Ϟ |rgp0EbݯG/" G3DKs> f38aVE8Y=ɠTFSs(W&E̱:T6)#$mR3d< {E%pϹ j~a4I27aF^f/ A)a?z¦'t4YH;S)t<wYURs )N)io cqshܩGVWhur^XaVWAtF. )+.%5Nbt_ q6x}YB6/Tr"r?!o$-l rئ 'rc22@/cfFP};Qqbp\`t^uWl4ᦷ`dP1vAQg>wbHRRUI~pߝ9gH!*lǪyuJr,5C+&֏U56!sҙ=Ci!~-`:^cҘbqi+ʫWz 3-C6<0P+qש~p]] Yd`2|+K(rwN)Rl֑;蚬+16nenY.BI /({>c ֲ頔ϞlɁ WҳDSuUA~.D:;"NόZ35B\1"a1d5x.}bO#oc>kEwYDG4H9 F*Ch0ƺ 6^<ߑQj Oz {^S`'])9iCІ4׳JW(Zt_V/$Y_{סzlxQ~/aM\]J軓/I$nciEud$ͫ!+MAK4Y [Q6&-}3 Z@Ds>jEs#|9$S WKO1]^%s$5eFo( Fb] ubmJp.UR!g2ju%V%8iDΆMrTx8z>xC82.tÜw- 'nluz;`fе^s)'W#Vӷ'a*19@sq>a]db`/"/[O?st &Zڱa{ MUxS&9鿏[e 7 X’+٤NoYZ@p`a+':6qQ'I?=!=!=\;f3| NgG_'&_se_!uU?%O8s[LӄδDRz3z}a~'Ct5({영}OYX=g:iy?-;nyP2;i%m,έľA?5Cleϊv׻?pА] <{Aq'}JMct<[GxJdx*Wk3W8.ˀ+*dr!#" 0l B!㛖yu@0vw_EЀr|/jSlfHi-h~D"dZt2r=77a4G =:XVs=R̈75?|}OFjQ^faed@̀K(:~l7 D\R:ʤc"? ۙo8l[l)4Iǣe$Q|RtYw7O˨g#&6 yzV#T4^@L6s~2m=PL!TDQ)>ҁR2'o@hV}7J~)MWv\a}ƯzMV,B5h7Hd2K4:զOs[${րMj]MYOH#sFLϧw ;n&mKʸ~XA< [ZG97_#?L-.J{WȴVk^1ܸY/5.*Ze{0,z|smRb-"BLOJVt[m2֥K#Nh.8 EHNz=W$ƻOF`gs7Tp]HWlJ-/Fi+ ذlܶ$[8Z\#}Unnj:-ha:  ihmSI8jLQyWaPRn;@L/{? fd-eU!9y* ʏHeTq*6+QkSSjtgS/aqse2ɠ0KGw-l~"N'U'rvJ8Jp[+ z/ BhTBPy+4[C6zgK7%b&Ր.#K5|7._Ӻ}ʗ#<,}} ;][%i h57X}˛$K+EG7#<^NU(Ib>ʘ}K2Ba>7G{}uWX fl, k}PۧIѷ`pwidcgl<N 2NK@KA.4!&iYnb䔡^[P$L "Ob=oQ<رP#30 Z}u4!®ۼr6$,q]Kzʍ9I &Ѹf]yr<6O_BqЇ졢#d#QZ dtȥ#?L¹ocWC<ˇP~D4ơ~ke5rաQ&H DGaΆԵk4 RVw<H(r0>#b}80:5mTy lU!3o{ec$3~6['aI^ Ú2|#|jRi-r]S獝l*jyxכ; hK 8[Jԑq-֎QmZGb% s̏^Ȯ4_`Ad:BV̬ipGaX5pquo~E;^Ba:8ӿEUrbK\_-նE.̱4xڗ"f݀kE-Ȣ~,sDoTN{0%4*6;tzᒂ]o@"g3JtzcZ^YNMziRϥcqcw Y<rA.F}a/h |2unSPv}Ztȳ *Ro՚ﺵZ$l@eZa`gNS+q'_;-AjŊB ?7m)tp; >K9v%w)1oQǙ4nUEn4Il&Ir,hn+afix&pWݤTM4:}K6P@)hEmnbV +*RcB9:\r&C2U[{ ZBp,_Ń*$cЏ5!*؋t Br`2f @<x}pCd' {Et,3Kg#m/NIy^WFj0kq(ۨǏZA&jng|!RPO6[p;BiA/J[u3f'SCɧ9aoh_N(]ߤY_SOXt2Oؾ(um5VWB Sz;8AB6> stream xڍP\-C`Kp ݡFq <{\[sν7_^{L[c5檦PQg!`fv6~;FbnjBtrAH8M]^l./qJ0@ ``cW ĉ i(!`3  de̿> v>>b@')db Y1]<?+;3 J rNn@ ʦ;cAhXC,]Mv~p[/࿃`7v'w!dSss)X쀀wҊ,..LS@S;gK)%/i1UKlrpqfqnw][H@`g$AN@mddmw?݄& 'ń :֬kx:r6tqX4Y_^(^Φn@+O#vv`QS =v_/򲀀<먫˫!/fNN37**X'Ul MeEg6]K"Z ?7`f3aV_)]%$jg/mj'E./WLCϬj^9ӗ9[{A  om=dv 0P }2Y/7"r_翗C,~O[' ۋ8^/hKV0%ҞDX%~B|/?j`57͕`9V@. _H_X_h_h@V? ? ? ?BpsW'+篑x97 h81|[+Fμ3.4MzPt-<ҋ%E%Du1-QqN;7Rdf ]GGo[O]4*2 ߿ּU@}(bь6(3˚%Dpa&Eb9əx&sY䥷nJs75!)IZ/^QX,Y( F;}^6 =둴Ўҟ%vCteP6zNZCiׄVQ,LGY4FFʍ#_,!:~W#WmZ^-+kFMk\aMrп$fKΝrj칥MV?ʑ<<@k*I53=iwF1i4̒ !|ѰD ~{MoqO"%*P>PLҭx&t|I2Q^?dzue"GԀE|GƗVu53Z P98ODG /3$]7D},Jy),<·3+ڊef8f(zpCG2Jق;tL*_'J$,*2ߙ0kVr k(Y /i˞=NCoc/ 5+r_,EU=jHwN\߽ŞwvH%yȧe.M7z`C#b26B|5Ù4+k#J"j;į,ШNj7ŔfXxS @R p(?@6fea8vh ą"lq&$*-g.!HhfgXr:(I#aLH?b1HȲKFEР3k9b8ħ6i<?+#q}_P4Ҟ\^ѻ:Bq=3n=iqSړϜ:xdžtXrkxRBj݅fT/A)\rOTayXi?-|ypP;,#~#eߐc`v&¨dFZjR̷ыe٠m[nاw uR, rl^C23!I{Mu7c!jDT+] kaW]J׋ޚiQcG=S*ٵNd6x'XuhP guCsUh 27t35J ;f:pUjk]΀6N| FnF=S#ec,:WssW"X 8k19OVpi3]R~uQlOfƃm1l`Ȁ:ü>'b+ 𻖑rPq0y-BtIW_;l+\:B+;HVsx;[ ` סԺ69^tQ}V Tjȴ@1Wᬡ`-WGfbh+Xƅ[*6Ju'q!5ŌI լjE&Ըxl~!0EPv {\&z;Yr2jW)kVl|XJy&$PȠ_`%d8uq79S7?NU{ƓȀbP59SeQ>ZMk˜['p"=ri<X+W_Wl-u`B)Fhh &/8(A$i.-Ϛo6v vx4`o49KoܢYuR"Cɹ&05`f(d`YXrp؄Ë.iE-{e9`-n{{Eq_%'R;)B(PzެWfSe -Yod?^N08 j䗍ysbk=|l~+[+KwDk Ip&=́ _l?M} S e֘u_^)B !}TJwsFE]eW0>v8q}Vw"ܦn8G/lT:|onmSQ;<(ؠ<冴1Zc0gng:79>.mؾ*r՞eH@1I+طr|[bHY6 =M~J& IRN@(odX]9G,rbLzQYdh\Y ]C`͘Nx3ȊQ8U8 !4նJQT%nіpơši2m$#l@nRakU" ?~\d< S[wG =g@\_)4/ɕ0Cщ/~d|tq~pQ+x;r7 }Ocb$Gmp2MȀzWek8I%aIpUHb)(j}:bC%ەڮ~/a O yecQwDd@eRɟҜ2ǓraUQ>PV]guyUIdjl Ӳ}-Bj7jt cs7&1_j.yѐ`q.ᙦwڥxU֑TZwxjUc:6'mI<gܦvH) ]v룚ė!'[̜{7?Loo kKkk=@ 6mxnJth _pAWVgu{CnʨG')ŝp{z%볼~n; ,y6Rߔ{.37DKG5N\yUڻ]PWjl'AGڭ$l D<`Fo b$ $[ RmZRįN[[Ao>֫{'m 7]+WP"gS@w坲Ӥxg9\<$(Q=ª:'iצfRM.?酼W+G 4ln E1`)sPJa"ϓ̎O< XRȊ9OtI_wwq}Jtͻq$[[zErz4Pڎ?[FOT}F]]RM.^;_+)jv-(RN?E{Ғ M7Xb%SaB/ճpK7AeśJQnXK既ec86j'3$ִ#JP_Ug13N`iQO>: >nk<S]>[9mBY:F4Wu֫!:1ǚiѥXe;[RrKCֵƅT7Ws^_Ŷ1F )ލ"]gi@^DNK[l6;BV^J!Mד08e+tD=f c̛t XI '8ۯs?}.gCxEuSSvu*%[=R~9l-B =g: Y}/3ɏ(vt9 qs,t4Z]f42*gK]%LWso!JG|&ֱ?pgG4"PA@X&qb.BTxN;yIwP!gMٽsO܅ wcly.$)U Դr\7K: ҃1rI׋MTo>Ϊkll-TuCo,f"2z򱚺5Gom] {:E#FX'Jh?m9!W/=\&iU3R/'z I%J?W?ޑBnNmW6?W!tN̳ 3b.̓ 1^x%h[5ӗ9+.qI1HZB2\ǎUk^<,؁FT_2X)} `;C+"BI.Mu`?9-`l)adGȽLWשRsy31gWeE`;>O|oU*_rn$' L >Nj-n)I0L"Zl&{]@zQg۳[o@Tn94HinPbѲ19HVWwp`"N!;D>{҄"*G*!aJSGa0CBYEr CyͰ$)Kwr;UR;SHnkgL}~2H.4@m~)2o8)Bv,UZ8m;%j]GDϏM4'e(*xϖ%N~;[ڀz%#5C[ed ڠ 6J2zIyJ]4k~5˕z1d\KH* ƴ}p, ǞO Ri 6xGUж P 2 x]0՜{Awx^ 8^lUQQ,Qm9w )ƒ\pc $ Y8'em]֙ ܻ)ڔv}Ñ.UvNP}2 fB>,iLZt}–ՂQRGMQUϻp[1%aа+ok! oDH{=f 50\fKAVP-UYLhX%F=~ ~b&ǼIu|[BM07C;bJVKGi[2ҬZ^G(-ȞBuƙ#Tl巤8ǿzl ,V Er9_ 1!/qb~d626cτgY;L-.wAzY"vbD jSȌǚgսp9j(+(.QF#"Smcd%_ `k7&l.ny&OEY~M:QT9;[{0E"}i(rȳP U3o R<.ښS|>k\>O\#󑢝qGT˵ 8S;|l{* HJl>ʩXarf̙" gJPY"ǐO釓88&jw]S)׮lLR kkc<܃E 4]])>1iI+NJ@'D֟cUX(ޭ3#P˔;pwQ]n!m:9Q6_&kV8fy 5лr{HnM3r'hvׯ1VCǗOhq~KGLhzT-J*T?:mXDr5-:}c*+]VcNP?|.z~YGaj%1Q֏ W8۰Fjfs{(0:BYm\sZo/xз{7R8i G5Zz%ގtDeV[P<ũZݍO R>!rDcJV=$͵v7?UR-d[ >.*PoYGu +buMurUvGp,Ox֓9fVOihO;޲x qzȰ ωgeKy-\tJ^DP҆9^A8}_|}L;v꼳?0gN7 cQ,_" ,ՃkA:` p|Vk$]d\(cE˙OQ oI*+dd|V_ƊsDGH@yk[1H7|%k#6r endstream endobj 25 0 obj << /Length1 2181 /Length2 14242 /Length3 0 /Length 15568 /Filter /FlateDecode >> stream xڍPbu%xBkKd{aV{TYA(`f`ad)0Y((ԭ(4 g+{YW1P b `app23XycZ@g 1G%5Mi,<<\D +Sc{1h`j{Oj~K0͍ؑΙd!HCp[T@+ e(V+n U`ke w~uq7j2%G!pxdePgf m^]lM^ * )0~MAV`gFg+=2J>q+w?wf.LVN.@l^Ed@0tM-~'Ppd-~`\>^V/B`aY&@ +{?_@z̯`of`o'fRV*EE^ V66Q_2}e?3 c):-@g?0s0~\(c+tKO׹u&_S-ߋ4rZ.[H+gI+w[{lV/ ^z8_*oF {SK 0=_'f@h~uv0w!~RNo_ $qYL;I0iA&".gljeej2u 5@Ʀ6{m#g="gO9)g2|M'+L[:\^y1ZbV;xXghzl}Y '+kٶzx}y?_GZk0 !RJf;G[U^h9^qY::6@QJ O!׆ l -^9nW?_v3@S9S`-Dv)vhA.(p4ik.m +%'ЦXGf c^"xBu=''oFvY,'n[)ޒ呐]JN9ǒ)OQ g(Mgߑb\]Ocd!|b`|7Z܁G cdK Awޫ j]`>b}{WO^#5B\ݍfHeTRCA@(ML5NkosJJ琞<JS,=HĨm#!ls=i|5gh4)kiXv~m[B4],ΞNE"ֈ 2#h싣x7p~a:Sem7h4kJ~/';D5KɃl_$|epBqԹDVQ">~ Ѯ6kϺWGJbޥ%qLKfv8Q;)t, NkwBJn:kxbjp(a)7&MWrDI3"?Y_Q9@#p4b?qaJ1kh3f]Yei?[ά:)_q0i 'Æՙ &5V&$n4ā%Ws'sqYsK %0ǧ_v8>DAѲXvd3de6 n}ly4BxH^ϸ|3 R=Pi#LO޺uuv ҧۑ6LдN？Gv粋W"cw. -N(.Hg>S_.' Y:|o$Eg?5Ŝbu&d"/P)ATL 6LxXMSҜ\jCΈ@!S۷ΣU|1J'DN7EWi~-֢ڣx*Ac}QѱA I.ڧD+ Kuh^ٸ/6!>i`D QC_>Mk|O(G*5L%&Hϫp&Ū"!sC|G$eR@"E B_[) T+E!޸EC\*#ے0Uk$dH;J=s%isEFtcGGqo+ʑ{}NJ0s#F}dO;j%_H^P9Om$3d[~uJy5M LduG1{vz7fn DI܌TŦK ;ϒS(S`ަ!VBG4s2 FQws)GF7-66r^pkR~Um?F/b? Af5F3N%mb=+FBk3Czsc<hXZmqq?W!Tw]Dz]TyW/.|j%jՆGc+? =D9$;쯬:X{ш x$MG6 pm"9>68,5_4}&)kz;,V &zc.=qEMEpZ;P3%8 0nIx/~mpmpωR0땧Ka ^x+ӾU#2%cE#/zPm2ڑٛ_vu>u_M}sx?!)Sn~jma!ksGi!cT"ES{/A2ACOw%/-Nƫ쁵2t< ^oi+@ˣ^4A%`QWFN D/9ऊA*z5>rH-t5dGD3f&ΞTZ"5%ɂ 8\d/cð!t6q0'ƽP[nf_|O=9Ӫ˛\V_Hj Q6uE?~0  Q%=zL~ʒ,)XMɺ=b}iN ?;\0ISrsDBGb8椃 콬< B̀&YoIJ' ᏶FsLPMk%"1:rjfaypW+}GL[M#6.{;~qOّsgh>TqwJ2\xL^_ `<=@ܑ [GH1d'.n;njҋ2 <MjMmM@, 0gWuuzlL#5DO0eBlPJ$rwV'?*iܤ'.,ЧmX7u>9RɣOm"\i_I !o^sI|Q:ē`T7EmMA7d̩9˂!`W=$&>Q{t\"Y[K.hBZ~Px/tL;wo(I+28r7ΕL8p~˚GQÛ>O b#vMf;+-쩸J+Hq%fB?BC҆~l ˮȲLէTǬScg-Yn&8Sw!Ձ F3b:2przwam7"I?TGHmo!wc oǔ¾*؎D_{~`VG%]RB.9.Y&N yiN;+wgVZɁU uԔ7W7Pzq.]֎&zNOY(?O.WVZx5^x~;LTSv;]6`2X.bwNVTG- v G=[8i,,0,t;u"y\ǒJ#2^tc4h[VLi2pqڼ-ɾ)B `h1[ao!;BwlvL~*]m \P+4o b:Y\$ }>NNQ-?I4j.椔㙳})uGz) z_.2ꩩtW>5Zй(>KvG%d^EU{x l1jN#Л7GP, aGR[KE0:׏<.V{Σ;nuXo&"ASd77ټEb<%7uدd7 3i|_( Mѕ/z3UB%9r2vf+d8>AiCQ}08"B/{mcM{| Dc@f2~/E+TM{MLq$E $}ˈQAו7k?R^6IEZ?B2 A9\κ" 2\*d8H@mC33!omI5~`,!#f9,8P+CRsFQqXf6۸ڒ{[ݜ0;9"CLUª]=/S{΁aFE#b&RMJcslb.QlfH]1_9qWSd15=()!~Roqk 2 8q2g,f0dy(e?Z|^3mE+*^Բ7 QWqI6Q,wM72PuqX!,ʬ2 ]?y\= D*KڶԇƬN\02Sd2r-D:de.S3o{C8gZ"# pUNud E+7- g.1H/ i{n짚(%{8ȥOj;4Z]}D$~^Ju_v? 3nYjNb nuaEsG^e"BkBY0ttɏbXwqFvH7Uc}O?~8oX9 uuE'F, ['w/+eo*3dyMK Y򲉉}SBr%h 5:n ^a9G~%]>rcG"ru#:NJR~TדuϹ_ <# صwdi&$rÉlV»mf +?<ѯZDb}JGjՇѸMcsMjUc7 >\ogp:Siqd*XCD"u{w*@J1Ro08IZsx9MşoSw!#Cc|&?rP31wMm̻#  Bk 4xڃM[PC).%8/Ju817PB~t/83_/cZk,jZ:97i aϓPy}2S&nxNEKn!~U"ƷKMF*!*ibkt!vJa³$;7 f$*xuHcMBpOnWk9/ó}B Wyt'-@:5;xJֵHv=\MЮ2U]Y9K8q . nh G JD -, "F[96iXƛd!L&3n|=pkiI*䪮g#YGpi`"b[CTX2bB'5iNzCn,}){MJ }%$/$rߍpE=c({f:umYӂT_4]yo8Ee,sRG+Ej'$yz\KPBm9‡N1Pxr|hF,Xey櫓RX~T1rJx1Uѩx+,~~ sύeo i$Z 0[u a. EiCTڅTV DXtj;qd?nm8<[ŐhW_)jl8}CGLzju<MiSIQ7yf+'"7|Ͱlu1*->ǘpQ''g:DkՍ]i\YSl;1HpgĺbRۆ(L?o]>|($l^܌&2_kE@@+wNS .F?݊`-_BaeDv\xo؄>fEF7_$ /!UΔ!iCi8 ަȒ%>(.+{xqǥDɸtzDi!:pOfeGA-cfE-}[o-+ 5$N3?^(K|"eObCig0:0y!LT!duj$>XAr @f8H@yZ{Q{%{LSl#6P=ycWHfB !߃ Ӂde}/Kbf-?'ԏtOSL_wQ>6htTjן4 s\ti2k.N/q5hdu~%PE;eРO?/wJRķ/ ,u"Ma O"CHЋ!dC6dDvX~(FjDkZR /Ux9OGspzNm~dYٖ%(0YZv q9Kʾ44CXwf@ OGS7T\[8P۰ l5uBܻ3u_z⣺C..3J5y3"q$hLR MfдcW~1IF9CZmcoL[@7 VKPe`LUSq *ħ譃|H-kN3p_H;AN[#:F:-1&CJK1qgq̨nKB 8 Z)bl1e1̗AщW,$!4q'CAaɈwA-zGIҳ%_FgSީgף}X\Hu.*T܍ [`myn_\)8@vsb;J"겿OI|ډ)>yU!0?0bF&<;O ue݅Ƹwn%82woT1ݩGp{M=wOI-BcGY<QaW.G#xEk+}D~ M t2rHyMbN^ g2΋*vvEҘf2^*QxL,:QyW I{m.)gp*,Θà79Ŷ~}pGYE4E^2mQi}^3V6(ͧG~.͓X: Mgx >gaX,b+4⇋h6k-ޣruluZׂkYnӡy;m-P:v^j> g@Oz2=*Hq=Oش2ӵV㪗h,xԘ4O{-q)p&h#5n$A:T :Tʠ[UK݌k6gj+9w6ěN c;]i،y} ?ѯlkC9Ozl~\S1ux*>D4'Z>[DM[V2S2!m[*҇SC;-ѱ %<hw_'@DҩN?ͦ0`)8՚Ttn>bW;E*u^M?;eylMd 2TpfLH QHsCg&߅}3+v<-Z7Q~$,=y(Ġ+w>D[#(fu1[A,F[6,u󮛻o><}HXP(0Dor!JM.B٣4l9wkAa@G0R,mh}xosɒ?;#REKP[hLIcZۢ TQt]b{)aICw&ǏtLpEczA)Km5VaSڔ-Mp~ y2`ZgӢÙ~E]d*KLuf%:u߱DNM#n{MҰ/V45hDvvӕmU&F[~PvzY,R~et<#'Wq\jlgI˺SRdt{8`Ɣ>w'G[UT: =vgKF!o{, Hn}@ %VƆgӤA捅_U<] - N8!}vkUؠ G($}LՅv\d1K]|?lF9ET}֣[]R W: yL 5*UllSL&hHqu L^VnGގ\gڱ} nRģ9wsUv>I񢲜xl .Մ:[6WNԦp;ӪM8m̧RpT7)k]et_욹\agZ2SXiI =BZkcd@@?jZH#)lJפBme[QҊZS, +@k-QWfXU =)\dĜ'mu'hhT7UƆk͋´HӋ?@w?~ք{n%+|2YC$,D ՘gm/8GJjrPb#]ѴqorCLgEOӧOVҫ6?=v E1i-*-)o(Wb >B&~b75U.3JrGI.˴X⍞dԝl0W[d\odtK-bL3 PGz{{hg Y('\6:?Rvz,|la>tu =oj="Τ_o!N47eu[|otSYqoe̎wݑ${ !tH43RyJ')8%=mʡ,*2Ce-dmv|SI䲝'SiҴnǡjW!= B+rFQb?)u;$1){C֗N?~9Ī`NiK0WDֆ8esEkK3=A <@hdpʗS i38/4*pwL\^sв Cg 3NTS"cZ9fFF,ٶֈCoN7?y}lƤnq>`ޢ/Z Uj%\t:ۇ#bwV!cJY)I, ۳k &U,KN1t{![pb,QR*?ƀd;U wכzҒCQt *YU$ L{rm嫎+h܊T ρ-f x7ȧkv o(dOHge8ɯEHjwm+)M8cpTҽ\@ˮywY`\ms>#+93ԶeKQeG:t+k|r_-4H `슈xc4r OL#xtبC;8XuDW{@`KFAQ| XkVN3VqΕ ͬϛ\'pVMJJ%煡#W(U8q?#6ye?760)OԀ?ީ{ VR8ͅDDjʈH~X Ҹ!X?I ~LF)8঍ÿ <"fcW~#=q|/W& :ԷqrQX q0 bSVna'GtY}'h| (b o]:}KZQ=eͱ~~LW_ݣ~rw5@TI<֔\yM &%~c_5(eiPEepm͈G5GnIib q߯RʞsJi]^_]Qsb;*|s&vN 6%̎9phRi*QIwC5T £-wUE_JIkfr~♊Mo}:M ƣW{h čE:ΪLn toMzWϽ9~C%3sy>R!mvy/"TY9\rZԒϫi$;PRpT>?]dHr ݎfPF&/W.fcAtO8OA&|гWG-G`a6{ *> iwaam*g ߎǯ ʱRZL)9jl-Z}`+fΏ/ @}?H,>;#,UZ낵QB复/..$v3Ć٬~5̕کytOpJERqU')_o"bWkx u׍РBV]1S{l:3 Rse(IͿ<4^\95Bs-Bhq ZV$9PϪSE NA̚Gi.;8 ڌ.^٥c_])/r\4{rBgHC.°k-2bl1u5- ? [k}kcdEl ks&ٜ#эR(G8QHxá{vVo ȏ@XkNJ.! p2ϫM} P4Ր[E^uvُbDY9]$#:V@1Y)*E'㞳m7uS<յ e`Rm5V㪱tT z!Њ}(eC!u 9|1@WW+ :5|6֠_Cujo .4W>ʅ< PE7ZʏJ7ieZɼ3EQ)x"Ҧm5)"l|/N=Zɳwg}=yS.̈Y]ZM+= Qe$O'm v6=\ C,'pY?ilS8Ճ>Y l>;t;n#⯡rNa}.vy 0n˛ߩ`?/Kk,đ2h 7u]Sc`B&YGL3Zz`͞NttMb \B_\/>vΎU u[nƮv/4wgkIӎ_a@XA򷪙8<<Ʒ?bSJ/ݕ 'dIt$ؖF] ALIBT>G;\j:$9YKy6>f'%G=HV/Eً1N{?*P0\ƒ߿(j7ONLкvgqˮQWWc@Jek^h*0"Ś|R}4 w#ؼ۬sP-XA&T 1=)YtDbS| A?8 6sUa )bK07Op|?ZSZ3h `6w] ~N7R]6\Ȁq[ٷ6̂a<7갓V{WLb}ima u@z'em^bN}[b;b+Ě~39ߚ{$;ԡd U`A$'Q̪|R۫9Dxk894m juU}kwOB%GJivK"35}HP@;#3 e̸DzqleJ":6k42ښ48*CҧS6ad}%Jx[YUl56/8PmZrUxpE-gQBdkFp35"0{!">7<rR:dW9]` E;U> 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 30 0 obj << /Producer (pdfTeX-1.40.20) /Creator (TeX) /CreationDate (D:20210309084101+01'00') /ModDate (D:20210309084101+01'00') /Trapped /False /PTEX.Fullbanner (This is pdfTeX, Version 3.14159265-2.6-1.40.20 (TeX Live 2019/Debian) kpathsea version 6.3.1) >> endobj 9 0 obj << /Type /ObjStm /N 21 /First 152 /Length 1406 /Filter /FlateDecode >> stream xXYs6~ׯc;7x28Vs8Gmq-ITHq PH[m5iZ,{| N pΉH% 821c@"4 2k0D2XТ4Ɉ4:#,'1M,QL8ZΈ()`@Ͼ.=rES  良U55xu?-p2'.}?G:W 3-iٖD#)-8$hr|r>zr6ơ?BϿ\Z r(QdzUhi(*΄B=8wLCײE2H4R)i-cP%=خG"jU2fѧ(eXf0 r!':v兽vipGկ#y=FB' NNVG ݕqE/&$YD:PQ:%+0$.Ӯ ד5a*=|ehcdResaTH1@ 7H@Jj80v;Յ]r/lu , 6QJfܥ3TF6pn:m#aF*FzGW(ߍ`Ә Aca!#RIP(2>;l [)#϶[b3`!Ji5ZR2pN9QbX)-2ȴ{#?.e"/ao3HÈF:] ]&;^|=eSVZ~aч?> |RKbsx@3 1`0,kB=t秧/O:td$?hú 1e[_:}}sD{vq ZYKhHgh9DMB8{z(E5^#k\UoBt C,*ymu41hE|6-5~El߂vݔ*콒$݇GG$XI3Z?I .NL1UeOڇ7A_uÛڨ qu3yo۽cg[m rbۭm!ӳMֱ-3nn3n]Ն5hU\"dkޟ99ĝ;S endstream endobj 31 0 obj << /Type /XRef /Index [0 32] /Size 32 /W [1 2 1] /Root 29 0 R /Info 30 0 R /ID [<8FEB5B6BC0CE6DA1B4EB5066D600950B> <8FEB5B6BC0CE6DA1B4EB5066D600950B>] /Length 93 /Filter /FlateDecode >> stream xȹ@]}BRB(E%hH g_?>1D FJ)=ߊ+ö'Jİ?Z.5>X35>#~AV endstream endobj startxref 61509 %%EOF pbkrtest/inst/doc/coercion.R0000644000176200001440000000350014021623215015550 0ustar liggesusers### R code from vignette source 'coercion.Rnw' ################################################### ### code chunk number 1: coercion.Rnw:19-22 ################################################### require( pbkrtest ) prettyVersion <- packageDescription("pbkrtest")$Version prettyDate <- format(Sys.Date()) ################################################### ### code chunk number 2: coercion.Rnw:64-66 ################################################### options(prompt = "R> ", continue = "+ ", width = 80, useFancyQuotes=FALSE) dir.create("figures") ################################################### ### code chunk number 3: coercion.Rnw:71-72 ################################################### library(pbkrtest) ################################################### ### code chunk number 4: coercion.Rnw:79-82 ################################################### mod0 <- lm(dist ~ 1, data=cars); coef(mod0) mod1 <- update(mod0, .~. + speed); coef(mod1) mod2 <- update(mod1, .~. + I(speed^2)); coef(mod2) ################################################### ### code chunk number 5: coercion.Rnw:88-91 ################################################### L21 <- model2remat(mod2, mod1); L21 L20 <- model2remat(mod2, mod0); L20 L10 <- model2remat(mod1, mod0); L10 ################################################### ### code chunk number 6: coercion.Rnw:97-100 ################################################### new1 <- remat2model(mod2, L21); coef(new1) new0a <- remat2model(mod2, L20); coef(new0a) new0b <- remat2model(mod1, L10); coef(new0b) ################################################### ### code chunk number 7: coercion.Rnw:107-111 ################################################### eps <- 1e-8 max(abs(fitted(new1) - fitted(mod1))) < eps max(abs(fitted(new0a) - fitted(mod0))) < eps max(abs(fitted(new0b) - fitted(mod0))) < eps pbkrtest/inst/doc/pbkrtest.Rnw0000755000176200001440000001203413712550526016171 0ustar liggesusers%\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, cl=2) ) @ %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, cl=2) ) @ %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/coercion.Rnw0000644000176200001440000000520113712550526016127 0ustar liggesusers%\VignetteIndexEntry{coercion: Model objects and restriction matrices} %\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{Coercion between model objects and restriction matrices in 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} Consider regression models for the `cars` dataset: <<>>= mod0 <- lm(dist ~ 1, data=cars); coef(mod0) mod1 <- update(mod0, .~. + speed); coef(mod1) mod2 <- update(mod1, .~. + I(speed^2)); coef(mod2) @ Reducing `mod2` to `mod0` corresponds to restricting the model space for `mod2` and so on: <<>>= L21 <- model2remat(mod2, mod1); L21 L20 <- model2remat(mod2, mod0); L20 L10 <- model2remat(mod1, mod0); L10 @ The other way around is that given a restriction matrix and a large model, we can construct the corresponding smaller model: <<>>= new1 <- remat2model(mod2, L21); coef(new1) new0a <- remat2model(mod2, L20); coef(new0a) new0b <- remat2model(mod1, L10); coef(new0b) @ It should be checked that the original and new model matrices span the same space. For now we will simply check that the fitted values are practically identical: <<>>= eps <- 1e-8 max(abs(fitted(new1) - fitted(mod1))) < eps max(abs(fitted(new0a) - fitted(mod0))) < eps max(abs(fitted(new0b) - fitted(mod0))) < eps @ \end{document} pbkrtest/inst/doc/pbkrtest.R0000644000176200001440000001134314021623227015614 0ustar liggesusers### R code from vignette source 'pbkrtest.Rnw' ################################################### ### code chunk number 1: pbkrtest.Rnw:19-22 ################################################### require( pbkrtest ) prettyVersion <- packageDescription("pbkrtest")$Version prettyDate <- format(Sys.Date()) ################################################### ### code chunk number 2: pbkrtest.Rnw:65-67 ################################################### options(prompt = "R> ", continue = "+ ", width = 80, useFancyQuotes=FALSE) dir.create("figures") ################################################### ### code chunk number 3: pbkrtest.Rnw:72-73 ################################################### library(pbkrtest) ################################################### ### code chunk number 4: pbkrtest.Rnw:82-84 ################################################### data(shoes, package="MASS") shoes ################################################### ### code chunk number 5: pbkrtest.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.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.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.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.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.Rnw:150-151 ################################################### ( kr.b<-KRmodcomp(lmm1.b, lmm0.b) ) ################################################### ### code chunk number 11: pbkrtest.Rnw:155-156 ################################################### summary( kr.b ) ################################################### ### code chunk number 12: pbkrtest.Rnw:162-163 ################################################### getKR(kr.b, "ddf") ################################################### ### code chunk number 13: pbkrtest.Rnw:168-169 ################################################### ( kr.i<-KRmodcomp(lmm1.i, lmm0.i) ) ################################################### ### code chunk number 14: pbkrtest.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.Rnw:191-192 ################################################### ( pb.b <- PBmodcomp(lmm1.b, lmm0.b, nsim=500, cl=2) ) ################################################### ### code chunk number 16: pbkrtest.Rnw:196-197 ################################################### summary( pb.b ) ################################################### ### code chunk number 17: pbkrtest.Rnw:205-206 ################################################### ( pb.i<-PBmodcomp(lmm1.i, lmm0.i, nsim=500, cl=2) ) ################################################### ### code chunk number 18: pbkrtest.Rnw:210-211 ################################################### summary( pb.i ) ################################################### ### code chunk number 19: pbkrtest.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.Rnw:231-232 ################################################### round( SG$Sigma*10 ) ################################################### ### code chunk number 21: pbkrtest.Rnw:236-237 ################################################### SG$G pbkrtest/inst/CITATION0000755000176200001440000000153313753132453014235 0ustar liggesuserscitHeader("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 = "https://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 https://www.jstatsoft.org/v59/i09/.") )