pbkrtest/0000755000176200001440000000000015036336542012117 5ustar liggesuserspbkrtest/MD50000644000176200001440000000576015036336542012437 0ustar liggesusers3279c01f6caf536d363ded574523fef7 *ChangeLog e1469123a84fe2e7acb70dff13cb7145 *DESCRIPTION 07f13014f772c6521903b2d2234bb4da *NAMESPACE 0d42ae38636e6446bbef736511875152 *NEWS f4976656f10c21982d68824b84a71e8c *R/DATA_pbkrtest.R d993590591fb56dc0d336fbc6b8057cf *R/KR_Sigma_G2.R da8ede6e70bd1986a46ccef88d540c01 *R/KR_modcomp.R bc8d694e3994de4a31b6b634e48717c8 *R/KR_utils.R d63eb49d83cef920d2aa242dde796cf8 *R/KR_vcovAdj.R a0771a277f863f37e5e72e45ba11296c *R/NAMESPACE_pbkrtest.R 321ba0f73d5ebf9f74e694b5c2d814ae *R/PB_modcomp.R 9a887dc946fca000a297867e102fe124 *R/PB_refdist.R de9e8b91b548d14261fee9d44e3ea7d5 *R/SAT_modcomp.R ddf56a3c4b6f90465dfe6fcc70fb1c40 *R/X2_modcomp.R 5a2f145855cff955575af4e2d35d37dc *R/anovax.R e5c18f4af49707f22e2fe9fd51c6958a *R/get_info_functions.R bf822ce9afcf67858e83f70535145e7c *R/init_modcomp.R 60b9fa9992a6655341b56690d397833d *R/linear_algebra.R 224de502381162eabfc45d7b0aee6aaf *R/model_coerce.R f5e48d7f1c50dcbcd4d78ec6f8316c23 *R/nested_model_info.R 0756e45963f48440262aa82fbb0c621e *R/pbkr_utilities.R 036800dde054044afe3bb31eef0012e6 *R/xx_modcomp_new.R 7fda9e53a0c4fd1d49bef84982f2b1d7 *README.md 529aa68374724deb76076dc724b5a3fd *build/vignette.rds 25a3a55d27aa15aa5472e6fc4d10310d *data/beets.RData 0bf3e5202394edbc9390961036629ad1 *data/budworm.RData 8e872a819690541db1267761c687a7ff *inst/CITATION e09c85aa411e04badc0a6c9a7279e8b2 *inst/WORDLIST 248d3d5e003e6cf166bfc56013e4b64e *inst/doc/a01-pbkrtest.R 4dd2b7b22c47b5410e3b3938b90717c7 *inst/doc/a01-pbkrtest.html 07a13dedae4a9afe5c97dccb203ee97c *inst/doc/a01-pbkrtest.rmd d79933898f87f3910516e20c2c7a4e3d *inst/doc/a02-coercion.R 56150fff92abd9b283ee61c7a20da076 *inst/doc/a02-coercion.html 7e98fc09d9eaf88fe0513db4958700b9 *inst/doc/a02-coercion.rmd d4d42589c14d781384a996972debf67e *man/anovax.Rd 301ffb2735e93343d7bf5e078d33d380 *man/anovax_list.Rd 08748fd6bfc07f42c009e6344634378a *man/any_modcomp.Rd 811c628745843417fd9b5caf68e4ca23 *man/compare_column_space.Rd cc6977435f78a4da0a5c897a072d5e4e *man/compute_auxiliary.Rd 56e8736832396a4af832520b3932abff *man/data-beets.Rd 0bf54cfd0b105863960666d59af9606f *man/data-budworm.Rd 6821a775b413bc33f386237714ae8013 *man/devfun_vp.Rd 938480a53afae4138be7050fac42bd04 *man/getLRT.Rd 4c95fdd76f583e6f63e4334ef4742430 *man/get_Fstat_ddf.Rd d3907e536a4fd9b635bb81ebd9669d9b *man/get_covbeta.Rd 6cbe7b7cb0ef5ec91b3afd34fd0e369b *man/get_ddf_Lb.Rd 92d327d459ab7214c7415c06466d90ef *man/get_modcomp.Rd ad67141d852fbc0a94f5a538c426969c *man/get_nested_model_info.Rd 3ff0c0fa522a0fa6ba3b0a9bea90c5dd *man/internal-pbkrtest.Rd f12c99b28fa8b9fbdea9967eaf300bf8 *man/kr-vcovAdj.Rd 9755529d746558711201cba58c10946b *man/kr__modcomp.Rd f8731ae439b280f5b3e89def6f42debd *man/model-coerce.Rd a718c5605db7469b7ea472d384dcc466 *man/pb-refdist.Rd e76bb4105b105c7242761a78efadbe83 *man/pb__modcomp.Rd 56467bce8c500e61e9c3d5552d44f110 *man/sat__modcomp.Rd 346cbb3f4e50c3a98d2fbcbe7b13045b *man/x2__modcomp.Rd 07a13dedae4a9afe5c97dccb203ee97c *vignettes/a01-pbkrtest.rmd 7e98fc09d9eaf88fe0513db4958700b9 *vignettes/a02-coercion.rmd pbkrtest/R/0000755000176200001440000000000015032042247012310 5ustar liggesuserspbkrtest/R/nested_model_info.R0000644000176200001440000001467415027211156016125 0ustar liggesusers#' @title Resolve Nested Model Representation #' #' @description #' Constructs or extracts a nested model (`fit0`) from a full model (`fit1`) #' using flexible input: a model object, formula, character string, or matrix. #' #' This function is useful for preparing models for comparison, e.g., via likelihood ratio test. #' #' @param fit1 A fitted model object (e.g., from `lm`, `lmer`, etc.). #' @param fit0 A nested model specification: a model object, a formula (e.g., `~ . - x`), #' a character vector of term names to remove, or a restriction matrix. #' #' @return A list with: #' \describe{ #' \item{formula_large}{Formula for `fit1`.} #' \item{formula_small}{Formula for resolved `fit0`.} #' \item{large_model}{The full model `fit1`.} #' \item{small_model}{The nested model `fit0`.} #' \item{L}{Restriction matrix defining the nested model.} #' } #' #' @examples #' if (requireNamespace("lme4", quietly = TRUE)) { #' library(lme4) #' data(sleepstudy) #' fit1 <- lmer(Reaction ~ Days + (Days | Subject), sleepstudy) #' fit0 <- lmer(Reaction ~ (Days | Subject), sleepstudy) #' #' get_nested_model_info(fit1, fit0) # as model object #' get_nested_model_info(fit1, ~ . - Days) # as formula #' get_nested_model_info(fit1, "Days") # as string #' ## get_nested_model_info(fit1, c(0, 1)) # numeric (converted to matrix) #' } #' #' @export get_nested_model_info <- function(fit1, fit0){ ## cat("handle_models\n") if (is.character(fit0)){ fit0 <- doBy::formula_add_str(formula(fit1), terms=fit0, op="-") ## cat("Convert character into formula:\n"); print(fit0) } if (is.numeric(fit0) && !is.matrix(fit0)){ fit0 <- matrix(fit0, nrow=1) ## cat("Convert numeric to matrix:\n"); print(fit0) } ## Here fit0 is either (1) formula, (2) restriction matrix ## or (3) model object. if (inherits(fit0, "formula")){ fit0 <- update(fit1, fit0) ## cat("Convert formula to model object: \n"); print(fit0) } else { if (inherits(fit0, c("Matrix", "matrix"))){ ## formula.small <- fit0 fit0 <- restriction_matrix2model(fit1, fit0, REML=FALSE) ## cat("Convert matrix to model object: \n"); print(fit0) } else { if (!identical(class(fit1), class(fit0))) stop("Model objects not same class\n") } } L <- model2restriction_matrix(fit1, fit0) formula.small <- formula(fit0) attributes(formula.small) <- NULL formula.large <- formula(fit1) attributes(formula.large) <- NULL out <- list(formula.large = formula.large, formula.small = formula.small, largeModel = fit1, smallModel = fit0, L = L ) return(out) } ## get_nested_model_info <- function(fit1, fit0) { ## if (is.character(fit0)) { ## fit0 <- doBy::formula_add_str(formula(fit1), terms = fit0, op = "-") ## } ## if (is.numeric(fit0) && !is.matrix(fit0)) { ## fit0 <- matrix(fit0, nrow = 1) ## } ## if (inherits(fit0, "formula")) { ## fit0 <- update(fit1, fit0) ## } else if (inherits(fit0, c("Matrix", "matrix"))) { ## fit0 <- restriction_matrix2model(fit1, fit0, REML = FALSE) ## } else { ## if (!identical(class(fit1), class(fit0))) { ## stop("Model objects must be of the same class.") ## } ## } ## L <- model2restriction_matrix(fit1, fit0) ## formula_large <- formula(fit1); attributes(formula_large) <- NULL ## formula_small <- formula(fit0); attributes(formula_small) <- NULL ## out <- list( ## formula_large = formula_large, ## formula_small = formula_small, ## large_model = fit1, ## small_model = fit0, ## L = L ## ) ## invisible(out) ## } ## FIXME: There is an issue with mixed models and lmerControl which is not set here.. ## #' (fm0 <- lmer(Reaction ~ (Days|Subject), sleepstudy)) ## #' (fm1 <- lmer(Reaction ~ Days + (Days|Subject), sleepstudy)) ## #' (fm2 <- lmer(Reaction ~ Days + I(Days^2) + (Days|Subject), sleepstudy)) ## #' ## #' ## Test for no effect of Days in fm1, i.e. test fm0 under fm1 ## #' ## #' load_all() ## #' handle_models(fm1, "Days") ## #' handle_models(fm1, ~.-Days) ## #' handle_models(fm1, cbind(0, 1)) ## FIXME ## #' handle_models(fm1, c(0,1)) ## FIXME ## handle_models <- function(largeModel, smallModel){ ## ## cat("handle_models\n") ## if (is.character(smallModel)){ ## smallModel <- doBy::formula_add_str(formula(largeModel), terms=smallModel, op="-") ## ## cat("Convert character into formula:\n"); print(smallModel) ## } ## if (is.numeric(smallModel) && !is.matrix(smallModel)){ ## smallModel <- matrix(smallModel, nrow=1) ## ## cat("Convert numeric to matrix:\n"); print(smallModel) ## } ## ## Here smallModel is either (1) formula, (2) restriction matrix ## ## or (3) model object. ## if (inherits(smallModel, "formula")){ ## smallModel <- update(largeModel, smallModel) ## ## cat("Convert formula to model object: \n"); print(smallModel) ## } else { ## if (inherits(smallModel, c("Matrix", "matrix"))){ ## ## formula.small <- smallModel ## smallModel <- restriction_matrix2model(largeModel, smallModel, REML=FALSE) ## ## cat("Convert matrix to model object: \n"); print(smallModel) ## } else { ## if (!identical(class(largeModel), class(smallModel))) ## stop("Model objects not same class\n") ## } ## } ## L <- model2restriction_matrix(largeModel, smallModel) ## formula.small <- formula(smallModel) ## attributes(formula.small) <- NULL ## formula.large <- formula(largeModel) ## attributes(formula.large) <- NULL ## out <- list(formula.large = formula.large, ## formula.small = formula.small, ## largeModel = largeModel, ## smallModel = smallModel, ## L = L ## ) ## invisible(out) ## } ## largeModel is model object ## smallModel is ## 1. Model object ## 2. Restriction string ## 3. Restriction formula ## 4. Restriction matrix ## cat("smallModel: \n"); print(smallModel) ## mmm <- handle_models(largeModel, smallModel) ## largeModel <- mmm$largeModel ## smallModel <- mmm$smallModel ## formula.large <- mmm$formula.large ## formula.small <- mmm$formula.small pbkrtest/R/DATA_pbkrtest.R0000644000176200001440000001007315031202644015061 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. #' @concept data #' #' @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" #' @title Budworm data #' #' @description Experiment on the toxicity to the tobacco budworm #' Heliothis virescens of doses of the pyrethroid #' trans-cypermethrin to which the moths were beginning to show #' resistance. Batches of 20 moths of each sex were exposed for #' three days to the pyrethroid and the number in each batch that #' were dead or knocked down was recorded. Data is reported in #' Collett (1991, p. 75). #' #' @concept data #' @name data-budworm #' @docType 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 micro grams)}. #' \item{ndead:}{budworms killed in a trial.} #' \item{ntotal:}{total number of budworms exposed per trial.} #' } #' #' @references Venables, W.N; Ripley, B.D.(1999) Modern Applied Statistics with #' S-Plus, Heidelberg, Springer, 3rd edition, chapter 7.2 #' #' @source Collett, D. (1991) Modelling Binary Data, Chapman & Hall, London, #' Example 3.7 #' #' #' @keywords datasets #' @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; #' } #' #' "budworm" pbkrtest/R/xx_modcomp_new.R0000644000176200001440000000707515032041440015464 0ustar liggesusers## FIXME: comodex er et dumt navn ## ' @title Model comparison ## ' ## ' @description Wrapper for functions KRmodcomp, SATmodcomp, PBmodcomp, X2modcomp ## ' @name comodex ## ' @param largeModel A model object ## ' @param smallModel A model object, a formula or a restriction matrix ## ' @param test A character string ## ' @param control A list controlling the model comparions. ## ' @param ... Additional arguments to be passed on to other methods ## ' @param details should details be printed ## ' @author Søren Højsgaard ## ' ## ' @examples ## ' (lmm0 <- lmer(Reaction ~ (Days|Subject), sleepstudy)) ## ' (lmm1 <- lmer(Reaction ~ Days + (Days|Subject), sleepstudy)) ## ' (lmm2 <- lmer(Reaction ~ Days + I(Days^2) + (Days|Subject), sleepstudy)) ## ' ## ' lm1 <- lm(dist ~ speed + I(speed^2), data=cars) ## ' lm0 <- lm(dist ~ speed, data=cars) ## ' ## ' comodex(lmm2, lmm1, test="x2") ## ' comodex(lmm2, lmm1, test="kr") ## ' comodex(lmm2, lmm1, test="sat") ## ' comodex(lmm2, lmm1, test="PB", control=list(nsim=50, cl=1)) ## ' comodex(lmm2, .~. - I(Days^2)) ## ' ## ' comodex(lm1, lm0) ## ' comodex(lm1, lm0, test="pb", control=list(nsim=50, cl=1)) ## ' ## ' @export ## ' @rdname comodex comodex <- function(largeModel, smallModel, test="x2", control=list(), details=0, ...){ UseMethod("comodex") } ## ' @rdname comodex ## ' @export comodex.lmerMod <- function(largeModel, smallModel, test="x2", control=list(), details=0, ...){ test <- match.arg(tolower(test), c("kr", "sat", "pb", "x2")) modcomp_fun <- switch(test, "x2" =x2_modcomp, "kr" =kr_modcomp, "sat"=sat_modcomp, "pb" =pb_modcomp) out <- suppressWarnings(modcomp_fun(largeModel, smallModel, control=control, ...)) return(out) } ## ' @rdname comodex ## ' @export comodex.default <- function(largeModel, smallModel, test="x2", control=list(), details=0, ...){ test <- match.arg(tolower(test), c("pb", "x2")) modcomp_fun <- switch(test, "x2" = x2_modcomp, "pb" = pb_modcomp) out <- suppressWarnings(modcomp_fun(largeModel, smallModel, control=control, ...)) return(out) } #' @title Compare two models #' @name modcomp #' #' @param largeModel,smallModel Two models #' @param control A list #' @export #' @rdname any_modcomp pb_modcomp <- function(largeModel, smallModel, control=list()){ out <- PBmodcomp(largeModel, smallModel, nsim=control$nsim, cl=control$cl) ## return(out) out2 <- handle_old_output(out) out2 <- out2[2,,drop=FALSE] ## QUICK and dirty? return(out2) } #' @export #' @rdname any_modcomp kr_modcomp <- function(largeModel, smallModel, control=list()){ out <- KRmodcomp(largeModel, smallModel, betaH=control$betaH, details=control$details) out2 <- handle_old_output(out) out2$F.scaling <- NULL out2 <- out2[1,,drop=FALSE] ## QUICK and dirty? return(out2) } #' @export #' @rdname any_modcomp sat_modcomp <- function(largeModel, smallModel, control=list()){ out <- SATmodcomp(largeModel, smallModel, betaH=control$betaH, details=control$details) out2 <- handle_old_output(out) return(out2) } #' @export #' @rdname any_modcomp x2_modcomp <- function(largeModel, smallModel, control=list()){ out <- X2modcomp(largeModel, smallModel, betaH=control$betaH, details=control$details) return(out) } handle_old_output <- function(out){ out2 <- out$test } pbkrtest/R/get_info_functions.R0000644000176200001440000002617615032037523016332 0ustar liggesusers#' @title Likelihood Ratio Test Between Nested Models #' #' @description #' Performs a likelihood ratio test (LRT) between two nested models. Supports #' models of class `lm`, `lmerMod`, `glmerMod`, `lme`, and `gls`. #' #' @param fit1 A model object representing the more complex (full) model. #' @param fit0 A model object representing the simpler (nested) model. #' #' @return A named numeric vector with: #' \describe{ #' \item{tobs}{Test statistic (twice the difference in log-likelihoods).} #' \item{df}{Degrees of freedom (difference in number of parameters).} #' \item{p.value}{P-value from the chi-squared distribution.} #' } #' #' @examples #' ## lm #' fit1 <- lm(mpg ~ wt + hp, data = mtcars) #' fit0 <- lm(mpg ~ wt, data = mtcars) #' getLRT(fit1, fit0) #' #' ## lmerMod #' if (requireNamespace("lme4", quietly = TRUE)) { #' library(lme4) #' fit1 <- lmer(Reaction ~ Days + (Days | Subject), sleepstudy, REML = FALSE) #' fit0 <- lmer(Reaction ~ 1 + (Days | Subject), sleepstudy, REML = FALSE) #' getLRT(fit1, fit0) #' } #' #' ## glmerMod #' if (requireNamespace("lme4", quietly = TRUE)) { #' library(lme4) #' data(cbpp) #' fit1 <- glmer(cbind(incidence, size - incidence) ~ period + (1 | herd), #' data = cbpp, family = binomial) #' fit0 <- glmer(cbind(incidence, size - incidence) ~ 1 + (1 | herd), #' data = cbpp, family = binomial) #' getLRT(fit1, fit0) #' } #' #' ## lme #' if (requireNamespace("nlme", quietly = TRUE)) { #' library(nlme) #' fit1 <- lme(distance ~ age + Sex, random = ~1 | Subject, #' data = Orthodont, method = "ML") #' fit0 <- lme(distance ~ age, random = ~1 | Subject, #' data = Orthodont, method = "ML") #' getLRT(fit1, fit0) #' } #' #' ## gls #' if (requireNamespace("nlme", quietly = TRUE)) { #' library(nlme) #' fit1 <- gls(mpg ~ wt + hp, data = mtcars, method = "ML") #' fit0 <- gls(mpg ~ wt, data = mtcars, method = "ML") #' getLRT(fit1, fit0) #' } #' #' @export getLRT <- function(fit1, fit0) { UseMethod("getLRT") } #' @export getLRT.lm <- function(fit1, fit0) { logL1 <- logLik(fit1) logL0 <- logLik(fit0) tobs <- 2 * (logL1 - logL0) df <- attr(logL1, "df") - attr(logL0, "df") pval <- 1 - pchisq(tobs, df) c(tobs = tobs, df = df, p.value = pval) } #' @export getLRT.lmerMod <- function(fit1, fit0) { logL1 <- logLik(update(fit1, REML = FALSE)) logL0 <- logLik(update(fit0, REML = FALSE)) tobs <- 2 * (logL1 - logL0) df <- attr(logL1, "df") - attr(logL0, "df") pval <- 1 - pchisq(tobs, df) c(tobs = tobs, df = df, p.value = pval) } #' @export getLRT.glmerMod <- function(fit1, fit0) { logL1 <- logLik(update(fit1)) logL0 <- logLik(update(fit0)) tobs <- 2 * (logL1 - logL0) df <- attr(logL1, "df") - attr(logL0, "df") pval <- 1 - pchisq(tobs, df) c(tobs = tobs, df = df, p.value = pval) } #' @export getLRT.lme <- function(fit1, fit0) { logL1 <- logLik(update(fit1, method = "ML")) logL0 <- logLik(update(fit0, method = "ML")) tobs <- 2 * (logL1 - logL0) df <- attr(logL1, "df") - attr(logL0, "df") pval <- 1 - pchisq(tobs, df) c(tobs = tobs, df = df, p.value = pval) } #' @export getLRT.gls <- function(fit1, fit0) { logL1 <- logLik(update(fit1, method = "ML")) logL0 <- logLik(update(fit0, method = "ML")) tobs <- 2 * (logL1 - logL0) df <- attr(logL1, "df") - attr(logL0, "df") pval <- 1 - pchisq(tobs, df) c(tobs = tobs, df = df, p.value = pval) } #' @title Extract (or "get") components from a \code{KRmodcomp} or #' \code{SATmodcomp} object. #' #' @description Extract (or "get") components from a \code{KRmodcomp} #' or \code{SATmodcomp} object. In particular, get denominator #' degrees of freedom. #' #' @name get_modcomp #' #' @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 #' #' (fm0 <- lmer(Reaction ~ (Days|Subject), sleepstudy)) #' (fm1 <- lmer(Reaction ~ Days + (Days|Subject), sleepstudy)) #' (fm2 <- lmer(Reaction ~ Days + I(Days^2) + (Days|Subject), sleepstudy)) #' #' x10 <- KRmodcomp(fm1, fm0) #' getKR(x10, "ddf") #' #' KRmodcomp(fm1, fm0) |> getKR("ddf") #' KRmodcomp(fm2, fm0) |> getKR("ddf") #' KRmodcomp(fm2, fm1) |> getKR("ddf") #' #' ## For comparison: #' #' SATmodcomp(fm1, fm0) |> getSAT("ddf") #' SATmodcomp(fm2, fm0) |> getSAT("ddf") #' SATmodcomp(fm2, fm1) |> getSAT("ddf") #' #' @export #' @rdname get_modcomp 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]] } } #' @export #' @rdname get_modcomp getSAT <- function (object, name = c("ndf", "ddf", "Fstat", "p.value")) { stopifnot(is(object, "SATmodcomp")) if (missing(name) || is.null(name)){ return(object$test) ## FIXME Should be stats } else { stopifnot(length(name <- as.character(name)) == 1) name <- match.arg(name) object$test[[name]] ## FIXME Should be stats } } ## ' ## ' \dontrun{ ## ' p <- PBrefdist(fm1, fm0, seed=123, nsim=50, cl=1) ## ' e <- mean(p) ## ' e ## ' -2*e/(1-e) ## ' ## ' x <- PBmodcomp(fm1, fm0, nsim=50, seed=123, cl=1) ## ' summary(x)$test$ddf[5] ## ' ## ' x <- PBmodcomp(fm2, fm0, nsim=50, cl=2) ## ' summary(x)$test$ddf[5] ## ' ## ' x <- PBmodcomp(fm2, fm1, nsim=50, cl=2) ## ' summary(x)$test$ddf[5] ## ' } ## ' #' @title Adjusted denominator degrees of freedom for linear estimate for linear #' mixed model. #' #' @description Get adjusted denominator degrees 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 The unadjusted and the adjusted covariance matrices for the fixed #' effects parameters. The unadjusted covariance matrix is obtained with #' \code{vcov()} and adjusted with \code{vcovAdj()}. #' @return Adjusted degrees of freedom (adjustment 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{model2restriction_matrix}}, #' \code{\link{restriction_matrix2model}} #' @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 #' #' (fm1 <- lmer(Reaction ~ Days + (Days|Subject), sleepstudy)) #' (fm0 <- lmer(Reaction ~ 1 + (Days|Subject), sleepstudy)) #' anova(fm1, fm0) #' #' KRmodcomp(fm1, fm0) ## 17 denominator df's #' get_Lb_ddf(fm1, c(0, 1)) ## 17 denominator df's #' #' # Notice: The restriction matrix L corresponding to the test above #' # can be found with #' L <- model2restriction_matrix(fm1, fm0) #' 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)) } #' @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 } ## ## FIXME Backward compatibility with Russ Lenths work. Not sure if ## needed any more... ## ## 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)) } ## 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 } pbkrtest/R/linear_algebra.R0000644000176200001440000000255115032040313015355 0ustar liggesusers#' Compare column spaces #' #' Compare column spaces of two matrices #' #' @param X1,X2 matrices with the same number of rows #' #' @return #' #' * -1 : Either C(X1)=C(X2), or the spaces are not nested. #' * 0 : C(X1) is contained in C(X2) #' * 1 : C(X2) is contained in C(X1) #' #' @examples #' #' A1 <- matrix(c(1,1,1,1,2,3), nrow=3) #' A2 <- A1[, 1, drop=FALSE] #' #' compare_column_space(A1, A2) #' compare_column_space(A2, A1) #' compare_column_space(A1, A1) #' #' @export compare_column_space <- function(X1, X2){ if (!inherits(X1, "matrix")) stop("'X1' is not at matrix\n") if (!inherits(X2, "matrix")) stop("'X2' is not at matrix\n") if (nrow(X1) != nrow(X2)) stop("'X1' and 'X2' do not have same number of rows\n") ## -1 : Either C(X1)=C(X2), or the spaces are not nested. ## 0 : C(X1) is contained in C(X2) ## 1 : C(X2) is contained in C(X1) r1 <- rankMatrix_(X1) r2 <- rankMatrix_(X2) rboth <- rankMatrix(cbind(X1, X2)) ## NOTE: Should NOT be rankMatrix_ if (rboth == pmax(r1, r2)) { if (r2 < r1) { out <- 1 } else { if (r2 > r1) { out <- 0 } else { out <- -1 } } } else { out <- -1 } out } rankMatrix_ <- function(X){ rankMatrix(X) ## rankMatrix(crossprod(X), method="qr.R") } pbkrtest/R/model_coerce.R0000644000176200001440000002243015032040656015056 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{model2restriction_matrix}: A restriction matrix. #' \code{restriction_matrix2model}: 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 <- model2restriction_matrix(sug, sug.h); L.h #' L.s <- model2restriction_matrix(sug, sug.s); L.s #' #' ## Construct submodels from restriction matrices #' mod.h <- restriction_matrix2model(sug, L.h); mod.h #' mod.s <- restriction_matrix2model(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 model2restriction_matrix #' @rdname model-coerce model2restriction_matrix <- function (largeModel, smallModel, sparse=FALSE) { UseMethod("model2restriction_matrix") } #' @export model2restriction_matrix.default <- function (largeModel, smallModel, sparse=FALSE) { stop("No useful default method for 'model2restriction_matrix'") } #' @method model2restriction_matrix merMod #' @export model2restriction_matrix.merMod <- function (largeModel, smallModel, sparse=FALSE) { ## cat("model2restriction_matrix.merMod\n") ## print(largeModel); print(smallModel) L <- if (is.numeric(smallModel)) { force_full_rank(smallModel) } else { ## smallModel is lmerMod make_restriction_matrix(getME(largeModel, 'X'), getME(smallModel, 'X')) } if (sparse) .makeSparse(L) else L } #' @method model2restriction_matrix lm #' @export model2restriction_matrix.lm <- function (largeModel, smallModel, sparse=FALSE) { L <- if (is.numeric(smallModel)) { force_full_rank(smallModel) } else { make_restriction_matrix(model.matrix(largeModel), model.matrix(smallModel)) } if (sparse) .makeSparse(L) else L } #' @rdname model-coerce #' @export restriction_matrix2model <- function(largeModel, L, REML=TRUE, ...){ UseMethod("restriction_matrix2model") } #' @export restriction_matrix2model.default <- function(largeModel, L, REML=TRUE, ...){ stop("No useful default method for 'restriction_matrix2model'") } restriction_matrix2model_internal <- function(largeModel, L, XX.lg){ form <- as.formula(formula(largeModel)) attributes(XX.lg)[-1] <- NULL XX.sm <- make_model_matrix(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 restriction_matrix2model.lmerMod <- function(largeModel, L, REML=TRUE, ...){ zzz <- restriction_matrix2model_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=eval(new.data)) new_formula <- as.formula(paste(zzz$new_form$lhs, "~ -1 +", zzz$rhs.fix2, "+", zzz$new_form$rhs.ran)) ## Evaluate the new dataset once and give it a name data_used <- cbind(zzz$XX.sm, eval(largeModel@call$data)) ## Use bquote to avoid storing fragile expressions in the call ans <- eval(bquote(update(.(largeModel), formula = .(new_formula), data = .(data_used)))) if (!REML) ans <- update(ans, REML=FALSE) ans } ## #' @rdname model-coerce #' @export restriction_matrix2model.glmerMod <- function(largeModel, L, REML=TRUE, ...){ zzz <- restriction_matrix2model_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) new_formula <- as.formula(paste(zzz$new_form$lhs, "~ -1 +", zzz$rhs.fix2, "+", zzz$new_form$rhs.ran)) ## Evaluate the new dataset once and give it a name data_used <- cbind(zzz$XX.sm, eval(largeModel@call$data)) ## Use bquote to avoid storing fragile expressions in the call ans <- eval(bquote(update(.(largeModel), formula = .(new_formula), data = .(data_used)))) ans } ## #' @rdname model-coerce #' @export restriction_matrix2model.lm <- function(largeModel, L, ...){ zzz <- restriction_matrix2model_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_model_matrix <- 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 %*% orthogonal_complement(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 number of rows. #' @details `make_restriction_matrix` Make a restriction matrix. If span(X2) is in #' span(X) then the corresponding restriction matrix `L` is #' returned. #' @export make_restriction_matrix <- 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)))) zapsmall(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 } pbkrtest/R/KR_utils.R0000644000176200001440000000337215031444246014200 0ustar liggesusersorthogonal_complement<-function(W) { ##orthogonal complement of : orth= rW <- rankMatrix_(W) Worth <- qr.Q(qr(cbind(W)), complete=TRUE)[,-c(1:rW), drop=FALSE] Worth } .spur<-function(U){ sum(diag(U)) } .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 } ## FIXME Get rid of these .is.lmm <- function(object) { inherits(object, "lmerMod") } .is.mm <- function(object) { inherits(object, "merMod") } pbkrtest/R/KR_Sigma_G2.R0000644000176200001440000001006514721100744014422 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) } ## 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/init_modcomp.R0000644000176200001440000000411114721100744015112 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 ## cat("m1:\n"); print(m1) ## cat("m2:\n"); print(m2) 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") ## Xs <<- Xsmall ## rs <<- rankMatrix(Xs) ## print(Xsmall) rsmall <- rankMatrix_(Xsmall) rboth <- rankMatrix_(cbind(Xlarge, Xsmall)) if (rboth == pmax(rlarge, rsmall)) { if (rsmall < rlarge) { 1 } else { if (rsmall > rlarge) { 0 } else { -1 } } } else { -1 } } else { ##now model m2 is a restriction matrix if (rankMatrix_(rbind(Xlarge, m2)) > rlarge) { -1 } else { 1 } } code } pbkrtest/R/KR_modcomp.R0000644000176200001440000002745015003322302014464 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. #' @concept model_comparison #' @name kr__modcomp #' ## ########################################################################## #' @details #' #' An F test is calculated according to the approach of Kenward and #' Roger (1997). The function works for linear mixed models fitted #' with the lmer() function of the `lme4` package. Only models where #' the covariance structure is a linear combination (a weighted sum) #' of known matrices can be compared. #' #' The `smallModel` is the model to be tested against the `largeModel`. #' #' The `largeModel` is a model fitted with `lmer()`. A technical #' detail: The model must be fitted with `REML=TRUE`. If the model is #' fitted with `REML=FALSE` then the model is refitted with #' `REML=TRUE` before the p-values are calculated. Put differently, #' the user needs not worry about this issue. #' #' The `smallModel` can be one of several things: #' #' 1) a model fitted with `lmer()`. It must have the same covariance #' structure as `largeModel`. Furthermore, its linear space of #' expectation must be a subspace of the space for `largeModel`. #' #' 2) a restriction matrix `L` specifying the hypothesis #' \deqn{L \beta = L \beta_H} #' where `L` is a `k x p` matrix (there are k restrictions and p is #' the number of fixed effect parameters (the length of #' `fixef(largeModel)`) and `beta_H` is a p column vector. #' #' 3) A formula or a text string specifying what is to be removed from the #' larger model to form the smaller model. #' #' Notice: if you want to test a hypothesis #' #' \deqn{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. If `smallModel` is a model object then betaH=0. #' @param details If larger than 0 some timing details are printed. #' #' @author Ulrich Halekoh \email{uhalekoh@@health.sdu.dk}, Søren Højsgaard #' \email{sorenh@@math.aau.dk} #' #' @seealso \code{\link{getKR}}, \code{\link[lme4]{lmer}}, #' \code{\link{vcovAdj}}, \code{\link{PBmodcomp}}, #' \code{\link{SATmodcomp}} #' #' @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 #' #' (fm0 <- lmer(Reaction ~ (Days|Subject), sleepstudy)) #' (fm1 <- lmer(Reaction ~ Days + (Days|Subject), sleepstudy)) #' (fm2 <- lmer(Reaction ~ Days + I(Days^2) + (Days|Subject), sleepstudy)) #' #' ## Test for no effect of Days in fm1, i.e. test fm0 under fm1 #' KRmodcomp(fm1, "Days") #' KRmodcomp(fm1, ~.-Days) #' L1 <- cbind(0, 1) #' KRmodcomp(fm1, L1) #' KRmodcomp(fm1, fm0) #' anova(fm1, fm0) #' #' ## Test for no effect of Days and Days-squared in fm2, i.e. test fm0 under fm2 #' KRmodcomp(fm2, "(Days+I(Days^2))") #' KRmodcomp(fm2, ~. - Days - I(Days^2)) #' L2 <- rbind(c(0, 1, 0), c(0, 0, 1)) #' KRmodcomp(fm2, L2) #' KRmodcomp(fm2, fm0) #' anova(fm2, fm0) #' #' ## Test for no effect of Days-squared in fm2, i.e. test fm1 under fm2 #' KRmodcomp(fm2, "I(Days^2)") #' KRmodcomp(fm2, ~. - I(Days^2)) #' L3 <- rbind(c(0, 0, 1)) #' KRmodcomp(fm2, L3) #' KRmodcomp(fm2, fm1) #' anova(fm2, fm1) #' @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) { KRmodcomp_internal(largeModel=largeModel, smallModel=smallModel, betaH=betaH, details=details) } KRmodcomp_internal <- function(largeModel, smallModel, betaH=0, details=0) { if (is.character(smallModel)) smallModel <- doBy::formula_add_str(formula(largeModel), terms=smallModel, op="-") 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) } KRmodcomp_worker(largeModel, smallModel, betaH=betaH, details=details) } KRmodcomp_worker <- function(largeModel, smallModel, betaH=0, details=0) { if (is.null(betaH)) betaH <- 0 if (is.null(details)) details <- 0 ## All computations are based on 'largeModel' and the restriction matrix 'L' ## ------------------------------------------------------------------------- t0 <- proc.time() L <- model2restriction_matrix(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 } .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_internal2 <- 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" ) ## print(Theta %*% Phi) ## print(W) ## print(P) 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 ## print(ui); print(uj) A1 <- A1 + e * W[ii,jj] * (.spur(ui) * .spur(uj)) A2 <- A2 + e * W[ii,jj] * sum(ui * t(uj)) } } q <- as.numeric(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) ## str(list(q=q, A2=A2, V1=V1, V0=V0, V2=V2)) 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 auxiliary 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)) Lb2 <- L %*% betaDiff Wald <- as.numeric(t(Lb2) %*% solve(L %*% PhiA %*% t(L), Lb2)) WaldU <- as.numeric(t(Lb2) %*% solve(L %*% Phi %*% t(L), Lb2)) 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 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) tab <- object$test printCoefmat(tab, tst.ind=c(1,2,3), na.print='', has.Pvalue=TRUE) FF.thresh <- 0.2 F.scale <- object$aux['F.scaling'] 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 ') } } class(tab) <- c("summary_KRmodcomp", "data.frame") invisible(tab) } pbkrtest/R/pbkr_utilities.R0000644000176200001440000000241215032040574015464 0ustar liggesusers as.data.frame.PBmodcomp <- function(x, ...){ out <- x$test attributes(out) <- c(attributes(out), x[-1]) out } as.data.frame.summary_PBmodcomp <- function(x, ...){ out <- x$test attributes(out) <- c(attributes(out), x[-1]) out } #' @export tidy.PBmodcomp <- function(x, ...){ ret <- x$test as_tibble(cbind(type=rownames(ret), ret)) } #' @export tidy.summary_PBmodcomp <- function(x, ...){ ret <- x$test as_tibble(cbind(type=rownames(ret), ret)) } #' @export tidy.summary_KRmodcomp <- function(x, ...){ ret <- x##$test as_tibble(cbind(type=rownames(ret), ret)) } #' @export tidy.KRmodcomp <- function(x, ...){ F.scale <- x$aux['F.scaling'] tab <- x$test FF.thresh <- 0.2 ## ttt <<- tab if (max(F.scale) > FF.thresh) i <- 1 else i <- 2 ret <- x$test[i,,drop=FALSE] ret$F.scaling <- NULL 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 } pbkrtest/R/X2_modcomp.R0000644000176200001440000001617715026742477014475 0ustar liggesusers## ########################################################################## ## #' @title Chisq test #' #' @description Chisq test #' @concept model_comparison #' @name x2__modcomp #' ## ########################################################################## #' @details TBW #' #' @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. If `smallModel` is a model object then betaH=0. #' @param details If larger than 0 some timing details are printed. #' @param ... Additional arguments, currently not used. #' #' @author Ulrich Halekoh \email{uhalekoh@@health.sdu.dk}, Søren Højsgaard #' \email{sorenh@@math.aau.dk} #' #' (fm0 <- lmer(Reaction ~ (Days|Subject), sleepstudy)) #' (fm1 <- lmer(Reaction ~ Days + (Days|Subject), sleepstudy)) #' (fm2 <- lmer(Reaction ~ Days + I(Days^2) + (Days|Subject), sleepstudy)) #' #' ## Test for no effect of Days in fm1, i.e. test fm0 under fm1 #' #' X2modcomp(fm1, "Days") #' X2modcomp(fm1, ~.-Days) #' L1 <- cbind(0, 1) #' X2modcomp(fm1, L1) ## FIXME #' X2modcomp(fm1, fm0) #' anova(fm1, fm0) #' @export #' @rdname x2__modcomp X2modcomp <- function(largeModel, smallModel, betaH=0, details=0, ...){ UseMethod("X2modcomp") } #' @export #' @rdname x2__modcomp X2modcomp.default <- function(largeModel, smallModel, betaH=0, details=0, ...) { X2modcomp_internal(largeModel=largeModel, smallModel=smallModel, betaH=betaH, details=details) } X2modcomp_internal <- function(largeModel, smallModel, betaH=0, details=0) { ## FIXME: We need check that largeModel is the right type if (is.character(smallModel)) smallModel <- doBy::formula_add_str(formula(largeModel), terms=smallModel, op="-") if (inherits(smallModel, "formula")) smallModel <- update(largeModel, smallModel) X2modcomp_worker(largeModel, smallModel, betaH=betaH, details=details) } X2modcomp_worker <- function(largeModel, smallModel, betaH=0, details=0) { ## cat("X2modcomp_worker\n") if (is.null(betaH)) betaH <- 0 if (is.null(details)) details <- 0 t0 <- proc.time() ## L not used but goes into output. Perhaps relevant to have it L <- NULL ##model2restriction_matrix(largeModel, smallModel) LRTstat <- getLRT(largeModel, smallModel) stats <- NULL ## Keep this ans <- X2compute_p_values(LRTstat, stats) formula.large <- formula(largeModel) formula.small <- formula(smallModel) attributes(formula.large) <- NULL ans$formula.large <- formula.large ans$formula.small <- formula.small ans$ctime <- (proc.time() - t0)[3] ans$L <- L out <- ans$test[1,, drop=FALSE] attr(out, "aux") <- ans attr(out, "heading") <- c( deparse(formula.large), deparse(formula.small)) class(out) <- c("X2modcomp", "anova", "data.frame") return(out) } X2compute_p_values <- function(LRTstat, stats=NULL){ tobs <- unname(LRTstat[1]) ndf <- unname(LRTstat[2]) p.chi <- 1 - pchisq(tobs, df=ndf) test = list( LRT = c(stat=tobs, df=ndf, ddf=NA, p.value=p.chi) ) test <- as.data.frame(do.call(rbind, test)) test$df <- as.integer(test$df) out <- list(test=test, type="X2", aux=stats$aux, stats=stats) ## Notice: stats are carried to the output. Used for get getKR function... class(out) <- c("X2modcomp") out } ## X2modcomp_worker <- function(largeModel, smallModel, betaH=0, details=0) { ## if (is.null(betaH)) betaH <- 0 ## if (is.null(details)) details <- 0 ## ## cat("X2modcomp_worker\n") ## ## All computations are based on 'largeModel' and the restriction matrix 'L' ## ## ------------------------------------------------------------------------- ## t0 <- proc.time() ## L <- NULL ##model2restriction_matrix(largeModel, smallModel) ## ## if (inherits(smallModel, "matrix")){ ## ## smallModel <- suppressWarnings(restriction_matrix2model(largeModel, L=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 ## stats <- NULL ## LRTstat <- getLRT(largeModel, smallModel) ## ## cat("LRTstat:\n"); print(LRTstat); cat("LRTstat done:\n"); ## ans <- X2compute_p_values(LRTstat,stats) ## ## print(ans) ## formula.large <- formula(largeModel) ## formula.small <- formula(smallModel) ## attributes(formula.large) <- NULL ## ans$formula.large <- formula.large ## ans$formula.small <- formula.small ## ans$ctime <- (proc.time() - t0)[3] ## ans$L <- L ## ## print(ans) ## out <- ans$test[1,, drop=FALSE] ## ## print(out) ## attr(out, "aux") <- ans ## attr(out, "heading") <- c( ## deparse(formula.large), ## deparse(formula.small)) ## class(out) <- c("X2modcomp", "anova", "data.frame") ## return(out) ## } ## X2modcomp_internal <- function(largeModel, smallModel, betaH=0, details=0) { ## if (is.character(smallModel)) ## smallModel <- doBy::formula_add_str(formula(largeModel), terms=smallModel, op="-") ## if (inherits(smallModel, "formula")) ## smallModel <- update(largeModel, smallModel) ## ## if (is.numeric(smallModel) && !is.matrix(smallModel)) ## ## smallModel <- matrix(smallModel, nrow=1) ## ## 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) ## ## } ## ## print(largeModel) ## ## print(smallModel) ## X2modcomp_worker(largeModel, smallModel, betaH=betaH, details=details) ## } ## #' @export ## #' @rdname x2__modcomp ## X2modcomp.lmerMod <- function(largeModel, smallModel, betaH=0, details=0, ...) { ## X2modcomp_internal(largeModel=largeModel, smallModel=smallModel, betaH=betaH, details=details) ## } ## #' @export ## #' @rdname x2__modcomp ## X2modcomp.glmerMod <- function(largeModel, smallModel, betaH=0, details=0, ...) { ## X2modcomp_internal(largeModel=largeModel, smallModel=smallModel, betaH=betaH, details=details) ## } ## #' @export ## #' @rdname x2__modcomp ## X2modcomp.gls <- function(largeModel, smallModel, betaH=0, details=0, ...) { ## X2modcomp_internal(largeModel=largeModel, smallModel=smallModel, betaH=betaH, details=details) ## } ## #' @export ## #' @rdname x2__modcomp ## X2modcomp.lm <- function(largeModel, smallModel, betaH=0, details=0, ...) { ## X2modcomp_internal(largeModel=largeModel, smallModel=smallModel, betaH=betaH, details=details) ## } pbkrtest/R/PB_refdist.R0000644000176200001440000003207415031570655014472 0ustar liggesusers#' @title Calculate reference distribution using parametric bootstrap #' #' @description Calculate reference distribution of likelihood ratio statistic #' in mixed effects models using parametric bootstrap #' #' @concept model_comparison #' @name pb-refdist #' #' @details The model \code{object} must be fitted with maximum likelihood #' (i.e. with \code{REML=FALSE}). If the object is fitted with restricted #' maximum likelihood (i.e. with \code{REML=TRUE}) then the model is #' refitted with \code{REML=FALSE} before the p-values are calculated. Put #' differently, the user needs not worry about this issue. #' #' 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 #' #' #' @aliases PBrefdist PBrefdist.merMod PBrefdist.lm #' #' @param largeModel A linear mixed effects model as fitted with the #' \code{lmer()} function in the \pkg{lme4} package. This model muse be #' larger than \code{smallModel} (see below). #' @param smallModel A linear mixed effects model as fitted with the #' \code{lmer()} function in the \pkg{lme4} package. This model muse be #' smaller than \code{largeModel} (see above). #' @param nsim The number of simulations to form the reference distribution. #' @param seed Seed for the random number generation. #' #' @param cl Used for controlling parallel computations. See sections #' 'details' and 'examples' below. #' #' @param details The amount of output produced. Mainly relevant for debugging #' purposes. #' @return A numeric vector #' @author Søren Højsgaard \email{sorenh@@math.aau.dk} #' @seealso \code{\link{PBmodcomp}}, \code{\link{KRmodcomp}} #' @references Ulrich Halekoh, Søren Højsgaard (2014)., A Kenward-Roger #' Approximation and Parametric Bootstrap Methods for Tests in Linear Mixed #' Models - The R Package pbkrtest., Journal of Statistical Software, #' 58(10), 1-30., \url{https://www.jstatsoft.org/v59/i09/} #' #' @keywords models inference #' @examples #' #' data(beets) #' head(beets) #' beet0 <- lmer(sugpct ~ block + sow + harvest + (1|block:harvest), data=beets, REML=FALSE) #' beet_no.harv <- update(beet0, . ~ . -harvest) #' 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) #' } #' @rdname pb-refdist #' @export PBrefdist <- function(largeModel, smallModel, nsim=1000, seed=NULL, cl=NULL, details=0){ UseMethod("PBrefdist") } #' @rdname pb-refdist #' @export PBrefdist.lm <- function(largeModel, smallModel, nsim=1000, seed=NULL, cl=NULL, details=0){ ## Specific for object class: nr_data <- nrow(eval(largeModel$call$data)) nr_fit <- nrow(largeModel$model) ## Generic across object classes t0 <- proc.time() if (nr_data != nr_fit) stop("Number of rows in data and fit do not match; remove NAs from data before fitting\n") ref <- do_sampling(largeModel, smallModel, nsim, cl, details) LRTstat <- getLRT(largeModel, smallModel) ref <- finalize_refdist(LRTstat, ref, nsim) 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){ ## Specific for object class: ctrl <- lmerControl( optCtrl = list(maxfun = 1e5, tol = 0.01), check.conv.grad = "ignore", check.conv.singular = "ignore", check.conv.hess = "ignore" # optional ) if (getME(smallModel, "is_REML")) { smallModel <- eval(bquote(update(.(smallModel), REML = FALSE, control = .(ctrl)))) } if (getME(largeModel, "is_REML")){ largeModel <- eval(bquote(update(.(largeModel), REML = FALSE, control = .(ctrl)))) } nr_data <- nrow(getData(largeModel)) nr_fit <- getME(largeModel, "n") ## Generic across object classes t0 <- proc.time() if (nr_data != nr_fit) stop("Number of rows in data and fit do not match; remove NAs from data before fitting\n") LRTstat <- getLRT(largeModel, smallModel) ref <- do_sampling(largeModel, smallModel, nsim, cl, details) ref <- finalize_refdist(LRTstat, ref, nsim) if (details > 0) cat(sprintf("Reference distribution with %5i samples; computing time: %5.2f secs. \n", length(ref), attr(ref, "ctime"))) ref } #' @rdname pb-refdist #' @export PBrefdist.gls <- function(largeModel, smallModel, nsim=1000, seed=NULL, cl=NULL, details=0){ ## Specific for object class: smallModel <- update(smallModel, method="ML") largeModel <- update(largeModel, method="ML") nr_data <- nrow(getData(largeModel)) nr_fit <- largeModel$dims$N ## Generic across object classes t0 <- proc.time() if (nr_data != nr_fit) stop("Number of rows in data and fit do not match; remove NAs from data before fitting\n") ref <- do_sampling(largeModel, smallModel, nsim, cl, details) LRTstat <- getLRT(largeModel, smallModel) ref <- finalize_refdist(LRTstat, ref, nsim) if (details > 0) cat(sprintf("Reference distribution with %5i samples; computing time: %5.2f secs. \n", length(ref), attr(ref, "ctime"))) ref } finalize_refdist <- function(LRTstat, ref, nsim){ 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" return(ref) } #' @export 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)){ refit_safe <- function(model, newresp, ctrl) { ff <- formula(model) dd <- getData(model) dd[[as.character(ff[[2]])]] <- newresp # Replace response update(model, formula = ff, data = dd, REML = FALSE, control = ctrl) } ctrl <- lmerControl( optCtrl = list(tol = 0.1), check.conv.grad = "ignore", check.conv.hess = "ignore", check.conv.singular = "ignore" ) unname(unlist(lapply(simdata, function(yyy) { sm2 <- suppressMessages(refit_safe(sm, yyy, ctrl)) lg2 <- suppressMessages(refit_safe(lg, yyy, ctrl)) 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 } return(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 } ## ALTERNATIV ## safe_update_lmer <- function(model, REML = FALSE, control = lmerControl()) { ## eval(bquote(update(.(model), ## REML = .(REML), ## control = .(control)))) ## } ## smallModel <- safe_update_lmer(smallModel, REML = FALSE, control = ctrl) ## smallModel <- update(smallModel, REML = FALSE, control = ctrl) ## smallModel <- eval(bquote(update(.(smallModel), ## REML = FALSE, ## control = .(ctrl)))) ## smallModel <- update(smallModel, REML = FALSE, control = ctrl) ## smallModel <- update(smallModel, REML=FALSE, ## control=lmerControl(check.conv.singular = "ignore")) ## largeModel <- update(largeModel, REML = FALSE, control = ctrl) ## largeModel <- update(largeModel, REML=FALSE, ## control=lmerControl(check.conv.singular = "ignore")) ### ########################################################### ### ### Computing of reference distribution; possibly in parallel ### ### ########################################################### pbkrtest/R/anovax.R0000644000176200001440000001254215003322455013733 0ustar liggesusers##' @title anova like function ##' @name anovax ##' @param object A model object object ##' @param ... further arguments ##' @param control A list controling simulations, only relevant for ##' parametric bootstrapping. ##' @param test A character string ##' @author Søren Højsgaard ##' ##' @examples ##' lmm1 <- lmer(sugpct ~ block + sow + harvest + (1|block:harvest), data=beets) ##' lmm0 <- update(lmm1, .~. - sow) ##' anovax(lmm1, .~. - harvest, test="KR") ##' anovax(lmm1, .~. - harvest, test="SAT") ##' ## anovax(lmm1, .~. - harvest, test="PB", control=list(nsim=50, cl=1)) ##' ##' anovax(lmm1, test="KR") ##' anovax(lmm1, test="SAT") ##' anovax(lmm1, test="PB", control=list(nsim=50, cl=1)) ##' ##' @export ##' @rdname anovax anovax <- function(object, ..., test="x2", control=list(nsim=1000, cl=NULL)){ UseMethod("anovax") } #' @rdname anovax #' @export anovax.lmerMod <- function(object, ..., test="x2", control=list(nsim=1000, cl=NULL)){ test <- match.arg(tolower(test), c("kr", "sat", "pb", "x2")) anovax_worker(object, ..., test=test, control=control) } #' @rdname anovax #' @export anovax.default <- function(object, ..., test="x2", control=list(nsim=1000, cl=NULL)){ test <- match.arg(tolower(test), c("pb", "x2")) anovax_worker(object, ..., test=test, control=control) } anovax_worker <- function(object, ..., test="x2", control=list(nsim=1000, cl=NULL)){ print(test) dots <- list(...) if (is.null(control$nsim)) control$nsim <- 1000 print(control) cat("anovax_worker dots:\n"); print(dots) test <- match.arg(tolower(test), c("kr", "sat", "pb", "x2")) if (length(dots) == 0){ an <- anova(object) nms <- rownames(an) nms <- setdiff(nms, "Residuals") lg <- object lgf <- formula(lg) nms <- rev(nms) ttt <- vector("list", length(nms)) for (i in seq_along(nms)){ term <- nms[i] smf <- doBy::formula_add_str(lgf, terms=term, op="-") sm <- update(lg, smf, control=lmerControl(check.conv.singular = "ignore")) kk <- comodex(lg, sm, test=test, control=control) out <- as.data.frame(kk) ttt[[i]] <- out lg <- sm lgf <- formula(lg) } ttt <- rev(ttt) ## print(ttt) ttt <- do.call(rbind, ttt) rownames(ttt) <- rev(nms) } else { if (length(dots)==1){ mod <- dots[[1]] ## if (!inherits(mod, "lmerMod")) ## stop("Second argument is not lmerMod\n") ttt <- comodex(object, mod, test=test, control=control) } } class(ttt) <- c("anovax", "data.frame") return(ttt) } ##' @title print anovax object ##' @param x anovax object ##' #' @rdname anovax #' @export print.anovax <- function(x, ...){ ## printCoefmat(x, digits=5, zap.ind =c(3,4)) printCoefmat(x, digits=5) ## old <- options("digits")$digits ## options("digits"=5) ## print.data.frame(x) ## options("digits"=old) return(invisible(x)) } ## lmerControl(check.conv.singular = "ignore") ##' @title Various different tests for model comparison ##' @param object Model object ##' @param object2 Model object or equivalent way of specifying a submodel of lmm1 ##' @param test A vector with the various test types. ##' @param control A list controlling the model comparions. ##' @return Dataframe with results of the various tests ##' @author Søren Højsgaard ##' @export anovax_list <- function(object, object2, test=c("x2", "kr", "sat", "pb"), control=list(nsim=1000)){ if (is.null(control$nsim)) control$nsim <- 1000 lapply(test, function(.test){ anovax(object, object2, test=.test, control=control) }) |> do.call(rbind, args=_) } ## #' @rdname comodex ## #' @export ## comodex.gls <- function(largeModel, smallModel, test="x2", control=list(), details=0, ...){ ## test <- match.arg(tolower(test), c("pb", "x2")) ## modcomp_fun <- switch(test, ## "x2" = x2_modcomp, ## "pb" = pb_modcomp) ## out <- modcomp_fun(largeModel, smallModel, ...) ## out ## } ## #' @rdname comodex ## #' @export ## comodex.glmerMod <- function(largeModel, smallModel, test="x2", control=list(), details=0, ...){ ## test <- match.arg(tolower(test), c("pb", "x2")) ## modcomp_fun <- switch(test, ## "x2" = x2_modcomp, ## "pb" = pb_modcomp) ## out <- modcomp_fun(largeModel, smallModel, ...) ## out ## } ## #' @rdname comodex ## #' @export ## comodex.lm <- comodex.gls ## #' @rdname anovax ## #' @export ## anovax.glmerMod <- function(object, ..., test="x2", control=list(nsim=1000, cl=NULL)){ ## test <- match.arg(tolower(test), c("pb", "x2")) ## anovax_worker(object, ..., test=test, control=control) ## } ## #' @rdname anovax ## #' @export ## anovax.gls <- function(object, ..., test="x2", control=list(nsim=1000, cl=NULL)){ ## test <- match.arg(tolower(test), c("pb", "x2")) ## anovax_worker(object, ..., test=test, control=control) ## } ## #' @rdname anovax ## #' @export ## anovax.lm <- function(object, ..., test="x2", control=list(nsim=1000, cl=NULL)){ ## test <- match.arg(tolower(test), c("pb", "x2")) ## anovax_worker(object, ..., test=test, control=control) ## } pbkrtest/R/SAT_modcomp.R0000644000176200001440000003353515003066713014613 0ustar liggesusers## ########################################################################## ## #' @title F-test and degrees of freedom based on Satterthwaite approximation #' @description An approximate F-test based on the Satterthwaite approach. #' @concept model_comparison #' @name sat__modcomp #' ## ########################################################################## #' @details #' #' Notice: It cannot be guaranteed that the results agree with other #' implementations of the Satterthwaite approach! #' #' @inheritParams kr__modcomp #' @param eps A small number. #' #' @author Søren Højsgaard, \email{sorenh@@math.aau.dk} #' #' @seealso \code{\link{getKR}}, \code{\link[lme4]{lmer}}, \code{\link{vcovAdj}}, #' \code{\link{PBmodcomp}}, \code{\link{KRmodcomp}} #' #' @references Ulrich Halekoh, Søren Højsgaard (2014)., A #' Kenward-Roger Approximation and Parametric Bootstrap Methods #' for Tests in Linear Mixed Models - The R Package pbkrtest., #' Journal of Statistical Software, 58(10), 1-30., #' \url{https://www.jstatsoft.org/v59/i09/} #' #' @keywords models inference #' @examples #' #' (fm0 <- lmer(Reaction ~ (Days|Subject), sleepstudy)) #' (fm1 <- lmer(Reaction ~ Days + (Days|Subject), sleepstudy)) #' (fm2 <- lmer(Reaction ~ Days + I(Days^2) + (Days|Subject), sleepstudy)) #' #' ## Test for no effect of Days in fm1, i.e. test fm0 under fm1 #' SATmodcomp(fm1, "Days") #' SATmodcomp(fm1, ~.-Days) #' L1 <- cbind(0, 1) #' ## SATmodcomp(fm1, L1) ## FIXME #' SATmodcomp(fm1, fm0) #' anova(fm1, fm0) #' #' ## Test for no effect of Days and Days-squared in fm2, i.e. test fm0 under fm2 #' SATmodcomp(fm2, "(Days+I(Days^2))") #' SATmodcomp(fm2, ~. - Days - I(Days^2)) #' L2 <- rbind(c(0, 1, 0), c(0, 0, 1)) #' ## SATmodcomp(fm2, L2) ## FIXME #' SATmodcomp(fm2, fm0) #' anova(fm2, fm0) #' #' ## Test for no effect of Days-squared in fm2, i.e. test fm1 under fm2 #' SATmodcomp(fm2, "I(Days^2)") #' SATmodcomp(fm2, ~. - I(Days^2)) #' L3 <- rbind(c(0, 0, 1)) #' ## SATmodcomp(fm2, L3) ## FIXME #' SATmodcomp(fm2, fm1) #' anova(fm2, fm1) #' @export #' @rdname sat__modcomp SATmodcomp <- function(largeModel, smallModel, betaH=0, details=0, eps=sqrt(.Machine$double.eps)){ UseMethod("SATmodcomp") } #' @export #' @rdname sat__modcomp SATmodcomp.lmerMod <- function(largeModel, smallModel, betaH=0, details=0, eps=sqrt(.Machine$double.eps)){ SATmodcomp_internal(largeModel=largeModel, smallModel=smallModel, betaH=betaH, details=details, eps=eps) } SATmodcomp_internal <- function(largeModel, smallModel, betaH=0, details=0, eps=sqrt(.Machine$double.eps)){ if (is.character(smallModel)) smallModel <- doBy::formula_add_str(formula(largeModel), terms=smallModel, op="-") 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 } SATmodcomp_worker(largeModel, smallModel, betaH=betaH, details=details, eps=eps) } SATmodcomp_worker <- function(largeModel, smallModel, betaH=0, details=0, eps=1e-6) { if (is.null(betaH)) betaH <- 0 if (is.null(details)) details <- 0 ## All computations are based on 'largeModel' and the restriction matrix 'L' ## ------------------------------------------------------------------------- ## print(largeModel) ## print(smallModel) largeModel <- update(largeModel, REML=TRUE) ## FIXME: Almost surely t0 <- proc.time() L <- model2restriction_matrix(largeModel, smallModel) beta <- getME(largeModel, "beta") aux <- compute_auxiliary(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) ## FIXME: do betaDiff <- beta - betaH betaDiff <- beta - betaH ## t2 <- drop(PtL %*% beta)^2 / d[1:qq] t2 <- drop(PtL %*% betaDiff)^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=formula(smallModel), 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) } #' @export summary.SATmodcomp <- function(object, ...){ cat(sprintf("F-test with Satterthwaite approximation; time: %.2f sec\n", object$ctime)) tab <- object$test printCoefmat(tab, tst.ind=c(1,2,3), na.print='', has.Pvalue=TRUE) class(tab) <- c("summary_SATmodcomp", "data.frame") invisible(tab) } 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) } ## 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_auxiliary quantities needed for the Satterthwaite #' approximation. #' #' Computes variance-covariance matrix of variance parameters (theta, sigma), the 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 #' @keywords internal compute_auxiliary <- 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 degrees of freedom for F-test #' #' From a vector of denominator degrees of freedom from independent #' t-statistics (\code{nu}), the denominator degrees of freedom 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 degrees of freedom for the #' t-statistics #' @param tol tolerance on the consecutive 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 degrees of freedom; a numerical scalar #' @keywords internal get_Fstat_ddf <- function(nu, tol=1e-8) { # Computes denominator degrees of freedom 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 degrees of freedom 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 denominator degrees of freedom 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 a linear mixed model 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 covariance of fixed effect parameters as a function of #' variance parameters of a linear mixed model #' #' At the optimum the covariance is available as #' `vcov(lmer-model)`. This function computes `cov(beta)` at non #' (RE)ML estimates of `varpar`. #' #' @inheritParams devfun_vp #' #' @return The covariances matrix of the fixed effects 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.R0000644000176200001440000006260515031571351014465 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. #' @concept model_comparison #' @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 generated. #' #' 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 plot.XXmodcomp #' PBmodcomp.mer getLRT.mer #' #' @inheritParams kr_modcomp #' @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 #' process 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 #' over fit; 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 `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 #' #' \dontrun{ #' (fm0 <- lmer(Reaction ~ (Days|Subject), sleepstudy)) #' (fm1 <- lmer(Reaction ~ Days + (Days|Subject), sleepstudy)) #' (fm2 <- lmer(Reaction ~ Days + I(Days^2) + (Days|Subject), sleepstudy)) #' #' NSIM <- 50 ## Simulations in parametric bootstrap; default is 1000. #' #' ## Test for no effect of Days in fm1, i.e. test fm0 under fm1 #' PBmodcomp(fm1, "Days", cl=1, nsim=NSIM) #' PBmodcomp(fm1, ~.-Days, cl=1, nsim=NSIM) #' L1 <- cbind(0, 1) #' PBmodcomp(fm1, L1, cl=1, nsim=NSIM) #' PBmodcomp(fm1, fm0, cl=1, nsim=NSIM) #' anova(fm1, fm0) #' #' ## Test for no effect of Days and Days-squared in fm2, i.e. test fm0 under fm2 #' PBmodcomp(fm2, "(Days+I(Days^2))", cl=1, nsim=NSIM) #' PBmodcomp(fm2, ~. - Days - I(Days^2), cl=1, nsim=NSIM) #' L2 <- rbind(c(0, 1, 0), c(0, 0, 1)) #' PBmodcomp(fm2, L2, cl=1, nsim=NSIM) ## FIXME #' #' PBmodcomp(fm2, fm0, cl=1, nsim=NSIM) #' anova(fm2, fm0) #' #' ## Test for no effect of Days-squared in fm2, i.e. test fm1 under fm2 #' PBmodcomp(fm2, "I(Days^2)", cl=1, nsim=NSIM) #' PBmodcomp(fm2, ~. - I(Days^2), cl=1, nsim=NSIM) #' L3 <- rbind(c(0, 0, 1)) #' PBmodcomp(fm2, L3, cl=1, nsim=NSIM) #' PBmodcomp(fm2, fm1, cl=1, nsim=NSIM) #' anova(fm2, fm1) #' #' ## Linear normal model: #' sug <- lm(sugpct ~ block + sow + harvest, data=beets) #' sug.h <- update(sug, .~. -harvest) #' sug.s <- update(sug, .~. -sow) #' #' PBmodcomp(sug, "harvest", nsim=NSIM, cl=1) #' PBmodcomp(sug, ~. - harvest, nsim=NSIM, cl=1) #' PBmodcomp(sug, sug.h, nsim=NSIM, cl=1) #' anova(sug, sug.h) #' #' ## Generalized linear model #' mm <- glm(ndead/ntotal ~ sex + log(dose), family=binomial, weight=ntotal, data=budworm) #' mm0 <- update(mm, .~. -sex) #' #' ### Test for no effect of sex #' PBmodcomp(mm, "sex", cl=1, nsim=NSIM) #' PBmodcomp(mm, ~.-sex, cl=1, nsim=NSIM) #' ## PBmodcomp(mm, cbind(0, 1, 0), nsim=NSIM): FIXME #' PBmodcomp(mm, mm0, cl=1, nsim=NSIM) #' anova(mm, mm0, test="Chisq") #' } #' #' ## 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)) #' #' PBmodcomp(gm1, "period", nsim=NSIM) #' PBmodcomp(gm1, ~. -period, nsim=NSIM) #' PBmodcomp(gm1, gm2, nsim=NSIM) #' anova(gm1, gm2) #' } #' #' \dontrun{ #' ## 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) #' PBmodcomp(sug, "harvest", nsim=NSIM, cl=1) #' #' anova(sug, sug.s) #' PBmodcomp(sug, sug.s, nsim=NSIM, cl=1) #' PBmodcomp(sug, "sow", nsim=NSIM, cl=1) #' #' ## Simulate reference distribution separately: #' refdist <- PBrefdist(sug, sug.h, nsim=1000, cl=1) #' refdist <- PBrefdist(sug, "harvest", nsim=1000, cl=1) #' refdist <- PBrefdist(sug, ~.-harvest, nsim=1000, cl=1) #' #' ## Do computations with multiple processors: #' ## Number of cores: #' #' (nc <- detectCores()) #' ## Create clusters #' cl <- makeCluster(rep("localhost", nc)) #' #' ## Then do: #' refdist <- PBrefdist(sug, sug.h, nsim=1000, cl=cl) #' #' ## It is recommended to stop the clusters before quitting R: #' stopCluster(cl) #' } #' #' lm1 <- lm(dist~speed+I(speed^2), data=cars) #' PBmodcomp(lm1, .~.-speed, cl=2) #' PBmodcomp(lm1, .~.-I(speed^2), cl=2) #' #' #' @export #' @rdname pb__modcomp PBmodcomp <- function(largeModel, smallModel, nsim=1000, ref=NULL, seed=NULL, cl=NULL, details=0){ UseMethod("PBmodcomp") } ## ' ## ' @examples ## ' if (requireNamespace("nlme", quietly = TRUE)) { ## ' library(nlme) ## ' ## ' # Load data ## ' data(sleepstudy) ## ' ## ' # Create quadratic term explicitly ## ' sleepstudy$Days2 <- sleepstudy$Days^2 ## ' ## ' # Model 0: Random intercept and slope, no fixed effect for Days ## ' fm0 <- lme(Reaction ~ 1, ## ' random = ~ Days | Subject, ## ' data = sleepstudy, ## ' method = "REML") ## ' ## ' # Model 1: Add fixed effect for Days ## ' fm1 <- lme(Reaction ~ Days, ## ' random = ~ Days | Subject, ## ' data = sleepstudy, ## ' method = "REML") ## ' ## ' # Model 2: Add fixed quadratic effect ## ' fm2 <- lme(Reaction ~ Days + Days2, ## ' random = ~ Days | Subject, ## ' data = sleepstudy, ## ' method = "REML") ## ' ## ' # Create quadratic term explicitly ## ' sleepstudy$Days2 <- sleepstudy$Days^2 ## ' ## ' # Model 0: Intercept only ## ' g0 <- gls(Reaction ~ 1, ## ' data = sleepstudy, ## ' method = "REML") ## ' ## ' # Model 1: Add linear effect of Days ## ' g1 <- gls(Reaction ~ Days, ## ' data = sleepstudy, ## ' method = "REML") ## ' ## ' # Model 2: Add quadratic term ## ' g2 <- gls(Reaction ~ Days + Days2, ## ' data = sleepstudy, ## ' method = "REML") ## ' } ## ' ## ' PBmodcomp(g1, g0) ## ' ## ' PBmodcomp(fm1, fm0) #' @export #' @rdname pb__modcomp PBmodcomp.merMod <- function(largeModel, smallModel, nsim=1000, ref=NULL, seed=NULL, cl=NULL, details=0){ M <- get_nested_model_info(largeModel, smallModel) ## Specific for object class: nr_data <- nrow(getData(M$largeModel)) nr_fit <- getME(largeModel, "n") ## Generic across object classes if (nr_data != nr_fit) stop("Number of rows in data and fit do not match; remove NAs from data before fitting\n") if (is.null(ref)){ ref <- PBrefdist(M$largeModel, M$smallModel, nsim=nsim, seed=seed, cl=cl, details=details) } LRTstat <- getLRT(M$largeModel, M$smallModel) out <- .finalizePB(LRTstat, ref) out <- .padPB(out, LRTstat, ref, M$formula.large, M$formula.small) return(out) } #' @export #' @rdname pb__modcomp PBmodcomp.lm <- function(largeModel, smallModel, nsim=1000, ref=NULL, seed=NULL, cl=NULL, details=0){ M <- get_nested_model_info(largeModel, smallModel) ## Specific for object class: ok.fam <- c("binomial", "gaussian", "Gamma", "inverse.gaussian", "poisson") fam.l <- family(M$largeModel) fam.s <- family(M$smallModel) if (!all.equal(fam.l, fam.s)) 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))) nr_data <- nrow(eval(M$largeModel$call$data)) nr_fit <- nrow(M$largeModel$model) ## Generic across object classes if (nr_data != nr_fit) stop("Number of rows in data and fit do not match; remove NAs from data before fitting\n") if (is.null(ref)){ ref <- PBrefdist(M$largeModel, M$smallModel, nsim=nsim, seed=seed, cl=cl, details=details) } LRTstat <- getLRT(M$largeModel, M$smallModel) out <- .finalizePB(LRTstat, ref) out <- .padPB(out, LRTstat, ref, M$formula.large, M$formula.small) return(out) } #' @export #' @rdname pb_modcomp PBmodcomp.gls <- function(largeModel, smallModel, nsim=1000, ref=NULL, seed=NULL, cl=NULL, details=0){ M <- get_nested_model_info(largeModel, smallModel) ## Specific for object class: nr_data <- nrow(getData(largeModel)) nr_fit <- largeModel$dims$N if (nr_data != nr_fit) stop("Number of rows in data and fit do not match; remove NAs from data before fitting\n") ## Generic across object classes if (is.null(ref)){ ref <- PBrefdist(M$largeModel, M$smallModel, nsim=nsim, seed=seed, cl=cl, details=details) } LRTstat <- getLRT(largeModel, smallModel) out <- .finalizePB(LRTstat, ref) out <- .padPB(out, LRTstat, ref, M$formula.large, M$formula.small) return(out) } PBcompute_p_values <- function(LRTstat, ref){ tobs <- unname(LRTstat[1]) ndf <- unname(LRTstat[2]) ##rr <<- ref 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) ## ddf <- 2 * EE / (EE - 1) EE2 <- EE / ndf ddf <- 2 * EE2 / (EE2 - 1) ## cat("EE:\n"); print(EE); print(ddf) Fobs <- tobs/ndf if (ddf > 2) p.FF <- 1 - pf(Fobs, df1=ndf, df2=ddf) else p.FF <- NA 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), PB_Ftest = c(stat=Fobs, df=ndf, ddf=ddf, p.value=p.FF), Gamma = c(stat=tobs, df=NA, ddf=NA, p.value=p.Ga), Bartlett = c(stat=BCstat, df=ndf, ddf=NA, p.value=p.BC) ) test <- as.data.frame(do.call(rbind, test)) out <- 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, LRTstat = LRTstat, ci = ci, se = se, n.extreme = n.extreme, ctime = attr(ref, "ctime") ) out } .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 } .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 } #' @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 .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 summary.PBmodcomp <- function(object, ...){ ans <- .summarizePB(object$LRTstat, object$ref) ans$formula.large <- object$formula.large ans$formula.small <- object$formula.small class(ans) <- "summary_PBmodcomp" ans } #' @export print.PBmodcomp <- function(x, ...){ .PBcommon(x) tab <- x$test printCoefmat(tab, tst.ind=1, na.print='', has.Pvalue=TRUE) return(invisible(x)) } #' @export print.summary_PBmodcomp <- function(x, ...){ .PBcommon(x) tab <- x$test printCoefmat(tab, tst.ind=1, na.print='', has.Pvalue=TRUE) cat("\n") return(invisible(x)) } #' @export as.data.frame.XXmodcomp <- function(x, row.names = NULL, optional = FALSE, ...){ as.data.frame(do.call(rbind, x[-c(1:3)])) } ## 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])) #' @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 ## PBmodcomp.mer <- PBmodcomp.merMod ## #' @export ## #' @rdname pb__modcomp ## PBFmodcomp <- function(largeModel, smallModel, ## nsim=500, ref=NULL, seed=NULL, cl=NULL, ## details=0){ ## ## if (is.null(control$nsim)) control$nsim <- 1000 ## ans <- PBmodcomp(largeModel, smallModel, ## nsim=nsim, ref=ref, seed=seed, cl=cl, ## details=details) ## ## heading <- attr(ans, "heading") ## ## out <- attr(ans, "aux")$test["PB_Ftest",] ## ## attr(out, "heading") <- heading ## ## attr(out, "aux") <- attr(ans, "aux") ## class(out) <- c("PBFmodcomp", "anova", "data.frame") ## out ## } ## PBmodcomp.lm ## if (is.character(smallModel)) ## smallModel <- doBy::formula_add_str(formula(largeModel), terms=smallModel, op="-") ## 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 <- restriction_matrix2model(largeModel, smallModel) ## } else { ## formula.small <- formula(smallModel) ## attributes(formula.small) <- NULL ## } ## PBmodcomp.merMod ## if (is.character(smallModel)) ## smallModel <- doBy::formula_add_str(formula(largeModel), terms=smallModel, op="-") ## if (inherits(smallModel, "formula")) ## smallModel <- update(largeModel, smallModel, control=lmerControl(check.conv.singular = "ignore")) ## if (is.numeric(smallModel) && !is.matrix(smallModel)) ## smallModel <- matrix(smallModel, nrow=1) ## if (inherits(smallModel, c("Matrix", "matrix"))){ ## formula.small <- smallModel ## smallModel <- restriction_matrix2model(largeModel, smallModel, REML=FALSE) ## } else { ## formula.small <- formula(smallModel) ## attributes(formula.small) <- NULL ## } ## formula.large <- formula(largeModel) ## attributes(formula.large) <- NULL ## All computations are based on 'largeModel' and 'smallModel' ## which at this point are both model objects. ## ----------------------------------------------------------- ## cat("ref\n"); print(ref) ## largeModel <<- largeModel ## smallModel <<- smallModel ## dd <- logLik(largeModel) - logLik(smallModel) ## cat("dd:\n"); print(dd) ## ll.small <- logLik(smallModel, REML=FALSE) ## ll.large <- logLik(largeModel, REML=FALSE) ## dd <- ll.large - ll.small ## cat("dd:\n"); print(dd) pbkrtest/R/NAMESPACE_pbkrtest.R0000644000176200001440000000151315031203742015643 0ustar liggesusers#' @import lme4 #' @importFrom MASS ginv #' @importFrom utils head #' @importFrom stats coef anova #' #' @importFrom parallel clusterCall clusterExport clusterSetRNGStream #' mclapply detectCores makeCluster stopCluster #' #' @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 #' #' @importFrom dplyr as_tibble #' @title pbkrtest internal #' @description pbkrtest internal #' @name internal-pbkrtest #' NULL pbkrtest/R/KR_vcovAdj.R0000644000176200001440000001645415031571015014434 0ustar liggesusers################################################################################ #' #' @title Adjusted covariance matrix for linear mixed models according #' to Kenward and Roger #' @description Kenward and Roger (1997) describe an improved small #' sample approximation to the covariance matrix estimate of the #' fixed parameters in a linear mixed model. #' @name kr-vcovAdj #' ################################################################################ ## 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 effects} #' #' \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[lme4]{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, REML=TRUE) #' class(fm1) #' #' set.seed(123) #' sleepstudy2 <- sleepstudy[sample(nrow(sleepstudy), size=120), ] #' #' fm2 <- lmer(Reaction ~ Days + (Days|Subject), sleepstudy2, REML=TRUE) #' #' ## Here the adjusted and unadjusted covariance matrices are identical, #' ## but that is not generally the case: #' #' v1 <- vcov(fm1) #' v1a <- vcovAdj(fm1, details=0) #' v1a / v1 #' #' v2 <- vcov(fm2) #' v2a <- vcovAdj(fm2, details=0) #' v2a / v2 #' #' # For comparison, an alternative estimate of the #' # variance-covariance matrix is based on parametric bootstrap (and #' # this is easily parallelized): #' #' @export vcovAdj #' #' @rdname kr-vcovAdj vcovAdj <- function(object, details=0){ UseMethod("vcovAdj") } #' @method vcovAdj lmerMod #' @rdname kr-vcovAdj #' @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) ) ) ## SS <<- SigmaG$Sigma ## November 2022: The line below causes random errors ## SigmaInv <- chol2inv( chol( forceSymmetric(as(SigmaG$Sigma, "matrix")))) ##SigmaInv <- as(SigmaInv, "dpoMatrix") if(DB){ cat(sprintf("Finding SigmaInv: time: %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: time: %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: time: %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: time: %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: time: %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 } ## ' \dontrun{ ## ' nsim <- 100 ## ' ## ' sim1 <- simulate(fm1, nsim) ## ' B1 <- lapply(sim1, function(y){ ## ' fixef(refit(fm1, newresp=y)) ## ' }) ## ' ## ' sim2 <- simulate(fm2, nsim) ## ' B2 <- lapply(sim2, function(y){ ## ' fixef(refit(fm2, newresp=y)) ## ' }) ## ' ## ' B1 <- do.call(rbind, B1) ## ' B2 <- do.call(rbind, B2) ## ' ## ' v13 <- cov.wt(B1)$cov ## ' v23 <- cov.wt(B2)$cov ## ' ## ' v13 / v1 ## ' v23 / v2 ## ' ## ' v13 / v1a ## ' v23 / v2a ## ' } ## ' pbkrtest/NEWS0000644000176200001440000000420015032042101012567 0ustar liggesuserspbkrtest 0.5.5 (Release date: 2025-07-04) ============================================ Changes: * Various updates preparing for new major release. pbkrtest 0.5.4 (Release date: 2025-04-27) ============================================ Changes * `anovax()` function added. Similar to anova but with support for different types of tests. * Functions `pb_modcomp()`, `kr_modcomp()`, `sat_modcomp()`, `x2_modcomp()` added. They have a standardized interface and invoke the old PBmodcomp() etc functions. * PBmodcomp method added for `gls` objects. pbkrtest 0.5.3 (Release date: 2024-06-26) ============================================ Changes * Improved documentation of PBmodcomp, KRmodcomp, SATmodcomp pbkrtest 0.5.2 (Release date: 2023-01-19) ============================================ Changes * remat changed to restriction_matrix for increased readability * WORDLIST file added * Changes in reference to JSS paper * Various changes in documentation * Satterthwaite approximation now illustrated in vignette * Fixed bug in computation of LRTstatistic. Thanks to Helle Sorensen for pointing it out. pbkrtest 0.5.1 (Release date: 2021-03-09) ============================================ Changes * Improved documentation pbkrtest 0.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 0.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 0.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/vignettes/0000755000176200001440000000000015032042247014117 5ustar liggesuserspbkrtest/vignettes/a02-coercion.rmd0000644000176200001440000000370514721100744017012 0ustar liggesusers--- title: "02 - Coercion between model objects and restriction matrices in 'pbkrtest'" author: "Søren Højsgaard and Ulrich Halekoh" output: rmarkdown::html_vignette vignette: > %\VignetteEngine{knitr::knitr} %\VignetteIndexEntry{02 - Coercion between model objects and restriction matrices in 'pbkrtest'} %\VignetteEncoding{UTF-8} --- ```{r, echo=FALSE} require( pbkrtest ) prettyVersion <- packageDescription("pbkrtest")$Version prettyDate <- format(Sys.Date()) ``` ```{r setup, include=FALSE} knitr::opts_chunk$set(echo = TRUE) options("warn"=-1) ## FIXME Fragile; issue with rankMatrix(, method="qr.R") ``` **Package version: `r prettyVersion`** Consider two linear models; the smaller is a submodel of the large: ```{r} N <- 4 dat <- data.frame(int=rep(1, N), x=1:N, y=rnorm(N)) ``` ```{r} lg <- lm(y ~ x + I(x^2), data=dat) sm <- lm(y ~ x, data=dat) lg sm ``` The corresponding model matrices are ```{r} Xlg <- model.matrix(lg) Xsm <- model.matrix(sm) Xlg Xsm ``` Given the two model matrices, the restriction matrix which describes the restrictions that should be made to the model matrix of the large model to produce the model matrix of the small model: ```{r} L <- make_restriction_matrix(Xlg, Xsm) L ``` Given the model matrix of the large model and the restriction matrix, the model matrix of the small model can be constructed as: ```{r} Xsm_2 <- make_model_matrix(Xlg, L) Xsm_2 ``` The same operation can be made directly on model objects: ```{r} L <- model2restriction_matrix(lg, sm) L ``` Likewise, given the large model and the restriction matrix, the small model can be constructed: ```{r} sm_2 <- restriction_matrix2model(lg, L) sm_2 sm_2 |> model.matrix() ``` Lastly, model matrices can be compared ```{r} ## The first column space contains the second compare_column_space(Xlg, Xsm) ## The second column space contains the first compare_column_space(Xsm, Xlg) ## The two column spaces are identical compare_column_space(Xlg, Xlg) ``` pbkrtest/vignettes/a01-pbkrtest.rmd0000644000176200001440000001144415031443112017037 0ustar liggesusers--- title: "01 - Introduction to 'pbkrtest'" author: "Søren Højsgaard and Ulrich Halekoh" output: rmarkdown::html_vignette vignette: > %\VignetteEngine{knitr::knitr} %\VignetteIndexEntry{01 - Introduction to 'pbkrtest'} %\VignetteEncoding{UTF-8} --- ```{r, echo=FALSE} require( pbkrtest ) prettyVersion <- packageDescription("pbkrtest")$Version prettyDate <- format(Sys.Date()) ``` ```{r setup, include=FALSE} knitr::opts_chunk$set(echo = TRUE) options("warn"=-1) ## FIXME Fragile; issue with rankMatrix(, method="qr.R") ``` **Package version: `r prettyVersion`** # Introduction ```{r} library(broom) ``` 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. ```{r} data(shoes, package="MASS") shoes ``` A plot reveals that boys wear their shoes differently. ```{r} 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) ``` One option for testing the effect of materials is to make a paired $t$--test, e.g.\ as: ```{r} r1 <- t.test(shoes$A, shoes$B, paired=T) r1 |> tidy() ``` 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: ```{r} boy <- rep(1:10, 2) boyf<- factor(letters[boy]) material <- factor(c(rep("A", 10), rep("B", 10))) ## Balanced data: shoe.bal <- data.frame(wear=unlist(shoes), boy=boy, boyf=boyf, material=material) head(shoe.bal) ## Imbalanced data; delete (boy=1, material=1) and (boy=2, material=b) shoe.imbal <- shoe.bal[-c(1, 12),] ``` We fit models to the two datasets: ```{r} lmm1.bal <- lmer( wear ~ material + (1|boyf), data=shoe.bal) lmm0.bal <- update(lmm1.bal, .~. - material) lmm1.imbal <- lmer(wear ~ material + (1|boyf), data=shoe.imbal) lmm0.imbal <- update(lmm1.imbal, .~. - material) ``` The asymptotic likelihood ratio test shows stronger significance than the $t$--test: ```{r} anova(lmm1.bal, lmm0.bal, test="Chisq") |> tidy() anova(lmm1.imbal, lmm0.imbal, test="Chisq") |> tidy() ``` # Kenward--Roger approach The Kenward--Roger approximation is exact in certain balanced designs in the sense that the approximation produces the same result as the paired $t$--test. ```{r} kr.bal <- KRmodcomp(lmm1.bal, lmm0.bal) kr.bal |> tidy() summary(kr.bal) |> tidy() ``` For the imbalanced data we get ```{r} kr.imbal <- KRmodcomp(lmm1.imbal, lmm0.imbal) kr.imbal |> tidy() summary(kr.imbal) |> tidy() ``` Estimated degrees of freedom can be found with ```{r} c(bal_ddf = getKR(kr.bal, "ddf"), imbal_ddf = getKR(kr.imbal, "ddf")) ``` Notice that the Kenward-Roger approximation gives results similar to but not identical to the paired $t$--test when the two boys are removed: ```{r} shoes2 <- list(A=shoes$A[-(1:2)], B=shoes$B[-(1:2)]) t.test(shoes2$A, shoes2$B, paired=T) |> tidy() ``` # Satterthwaite approach The Satterthwaite approximation is exact in certain balanced designs in the sense that the approximation produces the same result as the paired $t$--test. ```{r} sat.bal <- SATmodcomp(lmm1.bal, lmm0.bal) sat.bal |> tidy() ``` ```{r} sat.imbal <- SATmodcomp(lmm1.imbal, lmm0.imbal) sat.imbal |> tidy() ``` Estimated degrees of freedom can be found with ```{r} c(bal_ddf = getSAT(sat.bal, "ddf"), imbal_ddf = getSAT(sat.imbal, "ddf")) ``` # 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 computations can be made en parallel, see the documentation): ```{r} pb.bal <- PBmodcomp(lmm1.bal, lmm0.bal, nsim=500, cl=2) pb.bal |> tidy() summary(pb.bal) |> tidy() ``` For the imbalanced data, the result is similar to the result from the paired $t$--test. ```{r} pb.imbal <- PBmodcomp(lmm1.imbal, lmm0.imbal, nsim=500, cl=2) pb.imbal |> tidy() summary(pb.imbal) |> tidy() ``` # Matrices for random effects The matrices involved in the random effects can be obtained with ```{r} shoe3 <- subset(shoe.bal, boy<=5) shoe3 <- shoe3[order(shoe3$boy), ] lmm1 <- lmer( wear ~ material + (1|boyf), data=shoe3 ) str( SG <- get_SigmaG( lmm1 ), max=2) ``` ```{r} round( SG$Sigma*10 ) ``` ```{r} SG$G ``` pbkrtest/data/0000755000176200001440000000000014721100744013021 5ustar liggesuserspbkrtest/data/budworm.RData0000755000176200001440000000034714721100744015424 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.RData0000755000176200001440000000067014721100744015046 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/ChangeLog0000644000176200001440000001146214721100744013666 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/NAMESPACE0000644000176200001440000000641515032041450013327 0ustar liggesusers# Generated by roxygen2: do not edit by hand S3method(KRmodcomp,lmerMod) S3method(PBmodcomp,gls) S3method(PBmodcomp,lm) S3method(PBmodcomp,merMod) S3method(PBrefdist,gls) S3method(PBrefdist,lm) S3method(PBrefdist,merMod) S3method(SATmodcomp,lmerMod) S3method(X2modcomp,default) S3method(anovax,default) S3method(anovax,lmerMod) S3method(as.data.frame,KRmodcomp) S3method(as.data.frame,PBmodcomp) S3method(as.data.frame,SATmodcomp) S3method(as.data.frame,XXmodcomp) S3method(getLRT,glmerMod) S3method(getLRT,gls) S3method(getLRT,lm) S3method(getLRT,lme) S3method(getLRT,lmerMod) S3method(get_Lb_ddf,lmerMod) S3method(get_SigmaG,lmerMod) S3method(model2restriction_matrix,default) S3method(model2restriction_matrix,lm) S3method(model2restriction_matrix,merMod) S3method(plot,PBmodcomp) S3method(print,KRmodcomp) S3method(print,PBmodcomp) S3method(print,SATmodcomp) S3method(print,anovax) S3method(print,refdist) S3method(print,summary_PBmodcomp) S3method(restriction_matrix2model,default) S3method(restriction_matrix2model,glmerMod) S3method(restriction_matrix2model,lm) S3method(restriction_matrix2model,lmerMod) S3method(summary,KRmodcomp) S3method(summary,PBmodcomp) S3method(summary,SATmodcomp) S3method(tidy,KRmodcomp) S3method(tidy,PBmodcomp) S3method(tidy,SATmodcomp) S3method(tidy,summary_KRmodcomp) S3method(tidy,summary_PBmodcomp) S3method(vcovAdj,lmerMod) export(KRmodcomp) export(Lb_ddf) export(PBmodcomp) export(PBrefdist) export(SATmodcomp) export(X2modcomp) export(anovax) export(anovax_list) export(compare_column_space) export(ddf_Lb) export(getKR) export(getLRT) export(getSAT) export(get_Lb_ddf) export(get_SigmaG) export(get_nested_model_info) export(kr_modcomp) export(make_model_matrix) export(make_restriction_matrix) export(model2restriction_matrix) export(pb_modcomp) export(restriction_matrix2model) export(sat_modcomp) export(vcovAdj) export(vcovAdj.lmerMod) export(x2_modcomp) 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(methods,as) importFrom(methods,is) importFrom(parallel,clusterCall) importFrom(parallel,clusterExport) importFrom(parallel,clusterSetRNGStream) importFrom(parallel,detectCores) importFrom(parallel,makeCluster) importFrom(parallel,mclapply) importFrom(parallel,stopCluster) importFrom(stats,anova) 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/inst/0000755000176200001440000000000015032042247013064 5ustar liggesuserspbkrtest/inst/CITATION0000755000176200001440000000144514721100744014231 0ustar liggesuserscitHeader("To cite pbkrtest in publications use:") bibentry(bibtype = "Article", title = "A Kenward-Roger Approximation and Parametric Bootstrap Methods for Tests in Linear Mixed Models -- The {R} Package {pbkrtest}", author = c("Ulrich Halekoh", "Søren Hø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/.") ) pbkrtest/inst/doc/0000755000176200001440000000000015032042247013631 5ustar liggesuserspbkrtest/inst/doc/a01-pbkrtest.R0000644000176200001440000000735615032042247016204 0ustar liggesusers## ----echo=FALSE--------------------------------------------------------------- require( pbkrtest ) prettyVersion <- packageDescription("pbkrtest")$Version prettyDate <- format(Sys.Date()) ## ----setup, include=FALSE----------------------------------------------------- knitr::opts_chunk$set(echo = TRUE) options("warn"=-1) ## FIXME Fragile; issue with rankMatrix(, method="qr.R") ## ----------------------------------------------------------------------------- library(broom) ## ----------------------------------------------------------------------------- data(shoes, package="MASS") shoes ## ----------------------------------------------------------------------------- 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) ## ----------------------------------------------------------------------------- r1 <- t.test(shoes$A, shoes$B, paired=T) r1 |> tidy() ## ----------------------------------------------------------------------------- boy <- rep(1:10, 2) boyf<- factor(letters[boy]) material <- factor(c(rep("A", 10), rep("B", 10))) ## Balanced data: shoe.bal <- data.frame(wear=unlist(shoes), boy=boy, boyf=boyf, material=material) head(shoe.bal) ## Imbalanced data; delete (boy=1, material=1) and (boy=2, material=b) shoe.imbal <- shoe.bal[-c(1, 12),] ## ----------------------------------------------------------------------------- lmm1.bal <- lmer( wear ~ material + (1|boyf), data=shoe.bal) lmm0.bal <- update(lmm1.bal, .~. - material) lmm1.imbal <- lmer(wear ~ material + (1|boyf), data=shoe.imbal) lmm0.imbal <- update(lmm1.imbal, .~. - material) ## ----------------------------------------------------------------------------- anova(lmm1.bal, lmm0.bal, test="Chisq") |> tidy() anova(lmm1.imbal, lmm0.imbal, test="Chisq") |> tidy() ## ----------------------------------------------------------------------------- kr.bal <- KRmodcomp(lmm1.bal, lmm0.bal) kr.bal |> tidy() summary(kr.bal) |> tidy() ## ----------------------------------------------------------------------------- kr.imbal <- KRmodcomp(lmm1.imbal, lmm0.imbal) kr.imbal |> tidy() summary(kr.imbal) |> tidy() ## ----------------------------------------------------------------------------- c(bal_ddf = getKR(kr.bal, "ddf"), imbal_ddf = getKR(kr.imbal, "ddf")) ## ----------------------------------------------------------------------------- shoes2 <- list(A=shoes$A[-(1:2)], B=shoes$B[-(1:2)]) t.test(shoes2$A, shoes2$B, paired=T) |> tidy() ## ----------------------------------------------------------------------------- sat.bal <- SATmodcomp(lmm1.bal, lmm0.bal) sat.bal |> tidy() ## ----------------------------------------------------------------------------- sat.imbal <- SATmodcomp(lmm1.imbal, lmm0.imbal) sat.imbal |> tidy() ## ----------------------------------------------------------------------------- c(bal_ddf = getSAT(sat.bal, "ddf"), imbal_ddf = getSAT(sat.imbal, "ddf")) ## ----------------------------------------------------------------------------- pb.bal <- PBmodcomp(lmm1.bal, lmm0.bal, nsim=500, cl=2) pb.bal |> tidy() summary(pb.bal) |> tidy() ## ----------------------------------------------------------------------------- pb.imbal <- PBmodcomp(lmm1.imbal, lmm0.imbal, nsim=500, cl=2) pb.imbal |> tidy() summary(pb.imbal) |> tidy() ## ----------------------------------------------------------------------------- shoe3 <- subset(shoe.bal, boy<=5) shoe3 <- shoe3[order(shoe3$boy), ] lmm1 <- lmer( wear ~ material + (1|boyf), data=shoe3 ) str( SG <- get_SigmaG( lmm1 ), max=2) ## ----------------------------------------------------------------------------- round( SG$Sigma*10 ) ## ----------------------------------------------------------------------------- SG$G pbkrtest/inst/doc/a01-pbkrtest.html0000644000176200001440000007551615032042247016752 0ustar liggesusers 01 - Introduction to ‘pbkrtest’

01 - Introduction to ‘pbkrtest’

Søren Højsgaard and Ulrich Halekoh

## Loading required package: pbkrtest

## Loading required package: lme4

## Loading required package: Matrix

Package version: 0.5.5

Introduction

library(broom)

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

## $A
##  [1] 13.2  8.2 10.9 14.3 10.7  6.6  9.5 10.8  8.8 13.3
## 
## $B
##  [1] 14.0  8.8 11.2 14.2 11.8  6.4  9.8 11.3  9.3 13.6

A plot 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)

plot of chunk unnamed-chunk-4

One option for testing the effect of materials is to make a paired \(t\)–test, e.g.\ as:

r1 <- t.test(shoes$A, shoes$B, paired=T)
r1 |> tidy()

## # A tibble: 1 × 8
##   estimate statistic p.value parameter conf.low conf.high method     alternative
##      <dbl>     <dbl>   <dbl>     <dbl>    <dbl>     <dbl> <chr>      <chr>      
## 1    -0.41     -3.35 0.00854         9   -0.687    -0.133 Paired t-… two.sided

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])
material <- factor(c(rep("A", 10), rep("B", 10)))
## Balanced data:
shoe.bal <- data.frame(wear=unlist(shoes), boy=boy, boyf=boyf, material=material)
head(shoe.bal)

##    wear boy boyf material
## A1 13.2   1    a        A
## A2  8.2   2    b        A
## A3 10.9   3    c        A
## A4 14.3   4    d        A
## A5 10.7   5    e        A
## A6  6.6   6    f        A

## Imbalanced data; delete (boy=1, material=1) and (boy=2, material=b)
shoe.imbal <-  shoe.bal[-c(1, 12),]

We fit models to the two datasets:

lmm1.bal  <- lmer( wear ~ material + (1|boyf), data=shoe.bal)
lmm0.bal  <- update(lmm1.bal, .~. - material)
lmm1.imbal  <- lmer(wear ~ material + (1|boyf), data=shoe.imbal)
lmm0.imbal  <- update(lmm1.imbal, .~. - material)

The asymptotic likelihood ratio test shows stronger significance than the \(t\)–test:

anova(lmm1.bal, lmm0.bal, test="Chisq")  |> tidy()

## refitting model(s) with ML (instead of REML)

## # A tibble: 2 × 9
##   term      npar   AIC   BIC logLik minus2logL statistic    df  p.value
##   <chr>    <dbl> <dbl> <dbl>  <dbl>      <dbl>     <dbl> <dbl>    <dbl>
## 1 lmm0.bal     3  67.9  70.9  -31.0       61.9     NA       NA NA      
## 2 lmm1.bal     4  61.8  65.8  -26.9       53.8      8.09     1  0.00445

anova(lmm1.imbal, lmm0.imbal, test="Chisq")  |> tidy()

## refitting model(s) with ML (instead of REML)

## # A tibble: 2 × 9
##   term        npar   AIC   BIC logLik minus2logL statistic    df p.value
##   <chr>      <dbl> <dbl> <dbl>  <dbl>      <dbl>     <dbl> <dbl>   <dbl>
## 1 lmm0.imbal     3  63.9  66.5  -28.9       57.9     NA       NA NA     
## 2 lmm1.imbal     4  60.8  64.3  -26.4       52.8      5.09     1  0.0240

Kenward–Roger approach

The Kenward–Roger approximation is exact in certain balanced designs in the sense that the approximation produces the same result as the paired \(t\)–test.

kr.bal <- KRmodcomp(lmm1.bal, lmm0.bal)
kr.bal |> tidy()

## # A tibble: 1 × 5
##   type   stat   ndf   ddf p.value
##   <chr> <dbl> <int> <dbl>   <dbl>
## 1 Ftest  11.2     1  9.00 0.00854

summary(kr.bal) |> tidy() 

## F-test with Kenward-Roger approximation; time: 0.03 sec
## large : wear ~ material + (1 | boyf)
## small : wear ~ (1 | boyf)
##          stat    ndf    ddf F.scaling  p.value   
## Ftest  11.215  1.000  9.000         1 0.008539 **
## FtestU 11.215  1.000  9.000           0.008539 **
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1

## # A tibble: 2 × 6
##   type    stat   ndf   ddf F.scaling p.value
##   <chr>  <dbl> <int> <dbl>     <dbl>   <dbl>
## 1 Ftest   11.2     1  9.00         1 0.00854
## 2 FtestU  11.2     1  9.00        NA 0.00854

For the imbalanced data we get

kr.imbal <- KRmodcomp(lmm1.imbal, lmm0.imbal)
kr.imbal |> tidy()

## # A tibble: 1 × 5
##   type   stat   ndf   ddf p.value
##   <chr> <dbl> <int> <dbl>   <dbl>
## 1 Ftest  5.99     1  7.02  0.0442

summary(kr.imbal) |> tidy()

## F-test with Kenward-Roger approximation; time: 0.01 sec
## large : wear ~ material + (1 | boyf)
## small : wear ~ (1 | boyf)
##          stat    ndf    ddf F.scaling p.value  
## Ftest  5.9893 1.0000 7.0219         1 0.04418 *
## FtestU 5.9893 1.0000 7.0219           0.04418 *
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1

## # A tibble: 2 × 6
##   type    stat   ndf   ddf F.scaling p.value
##   <chr>  <dbl> <int> <dbl>     <dbl>   <dbl>
## 1 Ftest   5.99     1  7.02         1  0.0442
## 2 FtestU  5.99     1  7.02        NA  0.0442

Estimated degrees of freedom can be found with

c(bal_ddf = getKR(kr.bal, "ddf"), imbal_ddf = getKR(kr.imbal, "ddf"))

##   bal_ddf imbal_ddf 
##  9.000000  7.021904

Notice that the Kenward-Roger approximation gives results similar to but not identical to the paired \(t\)–test when the two boys are removed:

shoes2 <- list(A=shoes$A[-(1:2)], B=shoes$B[-(1:2)])
t.test(shoes2$A, shoes2$B, paired=T) |> tidy()

## # A tibble: 1 × 8
##   estimate statistic p.value parameter conf.low conf.high method     alternative
##      <dbl>     <dbl>   <dbl>     <dbl>    <dbl>     <dbl> <chr>      <chr>      
## 1   -0.337     -2.39  0.0483         7   -0.672  -0.00328 Paired t-… two.sided

Satterthwaite approach

The Satterthwaite approximation is exact in certain balanced designs in the sense that the approximation produces the same result as the paired \(t\)–test.

sat.bal <- SATmodcomp(lmm1.bal, lmm0.bal)
sat.bal |> tidy()

## # A tibble: 1 × 5
##   type  statistic   ndf   ddf p.value
##   <chr>     <dbl> <int> <dbl>   <dbl>
## 1 Ftest      11.2     1  9.00 0.00854

sat.imbal <- SATmodcomp(lmm1.imbal, lmm0.imbal)
sat.imbal |> tidy()

## # A tibble: 1 × 5
##   type  statistic   ndf   ddf p.value
##   <chr>     <dbl> <int> <dbl>   <dbl>
## 1 Ftest      6.00     1  7.01  0.0441

Estimated degrees of freedom can be found with

c(bal_ddf = getSAT(sat.bal, "ddf"), imbal_ddf = getSAT(sat.imbal, "ddf"))

##   bal_ddf imbal_ddf 
##  9.000000  7.010863

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 computations can be made en parallel, see the documentation):

pb.bal <- PBmodcomp(lmm1.bal, lmm0.bal, nsim=500, cl=2)
pb.bal |> tidy()

## # A tibble: 2 × 4
##   type    stat    df p.value
##   <chr>  <dbl> <dbl>   <dbl>
## 1 LRT     8.09     1 0.00445
## 2 PBtest  8.09    NA 0.00599

summary(pb.bal) |> tidy()

## # A tibble: 5 × 5
##   type      stat    df   ddf p.value
##   <chr>    <dbl> <dbl> <dbl>   <dbl>
## 1 LRT       8.09     1  NA   0.00445
## 2 PBtest    8.09    NA  NA   0.00599
## 3 Gamma     8.09    NA  NA   0.00596
## 4 Bartlett  7.43     1  NA   0.00640
## 5 F         8.09     1  24.6 0.00882

For the imbalanced data, the result is similar to the result from the paired \(t\)–test.

pb.imbal <- PBmodcomp(lmm1.imbal, lmm0.imbal, nsim=500, cl=2)
pb.imbal |> tidy()

## # A tibble: 2 × 4
##   type    stat    df p.value
##   <chr>  <dbl> <dbl>   <dbl>
## 1 LRT     5.09     1  0.0240
## 2 PBtest  5.09    NA  0.0419

summary(pb.imbal)  |> tidy()

## # A tibble: 5 × 5
##   type      stat    df   ddf p.value
##   <chr>    <dbl> <dbl> <dbl>   <dbl>
## 1 LRT       5.09     1 NA     0.0240
## 2 PBtest    5.09    NA NA     0.0419
## 3 Gamma     5.09    NA NA     0.0406
## 4 Bartlett  4.01     1 NA     0.0452
## 5 F         5.09     1  9.41  0.0492

Matrices for random effects

The matrices involved in the random effects can be obtained with

shoe3 <- subset(shoe.bal, boy<=5)
shoe3 <- shoe3[order(shoe3$boy), ]
lmm1  <- lmer( wear ~ material + (1|boyf), data=shoe3 )
str( SG <- get_SigmaG( lmm1 ), max=2)

## List of 3
##  $ Sigma   :Formal class 'dgCMatrix' [package "Matrix"] with 6 slots
##  $ G       :List of 2
##   ..$ :Formal class 'dgCMatrix' [package "Matrix"] with 6 slots
##   ..$ :Formal class 'dgCMatrix' [package "Matrix"] with 6 slots
##  $ n.ggamma: int 2

round( SG$Sigma*10 )

## 10 x 10 sparse Matrix of class "dgCMatrix"

##   [[ suppressing 10 column names 'A1', 'B1', 'A2' ... ]]

##                                 
## A1 53 52  .  .  .  .  .  .  .  .
## B1 52 53  .  .  .  .  .  .  .  .
## A2  .  . 53 52  .  .  .  .  .  .
## B2  .  . 52 53  .  .  .  .  .  .
## A3  .  .  .  . 53 52  .  .  .  .
## B3  .  .  .  . 52 53  .  .  .  .
## A4  .  .  .  .  .  . 53 52  .  .
## B4  .  .  .  .  .  . 52 53  .  .
## A5  .  .  .  .  .  .  .  . 53 52
## B5  .  .  .  .  .  .  .  . 52 53

SG$G

## [[1]]
## 10 x 10 sparse Matrix of class "dgCMatrix"

##   [[ suppressing 10 column names 'A1', 'B1', 'A2' ... ]]

##                       
## A1 1 1 . . . . . . . .
## B1 1 1 . . . . . . . .
## A2 . . 1 1 . . . . . .
## B2 . . 1 1 . . . . . .
## A3 . . . . 1 1 . . . .
## B3 . . . . 1 1 . . . .
## A4 . . . . . . 1 1 . .
## B4 . . . . . . 1 1 . .
## A5 . . . . . . . . 1 1
## B5 . . . . . . . . 1 1
## 
## [[2]]
## 10 x 10 sparse Matrix of class "dgCMatrix"
##                          
##  [1,] 1 . . . . . . . . .
##  [2,] . 1 . . . . . . . .
##  [3,] . . 1 . . . . . . .
##  [4,] . . . 1 . . . . . .
##  [5,] . . . . 1 . . . . .
##  [6,] . . . . . 1 . . . .
##  [7,] . . . . . . 1 . . .
##  [8,] . . . . . . . 1 . .
##  [9,] . . . . . . . . 1 .
## [10,] . . . . . . . . . 1
pbkrtest/inst/doc/a02-coercion.R0000644000176200001440000000314715032042247016142 0ustar liggesusers## ----echo=FALSE--------------------------------------------------------------- require( pbkrtest ) prettyVersion <- packageDescription("pbkrtest")$Version prettyDate <- format(Sys.Date()) ## ----setup, include=FALSE----------------------------------------------------- knitr::opts_chunk$set(echo = TRUE) options("warn"=-1) ## FIXME Fragile; issue with rankMatrix(, method="qr.R") ## ----------------------------------------------------------------------------- N <- 4 dat <- data.frame(int=rep(1, N), x=1:N, y=rnorm(N)) ## ----------------------------------------------------------------------------- lg <- lm(y ~ x + I(x^2), data=dat) sm <- lm(y ~ x, data=dat) lg sm ## ----------------------------------------------------------------------------- Xlg <- model.matrix(lg) Xsm <- model.matrix(sm) Xlg Xsm ## ----------------------------------------------------------------------------- L <- make_restriction_matrix(Xlg, Xsm) L ## ----------------------------------------------------------------------------- Xsm_2 <- make_model_matrix(Xlg, L) Xsm_2 ## ----------------------------------------------------------------------------- L <- model2restriction_matrix(lg, sm) L ## ----------------------------------------------------------------------------- sm_2 <- restriction_matrix2model(lg, L) sm_2 sm_2 |> model.matrix() ## ----------------------------------------------------------------------------- ## The first column space contains the second compare_column_space(Xlg, Xsm) ## The second column space contains the first compare_column_space(Xsm, Xlg) ## The two column spaces are identical compare_column_space(Xlg, Xlg) pbkrtest/inst/doc/a02-coercion.html0000644000176200001440000001765415032042247016715 0ustar liggesusers 02 - Coercion between model objects and restriction matrices in ‘pbkrtest’

02 - Coercion between model objects and restriction matrices in ‘pbkrtest’

Søren Højsgaard and Ulrich Halekoh

Package version: 0.5.5

Consider two linear models; the smaller is a submodel of the large:

N <- 4
dat <- data.frame(int=rep(1, N), x=1:N, y=rnorm(N))

lg <- lm(y ~ x + I(x^2), data=dat)
sm <- lm(y ~ x, data=dat)
lg

## 
## Call:
## lm(formula = y ~ x + I(x^2), data = dat)
## 
## Coefficients:
## (Intercept)            x       I(x^2)  
##      1.3032      -2.1246       0.5443

sm

## 
## Call:
## lm(formula = y ~ x, data = dat)
## 
## Coefficients:
## (Intercept)            x  
##     -1.4181       0.5967

The corresponding model matrices are

Xlg <- model.matrix(lg)
Xsm <- model.matrix(sm)
Xlg

##   (Intercept) x I(x^2)
## 1           1 1      1
## 2           1 2      4
## 3           1 3      9
## 4           1 4     16
## attr(,"assign")
## [1] 0 1 2

Xsm

##   (Intercept) x
## 1           1 1
## 2           1 2
## 3           1 3
## 4           1 4
## attr(,"assign")
## [1] 0 1

Given the two model matrices, the restriction matrix which describes the restrictions that should be made to the model matrix of the large model to produce the model matrix of the small model:

L <- make_restriction_matrix(Xlg, Xsm)
L 

##      [,1] [,2] [,3]
## [1,]    0    0   -1

Given the model matrix of the large model and the restriction matrix, the model matrix of the small model can be constructed as:

Xsm_2 <- make_model_matrix(Xlg, L)
Xsm_2

##   [,1] [,2]
## 1    1    1
## 2    2    1
## 3    3    1
## 4    4    1

The same operation can be made directly on model objects:

L <- model2restriction_matrix(lg, sm)
L

##      [,1] [,2] [,3]
## [1,]    0    0   -1

Likewise, given the large model and the restriction matrix, the small model can be constructed:

sm_2 <- restriction_matrix2model(lg, L)
sm_2

## 
## Call:
## lm(formula = y ~ .X1 + .X2 - 1, data = structure(list(.X1 = c(1, 
## 2, 3, 4), .X2 = c(1, 1, 1, 1), y = c(-0.0246086801960964, -1.52646545622158, 
## 0.585275909677089, 1.26047116172588), x = 1:4, `I(x^2)` = structure(c(1, 
## 4, 9, 16), class = "AsIs")), class = "data.frame", row.names = c(NA, 
## 4L)))
## 
## Coefficients:
##     .X1      .X2  
##  0.5967  -1.4181

sm_2 |> model.matrix()

##   .X1 .X2
## 1   1   1
## 2   2   1
## 3   3   1
## 4   4   1
## attr(,"assign")
## [1] 1 2

Lastly, model matrices can be compared

## The first column space contains the second
compare_column_space(Xlg, Xsm)

## [1] 1

## The second column space contains the first
compare_column_space(Xsm, Xlg)

## [1] 0

## The two column spaces are identical
compare_column_space(Xlg, Xlg) 

## [1] -1
pbkrtest/inst/doc/a02-coercion.rmd0000644000176200001440000000370514721100744016524 0ustar liggesusers--- title: "02 - Coercion between model objects and restriction matrices in 'pbkrtest'" author: "Søren Højsgaard and Ulrich Halekoh" output: rmarkdown::html_vignette vignette: > %\VignetteEngine{knitr::knitr} %\VignetteIndexEntry{02 - Coercion between model objects and restriction matrices in 'pbkrtest'} %\VignetteEncoding{UTF-8} --- ```{r, echo=FALSE} require( pbkrtest ) prettyVersion <- packageDescription("pbkrtest")$Version prettyDate <- format(Sys.Date()) ``` ```{r setup, include=FALSE} knitr::opts_chunk$set(echo = TRUE) options("warn"=-1) ## FIXME Fragile; issue with rankMatrix(, method="qr.R") ``` **Package version: `r prettyVersion`** Consider two linear models; the smaller is a submodel of the large: ```{r} N <- 4 dat <- data.frame(int=rep(1, N), x=1:N, y=rnorm(N)) ``` ```{r} lg <- lm(y ~ x + I(x^2), data=dat) sm <- lm(y ~ x, data=dat) lg sm ``` The corresponding model matrices are ```{r} Xlg <- model.matrix(lg) Xsm <- model.matrix(sm) Xlg Xsm ``` Given the two model matrices, the restriction matrix which describes the restrictions that should be made to the model matrix of the large model to produce the model matrix of the small model: ```{r} L <- make_restriction_matrix(Xlg, Xsm) L ``` Given the model matrix of the large model and the restriction matrix, the model matrix of the small model can be constructed as: ```{r} Xsm_2 <- make_model_matrix(Xlg, L) Xsm_2 ``` The same operation can be made directly on model objects: ```{r} L <- model2restriction_matrix(lg, sm) L ``` Likewise, given the large model and the restriction matrix, the small model can be constructed: ```{r} sm_2 <- restriction_matrix2model(lg, L) sm_2 sm_2 |> model.matrix() ``` Lastly, model matrices can be compared ```{r} ## The first column space contains the second compare_column_space(Xlg, Xsm) ## The second column space contains the first compare_column_space(Xsm, Xlg) ## The two column spaces are identical compare_column_space(Xlg, Xlg) ``` pbkrtest/inst/doc/a01-pbkrtest.rmd0000644000176200001440000001144415031443112016551 0ustar liggesusers--- title: "01 - Introduction to 'pbkrtest'" author: "Søren Højsgaard and Ulrich Halekoh" output: rmarkdown::html_vignette vignette: > %\VignetteEngine{knitr::knitr} %\VignetteIndexEntry{01 - Introduction to 'pbkrtest'} %\VignetteEncoding{UTF-8} --- ```{r, echo=FALSE} require( pbkrtest ) prettyVersion <- packageDescription("pbkrtest")$Version prettyDate <- format(Sys.Date()) ``` ```{r setup, include=FALSE} knitr::opts_chunk$set(echo = TRUE) options("warn"=-1) ## FIXME Fragile; issue with rankMatrix(, method="qr.R") ``` **Package version: `r prettyVersion`** # Introduction ```{r} library(broom) ``` 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. ```{r} data(shoes, package="MASS") shoes ``` A plot reveals that boys wear their shoes differently. ```{r} 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) ``` One option for testing the effect of materials is to make a paired $t$--test, e.g.\ as: ```{r} r1 <- t.test(shoes$A, shoes$B, paired=T) r1 |> tidy() ``` 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: ```{r} boy <- rep(1:10, 2) boyf<- factor(letters[boy]) material <- factor(c(rep("A", 10), rep("B", 10))) ## Balanced data: shoe.bal <- data.frame(wear=unlist(shoes), boy=boy, boyf=boyf, material=material) head(shoe.bal) ## Imbalanced data; delete (boy=1, material=1) and (boy=2, material=b) shoe.imbal <- shoe.bal[-c(1, 12),] ``` We fit models to the two datasets: ```{r} lmm1.bal <- lmer( wear ~ material + (1|boyf), data=shoe.bal) lmm0.bal <- update(lmm1.bal, .~. - material) lmm1.imbal <- lmer(wear ~ material + (1|boyf), data=shoe.imbal) lmm0.imbal <- update(lmm1.imbal, .~. - material) ``` The asymptotic likelihood ratio test shows stronger significance than the $t$--test: ```{r} anova(lmm1.bal, lmm0.bal, test="Chisq") |> tidy() anova(lmm1.imbal, lmm0.imbal, test="Chisq") |> tidy() ``` # Kenward--Roger approach The Kenward--Roger approximation is exact in certain balanced designs in the sense that the approximation produces the same result as the paired $t$--test. ```{r} kr.bal <- KRmodcomp(lmm1.bal, lmm0.bal) kr.bal |> tidy() summary(kr.bal) |> tidy() ``` For the imbalanced data we get ```{r} kr.imbal <- KRmodcomp(lmm1.imbal, lmm0.imbal) kr.imbal |> tidy() summary(kr.imbal) |> tidy() ``` Estimated degrees of freedom can be found with ```{r} c(bal_ddf = getKR(kr.bal, "ddf"), imbal_ddf = getKR(kr.imbal, "ddf")) ``` Notice that the Kenward-Roger approximation gives results similar to but not identical to the paired $t$--test when the two boys are removed: ```{r} shoes2 <- list(A=shoes$A[-(1:2)], B=shoes$B[-(1:2)]) t.test(shoes2$A, shoes2$B, paired=T) |> tidy() ``` # Satterthwaite approach The Satterthwaite approximation is exact in certain balanced designs in the sense that the approximation produces the same result as the paired $t$--test. ```{r} sat.bal <- SATmodcomp(lmm1.bal, lmm0.bal) sat.bal |> tidy() ``` ```{r} sat.imbal <- SATmodcomp(lmm1.imbal, lmm0.imbal) sat.imbal |> tidy() ``` Estimated degrees of freedom can be found with ```{r} c(bal_ddf = getSAT(sat.bal, "ddf"), imbal_ddf = getSAT(sat.imbal, "ddf")) ``` # 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 computations can be made en parallel, see the documentation): ```{r} pb.bal <- PBmodcomp(lmm1.bal, lmm0.bal, nsim=500, cl=2) pb.bal |> tidy() summary(pb.bal) |> tidy() ``` For the imbalanced data, the result is similar to the result from the paired $t$--test. ```{r} pb.imbal <- PBmodcomp(lmm1.imbal, lmm0.imbal, nsim=500, cl=2) pb.imbal |> tidy() summary(pb.imbal) |> tidy() ``` # Matrices for random effects The matrices involved in the random effects can be obtained with ```{r} shoe3 <- subset(shoe.bal, boy<=5) shoe3 <- shoe3[order(shoe3$boy), ] lmm1 <- lmer( wear ~ material + (1|boyf), data=shoe3 ) str( SG <- get_SigmaG( lmm1 ), max=2) ``` ```{r} round( SG$Sigma*10 ) ``` ```{r} SG$G ``` pbkrtest/inst/WORDLIST0000644000176200001440000000034514721100744014261 0ustar liggesusersBiometrics betaH budworm budworms Collett cypermethrin doi Github github Halekoh Haubo Heliothis hojsgaard https io jss Kenward lme lmer Modelling PBtest pyrethroid Satterthwaite Springer Unadjusted unadjusted Venables virescens pbkrtest/README.md0000644000176200001440000000756114721100744013400 0ustar liggesusersThe `pbkrtest` package: Parametric Bootstrap, Kenward-Roger and Satterthwaite Based Methods for Tests in Mixed Models ================ ## What does `pbkrtest` do for you? Hypothesis test of fixed effects in mixed models (also called random effects models, hierarchical models etc) is most commonly based on large sample asymptotics: When the amount of information becomes large, a test can be based an a ![\\chi^2](https://latex.codecogs.com/png.image?%5Cdpi%7B110%7D&space;%5Cbg_white&space;%5Cchi%5E2 "\\chi^2")-approximation. In small sample cases, this approximation can be very unreliable. The `pbkrtest` provides alternatives to this approximation. To be specific: For linear mixed models (as implemented in the `lme4` package), `pbkrtest` implements the following tests for fixed effects: 1. a parametric bootstrap test, 2. a Kenward-Roger-type F-test and 3. a Satterthwaite-type F-test. Moreover, for generalized linear mixed models (as implemented in `lme4`) and for generalized linear models, `pbkrtest` also implements a parametric bootstrap test ## Documentation The facilities of the package are documented in the paper by \[Halekoh and Højsgaard 2014)\] () Please see `citation("pbkrtest")` for information about citing the paper and the package. If you use the package in your work, please do cite this paper. Please notice: There are other packages that use `pbkrtest` under the hood. If you use one of those packages, please do also cite our paper. We also refer to the [Webpage for the package](https://people.math.aau.dk/~sorenh/software/pbkrtest/index.html) ## Online documentation See . ## Installation `pbkrtest` is available on CRAN and development versions can also be found on Github: ## Install from CRAN: install.packages('pbkrtest') ## Install from Github: Use the remotes package: remotes::install_github("hojsgaard/pbkrtest", build_vignettes = TRUE) ## Development site See . ## Brief introduction ``` r library(pbkrtest) library(ggplot2) ## Sugar beets: Does suger content depend on harvest time? beets |> ggplot(aes(x=sow, y=sugpct, group=harvest)) + geom_jitter(aes(color=harvest), width=0) ``` ![](README_files/figure-gfm/unnamed-chunk-2-1.png) ``` r fm0 <- lmer(sugpct ~ block + sow + harvest + (1|block:harvest), data=beets) fm1 <- update(fm0, .~. -harvest) ## Is there an effect of harvest time? an <- anova(fm0, fm1) pb <- PBmodcomp(fm0, fm1) kr <- KRmodcomp(fm0, fm1) sa <- SATmodcomp(fm0, fm1) tidy(an) #> # A tibble: 2 × 9 #> term npar AIC BIC logLik deviance statistic df p.value #> #> 1 fm1 9 -69.1 -56.5 43.5 -87.1 NA NA NA #> 2 fm0 10 -80.0 -66.0 50.0 -100. 12.9 1 0.000326 tidy(pb) #> # A tibble: 2 × 4 #> type stat df p.value #> #> 1 LRT 12.9 1 0.000326 #> 2 PBtest 12.9 NA 0.0300 tidy(kr) #> # A tibble: 1 × 6 #> type stat ndf ddf F.scaling p.value #> #> 1 Ftest 15.2 1 2.00 1 0.0599 tidy(sa) #> # A tibble: 1 × 5 #> type statistic ndf ddf p.value #> #> 1 Ftest 15.2 1 2.00 0.0599 ``` Please find more examples in the other vignettes available at . pbkrtest/build/0000755000176200001440000000000015032042247013206 5ustar liggesuserspbkrtest/build/vignette.rds0000644000176200001440000000043115032042247015543 0ustar liggesusersuMN0&@J T XuA"vaM72!4 p MɲYO٧2M*>]KPy!E}]1}FI\Fҍsصtkևf`jA+ɡ2h E*֖i!Ǝ~[/a0J |嵧<t$;"Yw^KF?j4od%rpřaɛB=v_m2pbkrtest/man/0000755000176200001440000000000015032041450012655 5ustar liggesuserspbkrtest/man/internal-pbkrtest.Rd0000755000176200001440000000032214721100744016622 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/NAMESPACE_pbkrtest.R \name{internal-pbkrtest} \alias{internal-pbkrtest} \title{pbkrtest internal} \description{ pbkrtest internal } pbkrtest/man/sat__modcomp.Rd0000644000176200001440000000462515003027537015627 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, betaH = 0, details = 0, eps = sqrt(.Machine$double.eps) ) \method{SATmodcomp}{lmerMod}( largeModel, smallModel, betaH = 0, details = 0, eps = sqrt(.Machine$double.eps) ) } \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. If \code{smallModel} is a model object then betaH=0.} \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! } \examples{ (fm0 <- lmer(Reaction ~ (Days|Subject), sleepstudy)) (fm1 <- lmer(Reaction ~ Days + (Days|Subject), sleepstudy)) (fm2 <- lmer(Reaction ~ Days + I(Days^2) + (Days|Subject), sleepstudy)) ## Test for no effect of Days in fm1, i.e. test fm0 under fm1 SATmodcomp(fm1, "Days") SATmodcomp(fm1, ~.-Days) L1 <- cbind(0, 1) ## SATmodcomp(fm1, L1) ## FIXME SATmodcomp(fm1, fm0) anova(fm1, fm0) ## Test for no effect of Days and Days-squared in fm2, i.e. test fm0 under fm2 SATmodcomp(fm2, "(Days+I(Days^2))") SATmodcomp(fm2, ~. - Days - I(Days^2)) L2 <- rbind(c(0, 1, 0), c(0, 0, 1)) ## SATmodcomp(fm2, L2) ## FIXME SATmodcomp(fm2, fm0) anova(fm2, fm0) ## Test for no effect of Days-squared in fm2, i.e. test fm1 under fm2 SATmodcomp(fm2, "I(Days^2)") SATmodcomp(fm2, ~. - I(Days^2)) L3 <- rbind(c(0, 0, 1)) ## SATmodcomp(fm2, L3) ## FIXME SATmodcomp(fm2, fm1) anova(fm2, fm1) } \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[lme4]{lmer}}, \code{\link{vcovAdj}}, \code{\link{PBmodcomp}}, \code{\link{KRmodcomp}} } \author{ Søren Højsgaard, \email{sorenh@math.aau.dk} } \concept{model_comparison} \keyword{inference} \keyword{models} pbkrtest/man/get_Fstat_ddf.Rd0000644000176200001440000000174315003022723015706 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 degrees of freedom for F-test} \usage{ get_Fstat_ddf(nu, tol = 1e-08) } \arguments{ \item{nu}{vector of denominator degrees of freedom for the t-statistics} \item{tol}{tolerance on the consecutive differences between elements of nu to determine if mean(nu) should be returned} } \value{ the denominator degrees of freedom; a numerical scalar } \description{ From a vector of denominator degrees of freedom from independent t-statistics (\code{nu}), the denominator degrees of freedom 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 \code{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.Rd0000755000176200001440000000415015032041450015160 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/get_info_functions.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 denominator degrees of freedom for linear estimate for linear mixed model.} \usage{ get_Lb_ddf(object, L) \method{get_Lb_ddf}{lmerMod}(object, L) Lb_ddf(L, V0, Vadj) get_ddf_Lb(object, Lcoef) \method{get_ddf_Lb}{lmerMod}(object, Lcoef) ddf_Lb(VVa, Lcoef, VV0 = VVa) } \arguments{ \item{object}{A linear mixed model object.} \item{L}{A vector with the same length as \code{fixef(object)} or a matrix with the same number of columns as the length of \code{fixef(object)}} \item{V0, Vadj}{The unadjusted and the adjusted covariance matrices for the fixed effects parameters. The unadjusted covariance matrix is obtained with \code{vcov()} and adjusted with \code{vcovAdj()}.} \item{Lcoef}{Linear contrast matrix} \item{VVa}{Adjusted covariance matrix} \item{VV0}{Unadjusted covariance matrix} } \value{ Adjusted degrees of freedom (adjustment made by a Kenward-Roger approximation). } \description{ Get adjusted denominator degrees freedom for testing Lb=0 in a linear mixed model where L is a restriction matrix. } \examples{ (fm1 <- lmer(Reaction ~ Days + (Days|Subject), sleepstudy)) (fm0 <- lmer(Reaction ~ 1 + (Days|Subject), sleepstudy)) anova(fm1, fm0) KRmodcomp(fm1, fm0) ## 17 denominator df's get_Lb_ddf(fm1, c(0, 1)) ## 17 denominator df's # Notice: The restriction matrix L corresponding to the test above # can be found with L <- model2restriction_matrix(fm1, fm0) 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{model2restriction_matrix}}, \code{\link{restriction_matrix2model}} } \author{ Søren Højsgaard, \email{sorenh@math.aau.dk} } \keyword{inference} \keyword{models} pbkrtest/man/data-beets.Rd0000755000176200001440000000410515031203000015146 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/DATA_pbkrtest.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/} } \concept{data} \keyword{datasets} pbkrtest/man/get_nested_model_info.Rd0000644000176200001440000000302615032041450017461 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/nested_model_info.R \name{get_nested_model_info} \alias{get_nested_model_info} \title{Resolve Nested Model Representation} \usage{ get_nested_model_info(fit1, fit0) } \arguments{ \item{fit1}{A fitted model object (e.g., from \code{lm}, \code{lmer}, etc.).} \item{fit0}{A nested model specification: a model object, a formula (e.g., \code{~ . - x}), a character vector of term names to remove, or a restriction matrix.} } \value{ A list with: \describe{ \item{formula_large}{Formula for \code{fit1}.} \item{formula_small}{Formula for resolved \code{fit0}.} \item{large_model}{The full model \code{fit1}.} \item{small_model}{The nested model \code{fit0}.} \item{L}{Restriction matrix defining the nested model.} } } \description{ Constructs or extracts a nested model (\code{fit0}) from a full model (\code{fit1}) using flexible input: a model object, formula, character string, or matrix. This function is useful for preparing models for comparison, e.g., via likelihood ratio test. } \examples{ if (requireNamespace("lme4", quietly = TRUE)) { library(lme4) data(sleepstudy) fit1 <- lmer(Reaction ~ Days + (Days | Subject), sleepstudy) fit0 <- lmer(Reaction ~ (Days | Subject), sleepstudy) get_nested_model_info(fit1, fit0) # as model object get_nested_model_info(fit1, ~ . - Days) # as formula get_nested_model_info(fit1, "Days") # as string ## get_nested_model_info(fit1, c(0, 1)) # numeric (converted to matrix) } } pbkrtest/man/anovax_list.Rd0000644000176200001440000000123515000625565015506 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/anovax.R \name{anovax_list} \alias{anovax_list} \title{Various different tests for model comparison} \usage{ anovax_list( object, object2, test = c("x2", "kr", "sat", "pb"), control = list(nsim = 1000) ) } \arguments{ \item{object}{Model object} \item{object2}{Model object or equivalent way of specifying a submodel of lmm1} \item{test}{A vector with the various test types.} \item{control}{A list controlling the model comparions.} } \value{ Dataframe with results of the various tests } \description{ Various different tests for model comparison } \author{ Søren Højsgaard } pbkrtest/man/any_modcomp.Rd0000644000176200001440000000107315003322270015452 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/xx_modcomp_new.R \name{modcomp} \alias{modcomp} \alias{pb_modcomp} \alias{kr_modcomp} \alias{sat_modcomp} \alias{x2_modcomp} \title{Compare two models} \usage{ pb_modcomp(largeModel, smallModel, control = list()) kr_modcomp(largeModel, smallModel, control = list()) sat_modcomp(largeModel, smallModel, control = list()) x2_modcomp(largeModel, smallModel, control = list()) } \arguments{ \item{largeModel, smallModel}{Two models} \item{control}{A list} } \description{ Compare two models } pbkrtest/man/data-budworm.Rd0000755000176200001440000000363615031203000015533 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/DATA_pbkrtest.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 micro grams)}. \item{ndead:}{budworms killed in a trial.} \item{ntotal:}{total number of budworms exposed per trial.} } } \source{ Collett, D. (1991) Modelling Binary Data, Chapman & Hall, London, Example 3.7 } \usage{ budworm } \description{ Experiment on the toxicity to the tobacco budworm Heliothis virescens of doses of the pyrethroid trans-cypermethrin to which the moths were beginning to show resistance. Batches of 20 moths of each sex were exposed for three days to the pyrethroid and the number in each batch that were dead or knocked down was recorded. Data is reported in Collett (1991, p. 75). } \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 } \concept{data} \keyword{datasets} pbkrtest/man/compare_column_space.Rd0000644000176200001440000000123315032041450017321 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/linear_algebra.R \name{compare_column_space} \alias{compare_column_space} \title{Compare column spaces} \usage{ compare_column_space(X1, X2) } \arguments{ \item{X1, X2}{matrices with the same number of rows} } \value{ \itemize{ \item -1 : Either C(X1)=C(X2), or the spaces are not nested. \item 0 : C(X1) is contained in C(X2) \item 1 : C(X2) is contained in C(X1) } } \description{ Compare column spaces of two matrices } \examples{ A1 <- matrix(c(1,1,1,1,2,3), nrow=3) A2 <- A1[, 1, drop=FALSE] compare_column_space(A1, A2) compare_column_space(A2, A1) compare_column_space(A1, A1) } pbkrtest/man/kr-vcovAdj.Rd0000644000176200001440000000514715031565133015171 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/KR_vcovAdj.R \name{kr-vcovAdj} \alias{kr-vcovAdj} \alias{vcovAdj} \alias{vcovAdj.lmerMod} \alias{vcovAdj_internal} \alias{vcovAdj0} \alias{vcovAdj2} \alias{vcovAdj.mer} \alias{LMM_Sigma_G} \alias{get_SigmaG} \alias{get_SigmaG.lmerMod} \alias{get_SigmaG.mer} \title{Adjusted 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 effects} \item{SigmaG}{list: Sigma: the covariance matrix of Y; G: the G matrices that sum up to Sigma; \code{n.ggamma}: the number (called M in the article) of G matrices) } } \description{ Kenward and Roger (1997) describe 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, REML=TRUE) class(fm1) set.seed(123) sleepstudy2 <- sleepstudy[sample(nrow(sleepstudy), size=120), ] fm2 <- lmer(Reaction ~ Days + (Days|Subject), sleepstudy2, REML=TRUE) ## Here the adjusted and unadjusted covariance matrices are identical, ## but that is not generally the case: v1 <- vcov(fm1) v1a <- vcovAdj(fm1, details=0) v1a / v1 v2 <- vcov(fm2) v2a <- vcovAdj(fm2, details=0) v2a / v2 # For comparison, an alternative estimate of the # variance-covariance matrix is based on parametric bootstrap (and # this is easily parallelized): } \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[lme4]{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/get_modcomp.Rd0000644000176200001440000000326615032041450015450 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/get_info_functions.R \name{get_modcomp} \alias{get_modcomp} \alias{getKR} \alias{getSAT} \title{Extract (or "get") components from a \code{KRmodcomp} or \code{SATmodcomp} object.} \usage{ getKR( object, name = c("ndf", "ddf", "Fstat", "p.value", "F.scaling", "FstatU", "p.valueU", "aux") ) getSAT(object, name = c("ndf", "ddf", "Fstat", "p.value")) } \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} or \code{SATmodcomp} object. In particular, get denominator degrees of freedom. } \examples{ (fm0 <- lmer(Reaction ~ (Days|Subject), sleepstudy)) (fm1 <- lmer(Reaction ~ Days + (Days|Subject), sleepstudy)) (fm2 <- lmer(Reaction ~ Days + I(Days^2) + (Days|Subject), sleepstudy)) x10 <- KRmodcomp(fm1, fm0) getKR(x10, "ddf") KRmodcomp(fm1, fm0) |> getKR("ddf") KRmodcomp(fm2, fm0) |> getKR("ddf") KRmodcomp(fm2, fm1) |> getKR("ddf") ## For comparison: SATmodcomp(fm1, fm0) |> getSAT("ddf") SATmodcomp(fm2, fm0) |> getSAT("ddf") SATmodcomp(fm2, fm1) |> getSAT("ddf") } \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/pb__modcomp.Rd0000644000176200001440000001745715031177730015452 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{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, smallModel}{Two models} \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 \code{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 process 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 generated. 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 over fit; 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{ \dontrun{ (fm0 <- lmer(Reaction ~ (Days|Subject), sleepstudy)) (fm1 <- lmer(Reaction ~ Days + (Days|Subject), sleepstudy)) (fm2 <- lmer(Reaction ~ Days + I(Days^2) + (Days|Subject), sleepstudy)) NSIM <- 50 ## Simulations in parametric bootstrap; default is 1000. ## Test for no effect of Days in fm1, i.e. test fm0 under fm1 PBmodcomp(fm1, "Days", cl=1, nsim=NSIM) PBmodcomp(fm1, ~.-Days, cl=1, nsim=NSIM) L1 <- cbind(0, 1) PBmodcomp(fm1, L1, cl=1, nsim=NSIM) PBmodcomp(fm1, fm0, cl=1, nsim=NSIM) anova(fm1, fm0) ## Test for no effect of Days and Days-squared in fm2, i.e. test fm0 under fm2 PBmodcomp(fm2, "(Days+I(Days^2))", cl=1, nsim=NSIM) PBmodcomp(fm2, ~. - Days - I(Days^2), cl=1, nsim=NSIM) L2 <- rbind(c(0, 1, 0), c(0, 0, 1)) PBmodcomp(fm2, L2, cl=1, nsim=NSIM) ## FIXME PBmodcomp(fm2, fm0, cl=1, nsim=NSIM) anova(fm2, fm0) ## Test for no effect of Days-squared in fm2, i.e. test fm1 under fm2 PBmodcomp(fm2, "I(Days^2)", cl=1, nsim=NSIM) PBmodcomp(fm2, ~. - I(Days^2), cl=1, nsim=NSIM) L3 <- rbind(c(0, 0, 1)) PBmodcomp(fm2, L3, cl=1, nsim=NSIM) PBmodcomp(fm2, fm1, cl=1, nsim=NSIM) anova(fm2, fm1) ## Linear normal model: sug <- lm(sugpct ~ block + sow + harvest, data=beets) sug.h <- update(sug, .~. -harvest) sug.s <- update(sug, .~. -sow) PBmodcomp(sug, "harvest", nsim=NSIM, cl=1) PBmodcomp(sug, ~. - harvest, nsim=NSIM, cl=1) PBmodcomp(sug, sug.h, nsim=NSIM, cl=1) anova(sug, sug.h) ## Generalized linear model mm <- glm(ndead/ntotal ~ sex + log(dose), family=binomial, weight=ntotal, data=budworm) mm0 <- update(mm, .~. -sex) ### Test for no effect of sex PBmodcomp(mm, "sex", cl=1, nsim=NSIM) PBmodcomp(mm, ~.-sex, cl=1, nsim=NSIM) ## PBmodcomp(mm, cbind(0, 1, 0), nsim=NSIM): FIXME PBmodcomp(mm, mm0, cl=1, nsim=NSIM) anova(mm, mm0, test="Chisq") } ## 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)) PBmodcomp(gm1, "period", nsim=NSIM) PBmodcomp(gm1, ~. -period, nsim=NSIM) PBmodcomp(gm1, gm2, nsim=NSIM) anova(gm1, gm2) } \dontrun{ ## 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) PBmodcomp(sug, "harvest", nsim=NSIM, cl=1) anova(sug, sug.s) PBmodcomp(sug, sug.s, nsim=NSIM, cl=1) PBmodcomp(sug, "sow", nsim=NSIM, cl=1) ## Simulate reference distribution separately: refdist <- PBrefdist(sug, sug.h, nsim=1000, cl=1) refdist <- PBrefdist(sug, "harvest", nsim=1000, cl=1) refdist <- PBrefdist(sug, ~.-harvest, nsim=1000, cl=1) ## Do computations with multiple processors: ## Number of cores: (nc <- detectCores()) ## Create clusters cl <- makeCluster(rep("localhost", nc)) ## Then do: refdist <- PBrefdist(sug, sug.h, nsim=1000, cl=cl) ## It is recommended to stop the clusters before quitting R: stopCluster(cl) } lm1 <- lm(dist~speed+I(speed^2), data=cars) PBmodcomp(lm1, .~.-speed, cl=2) PBmodcomp(lm1, .~.-I(speed^2), cl=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{KRmodcomp}}, \code{\link{PBrefdist}} } \author{ Søren Højsgaard \email{sorenh@math.aau.dk} } \concept{model_comparison} \keyword{inference} \keyword{models} pbkrtest/man/kr__modcomp.Rd0000644000176200001440000000777615003003223015450 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. If \code{smallModel} is a model object then betaH=0.} \item{details}{If larger than 0 some timing details are printed.} } \description{ An approximate F-test based on the Kenward-Roger approach. } \details{ An F test is calculated according to the approach of Kenward and Roger (1997). The function works for linear mixed models fitted with the lmer() function of the \code{lme4} package. Only models where the covariance structure is a linear combination (a weighted sum) of known matrices can be compared. The \code{smallModel} is the model to be tested against the \code{largeModel}. The \code{largeModel} is a model fitted with \code{lmer()}. A technical detail: The model must be fitted with \code{REML=TRUE}. If the model is fitted 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. The \code{smallModel} can be one of several things: \enumerate{ \item 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}. \item a restriction matrix \code{L} specifying the hypothesis \deqn{L \beta = L \beta_H} where \code{L} is a \verb{k x p} matrix (there are k restrictions and p is the number of fixed effect parameters (the length of \code{fixef(largeModel)}) and \code{beta_H} is a p column vector. \item A formula or a text string specifying what is to be removed from the larger model to form the smaller model. } Notice: if you want to test a hypothesis \deqn{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! } \examples{ (fm0 <- lmer(Reaction ~ (Days|Subject), sleepstudy)) (fm1 <- lmer(Reaction ~ Days + (Days|Subject), sleepstudy)) (fm2 <- lmer(Reaction ~ Days + I(Days^2) + (Days|Subject), sleepstudy)) ## Test for no effect of Days in fm1, i.e. test fm0 under fm1 KRmodcomp(fm1, "Days") KRmodcomp(fm1, ~.-Days) L1 <- cbind(0, 1) KRmodcomp(fm1, L1) KRmodcomp(fm1, fm0) anova(fm1, fm0) ## Test for no effect of Days and Days-squared in fm2, i.e. test fm0 under fm2 KRmodcomp(fm2, "(Days+I(Days^2))") KRmodcomp(fm2, ~. - Days - I(Days^2)) L2 <- rbind(c(0, 1, 0), c(0, 0, 1)) KRmodcomp(fm2, L2) KRmodcomp(fm2, fm0) anova(fm2, fm0) ## Test for no effect of Days-squared in fm2, i.e. test fm1 under fm2 KRmodcomp(fm2, "I(Days^2)") KRmodcomp(fm2, ~. - I(Days^2)) L3 <- rbind(c(0, 0, 1)) KRmodcomp(fm2, L3) KRmodcomp(fm2, fm1) anova(fm2, fm1) } \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[lme4]{lmer}}, \code{\link{vcovAdj}}, \code{\link{PBmodcomp}}, \code{\link{SATmodcomp}} } \author{ Ulrich Halekoh \email{uhalekoh@health.sdu.dk}, Søren Højsgaard \email{sorenh@math.aau.dk} } \concept{model_comparison} \keyword{inference} \keyword{models} pbkrtest/man/pb-refdist.Rd0000755000176200001440000001106615003326603015216 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} \alias{PBrefdist.gls} \title{Calculate reference distribution using parametric bootstrap} \usage{ PBrefdist( largeModel, smallModel, nsim = 1000, seed = NULL, cl = NULL, details = 0 ) \method{PBrefdist}{lm}( largeModel, smallModel, nsim = 1000, seed = NULL, cl = NULL, details = 0 ) \method{PBrefdist}{merMod}( largeModel, smallModel, nsim = 1000, seed = NULL, cl = NULL, details = 0 ) \method{PBrefdist}{gls}( 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. \if{html}{\out{
}}\preformatted{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. }\if{html}{\out{
}} Special care must be taken on Windows platforms (described below) but the general picture is this: \if{html}{\out{
}}\preformatted{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 }\if{html}{\out{
}} } \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} } \concept{model_comparison} \keyword{inference} \keyword{models} pbkrtest/man/model-coerce.Rd0000755000176200001440000000542614721100744015522 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{model2restriction_matrix} \alias{restriction_matrix2model} \alias{make_model_matrix} \alias{make_restriction_matrix} \title{Conversion between a model object and a restriction matrix} \usage{ model2restriction_matrix(largeModel, smallModel, sparse = FALSE) restriction_matrix2model(largeModel, L, REML = TRUE, ...) make_model_matrix(X, L) make_restriction_matrix(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 \code{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 number of rows.} } \value{ \code{model2restriction_matrix}: A restriction matrix. \code{restriction_matrix2model}: 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{ \code{make_restriction_matrix} Make a restriction matrix. If span(X2) is in span(X) then the corresponding restriction matrix \code{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 <- model2restriction_matrix(sug, sug.h); L.h L.s <- model2restriction_matrix(sug, sug.s); L.s ## Construct submodels from restriction matrices mod.h <- restriction_matrix2model(sug, L.h); mod.h mod.s <- restriction_matrix2model(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/anovax.Rd0000644000176200001440000000226415003322461014446 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/anovax.R \name{anovax} \alias{anovax} \alias{anovax.lmerMod} \alias{anovax.default} \alias{print.anovax} \title{anova like function} \usage{ anovax(object, ..., test = "x2", control = list(nsim = 1000, cl = NULL)) \method{anovax}{lmerMod}(object, ..., test = "x2", control = list(nsim = 1000, cl = NULL)) \method{anovax}{default}(object, ..., test = "x2", control = list(nsim = 1000, cl = NULL)) \method{print}{anovax}(x, ...) } \arguments{ \item{object}{A model object object} \item{...}{further arguments} \item{test}{A character string} \item{control}{A list controling simulations, only relevant for parametric bootstrapping.} \item{x}{anovax object} } \description{ anova like function print anovax object } \examples{ lmm1 <- lmer(sugpct ~ block + sow + harvest + (1|block:harvest), data=beets) lmm0 <- update(lmm1, .~. - sow) anovax(lmm1, .~. - harvest, test="KR") anovax(lmm1, .~. - harvest, test="SAT") ## anovax(lmm1, .~. - harvest, test="PB", control=list(nsim=50, cl=1)) anovax(lmm1, test="KR") anovax(lmm1, test="SAT") anovax(lmm1, test="PB", control=list(nsim=50, cl=1)) } \author{ Søren Højsgaard } pbkrtest/man/devfun_vp.Rd0000644000176200001440000000137415003022723015145 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 a linear mixed model 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.Rd0000644000176200001440000000142215003022723015425 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 covariance of fixed effect parameters as a function of variance parameters of a linear mixed model} \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{ The covariances matrix of the fixed effects at supplied \code{varpar} values. } \description{ At the optimum the covariance is available as \code{vcov(lmer-model)}. This function computes \code{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/x2__modcomp.Rd0000644000176200001440000000241615027166212015365 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/X2_modcomp.R \name{x2__modcomp} \alias{x2__modcomp} \alias{X2modcomp} \alias{X2modcomp.default} \title{Chisq test} \usage{ X2modcomp(largeModel, smallModel, betaH = 0, details = 0, ...) \method{X2modcomp}{default}(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. If \code{smallModel} is a model object then betaH=0.} \item{details}{If larger than 0 some timing details are printed.} \item{...}{Additional arguments, currently not used.} } \description{ Chisq test } \details{ TBW } \author{ Ulrich Halekoh \email{uhalekoh@health.sdu.dk}, Søren Højsgaard \email{sorenh@math.aau.dk} (fm0 <- lmer(Reaction ~ (Days|Subject), sleepstudy)) (fm1 <- lmer(Reaction ~ Days + (Days|Subject), sleepstudy)) (fm2 <- lmer(Reaction ~ Days + I(Days^2) + (Days|Subject), sleepstudy)) \subsection{Test for no effect of Days in fm1, i.e. test fm0 under fm1}{ X2modcomp(fm1, "Days") X2modcomp(fm1, ~.-Days) L1 <- cbind(0, 1) X2modcomp(fm1, L1) ## FIXME X2modcomp(fm1, fm0) anova(fm1, fm0) } } \concept{model_comparison} pbkrtest/man/getLRT.Rd0000644000176200001440000000374515032041450014316 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/get_info_functions.R \name{getLRT} \alias{getLRT} \title{Likelihood Ratio Test Between Nested Models} \usage{ getLRT(fit1, fit0) } \arguments{ \item{fit1}{A model object representing the more complex (full) model.} \item{fit0}{A model object representing the simpler (nested) model.} } \value{ A named numeric vector with: \describe{ \item{tobs}{Test statistic (twice the difference in log-likelihoods).} \item{df}{Degrees of freedom (difference in number of parameters).} \item{p.value}{P-value from the chi-squared distribution.} } } \description{ Performs a likelihood ratio test (LRT) between two nested models. Supports models of class \code{lm}, \code{lmerMod}, \code{glmerMod}, \code{lme}, and \code{gls}. } \examples{ ## lm fit1 <- lm(mpg ~ wt + hp, data = mtcars) fit0 <- lm(mpg ~ wt, data = mtcars) getLRT(fit1, fit0) ## lmerMod if (requireNamespace("lme4", quietly = TRUE)) { library(lme4) fit1 <- lmer(Reaction ~ Days + (Days | Subject), sleepstudy, REML = FALSE) fit0 <- lmer(Reaction ~ 1 + (Days | Subject), sleepstudy, REML = FALSE) getLRT(fit1, fit0) } ## glmerMod if (requireNamespace("lme4", quietly = TRUE)) { library(lme4) data(cbpp) fit1 <- glmer(cbind(incidence, size - incidence) ~ period + (1 | herd), data = cbpp, family = binomial) fit0 <- glmer(cbind(incidence, size - incidence) ~ 1 + (1 | herd), data = cbpp, family = binomial) getLRT(fit1, fit0) } ## lme if (requireNamespace("nlme", quietly = TRUE)) { library(nlme) fit1 <- lme(distance ~ age + Sex, random = ~1 | Subject, data = Orthodont, method = "ML") fit0 <- lme(distance ~ age, random = ~1 | Subject, data = Orthodont, method = "ML") getLRT(fit1, fit0) } ## gls if (requireNamespace("nlme", quietly = TRUE)) { library(nlme) fit1 <- gls(mpg ~ wt + hp, data = mtcars, method = "ML") fit0 <- gls(mpg ~ wt, data = mtcars, method = "ML") getLRT(fit1, fit0) } } pbkrtest/man/compute_auxiliary.Rd0000644000176200001440000000105214721100744016713 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/SAT_modcomp.R \name{compute_auxiliary} \alias{compute_auxiliary} \title{Compute_auxiliary quantities needed for the Satterthwaite approximation.} \usage{ compute_auxiliary(model, tol = 1e-06) } \arguments{ \item{model}{A linear mixed model object} \item{tol}{A tolerance} } \value{ A list } \description{ Computes variance-covariance matrix of variance parameters (theta, sigma), the Jacobian of each variance parameter etc. } \author{ Søren Højsgaard } \keyword{internal} pbkrtest/DESCRIPTION0000644000176200001440000000271415036336542013631 0ustar liggesusersPackage: pbkrtest Version: 0.5.5 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: Computes p-values based on (a) Satterthwaite or Kenward-Rogers degree of freedom methods and (b) parametric bootstrap for mixed effects models as implemented in the 'lme4' package. Implements parametric bootstrap test for generalized linear mixed models as implemented in 'lme4' and generalized linear models. The package is documented in the paper by Halekoh and Højsgaard, (2012, ). Please see 'citation("pbkrtest")' for citation details. URL: https://people.math.aau.dk/~sorenh/software/pbkrtest/ Depends: R (>= 4.2.0), lme4 (>= 1.1.31) Imports: broom, dplyr, MASS, methods, numDeriv, Matrix (>= 1.2.3), doBy (>= 4.6.22) Suggests: nlme, markdown, knitr Encoding: UTF-8 VignetteBuilder: knitr License: GPL (>= 2) ByteCompile: Yes RoxygenNote: 7.3.2 LazyData: true NeedsCompilation: no Packaged: 2025-07-04 21:16:23 UTC; sorenh Author: Ulrich Halekoh [aut, cph], Søren Højsgaard [aut, cre, cph] Repository: CRAN Date/Publication: 2025-07-18 03:20:02 UTC