├── .gitignore ├── .Rbuildignore ├── inst ├── doc │ ├── article.pdf │ ├── jsslogo.jpg │ ├── compile.sh │ ├── R │ │ ├── profileContour.R │ │ ├── util.R │ │ ├── display.R │ │ └── culcita.R │ ├── blme.bib │ ├── jss.cls │ └── generalizedLinearOptimization.tex ├── common │ ├── glmmData.R │ ├── lmmData.R │ └── checkWarning.R └── CITATION ├── tests ├── testthat │ ├── .DS_Store │ ├── test-02-glmm.R │ ├── test-01-lmm.R │ ├── test-06-lmm_resid.R │ ├── test-03-resid_errors.R │ ├── test-04-fixef_errors.R │ ├── test-05-covariance_errors.R │ ├── test-10-refit.R │ ├── test-11-prior_parse.R │ ├── test-09-glmm_priors.R │ ├── test-08-lmm_covariance.R │ └── test-07-lmm_fixef.R └── test-all.R ├── ToDo ├── R ├── AllClass.R ├── dist_point.R ├── dist_custom.R ├── util.R ├── string.R ├── dist_horseshoe.R ├── generics.R ├── dist_normal.R ├── dist_t.R ├── optimize.R ├── parameters.R ├── dist_gamma.R ├── control.R ├── dist_wishart.R ├── priorEval.R ├── devFun.R └── dist.R ├── README.md ├── DESCRIPTION ├── NAMESPACE ├── man ├── bmerMod-class.Rd ├── blmer.Rd └── bmerDist-class.Rd └── ChangeLog /.gitignore: -------------------------------------------------------------------------------- 1 | .DS_Store 2 | *\.swp 3 | -------------------------------------------------------------------------------- /.Rbuildignore: -------------------------------------------------------------------------------- 1 | inst/doc 2 | \.git$ 3 | \.gitignore$ 4 | ^README\.md$ 5 | -------------------------------------------------------------------------------- /inst/doc/article.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vdorie/blme/HEAD/inst/doc/article.pdf -------------------------------------------------------------------------------- /inst/doc/jsslogo.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vdorie/blme/HEAD/inst/doc/jsslogo.jpg -------------------------------------------------------------------------------- /tests/testthat/.DS_Store: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vdorie/blme/HEAD/tests/testthat/.DS_Store -------------------------------------------------------------------------------- /tests/test-all.R: -------------------------------------------------------------------------------- 1 | if (require(testthat, quietly = TRUE)) { 2 | test_check("blme") 3 | } else { 4 | cat("package 'testthat' not available; cannot run unit tests\n") 5 | } 6 | -------------------------------------------------------------------------------- /ToDo: -------------------------------------------------------------------------------- 1 | High Priority: 2 | sim for ranef covariance 3 | 4 | Medium Priority: 5 | investigate overdispersed models 6 | 7 | Low Priority: 8 | Consider optimal scaling for random effect covariances -------------------------------------------------------------------------------- /R/AllClass.R: -------------------------------------------------------------------------------- 1 | setClass("bmerMod", 2 | representation(priors = "list"), contains = "merMod"); 3 | setClass("blmerMod", contains=c("lmerMod", "bmerMod")); 4 | setClass("bglmerMod", contains=c("glmerMod", "bmerMod")); 5 | -------------------------------------------------------------------------------- /R/dist_point.R: -------------------------------------------------------------------------------- 1 | setClass("bmerPointDist", 2 | representation(value = "numeric"), 3 | contains = "bmerDist") 4 | 5 | toString.bmerPointDist <- function(x, digits = getOption("digits"), ...) 6 | paste("point(value = ", round(x@value, digits), ")", sep = "") 7 | -------------------------------------------------------------------------------- /inst/common/glmmData.R: -------------------------------------------------------------------------------- 1 | getGLMMData <- function() { 2 | set.seed(3, "Mersenne-Twister", "Inversion") 3 | J <- 4 4 | n <- 8 5 | N <- J * n 6 | x.1 <- rnorm(N) 7 | x.2 <- rnorm(N) 8 | theta <- rnorm(J, 0, 2) 9 | theta.g <- rep(theta, rep(n, J)) 10 | eta <- 3 * x.1 + 2 * x.2 + theta.g 11 | mu <- exp(eta) / (1 + exp(eta)) 12 | y <- rbinom(N, 1, mu) 13 | 14 | g <- gl(J, n) 15 | 16 | return(data.frame(y = y, x.1 = x.1, x.2 = x.2, g = g)) 17 | } 18 | testData <- getGLMMData() 19 | rm(getGLMMData) 20 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | blme 2 | ==== 3 | 4 | Bayesian Linear Mixed Effect Models 5 | 6 | A package for R. Built off of [lme4](https://cran.r-project.org/package=lme4) 7 | 8 | Pre-built bundles of the package are available on [CRAN](https://cran.r-project.org/package=blme). These can be installed from within R using the typical `install.packages()` mechanism. 9 | 10 | Steps to install from source: 11 | 12 | 1. Install the `remotes` package from within R: 13 | 14 | ```R 15 | install.packages("remotes") 16 | ``` 17 | 18 | 3. Run: 19 | 20 | ```R 21 | remotes::install_github("vdorie/blme") 22 | ``` 23 | -------------------------------------------------------------------------------- /inst/CITATION: -------------------------------------------------------------------------------- 1 | bibentry(bibtype = "article", 2 | title = "A nondegenerate penalized likelihood estimator for variance parameters in multilevel models", 3 | author = c(person("Yeojin", "Chung"), 4 | person("Sophia", "Rabe-Hesketh"), 5 | person("Vincent", "Dorie"), 6 | person("Andrew", "Gelman"), 7 | person("Jingchen", "Liu")), 8 | year = 2013, 9 | journal = "Psychometrika", 10 | volume = 78, 11 | number = 4, 12 | pages = "685--709", 13 | publisher = "Springer", 14 | doi = "10.1007/s11336-013-9328-2") 15 | -------------------------------------------------------------------------------- /tests/testthat/test-02-glmm.R: -------------------------------------------------------------------------------- 1 | context("glmer and bglmer") 2 | 3 | test_that("bglmer matches glmer exactly", { 4 | source(system.file("common", "glmmData.R", package = "blme")) 5 | 6 | control <- glmerControl(optimizer = "Nelder_Mead") 7 | 8 | glmerFit <- glmer(y ~ x.1 + x.2 + (1 | g), testData, family = binomial(), control = control) 9 | bglmerFit <- bglmer(y ~ x.1 + x.2 + (1 | g), testData, family = binomial(), control = control, 10 | cov.prior = NULL) 11 | 12 | expect_equal(glmerFit@theta, bglmerFit@theta) 13 | expect_equal(glmerFit@beta, bglmerFit@beta) 14 | expect_equal(glmerFit@u, bglmerFit@u) 15 | }) 16 | -------------------------------------------------------------------------------- /tests/testthat/test-01-lmm.R: -------------------------------------------------------------------------------- 1 | context("lmer and blmer") 2 | 3 | test_that("blmer matches lmer exactly", { 4 | source(system.file("common", "lmmData.R", package = "blme")) 5 | 6 | control <- lmerControl(optimizer = "bobyqa") 7 | 8 | lmerFit <- lmer(y ~ x.1 + x.2 + (1 + x.1 | g.1) + (1 + x.1 + x.2 | g.2), testData, control = control) 9 | blmerFit <- blmer(y ~ x.1 + x.2 + (1 + x.1 | g.1) + (1 + x.1 + x.2 | g.2), testData, control = control, 10 | cov.prior = NULL, fixef.prior = NULL, resid.prior = NULL) 11 | 12 | expect_equal(lmerFit@pp$theta, blmerFit@pp$theta) 13 | expect_equal(lmerFit@pp$u(1.0), blmerFit@pp$u(1.0)) 14 | expect_equal(lmerFit@pp$beta(1.0), blmerFit@pp$beta(1.0)) 15 | }) 16 | -------------------------------------------------------------------------------- /inst/doc/compile.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | 4 | getModifiedDates() { 5 | sourceFile=$1 6 | targetFile=$2 7 | 8 | sourceDate=`stat -s $sourceFile | sed -n -E "s/.*st_mtime=([0-9]+).*/\1/p"` 9 | targetDate=`stat -s $targetFile | sed -n -E "s/.*st_mtime=([0-9]+).*/\1/p"` 10 | } 11 | 12 | 13 | getModifiedDates article.Rnw article.tex 14 | 15 | if [ $sourceDate -ge $targetDate ]; then 16 | R --vanilla CMD Sweave article.Rnw 17 | [ $? -gt 0 ] && exit 1 18 | fi 19 | 20 | buildBib=0 21 | 22 | getModifiedDates blme.bib article.pdf 23 | 24 | [ $sourceDate -ge $targetDate ] && buildBib=1 25 | 26 | getModifiedDates article.tex article.pdf 27 | 28 | if [ $buildBib -gt 0 ]; then 29 | R CMD pdflatex article.tex && \ 30 | R CMD bibtex article.aux && \ 31 | R CMD bibtex article.aux 32 | [ $? -gt 0 ] && exit 1 33 | fi 34 | 35 | if [ $sourceDate -ge $targetDate ]; then 36 | R CMD pdflatex article.tex && \ 37 | R CMD pdflatex article.tex 38 | fi -------------------------------------------------------------------------------- /inst/common/lmmData.R: -------------------------------------------------------------------------------- 1 | getLMMData <- function() { 2 | set.seed(0, "Mersenne-Twister", "Inversion") 3 | 4 | N <- 100 5 | J.1 <- 5 6 | J.2 <- 5 7 | beta <- c(5, 2, 4) 8 | theta.1 <- matrix(rnorm(J.1 * 2), J.1, 2) 9 | theta.2 <- matrix(rnorm(J.2 * 3), J.2, 3) 10 | 11 | x.1 <- rnorm(N) 12 | x.2 <- rnorm(N) 13 | g.1 <- rmultinom(N, 1, runif(J.1)) 14 | g.2 <- rmultinom(N, 1, runif(J.2)) 15 | g.1 <- sapply(1:N, function(i) which(g.1[,i] == 1)) 16 | g.2 <- sapply(1:N, function(i) which(g.2[,i] == 1)) 17 | 18 | y <- 1 * (beta[1] + theta.1[g.1,1] + theta.2[g.2,1]) + 19 | x.1 * (beta[2] + theta.1[g.1,2] + theta.2[g.2,2]) + 20 | x.2 * (beta[3] + theta.2[g.2,3]) + 21 | rnorm(N) 22 | 23 | weights <- runif(N) 24 | weights <- weights / sum(weights) 25 | 26 | return(data.frame(y = y, x.1 = x.1, x.2 = x.2, g.1 = g.1, g.2 = g.2, w = weights)) 27 | } 28 | testData <- getLMMData() 29 | rm(getLMMData) 30 | -------------------------------------------------------------------------------- /R/dist_custom.R: -------------------------------------------------------------------------------- 1 | setClass("bmerCustomDist", 2 | representation(fnName = "name", 3 | fn = "function", 4 | chol = "logical", 5 | scale = "character"), 6 | contains = "bmerDist", 7 | validity = function(object) object@scale == "log" || object@scale == "dev" || object@scale == "none") 8 | 9 | toString.bmerCustomDist <- function(x, digits = getOption("digits"), ...) { 10 | paste0("custom(fn = ", x@fnName, ", ", 11 | "chol = ", x@chol, ", ", 12 | "scale = ", x@scale, ", ", 13 | "common.scale = ", x@commonScale, ")") 14 | } 15 | 16 | setMethod("getExponentialTerm", "bmerCustomDist", 17 | function(object, Lambda.t) { 18 | result <- object@fn(if (object@chol) Lambda.t else crossprod(Lambda.t)) 19 | 20 | if (object@scale == "log") { 21 | result <- -2 * result 22 | } else if (object@scale == "none") { 23 | result <- -2 * log(result) 24 | } 25 | 26 | c(0, result) 27 | }) 28 | -------------------------------------------------------------------------------- /R/util.R: -------------------------------------------------------------------------------- 1 | getCovBlocks <- function(cov, ranefStructure) { 2 | index <- 0 3 | result <- list() 4 | for (i in 1:ranefStructure$numFactors) { 5 | result[[i]] <- as.matrix(cov[index + 1:ranefStructure$numCoefPerFactor[i], 6 | index + 1:ranefStructure$numCoefPerFactor[i]]) 7 | index <- index + ranefStructure$numRanefPerFactor[i] 8 | } 9 | 10 | return(result) 11 | } 12 | 13 | ## from lme4 14 | namedList <- function(...) { 15 | result <- list(...) 16 | substituteNames <- sapply(substitute(list(...)), deparse)[-1] 17 | if (is.null(resultNames <- names(result))) resultNames <- substituteNames 18 | if (any(noNames <- resultNames == "")) resultNames[noNames] <- substituteNames[noNames] 19 | setNames(result, resultNames) 20 | } 21 | 22 | is.formula <- function(term) is.language(term) && term[[1]] == '~' 23 | 24 | #quoteInNamespace <- function(name, character.only = FALSE) { 25 | # result <- quote(a + b) 26 | # result[[1]] <- as.symbol(":::") 27 | # result[[2]] <- as.symbol("blme") 28 | # 29 | # result[[3]] <- if (character.only) name else match.call()[[2]] 30 | # result 31 | #} 32 | 33 | "%not_in%" <- function(x, table) match(x, table, nomatch = 0L) <= 0L 34 | -------------------------------------------------------------------------------- /R/string.R: -------------------------------------------------------------------------------- 1 | covariancePriorsToString <- function(covPriors, numGroupsPerFactor, digits) 2 | { 3 | result <- character(0L) 4 | resultIndex <- 1L 5 | 6 | numFactors <- length(numGroupsPerFactor) 7 | factorNames <- names(numGroupsPerFactor) 8 | for (i in seq_len(numFactors)) { 9 | prior.i <- covPriors[[i]] 10 | 11 | if (is.null(prior.i)) next 12 | 13 | result[resultIndex] <- paste(factorNames[i], " ~ ", toString(prior.i, digits), sep = "") 14 | resultIndex <- resultIndex + 1L 15 | } 16 | 17 | result 18 | } 19 | 20 | printPriors <- function(priors, numGroupsPerFactor, digits) { 21 | covariancePriorOutput <- covariancePriorsToString(priors$covPriors, numGroupsPerFactor, digits) 22 | if (length(covariancePriorOutput) > 0L) { 23 | cat("Cov prior : ", covariancePriorOutput[1L], "\n", sep="") 24 | if (length(covariancePriorOutput) > 1L) { 25 | for (i in seq.int(2L, length(covariancePriorOutput))) 26 | cat(" : ", covariancePriorOutput[i], "\n", sep="") 27 | } 28 | } 29 | if (!is.null(priors$fixefPrior)) 30 | cat("Fixef prior: ", toString(priors$fixefPrior, digits), "\n", sep="") 31 | 32 | if (!is.null(priors$residPrior)) 33 | cat("Resid prior: ", toString(priors$residPrior, digits, FALSE), "\n", sep="") 34 | } 35 | -------------------------------------------------------------------------------- /DESCRIPTION: -------------------------------------------------------------------------------- 1 | Package: blme 2 | Version: 1.0-7 3 | Date: 2025-02-28 4 | Title: Bayesian Linear Mixed-Effects Models 5 | Authors@R: c( 6 | person("Vincent", "Dorie", role = c("aut", "cre"), email = "vdorie@gmail.com", comment = c(ORCID = "0000-0002-9576-3064")), 7 | person("Douglas", "Bates", role = "ctb", comment = c("lme4 non-modular functions", ORCID = "0000-0001-8316-9503")), 8 | person("Martin", "Maechler", role = "ctb", comment = c("lme4 non-modular functions", ORCID = "0000-0002-8685-9910")), 9 | person("Ben", "Bolker", role = "ctb", comment = c("lme4 non-modular functions", ORCID = "0000-0002-2127-0443")), 10 | person("Steven", "Walker", role = "ctb", comment = c("lme4 non-modular functions", ORCID = "0000-0002-4394-9078"))) 11 | Depends: 12 | R (>= 3.0-0), 13 | lme4 (>= 1.0-6) 14 | Imports: 15 | methods, 16 | stats, 17 | utils 18 | Suggests: 19 | expint (>= 0.1-3), 20 | testthat 21 | Description: Maximum a posteriori estimation for linear and generalized linear mixed-effects models in a Bayesian setting, implementing the methods of Chung, et al. (2013) . Extends package 'lme4' (Bates, Maechler, Bolker, and Walker (2015) ). 22 | License: GPL (>=2) 23 | URL: https://github.com/vdorie/blme 24 | BugReports: https://github.com/vdorie/blme/issues 25 | 26 | -------------------------------------------------------------------------------- /NAMESPACE: -------------------------------------------------------------------------------- 1 | export(blmer, bglmer) 2 | 3 | exportClasses(bmerMod, blmerMod, bglmerMod) 4 | 5 | S3method(print, bmerMod) 6 | S3method(print, summary.bmerMod) 7 | S3method(summary, bmerMod) 8 | S3method(summary, summary.bmerMod) 9 | S3method(vcov, summary.bmerMod) 10 | S3method(refit, bmerMod) 11 | S3method(refitML, bmerMod) 12 | 13 | S3method(toString, bmerNormalDist) 14 | S3method(toString, bmerTDist) 15 | S3method(toString, bmerHorseshoeDist) 16 | S3method(toString, bmerPointDist) 17 | S3method(toString, bmerWishartDist) 18 | S3method(toString, bmerInvWishartDist) 19 | S3method(toString, bmerGammaDist) 20 | S3method(toString, bmerInvGammaDist) 21 | 22 | importFrom(methods, is, isGeneric, new, representation, show) 23 | importFrom(methods, setClass, setGeneric, setMethod) 24 | 25 | importFrom(stats, sd, vcov) 26 | importFrom(stats, gaussian, family) 27 | importFrom(stats, model.frame, formula) 28 | importFrom(stats, getCall, setNames) 29 | 30 | importFrom(utils, data, getS3method, packageVersion) 31 | 32 | importClassesFrom(lme4, merMod, lmerMod, glmerMod) 33 | importFrom(lme4, lmer, glmer) 34 | importFrom(lme4, lFormula, glFormula) 35 | importFrom(lme4, lmerControl, glmerControl) 36 | importFrom(lme4, mkMerMod) 37 | importFrom(lme4, optimizeGlmer) 38 | importFrom(lme4, mkLmerDevfun, mkGlmerDevfun, updateGlmerDevfun) 39 | importFrom(lme4, isLMM, isGLMM, mkRespMod, GHrule, isREML) 40 | importFrom(lme4, refit, refitML) -------------------------------------------------------------------------------- /tests/testthat/test-06-lmm_resid.R: -------------------------------------------------------------------------------- 1 | context("blmer numerical results with residual variance prior") 2 | 3 | test_that("blmer fits the eight schools example correctly", { 4 | # eight schools 5 | y <- c(28, 8, -3, 7, -1, 1, 18, 12) 6 | sigma <- c(15, 10, 16, 11, 9, 11, 10, 18) 7 | 8 | y.z <- (y - mean(y)) / sigma 9 | 10 | g <- 1:8 11 | 12 | control <- lmerControl(check.conv.singular = "ignore", 13 | check.nobs.vs.nRE = "ignore", 14 | check.nobs.vs.nlev = "ignore") 15 | eightSchools <- blmer(y.z ~ 1 + (1 | g), REML = FALSE, 16 | control = control, 17 | resid.prior = point, 18 | cov.prior = NULL, fixef.prior = NULL) 19 | 20 | expect_equal(eightSchools@theta, 0, tolerance = 1.0e-7) 21 | }) 22 | 23 | test_that("blmer fits test data with inv.gamma prior, matching previous version", { 24 | source(system.file("common", "lmmData.R", package = "blme")) 25 | 26 | control <- lmerControl(optimizer = "bobyqa") 27 | fit <- blmer(y ~ x.1 + x.2 + (1 + x.1 | g.1) + (1 + x.1 + x.2 | g.2), testData, control = control, 28 | cov.prior = NULL, resid.prior = invgamma(2, 1.0)) 29 | expect_equal(fit@pp$theta, c(0.725321928185923, -0.251272308917427, 1.5828609906233, 0.946932542474828, 0.467970716580088, -0.183212783510381, 1.07158442297183, 0.122067368879505, 0.223238050522642), 30 | tolerance = 1.0e-5) 31 | }) 32 | 33 | -------------------------------------------------------------------------------- /man/bmerMod-class.Rd: -------------------------------------------------------------------------------- 1 | \docType{class} 2 | \name{bmerMod-class} 3 | \title{Class "bmerMod" of Fitted Mixed-Effect Models} 4 | \alias{blmerMod-class} 5 | \alias{bglmerMod-class} 6 | \alias{bmerMod} 7 | \alias{bmerMod-class} 8 | \alias{print.bmerMod} 9 | \alias{print.summary.bmerMod} 10 | \alias{show,bmerMod-method} 11 | \alias{show.bmerMod} 12 | \alias{summary.bmerMod} 13 | \alias{summary.summary.bmerMod} 14 | \alias{vcov.summary.bmerMod} 15 | 16 | \description{The \code{bmerMod} class represents linear or generalized 17 | linear or nonlinear mixed-effects models with possible priors over 18 | model components. It inherits from the \code{\link[lme4:merMod-class]{merMod}} 19 | class. 20 | } 21 | 22 | \section{Objects from the Class}{ 23 | Objects are created by calls to \code{\link{blmer}} or \code{\link{bglmer}}. 24 | } 25 | 26 | \section{Slots}{ 27 | A \code{bmerMod} object contains one additional slot beyond the base 28 | \code{merMod} class: 29 | 30 | \describe{ 31 | \item{\code{priors}:}{A named list comprised of \code{covPriors}, 32 | \code{fixefPrior}, and \code{residPrior}.} 33 | } 34 | 35 | In addition, the \code{devcomp} slot, element \code{cmp} includes the 36 | \code{penalty} item which is the computed deviance for the priors. Add 37 | this to the regular deviance to obtain the value of the objective function 38 | that is used in optimization. 39 | } 40 | \seealso{ 41 | \code{\link{blmer}} and \code{\link{bglmer}}, 42 | which produce these objects. 43 | \cr 44 | \code{\link[lme4:merMod-class]{merMod}}, from which this class inherits. 45 | } 46 | \examples{ 47 | showClass("bmerMod") 48 | methods(class = "bmerMod") 49 | } 50 | \keyword{classes} 51 | -------------------------------------------------------------------------------- /R/dist_horseshoe.R: -------------------------------------------------------------------------------- 1 | setClass("bmerHorseshoeDist", 2 | representation(beta.0 = "numeric", 3 | tau.sq = "numeric"), 4 | contains = "bmerDist") 5 | 6 | toString.bmerHorseshoeDist <- function(x, digits = getOption("digits"), ...) { 7 | meanString <- "" 8 | beta.0 <- x@beta.0 9 | if (length(beta.0) > 4L) { 10 | meanString <- paste0("mean = c(", toString(round(beta.0[seq_len(4L)], digits)), ", ...)") 11 | } else if (length(beta.0) == 1L) { 12 | meanString <- paste0("mean = ", toString(round(beta.0[1L], digits))) 13 | } else { 14 | meanString <- paste0("mean = c(", toString(round(beta.0, digits)), ")") 15 | } 16 | 17 | paste0("horseshoe(", meanString, ", ", 18 | "global.shrinkage = ", round(sqrt(x@tau.sq), digits), ", ", 19 | "common.scale = ", x@commonScale, ")") 20 | } 21 | setMethod("getDFAdjustment", "bmerHorseshoeDist", 22 | function(object) { 23 | if (object@commonScale == TRUE) length(object@beta.0) else 0 24 | } 25 | ) 26 | setMethod("getConstantTerm", "bmerHorseshoeDist", 27 | function(object) { 28 | d <- length(object@beta.0) 29 | 30 | d * (3 * log(pi) + log(2) + log(object@tau.sq)) 31 | } 32 | ) 33 | setMethod("getExponentialTerm", "bmerHorseshoeDist", 34 | function(object, beta, sigma = NULL) { 35 | beta.0 <- object@beta.0 36 | tau.sq <- object@tau.sq 37 | 38 | dist <- 0.5 * (beta - beta.0)^2 / tau.sq 39 | if (object@commonScale == TRUE && !is.null(sigma)) dist <- dist / sigma^2 40 | 41 | temp <- suppressWarnings(sapply(dist, expint::expint_E1, scale = TRUE)) 42 | temp[is.nan(temp)] <- .Machine$double.xmax * .Machine$double.eps 43 | 44 | result <- -2 * sum(log(temp)) 45 | 46 | c(0, result) 47 | } 48 | ) 49 | 50 | -------------------------------------------------------------------------------- /tests/testthat/test-03-resid_errors.R: -------------------------------------------------------------------------------- 1 | context("blmer, resid.prior argument") 2 | 3 | test_that("resid.prior argument raises apprprioate errors", { 4 | source(system.file("common", "lmmData.R", package = "blme")) 5 | 6 | blmerFit <- blmer(y ~ x.1 + (1 | g.1), testData, 7 | cov.prior = NULL, fixef.prior = NULL, resid.prior = NULL) 8 | 9 | parsePrior <- blme:::parsePrior 10 | 11 | expect_error(parsePrior(blmerFit, resid.prior = numeric(0))) 12 | expect_error(parsePrior(blmerFit, resid.prior = list(numeric(0)))) 13 | expect_error(parsePrior(blmerFit, resid.prior = "not a prior")) 14 | 15 | expect_error(parsePrior(blmerFit, resid.prior = "point(()")) 16 | 17 | expect_error(parsePrior(blmerFit, resid.prior = "point(value = 2, notAParam = 0)")) 18 | expect_error(parsePrior(blmerFit, resid.prior = "point(value = 'not a number')")) 19 | expect_error(parsePrior(blmerFit, resid.prior = "point(value = 0)")) 20 | expect_error(parsePrior(blmerFit, resid.prior = "point(value = 2, posterior.scale = 'not a scale')")) 21 | 22 | expect_error(parsePrior(blmerFit, resid.prior = "invgamma(-1)")) 23 | expect_error(parsePrior(blmerFit, resid.prior = "invgamma(scale = -1)")) 24 | expect_error(parsePrior(blmerFit, resid.prior = "invgamma(notAParam = 0)")) 25 | expect_error(parsePrior(blmerFit, resid.prior = "invgamma(common.scale = 'anything')")) 26 | expect_error(parsePrior(blmerFit, resid.prior = "invgamma(posterior.scale = 'not a scale')")) 27 | 28 | expect_error(parsePrior(blmerFit, resid.prior = "gamma(-1)")) 29 | expect_error(parsePrior(blmerFit, resid.prior = "gamma(rate = -1)")) 30 | expect_error(parsePrior(blmerFit, resid.prior = "gamma(notAParam = 0)")) 31 | expect_error(parsePrior(blmerFit, resid.prior = "gamma(posterior.scale = 'not a scale')")) 32 | }) 33 | -------------------------------------------------------------------------------- /R/generics.R: -------------------------------------------------------------------------------- 1 | ## This is modeled a bit after print.summary.lm : 2 | ## Prints *both* 'mer' and 'merenv' - as it uses summary(x) mainly 3 | printBmerenv <- function(x, digits = max(3, getOption("digits") - 3), 4 | correlation = NULL, symbolic.cor = FALSE, 5 | signif.stars = getOption("show.signif.stars"), 6 | ranef.comp = c("Variance", "Std.Dev."), ...) 7 | { 8 | printPriors(x$priors, x$ngrps, digits) 9 | cat("Prior dev : ", round(x$devcomp$cmp[["penalty"]], digits), "\n\n", sep = "") 10 | 11 | printMethod <- getS3method("print", "summary.merMod") 12 | result <- printMethod(x, digits, correlation, symbolic.cor, signif.stars, ranef.comp, ...) 13 | invisible(result) 14 | } 15 | 16 | print.bmerMod <- function(x, digits = max(3, getOption("digits") - 3), 17 | correlation = NULL, symbolic.cor = FALSE, 18 | signif.stars = getOption("show.signif.stars"), 19 | ranef.comp = "Std.Dev.", ...) 20 | { 21 | printPriors(x@priors, x@cnms, digits) 22 | cat("Prior dev : ", round(x@devcomp$cmp[["penalty"]], digits), "\n\n", sep = "") 23 | 24 | printMethod <- getS3method("print", "merMod") 25 | result <- printMethod(x, digits, correlation, symbolic.cor, signif.stars, ranef.comp, ...) 26 | invisible(result) 27 | } 28 | 29 | setMethod("show", "bmerMod", function(object) print.bmerMod(object)) 30 | 31 | print.summary.bmerMod <- printBmerenv 32 | 33 | summary.bmerMod <- function(object, ...) 34 | { 35 | result <- NextMethod(.Generic, object = object, ...) 36 | result$priors <- object@priors 37 | 38 | structure(result, 39 | class = c("summary.bmerMod", "summary.merMod")) 40 | } 41 | 42 | summary.summary.bmerMod <- function(object, varcov = TRUE, ...) { 43 | getS3method("summary", "summary.merMod")(object, varcov, ...) 44 | } 45 | 46 | vcov.summary.bmerMod <- function(object, correlation = TRUE, ...) { 47 | getS3method("vcov", "summary.merMod")(object, correlation, ...) 48 | } 49 | -------------------------------------------------------------------------------- /inst/common/checkWarning.R: -------------------------------------------------------------------------------- 1 | checkWarning <- function (expr, msg = "", silent = getOption("RUnit")$silent) 2 | { 3 | tryWarn <- function (expr, silent = FALSE) { 4 | tryCatch(expr, warning = function(e) { 5 | call <- conditionCall(e) 6 | if (!is.null(call)) { 7 | if (identical(call[[1L]], quote(doTryCatch))) 8 | call <- sys.call(-4L) 9 | dcall <- deparse(call)[1L] 10 | prefix <- paste("Warning in", dcall, ": ") 11 | LONG <- 75L 12 | msg <- conditionMessage(e) 13 | sm <- strsplit(msg, "\n")[[1L]] 14 | w <- 14L + nchar(dcall, type = "w") + nchar(sm[1L], 15 | type = "w") 16 | if (is.na(w)) 17 | w <- 14L + nchar(dcall, type = "b") + nchar(sm[1L], 18 | type = "b") 19 | if (w > LONG) 20 | prefix <- paste(prefix, "\n ", sep = "") 21 | } 22 | else prefix <- "Warning : " 23 | msg <- paste(prefix, conditionMessage(e), "\n", sep = "") 24 | .Internal(seterrmessage(msg[1L])) 25 | if (!silent && identical(getOption("show.error.messages"), 26 | TRUE)) { 27 | cat(msg, file = stderr()) 28 | .Internal(printDeferredWarnings()) 29 | } 30 | invisible(structure(msg, class = "try-error")) 31 | }) 32 | } 33 | 34 | if (missing(expr)) { 35 | stop("'expr' is missing") 36 | } 37 | if (is.null(silent)) { 38 | silent <- FALSE 39 | warning("'silent' has to be of type 'logical'. Was NULL. Set to FALSE.") 40 | } 41 | if (RUnit:::.existsTestLogger()) { 42 | .testLogger$incrementCheckNum() 43 | } 44 | if (!inherits(tryWarn(eval(expr, envir = parent.frame()), silent = silent), 45 | "try-error")) { 46 | if (RUnit:::.existsTestLogger()) { 47 | .testLogger$setFailure() 48 | } 49 | stop("Warning not generated as expected\n", msg) 50 | } 51 | else { 52 | return(TRUE) 53 | } 54 | } 55 | -------------------------------------------------------------------------------- /R/dist_normal.R: -------------------------------------------------------------------------------- 1 | setClass("bmerNormalDist", 2 | representation(R.cov.inv = "matrix"), 3 | contains = "bmerDist") 4 | 5 | toString.bmerNormalDist <- function(x, digits = getOption("digits"), ...) { 6 | if (any(diag(x@R.cov.inv) == 0)) { 7 | cov <- diag(1 / diag(x@R.cov.inv)^2) 8 | sds <- sqrt(diag(cov)) 9 | corrs <- matrix(0, nrow(cov), ncol(cov)) 10 | } else { 11 | cov <- crossprod(solve(x@R.cov.inv)) 12 | sds <- sqrt(diag(cov)) 13 | corrs <- diag(1 / sds) %*% cov %*% diag(1 / sds) 14 | } 15 | 16 | sds <- round(sds, digits) 17 | corrs <- round(corrs[lower.tri(corrs)], digits) 18 | 19 | if (nrow(cov) > 2L) { 20 | covString <- paste0("sd = c(", paste0(round(sds[1L:2L], digits), collapse = ", "), 21 | ", ...), corr = c(", round(corrs[1L], digits), " ...)") 22 | } else if (nrow(cov) == 2L) { 23 | covString <- paste0("sd = c(", paste0(round(sds[1L:2L], digits), collapse = ", "), 24 | "), corr = ", round(corrs[1L], digits)) 25 | } else { 26 | covString <- paste0("sd = ", round(sds[1L], digits)) 27 | } 28 | 29 | paste0("normal(", covString, ", ", 30 | "common.scale = ", x@commonScale, ")") 31 | } 32 | 33 | setMethod("getDFAdjustment", "bmerNormalDist", 34 | function(object) { 35 | if (object@commonScale == TRUE) sum(diag(object@R.cov.inv) != 0) else 0 36 | } 37 | ) 38 | setMethod("getConstantTerm", "bmerNormalDist", 39 | function(object) { 40 | R.cov.inv <- object@R.cov.inv 41 | if (any(diag(R.cov.inv) < 0)) return(NA) 42 | 43 | nonZeroes <- diag(R.cov.inv) != 0 44 | rank <- sum(nonZeroes) 45 | 46 | rank * log(2 * pi) - 2.0 * sum(log(diag(R.cov.inv)[nonZeroes])) 47 | } 48 | ) 49 | setMethod("getExponentialSigmaPower", "bmerNormalDist", 50 | function(object) { if (object@commonScale == TRUE) -2 else 0 } 51 | ) 52 | setMethod("getExponentialTerm", "bmerNormalDist", 53 | function(object, beta) { 54 | exponential <- tcrossprod(crossprod(beta, object@R.cov.inv))[1] 55 | if (object@commonScale == TRUE) c(-2, exponential) else c(0, exponential) 56 | } 57 | ) 58 | -------------------------------------------------------------------------------- /tests/testthat/test-04-fixef_errors.R: -------------------------------------------------------------------------------- 1 | context("b(g)lmer, fixef.prior argument") 2 | 3 | test_that("fixef.prior argument raises appropriate errors for blmer fits", { 4 | source(system.file("common", "lmmData.R", package = "blme")) 5 | 6 | fit <- blmer(y ~ x.1 + (1 | g.1), testData, 7 | cov.prior = NULL, fixef.prior = NULL, resid.prior = NULL) 8 | 9 | parsePrior <- blme:::parsePrior 10 | 11 | expect_error(parsePrior(fit, fixef.prior = "normal(common.scale = 'crazy')")) 12 | expect_error(parsePrior(fit, fixef.prior = "normal(cov = diag(3))")) 13 | negDefiniteMatrix <- matrix(c(1, 0, 0, -0.1), 2, 2) 14 | expect_error(parsePrior(fit, fixef.prior = "normal(cov = negDefiniteMatrix)")) 15 | asymmetricMatrix <- matrix(c(1, 0.5, 0.3, 0.7), 2, 2) 16 | expect_error(parsePrior(fit, fixef.prior = "normal(cov = asymmetricMatrix)")) 17 | 18 | expect_error(parsePrior(fit, fixef.prior = "t")) 19 | 20 | fit <- blmer(y ~ x.1 + (1 | g.1), testData, REML = FALSE, 21 | cov.prior = NULL, fixef.prior = NULL, resid.prior = NULL) 22 | expect_error(parsePrior(fit, fixef.prior = "t(df = 0)")) 23 | expect_error(parsePrior(fit, fixef.prior = "t(scale = c(-1, 2))")) 24 | expect_error(parsePrior(fit, fixef.prior = "horseshoe(global.shrinkage = -1)")) 25 | 26 | expect_error(blmer(y ~ x.1 + (1 | g.1), testData, REML = TRUE, 27 | cov.prior = NULL, fixef.prior = t, resid.prior = NULL)) 28 | expect_error(blmer(y ~ x.1 + (1 | g.1), testData, REML = TRUE, 29 | cov.prior = NULL, fixef.prior = horseshoe(), resid.prior = NULL)) 30 | }) 31 | 32 | test_that("fixef.prior argument raises appropriate errors for bglmer fits", { 33 | source(system.file("common", "glmmData.R", package = "blme")) 34 | 35 | parsePrior <- blme:::parsePrior 36 | 37 | bglmerFit <- bglmer(y ~ x.1 + x.2 + (1 | g), testData, family = binomial(), 38 | cov.prior = NULL) 39 | 40 | expect_error(parsePrior(bglmerFit, fixef.prior = normal(common.scale = TRUE))) 41 | expect_error(parsePrior(bglmerFit, fixef.prior = t(common.scale = TRUE))) 42 | expect_error(parsePrior(bglmerFit, fixef.prior = horseshoe(common.scale = TRUE))) 43 | }) 44 | -------------------------------------------------------------------------------- /tests/testthat/test-05-covariance_errors.R: -------------------------------------------------------------------------------- 1 | context("blmer, cov.prior argument") 2 | 3 | 4 | test_that("cov.prior argument raises appropriate errors", { 5 | source(system.file("common", "lmmData.R", package = "blme")) 6 | 7 | lmerFit <- lmer(y ~ x.1 + (1 | g.1), testData) 8 | blmerFit <- blmer(y ~ x.1 + (1 | g.1), testData, 9 | cov.prior = NULL, fixef.prior = NULL, resid.prior = NULL) 10 | 11 | parsePrior <- blme:::parsePrior 12 | 13 | # Morally speaking, parsePrior isn't exposed to the user 14 | # so perhaps this first set of tests is excessive. 15 | expect_error(parsePrior()) 16 | expect_error(parsePrior(NULL)) 17 | expect_error(parsePrior(notAValidObject)) 18 | expect_error(parsePrior(lmerFit)) 19 | 20 | expect_error(parsePrior(blmerFit, numeric(0))) 21 | expect_error(parsePrior(blmerFit, list(numeric(0)))) 22 | expect_error(parsePrior(blmerFit, "not a prior")) 23 | expect_error(parsePrior(blmerFit, list("not a", "prior"))) 24 | expect_error(parsePrior(blmerFit, "notAGroup ~ gamma")) 25 | 26 | expect_error(parsePrior(blmerFit, "invgamma(shape = 'not a number')")) 27 | expect_error(parsePrior(blmerFit, "invgamma(shape = -1)")) 28 | expect_error(parsePrior(blmerFit, "invgamma(scale = -1)")) 29 | 30 | expect_error(parsePrior(blmerFit, "wishart(df = 'not a number')")) 31 | expect_error(parsePrior(blmerFit, "wishart(df = 0)")) 32 | expect_error(parsePrior(blmerFit, "wishart(scale = 'not a number')")) 33 | expect_error(parsePrior(blmerFit, "wishart(scale = -0.01)")) 34 | expect_error(parsePrior(blmerFit, "invwishart(df = 'not a number')")) 35 | expect_error(parsePrior(blmerFit, "invwishart(df = 0)")) 36 | expect_error(parsePrior(blmerFit, "invwishart(scale = 'not a number')")) 37 | expect_error(parsePrior(blmerFit, "invwishart(scale = -0.01)")) 38 | 39 | expect_error(parsePrior(blmerFit, "gamma(posterior.scale = 'not a scale')")) 40 | expect_error(parsePrior(blmerFit, "gamma(common.scale = 'not a boolean')")) 41 | 42 | blmerFit <- blmer(y ~ x.1 + (1 + x.1 | g.1), testData, 43 | cov.prior = NULL, fixef.prior = NULL, resid.prior = NULL) 44 | expect_warning(parsePrior(blmerFit, "gamma")) 45 | }) 46 | -------------------------------------------------------------------------------- /inst/doc/R/profileContour.R: -------------------------------------------------------------------------------- 1 | n <- 5; 2 | J <- 8; 3 | N <- n * J; 4 | g <- rep(1:J, rep(n, J)); 5 | mu <- 0; 6 | sigma.the <- 1; 7 | sigma.eps <- 1; 8 | 9 | set.seed(0); 10 | 11 | theta <- rnorm(J, 0, sigma.the * sigma.eps); 12 | y <- rnorm(N, mu + theta[g], sigma.eps); 13 | 14 | y.bar <- mean(y); 15 | y.bar.j <- sapply(1:J, function(j) mean(y[g == j])); 16 | S.w <- sum((y - y.bar.j[g])^2); 17 | S.b <- sum((y.bar.j - y.bar)^2); 18 | 19 | profiledLikelihood <- function(sigma.the, sigma.eps) { 20 | sigma.the.sq <- sigma.the^2; 21 | sigma.eps.sq <- sigma.eps^2; 22 | v <- sigma.the.sq + 1 / n; 23 | 24 | -0.5 * N * log(sigma.eps.sq) - 0.5 * J * log(v) - 0.5 * 25 | (S.w + S.b / v) / sigma.eps.sq; 26 | } 27 | 28 | sigma.eps.hat <- function(sigma.the) { 29 | v <- sigma.the^2 + 1 / n; 30 | sqrt((S.w + S.b / v) / N); 31 | } 32 | 33 | profiledProfiledLikelihood <- function(sigma.the) { 34 | v <- sigma.the^2 + 1 / n; 35 | -(N / 2) * log(S.w + S.b / v) - (J / 2) * log(v); 36 | } 37 | 38 | sigma.thes <- seq(0.25, 2.5, length.out = 101); 39 | sigma.epss <- seq(0.6, 1.25, length.out = 101); 40 | 41 | zValues <- sapply(sigma.epss, function(y) profiledLikelihood(sigma.thes, y)); 42 | zValues <- exp(zValues - median(zValues)); 43 | zValues <- zValues / sum(zValues * (sigma.thes[2] - sigma.thes[1]) * (sigma.epss[2] - sigma.epss[1])); 44 | 45 | pdf(imgPath, height = defaultImgHeight, width = defaultImgWidth * 2); 46 | par(mfrow = c(1, 2)); 47 | par(defaultPars); 48 | contour(sigma.thes, sigma.epss, zValues, 49 | xlab = expression(sigma[b]), ylab=expression(sigma), 50 | main = "Likelihood", drawlabels = FALSE); 51 | 52 | yValues <- sigma.eps.hat(sigma.thes); 53 | lines(sigma.thes, yValues, col="gray"); 54 | text(sigma.thes[2], yValues[2], expression(hat(sigma)(sigma[b])), 55 | adj = c(-0.1, 0.5), cex = defaultPars$cex.lab * defaultPars$cex); 56 | 57 | yValues <- profiledProfiledLikelihood(sigma.thes); 58 | yValues <- exp(yValues - median(yValues)); 59 | plotPars <- defaultPars; 60 | plotPars$mar[2] <- 0.1; 61 | par(plotPars); 62 | plot(sigma.thes, yValues, type = 'l', xlab=expression(sigma[b]), 63 | yaxt='n', ylab = "", bty = 'n', main="Profiled Likelihood", yaxs = 'i'); 64 | ignored <- dev.off(); 65 | -------------------------------------------------------------------------------- /tests/testthat/test-10-refit.R: -------------------------------------------------------------------------------- 1 | ## for old versions of lme4, the refit for g/lmer doesn't move very 2 | ## far from the fit so we just suppress the test 3 | 4 | lme4Version <- packageVersion("lme4") 5 | if (lme4Version >= "1.1-6") { 6 | context("refit generic for blmerMod and bglmerMod classes") 7 | 8 | source(system.file("common", "lmmData.R", package = "blme")) 9 | control <- lmerControl(optimizer = "Nelder_Mead") 10 | 11 | cov.prior <- "g.1 ~ wishart(scale = 2)" 12 | fit <- blmer(y ~ x.1 + x.2 + (1 + x.1 | g.1), testData, cov.prior = cov.prior, control = control) 13 | 14 | test_that("refit for blmer matches original, not lmer", { 15 | blmerRefit <- refit(fit) 16 | lmerRefit <- getS3method("refit", "merMod")(fit) 17 | 18 | expect_equal(fit@theta, blmerRefit@theta, tolerance = 1.0e-02) 19 | expect_equal(fit@beta, blmerRefit@beta, tolerance = 1.0e-03) 20 | 21 | expect_false(all(abs(fit@theta - lmerRefit@theta) <= 1.0e-02)) 22 | expect_false(all(abs(fit@beta - lmerRefit@beta) <= 1.0e-03)) 23 | }) 24 | 25 | test_that("ml refit matches ml fit", { 26 | mlRefit <- refitML(fit) 27 | mlFit <- blmer(y ~ x.1 + x.2 + (1 + x.1 | g.1), testData, cov.prior = cov.prior, control = control, REML = FALSE) 28 | 29 | expect_equal(mlRefit@theta, mlFit@theta, tolerance = 1.0e-02) 30 | expect_equal(mlRefit@beta, mlFit@beta, tolerance = 1.0e-03) 31 | 32 | expect_false(all(abs(fit@theta - mlRefit@theta) <= 1.0e-02)) 33 | expect_false(all(abs(fit@beta - mlFit@beta) <= 1.0e-03)) 34 | }) 35 | 36 | test_that("refit for bglmer matches original, not glmer", { 37 | source(system.file("common", "glmmData.R", package = "blme")) 38 | control <- if (lme4Version >= "1.1-8") 39 | glmerControl(optimizer = "Nelder_Mead", nAGQ0initStep = FALSE) 40 | else 41 | glmerControl(optimizer = "Nelder_Mead") 42 | 43 | fit <- bglmer(y ~ x.1 + x.2 + (1 | g), testData, family = binomial(), control = control, 44 | cov.prior = wishart) 45 | 46 | bglmerRefit <- refit(fit) 47 | glmerRefit <- getS3method("refit", "merMod")(fit) 48 | 49 | expect_equal(fit@theta, bglmerRefit@theta, tolerance = 1.0e-3) 50 | expect_equal(fit@beta, bglmerRefit@beta, tolerance = 1.0e-3) 51 | 52 | expect_false(all(abs(fit@theta - glmerRefit@theta) <= 1.0e-3)) 53 | expect_false(all(abs(fit@beta - glmerRefit@beta) <= 1.0e-3)) 54 | }) 55 | } 56 | -------------------------------------------------------------------------------- /inst/doc/R/util.R: -------------------------------------------------------------------------------- 1 | functionToString <- function(name, fn) { 2 | maxColWidth <- 75; 3 | 4 | indent <- nchar(name) + 1; 5 | indentString <- ""; 6 | if (indent > 0) { 7 | for (i in 1:indent) indentString <- sprintf("%s%s", indentString, " ") 8 | } 9 | 10 | result <- paste(name, "(", sep = ""); 11 | 12 | values <- formals(fn) 13 | names <- names(values) 14 | 15 | if (is.symbol(values[[1]])) { 16 | result <- paste(result, names[[1]], sep = ""); 17 | } else { 18 | value <- values[[1]]; 19 | if (is.character(value)) value <- paste("\"", value, "\"", sep = "") 20 | if (is.language(value)) value <- deparse(value) 21 | result <- paste(result, names[[1]], " = ", value, sep = "") 22 | } 23 | 24 | if (length(values) > 1) for (i in 2:length(values)) { 25 | if (is.symbol(values[[i]])) { 26 | result <- paste(result, ", ", names[[i]], sep = "") 27 | } else { 28 | value <- values[[i]]; 29 | if (is.character(value)) value <- paste('"', value, '"', sep = "") 30 | if (is.language(value)) value <- deparse(value) 31 | result <- paste(result, ", ", names[[i]], " = ", value, sep = "") 32 | } 33 | } 34 | 35 | result <- commaColumnWrap(result, maxColWidth); 36 | 37 | if (length(result) == 2) { 38 | cat("\\verb?", result[1], "?\\\\\n", sep = ""); 39 | cat("\\verb?", indentString, result[2], ")?\n", sep = ""); 40 | ##result <- paste(head, ",\\\\\\\\\n", indentString, tail, sep = ""); 41 | } else { 42 | cat("\\verb?", result, ")?\n", sep = ""); 43 | } 44 | } 45 | 46 | 47 | commaColumnWrap <- function(string, maxColWidth) { 48 | if (nchar(string) <= maxColWidth) return(string); 49 | 50 | ## replaces last ", " by a question mark and then splits on that 51 | ## OK, because question marks aren't allowed aside from help queries (I think) 52 | split <- strsplit(sub("(.*), (.*)", "\\1?\\2", string, perl = TRUE), "\\?") 53 | head <- split[[1]][1]; 54 | tail <- split[[1]][2]; 55 | 56 | while (nchar(head) > maxColWidth) { 57 | split <- strsplit(sub("(.*), (.*)", "\\1?\\2", head, perl = TRUE), "\\?") 58 | head <- split[[1]][1]; 59 | tail <- paste(split[[1]][2], ", ", tail, sep = ""); 60 | } 61 | 62 | return(c(paste(head, ",", sep = ""), tail)); 63 | } 64 | 65 | makeOrCheckDir <- function(dirName) 66 | { 67 | if (!file.exists(dirName)) dir.create(dirName) 68 | info <- file.info(dirName) 69 | if (!info$isdir) stop("'", dirName, "' is not a directory") 70 | } 71 | -------------------------------------------------------------------------------- /tests/testthat/test-11-prior_parse.R: -------------------------------------------------------------------------------- 1 | library(blme) 2 | source(system.file("common", "lmmData.R", package = "blme")) 3 | lme4Version <- packageVersion("lme4") 4 | control <- lmerControl(optimizer = "Nelder_Mead") 5 | control$optCtrl <- list(maxfun = 1L) 6 | control$checkConv <- NULL 7 | 8 | test_that("blmer finds prior options specified as variables in global env", { 9 | g1_rate <- 0.5 10 | cov.prior <- "g.1 ~ gamma(rate = g1_rate)" 11 | expect_is( 12 | suppressWarnings(blmer(y ~ x.1 + x.2 + (1 | g.1), testData, cov.prior = cov.prior, control = control)), 13 | "blmerMod" 14 | ) 15 | 16 | expect_is( 17 | suppressWarnings(blmer(y ~ x.1 + x.2 + (1 | g.1), testData, cov.prior = g.1 ~ gamma(rate = g1_rate), control = control)), 18 | "blmerMod" 19 | ) 20 | }) 21 | 22 | test_that("blmer finds prior options when fit in a function", { 23 | fit_fn <- function() { 24 | g1_rate <- 0.5 25 | cov.prior <- "g.1 ~ gamma(rate = g1_rate)" 26 | blmer(y ~ x.1 + x.2 + (1 | g.1), testData, cov.prior = cov.prior, control = control) 27 | } 28 | expect_is(suppressWarnings(fit_fn()), "blmerMod") 29 | 30 | fit_fn <- function() { 31 | g1_rate <- 0.5 32 | blmer(y ~ x.1 + x.2 + (1 | g.1), testData, cov.prior = g.1 ~ gamma(rate = g1_rate), control = control) 33 | } 34 | expect_is(suppressWarnings(fit_fn()), "blmerMod") 35 | 36 | g1_rate <- 0.5 37 | fit_fn <- function() { 38 | blmer(y ~ x.1 + x.2 + (1 | g.1), testData, cov.prior = g.1 ~ gamma(rate = g1_rate), control = control) 39 | } 40 | expect_is(suppressWarnings(fit_fn()), "blmerMod") 41 | }) 42 | 43 | # test thanks to Jacob Grytzka 44 | test_that("blmer finds prior options when fit in a function, horseshoe prior specifically", { 45 | skip_if_not_installed("expint") 46 | fit_fn <- function() { 47 | pen <- 5 48 | blmer(Sepal.Length ~ Sepal.Width + Petal.Length + Petal.Width + (1|Species), 49 | data = iris, REML = FALSE, 50 | fixef.prior = horseshoe(mean = 1e-5, 51 | global.shrinkage = pen, 52 | common.scale = TRUE) 53 | ) 54 | } 55 | expect_is(suppressWarnings(fit_fn()), "blmerMod") 56 | 57 | pen <- 5 58 | fit_fn <- function() { 59 | blmer(Sepal.Length ~ Sepal.Width + Petal.Length + Petal.Width + (1|Species), 60 | data = iris, REML = FALSE, 61 | fixef.prior = horseshoe(mean = 1e-5, 62 | global.shrinkage = pen, 63 | common.scale = TRUE) 64 | ) 65 | } 66 | expect_is(suppressWarnings(fit_fn()), "blmerMod") 67 | }) 68 | 69 | -------------------------------------------------------------------------------- /tests/testthat/test-09-glmm_priors.R: -------------------------------------------------------------------------------- 1 | context("bglmer numerical results with fixef and cov priors") 2 | 3 | source(system.file("common", "glmmData.R", package = "blme")) 4 | control <- glmerControl(optimizer = "Nelder_Mead") 5 | lme4Version <- packageVersion("lme4") 6 | 7 | test_that("bglmer fits test data with fixef prior, matching previous version", { 8 | fit <- bglmer(y ~ x.1 + x.2 + (1 | g), testData, family = binomial(), control = control, 9 | cov.prior = NULL, fixef.prior = normal) 10 | if (lme4Version < "1.1-4") { 11 | expect_equal(fit@theta, 1.26501253837861) 12 | expect_equal(fit@beta, c(0.873121247636467, 2.46647249930796, 1.32070156863358)) 13 | } else { 14 | expect_equal(fit@theta, 1.26501385482573) 15 | expect_equal(fit@beta, c(0.873131216784199, 2.46647899095567, 1.32070496549675)) 16 | } 17 | }) 18 | 19 | test_that("bglmer fits test data with cov prior, matching previous version", { 20 | fit <- bglmer(y ~ x.1 + x.2 + (1 | g), testData, family = binomial(), control = control, 21 | cov.prior = wishart) 22 | if (lme4Version < "1.1-4") { 23 | expect_equal(fit@theta, 2.96766525351892) 24 | expect_equal(fit@beta, c(1.0963789854971, 3.67790570859986, 1.75655010020603)) 25 | } else { 26 | expect_equal(fit@theta, 2.96767284827046) 27 | expect_equal(fit@beta, c(1.0963789854971, 3.67790570859986, 1.75655010020603)) 28 | } 29 | }) 30 | 31 | test_that("bglmer runs with fixef horseshoe prior", { 32 | skip_if_not_installed("expint") 33 | suppressWarnings(fit <- bglmer(y ~ x.1 + x.2 + (1 | g), testData, family = binomial(), control = control, 34 | cov.prior = NULL, fixef.prior = horseshoe)) 35 | 36 | expect_equal(fit@theta, 1.44188949480559) 37 | expect_equal(fit@beta, c(-3.00402517816968e-08, 2.38133218752372, 1.40658715296947)) 38 | }) 39 | 40 | test_that("bglmer runs cov prior specified using level.dim", { 41 | fit <- bglmer(y ~ x.1 + x.2 + (1 | g), testData, family = binomial(), control = control, 42 | cov.prior = wishart(df = level.dim + 1.25)) 43 | expect_is(fit, "bglmerMod") 44 | expect_equal(fit@priors$cov[[1]]@df, 2.25) 45 | }) 46 | 47 | test_that("blmer fits test data with custom prior, matching builtin gamma", { 48 | dgamma_cust <- function(x) dgamma(x, shape = 2.5, rate = 0.01, log = TRUE) 49 | 50 | fit.prof <- bglmer(y ~ x.1 + x.2 + (1 | g), testData, control = control, 51 | family = binomial(), 52 | cov.prior = gamma(rate = 0.01)) 53 | fit.cust <- bglmer(y ~ x.1 + x.2 + (1 | g), testData, control = control, 54 | family = binomial(), 55 | cov.prior = custom(dgamma_cust, chol = TRUE, scale = "log")) 56 | expect_equal(fit.prof@theta, fit.cust@theta, tolerance = 1e-6) 57 | }) 58 | 59 | -------------------------------------------------------------------------------- /R/dist_t.R: -------------------------------------------------------------------------------- 1 | setClass("bmerTDist", 2 | representation(df = "numeric", 3 | beta.0 = "numeric", 4 | d = "numeric", 5 | R.scale.inv = "matrix"), 6 | contains = "bmerDist") 7 | 8 | toString.bmerTDist <- function(x, digits = getOption("digits"), ...) { 9 | scaleString <- "" 10 | scale <- if (x@d != nrow(x@R.scale.inv)) diag(1 / diag(x@R.scale.inv)^2) else crossprod(solve(x@R.scale.inv)) 11 | 12 | meanString <- "" 13 | beta.0 <- x@beta.0 14 | if (length(beta.0) > 4L) { 15 | meanString <- paste0("mean = c(", toString(round(beta.0[seq_len(4L)], digits)), ", ...)") 16 | } else if (length(beta.0) == 1L) { 17 | meanString <- paste0("mean = ", toString(round(beta.0[1L], digits))) 18 | } else { 19 | meanString <- paste0("mean = c(", toString(round(beta.0, digits)), ")") 20 | } 21 | if (all(scale[lower.tri(scale) | upper.tri(scale)] == 0)) { 22 | scale <- diag(scale) 23 | if (length(scale) > 4L) { 24 | scaleString <- paste0("diag(scale) = c(", toString(round(scale[seq_len(4L)], digits)), ", ...") 25 | } else if (length(scale) == 1L) { 26 | scaleString <- paste0("scale = ", toString(round(scale[1L], digits))) 27 | } else { 28 | scaleString <- paste0("diag(scale) = c(", toString(round(scale, digits)), ")") 29 | } 30 | } else { 31 | if (nrow(scale) > 2L) { 32 | scaleString <- paste0("scale = c(", toString(round(scale[seq_len(4L)], digits)), ", ...)") 33 | } else if (nrow(scale) == 2L) { 34 | scaleString <- paste0("scale = c(", toString(round(scale[seq_len(4L)], digits)), ")") 35 | } else { 36 | scaleString <- paste0("scale = ", toString(round(scale[1L], digits))) 37 | } 38 | } 39 | 40 | paste0("t(df = ", x@df, ", ", meanString, ", ", scaleString, ", ", 41 | "common.scale = ", x@commonScale, ")") 42 | } 43 | setMethod("getDFAdjustment", "bmerTDist", 44 | function(object) { 45 | if (object@commonScale == TRUE) object@d else 0 46 | } 47 | ) 48 | setMethod("getConstantTerm", "bmerTDist", 49 | function(object) { 50 | R.scale.inv <- object@R.scale.inv 51 | d <- object@d 52 | df <- object@df 53 | 54 | ldet <- sum(log(if (d != nrow(R.scale.inv)) { p <- diag(R.scale.inv); p[p > 0] } else diag(R.scale.inv))) 55 | 56 | -2.0 * lgamma(0.5 * (df + d)) + 2.0 * lgamma(0.5 * df) + 57 | d * (log(df) + log(pi)) - 2.0 * ldet 58 | } 59 | ) 60 | setMethod("getExponentialTerm", "bmerTDist", 61 | function(object, beta, sigma = NULL) { 62 | beta.0 <- object@beta.0 63 | R.scale.inv <- object@R.scale.inv 64 | d <- object@d 65 | df <- object@df 66 | 67 | dist <- tcrossprod(crossprod(beta - beta.0, R.scale.inv))[1L] 68 | if (object@commonScale == TRUE && !is.null(sigma)) dist <- dist / sigma^2 69 | if (any(is.na(dist)) || any(is.infinite(dist))) stop("non-finite or NA result in t-prior") 70 | 71 | exponential <- (df + d) * log(1 + dist / df) 72 | c(0, exponential) 73 | } 74 | ) 75 | 76 | -------------------------------------------------------------------------------- /R/optimize.R: -------------------------------------------------------------------------------- 1 | ## derived from lme4/R/modular.R 2 | 3 | optimizeLmer <- function(devfun, 4 | optimizer = formals(lmerControl)$optimizer, 5 | restart_edge = formals(lmerControl)$restart_edge, 6 | boundary.tol = formals(lmerControl)$boundary.tol, 7 | start = NULL, 8 | verbose = 0L, 9 | control = list(), 10 | ...) { 11 | verbose <- as.integer(verbose) 12 | rho <- environment(devfun) 13 | 14 | lme4Env <- asNamespace("lme4") 15 | 16 | parInfo <- rho$parInfo 17 | startingValues <- getStartingValues(start, rho, parInfo) 18 | lowerBounds <- getLowerBounds(parInfo) 19 | rho$lower <- lowerBounds ## b/c lower bounds are pulled from devfunenv to check convergence 20 | thetaLowerBounds <- lowerBounds[seq_along(rho$pp$theta)] 21 | 22 | optwrap <- get("optwrap", lme4Env) 23 | lme4IsOld <- is.null(formals(optwrap)[["calc.derivs"]]) 24 | opt <- 25 | if (!lme4IsOld) 26 | optwrap(optimizer, devfun, startingValues, lower = lowerBounds, control = control, adj = FALSE, verbose = verbose, ...) 27 | else 28 | optwrap(optimizer, devfun, startingValues, lower = lowerBounds, control = control, adj = FALSE, verbose = verbose) 29 | 30 | if (restart_edge) { 31 | ## FIXME: should we be looking at rho$pp$theta or opt$par 32 | ## at this point??? in koller example (for getData(13)) we have 33 | ## rho$pp$theta=0, opt$par=0.08 34 | if (length(bvals <- which(rho$pp$theta == thetaLowerBounds)) > 0L) { 35 | par <- opt$par 36 | ## *don't* use numDeriv -- cruder but fewer dependencies, no worries 37 | ## about keeping to the interior of the allowed space 38 | theta0 <- new("numeric", rho$pp$theta) ## 'deep' copy ... 39 | d0 <- devfun(par) 40 | btol <- 1e-5 ## FIXME: make user-settable? 41 | bgrad <- sapply(bvals, 42 | function(i) { 43 | bndval <- rho$lower[i] 44 | par[seq_along(theta0)] <- theta0 45 | par[i] <- bndval + btol 46 | (devfun(par) - d0) / btol 47 | }) 48 | ## what do I need to do to reset rho$pp$theta to original value??? 49 | par[seq_along(theta0)] <- theta0 50 | devfun(par) ## reset rho$pp$theta after tests 51 | ## FIXME: allow user to specify ALWAYS restart if on boundary? 52 | if (any(bgrad < 0)) { 53 | if (verbose) message("some theta parameters on the boundary, restarting") 54 | opt <- if (!lme4IsOld) 55 | optwrap(optimizer, devfun, opt$par, lower = lowerBounds, control = control, adj = FALSE, verbose = verbose, ...) 56 | else 57 | optwrap(optimizer, devfun, opt$par, lower = lowerBounds, control = control, adj = FALSE, verbose = verbose) 58 | } 59 | } 60 | } 61 | if (!is.null(boundary.tol) && boundary.tol > 0) { 62 | if (exists("check.boundary", lme4Env)) 63 | opt <- get("check.boundary", lme4Env)(rho, opt, devfun, boundary.tol) 64 | } 65 | 66 | opt 67 | } 68 | -------------------------------------------------------------------------------- /ChangeLog: -------------------------------------------------------------------------------- 1 | 2025-02-28 Vincent Dorie 2 | 3 | * Added `refitML` and synced `refit` from lme4. 4 | 5 | 2024-09-06 Vincent Dorie 6 | 7 | * Fix for custom priors not being able to find variables when blmer is executed in functions. Bug report thanks to Jacob Grytzka. 8 | 9 | 2021-03-07 Vincent Dorie 10 | 11 | * Fix for custom covariance priors in glmm setting not working. Bug report thanks to mgoplerud. 12 | 13 | 2020-11-02 Vincent Dorie 14 | 15 | * Fix for programmatically defined variables not working with glmm priors. Bug fix thanks to mgoplerud. 16 | 17 | 2015-05-28 Vincent Dorie 18 | 19 | * Changed testing framework to testthat from RUnit 20 | * Brought parity with lme4 1.1-8 21 | * Overload refit generic so that it gets the correct deviance function 22 | 23 | 2015-03-10 Vincent Dorie 24 | 25 | * Fixed bug with t prior display on scalar variable 26 | 27 | 2014-08-14 Vincent Dorie 28 | 29 | * Now correctly stores lme4 convergence warnings 30 | 31 | 2014-07-09 Vincent Dorie 32 | 33 | * added CITATION file 34 | 35 | 2014-02-05 16:56 Vincent Dorie 36 | 37 | * Brought to parity with the latest lme4 release (1.1-6). 38 | * Bug fixes: 39 | quadratic term for normal priors calculated incorrectly when using non-zero correlations 40 | glmms could fail to apply full penalty term for mixed use of covariance priors 41 | * New features: 42 | t priors for fixed effects 43 | custom priors for ranef covariances 44 | 45 | 2013-09-13 03:30 Vincent Dorie 46 | 47 | * Complete re-write for lme4 version 1.0. 48 | 49 | 2013-08-12 10:25 Vincent Dorie 50 | 51 | * Minor addition to testing suite set of functions. Upgraded to lme4 0.999999-2. 52 | * Changed dependency to lme4.0. 53 | 54 | 2012-11-13 10:25 Vincent Dorie 55 | 56 | * Common scale is now optional for random effect covariance, specified with the "common.scale" parameter and taking values TRUE/FALSE. 57 | * Covariance priors can now all be improper. 58 | * Common scale prior can now be inverse gamma on sd, or gamma. 59 | * Reworked how the penalized weighted residual sum of squares is calculated, as it may not make sense depending on what priors are used. 60 | * Brought to parity with the latest version of lme4, 0.999999 or so. 61 | * Eliminated a false zero problem wherein the optimizer takes an initial step to the boundary and get stuck due to a flat likelihood. 62 | 63 | 2012-10-13 10:11 Vincent Dorie 64 | 65 | * blme now ignores the common scale when penalizing the random effect covariance. In previous versions it multiplied it in but didn't take the prior into account when profiling it out - in essence failing to correspond to a probabilistic model. The next version will allow the prior to be on the scale-free covariance, or on the real-world covariance matrix. For now, just the scale-free version. ** This means the fitted models will be different than previous versions. ** 66 | * Reduced the default shape for random-effect covariance posteriors on the variance scale so that the polynomial term has an exponent of 1 in the univariate case. The multivariate now has df of dim + 1 to correspond. 67 | * Fixed a few typos in the documentation. 68 | * Cleaned up imports from NAMESPACE file. 69 | * Replaced a .Internal call. 70 | 71 | 2012-03-09 13:01 Vincent Dorie 72 | 73 | * Fixed off-by one bug on termination of the optimization loop which caused gradient evaluation steps to be reported a the maximum. 74 | * REML optimization for sigma with a fixef prior was slightly off. 75 | * sigma now accepts inverse gamma priors (improper, as well). 76 | * Internal version of sim(). 77 | 78 | 79 | 2011-12-15 17:40 Vincent Dorie 80 | 81 | * Prevented summary from printing misc. lines when only one covariance prior is implemented. Gaussian fixed effects priors summarize in terms of their covariance correctly when the covariance is diagonal or a scalar times the identity. 82 | 83 | 84 | 2011-11-15 17:03 Vincent Dorie 85 | 86 | * Fixed a bug related to the scaling of priors to the data in the presence of interactions. 87 | * Added point priors on the common scale, enabling meta-analyses. 88 | 89 | 90 | 2010-12-19 19:27 Vincent Dorie 91 | * Initial version. 92 | -------------------------------------------------------------------------------- /R/parameters.R: -------------------------------------------------------------------------------- 1 | ## "parInfo" is a named list, each member also being a list containing 2 | ## length 3 | ## default - function of rho, aka the environment of the dev fun 4 | ## lower - lower bounds for par 5 | 6 | ## the order of elements in it is the order that they are passed to the optimizer 7 | ## not that that should matter to a downstream user. if they care, construct it by 8 | ## index 9 | 10 | ## for models with a single parameter vector, the name "theta" is sufficient 11 | ## so we can return without further analysis 12 | expandParsInCurrentFrame <- function(parVector, parInfo) { 13 | if (length(parInfo) == 1) return(invisible(NULL)) 14 | 15 | parentEnv <- parent.frame() 16 | parNames <- names(parInfo) 17 | 18 | index <- 0 19 | for (i in 1:length(parInfo)) { 20 | parLength <- parInfo[[i]]$length 21 | parName <- parNames[[i]] 22 | 23 | parentEnv[[parName]] <- parVector[index + 1:parLength] 24 | index <- index + parLength 25 | } 26 | invisible(NULL) 27 | } 28 | 29 | getStartingValues <- function(userStart, devFunEnv, parInfo) { 30 | if (is.null(userStart)) userStart <- list() 31 | if (is.numeric(userStart)) userStart <- list(theta = userStart) 32 | if (is.list(userStart) && length(userStart) == 1 && 33 | is.null(names(userStart))) names(userStart) <- "theta" 34 | 35 | invalidStartingValues <- !(names(userStart) %in% names(parInfo)) 36 | if (any(invalidStartingValues)) 37 | warning("starting values for parameter(s) '", toString(names(userStart)[invalidStartingValues]), 38 | "' not part of model and will be ignored") 39 | 40 | start <- numeric(sum(sapply(parInfo, function(par.i) par.i$length))) 41 | offset <- 0L 42 | for (i in 1:length(parInfo)) { 43 | parName <- names(parInfo)[[i]] 44 | parLength <- parInfo[[i]]$length 45 | 46 | userValue <- userStart[[parName]] 47 | useDefault <- TRUE 48 | if (!is.null(userValue)) { 49 | if (length(userValue) != parLength) { 50 | warning("parameter '", parName, "' is of length ", parLength, ", yet supplied vector is of length ", 51 | length(userValue), ". start will be ignored") 52 | } else { 53 | start[offset + 1:parLength] <- userValue 54 | useDefault <- FALSE 55 | } 56 | } 57 | if (useDefault) 58 | start[offset + 1:parLength] <- parInfo[[i]]$default(devFunEnv) 59 | 60 | offset <- offset + parLength 61 | } 62 | start 63 | } 64 | 65 | extractParameterListFromFit <- function(fit, blmerControl) { 66 | result <- list(theta = fit@theta) 67 | if (blmerControl$fixefOptimizationType == FIXEF_OPTIM_NUMERIC) { 68 | if (fit@devcomp$dims[["GLMM"]] != 0L) 69 | result$fixef <- fit@beta 70 | else 71 | result$beta <- fit@beta 72 | } 73 | if (fit@devcomp$dims[["GLMM"]] == 0L && blmerControl$fixefOptimizationType == SIGMA_OPTIM_NUMERIC) { 74 | result$sigma <- if (fit@devcomp$dims[["REML"]] == 0L) fit@devcomp$cmp[["sigmaML"]] else fit@devcomp$cmp[["sigmaREML"]] 75 | } 76 | result 77 | } 78 | 79 | getLowerBounds <- function(parInfo) { 80 | result <- numeric(sum(sapply(parInfo, function(par.i) par.i$length))) 81 | offset <- 0L 82 | for (i in 1:length(parInfo)) { 83 | parName <- names(parInfo)[[i]] 84 | parLength <- parInfo[[i]]$length 85 | parLower <- parInfo[[i]]$lower 86 | if (parLength != length(parLower)) stop("length of lower bounds for parameter '", parName, "' does not equal length of vector") 87 | 88 | result[offset + 1:parLength] <- parLower 89 | offset <- offset + parLength 90 | } 91 | 92 | result 93 | } 94 | 95 | getParInfo <- function(pred, resp, ranefStructure, blmerControl) { 96 | numPars <- 1 97 | result <- list(theta = list(length = ranefStructure$numCovParameters, 98 | lower = ranefStructure$lower, 99 | default = function(devFunEnv) pred$theta)) 100 | 101 | if (blmerControl$fixefOptimizationType == FIXEF_OPTIM_NUMERIC) { 102 | numPars <- numPars + 1 103 | numFixef <- if (length(pred$X) > 0) ncol(pred$X) else 0 104 | result[[numPars]] <- 105 | list(length = numFixef, 106 | lower = rep(-Inf, numFixef), 107 | default = function(devFunEnv) pred$beta0 + pred$delb) 108 | names(result)[[numPars]] <- "beta" 109 | } 110 | if (blmerControl$sigmaOptimizationType == SIGMA_OPTIM_NUMERIC) { 111 | numPars <- numPars + 1 112 | result[[numPars]] <- 113 | list(length = 1L, 114 | lower = 0, 115 | default = function(devFunEnv) sd(resp$y)) 116 | names(result)[[numPars]] <- "sigma" 117 | } 118 | 119 | result 120 | } 121 | -------------------------------------------------------------------------------- /inst/doc/blme.bib: -------------------------------------------------------------------------------- 1 | @article{albert_anderson:1984:existence, 2 | jstor_articletype = {research-article}, 3 | title = {On the Existence of Maximum Likelihood Estimates in Logistic Regression Models}, 4 | author = {Albert, A. and Anderson, J. A.}, 5 | journal = {Biometrika}, 6 | jstor_issuetitle = {}, 7 | volume = {71}, 8 | number = {1}, 9 | jstor_formatteddate = {Apr., 1984}, 10 | pages = {pp. 1-10}, 11 | url = {http://www.jstor.org/stable/2336390}, 12 | ISSN = {00063444}, 13 | abstract = {The problems of existence, uniqueness and location of maximum likelihood estimates in log linear models have received special attention in the literature (Haberman, 1974, Chapter 2; Wedderburn, 1976; Silvapulle, 1981). For multinomial logistic regression models, we prove existence theorems by considering the possible patterns of data points, which fall into three mutually exclusive and exhaustive categories: complete separation, quasicomplete separation and overlap. Our results suggest general rules for identifying infinite parameter estimates in log linear models for frequency tables.}, 14 | language = {English}, 15 | year = {1984}, 16 | publisher = {Biometrika Trust}, 17 | copyright = {Copyright © 1984 Biometrika Trust}, 18 | } 19 | 20 | @article{gelman:2008:weakly_informative, 21 | Abstract = {We propose a new prior distribution for classical (nonhierarchical) logistic regression models, constructed by first scaling all nonbinary variables to have mean 0 and standard deviation 0.5, and then placing independent Student-t prior distributions on the coefficients. As a default choice, we recommend the Cauchy distribution with center 0 and scale 2.5, which in the simplest setting is a longer-tailed version of the distribution attained by assuming one-half additional success and one-half additional failure in a logistic regression. Cross-validation on a corpus of datasets shows the Cauchy class of prior distributions to outperform existing implementations of Gaussian and Laplace priors. We recommend this prior distribution as a default choice for routine applied use. It has the advantage of always giving answers, even when there is complete separation in logistic regression (a common problem, even when the sample size is large and the number of predictors is small), and also automatically applying more shrinkage to higher-order interactions. This can be useful in routine data analysis as well as in automated procedures such as chained equations for missing-data imputation. We implement a procedure to fit generalized linear models in R with the Student-t prior distribution by incorporating an approximate EM algorithm into the usual iteratively weighted least squares. We illustrate with several applications, including a series of logistic regressions predicting voting preferences, a small bioassay experiment, and an imputation model for a public health data set.}, 22 | Author = {Gelman, Andrew and Jakulin, Aleks and Pittau, Maria Grazia and Su, Yu-Sung}, 23 | Cr = {Copyright \copyright 2008 Institute of Mathematical Statistics}, 24 | Date = {2008/12/01}, 25 | Date-Added = {2014-02-28 15:09:29 -0500}, 26 | Date-Modified = {2014-03-04 16:50:07 -0500}, 27 | Doi = {10.1214/08-AOAS191}, 28 | Isbn = {19326157}, 29 | Journal = {The Annals of Applied Statistics}, 30 | Keywords = {logistic, weakly informative}, 31 | M1 = {ArticleType: research-article / Full publication date: Dec., 2008 / Copyright {\copyright}2008 Institute of Mathematical Statistics}, 32 | Month = {12}, 33 | Number = {4}, 34 | Pages = {1360--1383}, 35 | Publisher = {Institute of Mathematical Statistics}, 36 | Read = {0}, 37 | Title = {A Weakly Informative Default Prior Distribution for Logistic and Other Regression Models}, 38 | Ty = {JOUR}, 39 | Url = {http://www.jstor.org/stable/30245139}, 40 | Volume = {2}, 41 | Year = {2008}, 42 | Bdsk-Url-1 = {http://www.jstor.org/stable/30245139}, 43 | Bdsk-Url-2 = {http://dx.doi.org/10.1214/08-AOAS191} 44 | } 45 | 46 | @article{mckeon:2012:defender, 47 | Author = {McKeon, C. Seabird and Stier, Adrian C. and McIlroy, Shelby E. and Bolker, Benjamin M.}, 48 | Date-Added = {2014-03-04 16:49:30 -0500}, 49 | Date-Modified = {2014-03-04 16:51:10 -0500}, 50 | Doi = {10.1007/s00442-012-2275-2}, 51 | Issn = {0029-8549}, 52 | Journal = {Oecologia}, 53 | Keywords = {example}, 54 | Language = {English}, 55 | Month = {August}, 56 | Number = {4}, 57 | Pages = {1095-1103}, 58 | Publisher = {Springer-Verlag}, 59 | Title = {Multiple defender effects: synergistic coral defense by mutualist crustaceans}, 60 | Url = {http://dx.doi.org/10.1007/s00442-012-2275-2}, 61 | Volume = {169}, 62 | Year = {2012}, 63 | Bdsk-Url-1 = {http://dx.doi.org/10.1007/s00442-012-2275-2} 64 | } 65 | 66 | -------------------------------------------------------------------------------- /R/dist_gamma.R: -------------------------------------------------------------------------------- 1 | setClass("bmerGammaDist", 2 | representation(shape = "numeric", 3 | rate = "numeric", 4 | posteriorScale = "character"), 5 | contains = "bmerDist", 6 | validity = function(object) object@posteriorScale == "var" || object@posteriorScale == "sd") 7 | setClass("bmerInvGammaDist", 8 | representation(shape = "numeric", 9 | scale = "numeric", 10 | posteriorScale = "character"), 11 | contains = "bmerDist", 12 | validity = function(object) object@posteriorScale == "var" || object@posteriorScale == "sd") 13 | 14 | toString.bmerGammaDist <- function(x, digits = getOption("digits"), includeCommonScale = TRUE, ...) { 15 | paste("gamma(shape = ", round(x@shape, digits), 16 | ", rate = ", round(x@rate, digits), 17 | ", posterior.scale = ", x@posteriorScale, 18 | if (includeCommonScale) paste(", common.scale = ", x@commonScale, sep = "") else "", 19 | ")", sep="") 20 | } 21 | 22 | toString.bmerInvGammaDist <- function(x, digits = getOption("digits"), includeCommonScale = TRUE, ...) { 23 | paste("invgamma(shape = ", round(x@shape, digits), 24 | ", scale = ", round(x@scale, digits), 25 | ", posterior.scale = ", x@posteriorScale, 26 | if (includeCommonScale) paste(", common.scale = ", x@commonScale, sep = "") else "", 27 | ")", sep="") 28 | } 29 | 30 | setMethod("getDFAdjustment", "bmerGammaDist", 31 | function(object) { 32 | if (object@commonScale) 0 else { 33 | if (object@posteriorScale == 'sd') 34 | -(object@shape - 1.0) 35 | else 36 | -2.0 * (object@shape - 1.0) 37 | } 38 | } 39 | ) 40 | setMethod("getDFAdjustment", "bmerInvGammaDist", 41 | function(object) { 42 | if (object@commonScale) 0 else { 43 | if (object@posteriorScale == 'sd') 44 | (object@shape + 1.0) 45 | else 46 | 2.0 * (object@shape + 1.0) 47 | } 48 | } 49 | ) 50 | 51 | setMethod("getConstantTerm", "bmerGammaDist", 52 | function(object) { 53 | shape <- object@shape; rate <- object@rate 54 | if (shape == 0.0 || rate == 0.0) return(0.0) 55 | if (shape < 0.0 || rate < 0.0) return(NaN) 56 | 57 | -2.0 * (shape * log(rate) - lgamma(shape)) 58 | } 59 | ) 60 | setMethod("getConstantTerm" ,"bmerInvGammaDist", 61 | function(object) { 62 | shape <- object@shape; scale <- object@scale 63 | 64 | if (shape == 0.0 || scale == 0.0) return(0.0) 65 | if (shape < 0.0 || scale < 0.0) return(NaN) 66 | 67 | -2.0 * (shape * log(scale) - lgamma(shape)) 68 | } 69 | ) 70 | 71 | setMethod("getExponentialSigmaPower", "bmerGammaDist", 72 | function (object) { 73 | if (object@commonScale || object@rate == 0) return(0) 74 | 75 | if (object@posteriorScale == "sd") 1 else 2 76 | }) 77 | 78 | setMethod("getExponentialSigmaPower", "bmerInvGammaDist", 79 | function (object) { 80 | if (object@commonScale || object@scale == 0) return(0) 81 | 82 | if (object@posteriorScale == "sd") -1 else -2 83 | }) 84 | 85 | setMethod("getExponentialTerm", "bmerGammaDist", 86 | function(object, lambda) { 87 | if (object@rate == 0) return (c(0, 0.0)) 88 | 89 | if (missing(lambda)) lambda <- 1.0 90 | 91 | if (object@posteriorScale == "var") { 92 | exponential <- 2.0 * lambda^2 * object@rate 93 | power <- 2 94 | } else { 95 | exponential <- 2.0 * lambda * object@rate 96 | power <- 1 97 | } 98 | 99 | if (object@commonScale == TRUE) c(0, exponential) else c(power, exponential) 100 | }) 101 | 102 | setMethod("getExponentialTerm", "bmerInvGammaDist", 103 | function(object, lambda) { 104 | if (object@scale == 0) return (c(0, 0.0)) 105 | 106 | if (missing(lambda)) lambda <- 1.0 107 | 108 | if (object@posteriorScale == "var") { 109 | exponential <- 2.0 * object@scale / lambda^2 110 | power <- -2 111 | } else { 112 | exponential <- 2.0 * object@scale / lambda 113 | power <- -1 114 | } 115 | 116 | if (object@commonScale == TRUE) c(0, exponential) else c(power, exponential) 117 | }) 118 | 119 | setMethod("getPolynomialTerm", "bmerGammaDist", 120 | function(object, lambda) { 121 | if (object@posteriorScale == "var") 122 | -4 * (object@shape - 1.0) * log(lambda) 123 | else 124 | -2 * (object@shape - 1.0) * log(lambda) 125 | } 126 | ) 127 | 128 | setMethod("getPolynomialTerm", "bmerInvGammaDist", 129 | function(object, lambda) { 130 | if (object@posteriorScale == "var") 131 | 4.0 * (object@shape + 1.0) * log(lambda) 132 | else 133 | 2.0 * (object@shape + 1.0) * log(lambda) 134 | } 135 | ) 136 | -------------------------------------------------------------------------------- /R/control.R: -------------------------------------------------------------------------------- 1 | ## "control" refers to how optimization should proceed, i.e. which parameters 2 | ## need numeric and which can be profiled out 3 | 4 | ## hack this as on "common scale" is really inconvenient here 5 | getResidPriorDFAdjustment <- function(residPrior) 6 | { 7 | if (is(residPrior, "bmerGammaDist")) { 8 | return(-(residPrior@shape - 1.0) * if (residPrior@posteriorScale == 'sd') 1 else 2) 9 | } else if (is(residPrior, "bmerInvGammaDist")) { 10 | return( (residPrior@shape + 1.0) * if (residPrior@posteriorScale == 'sd') 1 else 2) 11 | } 12 | 0 13 | } 14 | 15 | getThetaLowerBoundsForDimension <- function(d) { 16 | if (d == 1) return(0) 17 | c(0, rep(-Inf, d - 1), getThetaLowerBoundsForDimension(d - 1)) 18 | } 19 | 20 | ## TODO: this should eventually not assume the ranef structure but instead 21 | ## suck it from Lind and theta, if possible 22 | getRanefStructure <- function(pred, resp, reTrms) { 23 | ranefStructure <- list(numCovParameters = sum(sapply(reTrms$cnms, function(cnm) { d <- length(cnm); d * (d + 1) / 2; })), 24 | numRanefPerFactor = diff(reTrms$Gp), 25 | numCoefPerFactor = as.integer(sapply(reTrms$cnms, length)), 26 | numFactors = length(reTrms$cnms)) 27 | ranefStructure$numGroupsPerFactor <- as.integer(ranefStructure$numRanefPerFactor / ranefStructure$numCoefPerFactor + 0.5) 28 | ranefStructure$lower <- as.numeric(unlist(sapply(ranefStructure$numCoefPerFactor, getThetaLowerBoundsForDimension))) 29 | 30 | ranefStructure 31 | } 32 | 33 | createBlmerControl <- function(pred, resp, priors) 34 | { 35 | df <- 0 ## adjustment to polynomial (sigma.sq)^{-df/2} 36 | constant <- 0 ## normalizing constants and the like. On deviance (-2 log) scale 37 | 38 | numFactors <- length(priors$covPriors) 39 | 40 | df <- df + getDFAdjustment(priors$fixefPrior) + getResidPriorDFAdjustment(priors$residPrior) 41 | constant <- constant + getConstantTerm(priors$fixefPrior) + getConstantTerm(priors$residPrior) 42 | 43 | for (i in seq_len(numFactors)) { 44 | df <- df + getDFAdjustment(priors$covPrior[[i]]) 45 | constant <- constant + getConstantTerm(priors$covPrior[[i]]) 46 | } 47 | 48 | fixefOptimizationType <- getFixefOptimizationType(pred, resp, priors) 49 | sigmaOptimizationType <- getSigmaOptimizationType(resp, priors) 50 | 51 | namedList(df, constant, fixefOptimizationType, sigmaOptimizationType) 52 | } 53 | 54 | FIXEF_OPTIM_NA <- "na" ## no fixefs in model 55 | FIXEF_OPTIM_NUMERIC <- "numeric" ## brute force by adding to numeric optimizer 56 | FIXEF_OPTIM_LINEAR <- "linear" ## mle found by root of linear equation. or, don't worry about it 57 | getFixefOptimizationType <- function(pred, resp, priors) 58 | { 59 | if (length(pred$X) == 0) return(FIXEF_OPTIM_NA) 60 | 61 | if (!is(resp, "lmerResp")) return(FIXEF_OPTIM_NUMERIC) 62 | 63 | fixefPrior <- priors$fixefPrior 64 | 65 | if (is(fixefPrior, "bmerTDist") || is(fixefPrior, "bmerHorseshoeDist")) return(FIXEF_OPTIM_NUMERIC) 66 | 67 | FIXEF_OPTIM_LINEAR 68 | } 69 | 70 | ## determines how to optimize over sigma 71 | ## possible values are: 72 | SIGMA_OPTIM_NA <- "na" ## doesn't apply 73 | SIGMA_OPTIM_NUMERIC <- "numeric" ## brute force by adding to numeric optimizer 74 | SIGMA_OPTIM_POINT <- "point" ## sigma is fixed to a particular value 75 | SIGMA_OPTIM_SQ_LINEAR <- "sigma.sq.linear" ## sigma.sq.hat is root to linear equation 76 | SIGMA_OPTIM_SQ_QUADRATIC <- "sigma.sq.quadratic" ## sigma.sq.hat is root to quadratic equation 77 | SIGMA_OPTIM_QUADRATIC <- "sigma.quadratic" ## sigma.hat is root to quadratic equation 78 | 79 | getSigmaOptimizationType <- function(resp, priors) 80 | { 81 | if (!is(resp, "lmerResp")) return(SIGMA_OPTIM_NA) 82 | 83 | fixefPrior <- priors$fixefPrior 84 | covPriors <- priors$covPriors 85 | residPrior <- priors$residPrior 86 | 87 | if (is(residPrior, "bmerPointDist")) return(SIGMA_OPTIM_POINT) 88 | 89 | if (is(fixefPrior, "bmerNormalDist") && fixefPrior@commonScale == FALSE) 90 | return(SIGMA_OPTIM_NUMERIC) 91 | if ((is(fixefPrior, "bmerTDist") || is(fixefPrior, "bmerHorseshoeDist")) && fixefPrior@commonScale == TRUE) 92 | return(SIGMA_OPTIM_NUMERIC) 93 | 94 | exponentialTerms <- c() 95 | for (i in seq_along(covPriors)) { 96 | covPrior.i <- covPriors[[i]] 97 | 98 | if (is(covPrior.i, "bmerCustomDist") && covPrior.i@commonScale == FALSE) return(SIGMA_OPTIM_NUMERIC) 99 | 100 | exponentialTerm <- getExponentialSigmaPower(covPrior.i) 101 | if (exponentialTerm != 0) exponentialTerms <- union(exponentialTerms, exponentialTerm) 102 | } 103 | exponentialTerm <- getExponentialSigmaPower(residPrior) 104 | if (exponentialTerm != 0) exponentialTerms <- union(exponentialTerms, exponentialTerm) 105 | 106 | ## exp(-0.5 * sigma^-2 * stuff) always happens, so other terms are "extra" 107 | extraExponentialTerms <- setdiff(exponentialTerms, -2) 108 | 109 | if (length(extraExponentialTerms) == 0L) return(SIGMA_OPTIM_SQ_LINEAR) 110 | 111 | if (length(extraExponentialTerms) > 1L || !(extraExponentialTerms %in% c(-1, 2))) 112 | return(SIGMA_OPTIM_NUMERIC) 113 | 114 | if (extraExponentialTerms == -1) return(SIGMA_OPTIM_QUADRATIC) 115 | if (extraExponentialTerms == 2) return(SIGMA_OPTIM_SQ_QUADRATIC) 116 | 117 | ## should be unreachable 118 | SIGMA_OPTIM_NUMERIC 119 | } 120 | -------------------------------------------------------------------------------- /inst/doc/R/display.R: -------------------------------------------------------------------------------- 1 | ## from the package arm by Yu-Sung Su 2 | ## http://cran.r-project.org/web/packages/arm/index.html 3 | ## published under GPL v2 4 | 5 | if (!isGeneric("display")) { 6 | setGeneric("display", 7 | function(object, ...) 8 | standardGeneric("display")) 9 | } 10 | 11 | fround <- function (x, digits) { 12 | format (round (x, digits), nsmall=digits) 13 | } 14 | 15 | pfround <- function (x, digits) { 16 | print (fround (x, digits), quote=FALSE) 17 | } 18 | 19 | as.matrix.VarCorr <- function (varc, useScale, digits){ 20 | # VarCorr function for lmer objects, altered as follows: 21 | # 1. specify rounding 22 | # 2. print statement at end is removed 23 | # 3. reMat is returned 24 | # 4. last line kept in reMat even when there's no error term 25 | sc <- attr(varc, "sc")[[1]] 26 | if(is.na(sc)) sc <- 1 27 | # recorr <- lapply(varc, function(el) el@factors$correlation) 28 | recorr <- lapply(varc, function(el) attr(el, "correlation")) 29 | #reStdDev <- c(lapply(recorr, slot, "sd"), list(Residual = sc)) 30 | reStdDev <- c(lapply(varc, function(el) attr(el, "stddev")), list(Residual = sc)) 31 | reLens <- unlist(c(lapply(reStdDev, length))) 32 | reMat <- array('', c(sum(reLens), 4), 33 | list(rep('', sum(reLens)), 34 | c("Groups", "Name", "Variance", "Std.Dev."))) 35 | reMat[1+cumsum(reLens)-reLens, 1] <- names(reLens) 36 | reMat[,2] <- c(unlist(lapply(reStdDev, names)), "") 37 | # reMat[,3] <- format(unlist(reStdDev)^2, digits = digits) 38 | # reMat[,4] <- format(unlist(reStdDev), digits = digits) 39 | reMat[,3] <- fround(unlist(reStdDev)^2, digits) 40 | reMat[,4] <- fround(unlist(reStdDev), digits) 41 | if (any(reLens > 1)) { 42 | maxlen <- max(reLens) 43 | corr <- 44 | do.call("rbind", 45 | lapply(recorr, 46 | function(x, maxlen) { 47 | x <- as(x, "matrix") 48 | # cc <- format(round(x, 3), nsmall = 3) 49 | cc <- fround (x, digits) 50 | cc[!lower.tri(cc)] <- "" 51 | nr <- dim(cc)[1] 52 | if (nr >= maxlen) return(cc) 53 | cbind(cc, matrix("", nr, maxlen-nr)) 54 | }, maxlen)) 55 | colnames(corr) <- c("Corr", rep("", maxlen - 1)) 56 | reMat <- cbind(reMat, rbind(corr, rep("", ncol(corr)))) 57 | } 58 | # if (!useScale) reMat <- reMat[-nrow(reMat),] 59 | if (useScale<0) reMat[nrow(reMat),] <- c ("No residual sd", rep("",ncol(reMat)-1)) 60 | return (reMat) 61 | } 62 | 63 | 64 | 65 | setMethod("display", signature(object = "merMod"), 66 | function(object, digits=2, detail=FALSE) 67 | { 68 | out <- NULL 69 | out$call <- object@call 70 | print (out$call) 71 | #object <- summary(object) 72 | #summ <- summary(object) 73 | fcoef <- fixef(object) 74 | #coefs <- attr(summ, "coefs") 75 | #useScale <- attr (VarCorr (object), "sc") 76 | useScale <- getME(object, "devcomp")$dims["useSc"] 77 | corF <- vcov(object)@factors$correlation 78 | coefs <- cbind(fcoef, corF@sd) 79 | if (length (fcoef) > 0){ 80 | if (!useScale) { 81 | coefs <- coefs[, 1:2, drop = FALSE] 82 | out$z.value <- coefs[, 1]/coefs[, 2] 83 | out$p.value <- 2 * pnorm(abs(out$z.value), lower = FALSE) 84 | coefs <- cbind(coefs, `z value` = out$z.value, `Pr(>|z|)` = out$p.value) 85 | } 86 | else { 87 | out$t.value <- coefs[, 1]/coefs[, 2] 88 | coefs <- cbind(coefs, `t value` = out$t.value) 89 | } 90 | dimnames(coefs)[[2]][1:2] <- c("coef.est", "coef.se") 91 | if(detail){ 92 | pfround (coefs, digits) 93 | } 94 | else{ 95 | pfround(coefs[,1:2], digits) 96 | } 97 | } 98 | out$coef <- coefs[,"coef.est"] 99 | out$se <- coefs[,"coef.se"] 100 | cat("\nError terms:\n") 101 | vc <- as.matrix.VarCorr (VarCorr (object), useScale=useScale, digits) 102 | print (vc[,c(1:2,4:ncol(vc))], quote=FALSE) 103 | out$ngrps <- lapply(object@flist, function(x) length(levels(x))) 104 | is_REML <- isREML(object) 105 | llik <- logLik(object, REML=is_REML) 106 | out$AIC <- AIC(llik) 107 | out$deviance <- deviance(refitML(object)) # Dbar 108 | out$n <- getME(object, "devcomp")$dims["n"] 109 | Dhat <- -2*(llik) # Dhat 110 | pD <- out$deviance - Dhat # pD 111 | out$DIC <- out$deviance + pD # DIC=Dbar+pD=Dhat+2pD 112 | cat("---\n") 113 | cat(sprintf("number of obs: %d, groups: ", out$n)) 114 | cat(paste(paste(names(out$ngrps), out$ngrps, sep = ", "), collapse = "; ")) 115 | cat(sprintf("\nAIC = %g, DIC = ", round(out$AIC,1))) 116 | cat(round(out$DIC, 1)) 117 | cat("\ndeviance =", fround (out$deviance, 1), "\n") 118 | if (useScale < 0){ 119 | out$sigma.hat <- .Call("mer_sigma", object, FALSE, PACKAGE = "lme4") 120 | cat("overdispersion parameter =", fround (out$sigma.hat, 1), "\n") 121 | } 122 | return(invisible(out)) 123 | } 124 | ) 125 | 126 | -------------------------------------------------------------------------------- /inst/doc/R/culcita.R: -------------------------------------------------------------------------------- 1 | culcitaPath <- file.path(dataDir, "culcita.RData") 2 | if (!file.exists(culcitaPath)) 3 | download.file("http://glmm.wdfiles.com/local--files/examples/culcita.RData", culcitaPath) 4 | 5 | load(culcitaPath) 6 | rm(culcitaPath) 7 | 8 | culcita <- culcita_dat; rm(culcita_dat) 9 | 10 | ## applies to a call to model.matrix 11 | standardizeDesign <- function(X) 12 | { 13 | standardize.binary <- function(x) x - mean(x, na.rm = TRUE) 14 | standardize.cont <- function(x) 0.5 * (x - mean(x, na.rm = TRUE)) / sd(x, na.rm = TRUE) 15 | standardize <- function(x) { 16 | y <- unique(x) 17 | y <- y[!is.na(y)] 18 | if (length(y) == 2) return(standardize.binary(x)) 19 | standardize.cont(x) 20 | } 21 | 22 | X <- X[,colnames(X) != "(Intercept)"] 23 | apply(X, 2, standardize) 24 | } 25 | 26 | culcita.z <- with(culcita, 27 | data.frame(block, predation, standardizeDesign(model.matrix(~ttt, culcita)))) 28 | 29 | culcitaSep <- culcita[-c(19, 20),] 30 | culcitaSep.z <- with(culcitaSep, 31 | data.frame(block, predation, standardizeDesign(model.matrix(~ttt, culcitaSep)))) 32 | 33 | culcitaFitPath <- file.path(dataDir, "culcitaFit.RData") 34 | if (!file.exists(culcitaFitPath)) { 35 | m1 <- glmer(predation ~ tttcrabs + tttshrimp + tttboth + (1 | block), 36 | culcita.z, family = binomial, nAGQ = 10) 37 | 38 | m2 <- glmer(predation ~ tttcrabs + tttshrimp + tttboth + (1 | block), 39 | culcitaSep.z, family = binomial, nAGQ = 10) 40 | 41 | m3 <- bglmer(predation ~ tttcrabs + tttshrimp + tttboth + (1 | block), 42 | culcitaSep.z, family = binomial, nAGQ = 10, 43 | cov.prior = NULL, fixef.prior = t(1, 0.75)) 44 | 45 | save(m1, m2, m3, file = culcitaFitPath) 46 | } else load(culcitaFitPath) 47 | 48 | rm(culcitaFitPath, standardizeDesign) 49 | 50 | invlogit <- function(x) { e.x <- exp(x); e.x / (1 + e.x) } 51 | 52 | 53 | imgPath <- file.path(imgDir, "culcita.pdf") 54 | if (!file.exists(imgPath)) { 55 | m1DevFun <- glmer(predation ~ tttcrabs + tttshrimp + tttboth + (1 | block), 56 | culcita.z, family = binomial, devFunOnly = TRUE, nAGQ = 10) 57 | body(m1DevFun) <- expression({ 58 | resp$setOffset(baseOffset) 59 | resp$updateMu(lp0) 60 | pp$setTheta(as.double(theta)) 61 | spars <- as.numeric(pars[-dpars]) 62 | offset <- if (length(spars) == 0) 63 | baseOffset 64 | else baseOffset + pp$X %*% spars 65 | resp$setOffset(offset) 66 | p <- pwrssUpdate(pp, resp, tolPwrss, GQmat, compDev, fac, 67 | verbose) 68 | resp$updateWts() 69 | p 70 | }) 71 | environment(m1DevFun)$fixef <- m1@beta 72 | 73 | 74 | m2DevFun <- glmer(predation ~ tttcrabs + tttshrimp + tttboth + (1 | block), 75 | culcitaSep.z, family = binomial, devFunOnly = TRUE, nAGQ = 10) 76 | body(m2DevFun) <- body(m1DevFun) 77 | environment(m2DevFun)$fixef <- m2@beta 78 | 79 | m3DevFun <- bglmer(predation ~ tttcrabs + tttshrimp + tttboth + (1 | block), 80 | culcitaSep.z, family = binomial, devFunOnly = TRUE, nAGQ = 10, 81 | cov.prior = NULL, fixef.prior = t(1, 0.75)) 82 | body(m3DevFun) <- expression({ 83 | resp$setOffset(baseOffset) 84 | resp$updateMu(lp0) 85 | pp$setTheta(as.double(theta)) 86 | spars <- as.numeric(pars[-dpars]) 87 | offset <- if (length(spars) == 0) 88 | baseOffset 89 | else baseOffset + pp$X %*% spars 90 | resp$setOffset(offset) 91 | p <- pwrssUpdate(pp, resp, tolPwrss, GQmat, compDev, fac, 92 | verbose) 93 | resp$updateWts() 94 | Lambda.ts <- getCovBlocks(pp$Lambdat, ranefStructure) 95 | exponentialTerms <- calculatePriorExponentialTerms(priors, 96 | spars, Lambda.ts) 97 | polynomialTerm <- calculatePriorPolynomialTerm(priors$covPriors, 98 | Lambda.ts) 99 | p + exponentialTerms[[1]] + polynomialTerm + blmerControl$constant 100 | }) 101 | environment(m3DevFun)$fixef <- m3@beta 102 | 103 | 104 | expNormalize <- function(x, del) { 105 | if (length(x) == 1) return(x) 106 | x <- exp(x - median(x)) 107 | x / sum(x * del) 108 | } 109 | curveWrapper <- function(x) { 110 | result <- sapply(x, function(x.i) { 111 | rho <- environment(devFun) 112 | rho$theta <- x.i 113 | opt <- optimizeGlmer(devFun, optimizer = "Nelder_Mead", 114 | restart_edge = FALSE, control = list(), 115 | start = list(theta = x.i, fixef = rho$fixef), nAGQ = 1, verbose = 0L, stage = 2) 116 | rho$fixef <- opt$par[-1] 117 | -0.5 * opt$fval 118 | }) 119 | expNormalize(result, c(x[2] - x[1], diff(x))) 120 | } 121 | 122 | 123 | 124 | xValues <- seq(0.05, 15, length.out = 101) 125 | devFun <- m1DevFun; yValues1 <- curveWrapper(xValues) 126 | devFun <- m2DevFun; yValues2 <- curveWrapper(xValues) / 60 127 | devFun <- m3DevFun; yValues3 <- curveWrapper(xValues) 128 | 129 | pdf(imgPath, defaultImgWidth, defaultImgHeight) 130 | par(defaultPars) 131 | plot(NULL, type = "n", xlim = c(0, max(xValues)), ylim = range(yValues1, yValues2, yValues3), 132 | main = "Profiled Objective Fns", ylab = "density", xlab = expression(sigma[u]), 133 | yaxt = "n", bty = "n", yaxs = "i") 134 | lines(xValues, yValues1) 135 | lines(xValues, yValues2, lty = 2) 136 | lines(xValues, yValues3, col = "gray") 137 | 138 | legend("topright", c("lik-cmpl data", "lik-miss obs", "post-miss obs"), 139 | lty = c(1, 2, 1), col = c("black", "black", "gray"), bty = "n", 140 | cex = 0.7) 141 | dev.off() 142 | 143 | rm(xValues, yValues1, yValues2, yValues3, 144 | curveWrapper, expNormalize, 145 | devFun, m1DevFun, m2DevFun, m3DevFun) 146 | } 147 | rm(imgPath) 148 | -------------------------------------------------------------------------------- /tests/testthat/test-08-lmm_covariance.R: -------------------------------------------------------------------------------- 1 | context("blmer numerical results with cov prior") 2 | 3 | source(system.file("common", "lmmData.R", package = "blme")) 4 | lme4Version <- packageVersion("lme4") 5 | control <- lmerControl(optimizer = "Nelder_Mead") 6 | 7 | test_that("blmer fits test data with gamma prior(TRUE), matching previous version", { 8 | cov.prior <- "g.1 ~ gamma(rate = 0.5)" 9 | fit <- blmer(y ~ x.1 + x.2 + (1 | g.1), testData, cov.prior = cov.prior, control = control) 10 | if (lme4Version < "1.1-8") { 11 | expect_equal(fit@theta, 0.626025390625) 12 | } else { 13 | expect_equal(fit@theta, 0.626021723159) 14 | } 15 | }) 16 | 17 | test_that("blmer fits test data with invgamma prior(TRUE), matching previous version", { 18 | cov.prior <- "g.1 ~ invgamma(scale = 2.0)" 19 | fit <- blmer(y ~ x.1 + x.2 + (1 | g.1), testData, cov.prior = cov.prior, control = control) 20 | if (lme4Version < "1.1-4") { 21 | expect_equal(fit@theta, 0.93956054688) 22 | } else if (lme4Version < "1.1-8") { 23 | expect_equal(fit@theta, 0.93955078125) 24 | } else { 25 | expect_equal(fit@theta, 0.93955687941) 26 | } 27 | }) 28 | 29 | test_that("blmer fits test data with wishart prior(TRUE), matching previous version", { 30 | cov.prior <- "g.1 ~ wishart(scale = 2)" 31 | fit <- blmer(y ~ x.1 + x.2 + (1 + x.1 | g.1), testData, cov.prior = cov.prior, control = control) 32 | expect_equal(fit@theta, c(0.677745102365688, -0.439777135132983, 1.48026251108622)) 33 | }) 34 | 35 | test_that("blmer fits test data with invwishart prior(TRUE), matching previous version", { 36 | cov.prior <- "g.1 ~ invwishart(scale = 2)" 37 | fit <- blmer(y ~ x.1 + x.2 + (1 + x.1 | g.1), testData, cov.prior = cov.prior, control = control) 38 | expect_equal(fit@theta, c(0.627739008945695, -0.137563742254117, 1.05679359569432)) 39 | }) 40 | 41 | test_that("blmer fits test data with gamma prior('var', FALSE), matching previous version", { 42 | cov.prior <- "g.1 ~ gamma(shape = 1.75, rate = 2, posterior.scale = 'var', common.scale = FALSE)" 43 | fit <- blmer(y ~ x.1 + x.2 + (1 | g.1), testData, cov.prior = cov.prior, control = control) 44 | if (lme4Version < "1.1-8") { 45 | expect_equal(fit@theta, 0.435458984375) 46 | } else { 47 | expect_equal(fit@theta, 0.435465082534) 48 | } 49 | }) 50 | 51 | test_that("blmer fits test data with invgamma prior('var', FALSE), matching previous version", { 52 | cov.prior <- "g.1 ~ invgamma(scale = 0.5, posterior.scale = 'var', common.scale = FALSE)" 53 | fit <- blmer(y ~ x.1 + x.2 + (1 | g.1), testData, cov.prior = cov.prior, control = control) 54 | if (lme4Version < "1.1-4") { 55 | expect_equal(fit@theta, 0.460400390625) 56 | } else if (lme4Version < "1.1-8") { 57 | expect_equal(fit@theta, 0.460410156250) 58 | } else { 59 | expect_equal(fit@theta, 0.460406488784) 60 | } 61 | }) 62 | 63 | test_that("blmer fits test data with gamma prior('sd', FALSE), matching previous version", { 64 | cov.prior <- "g.1 ~ gamma(rate = 2, posterior.scale = 'sd', common.scale = FALSE)" 65 | fit <- blmer(y ~ x.1 + x.2 + (1 | g.1), testData, cov.prior = cov.prior, control = control) 66 | if (lme4Version < "1.1-8") { 67 | expect_equal(fit@theta, 0.476779702210) 68 | } else { 69 | expect_equal(fit@theta, 0.476774614593) 70 | } 71 | }) 72 | 73 | test_that("blmer fits test data with invgamma prior('sd', FALSE), matching previous version", { 74 | cov.prior <- "g.1 ~ invgamma(scale = 0.5, posterior.scale = 'sd', common.scale = FALSE)" 75 | fit <- blmer(y ~ x.1 + x.2 + (1 | g.1), testData, cov.prior = cov.prior, control = control) 76 | if (lme4Version < "1.1-4") { 77 | expect_equal(fit@theta, 0.452841796875) 78 | } else if (lme4Version < "1.1-8") { 79 | expect_equal(fit@theta, 0.452832031250) 80 | } else { 81 | expect_equal(fit@theta, 0.452838129409) 82 | } 83 | }) 84 | 85 | test_that("blmer fits test data with wishart prior(FALSE), matching previous version", { 86 | cov.prior <- "g.1 ~ wishart(scale = 2, common.scale = FALSE)" 87 | fit <- blmer(y ~ x.1 + x.2 + (1 + x.1 | g.1), testData, cov.prior = cov.prior, control = control) 88 | expect_equal(fit@pp$theta, c(0.63996739265564, -0.340538787006457, 1.34228986794088)) 89 | }) 90 | 91 | test_that("blmer fits test data with invwishart prior(FALSE), matching previous version", { 92 | cov.prior <- "g.1 ~ invwishart(scale = 2, common.scale = FALSE)" 93 | fit <- blmer(y ~ x.1 + x.2 + (1 + x.1 | g.1), testData, cov.prior = cov.prior, control = control) 94 | expect_equal(fit@pp$theta, c(0.505864621989816, -0.137623340382083, 0.979903012179649)) 95 | }) 96 | 97 | test_that("blmer fits test data with custom prior, matching builtin wishart", { 98 | dwish <- function(R) { 99 | d <- nrow(R) 100 | nu <- d + 1 + 1.5 101 | R.scale.inv <- diag(1e-2, d) 102 | 103 | const <- nu * (d * log(2) - 2 * sum(log(diag(R.scale.inv)))) + 104 | 0.5 * d * (d - 1) * log(pi) 105 | for (i in 1:d) const <- const + 2 * lgamma(0.5 * (nu + 1.0 - i)) 106 | 107 | det <- 2 * sum(log(diag(R))) 108 | 109 | const - (nu - d - 1) * det + sum((R %*% R.scale.inv)^2) 110 | } 111 | fit.prof <- blmer(y ~ x.1 + x.2 + (1 + x.1 | g.1), testData, control = control, 112 | cov.prior = wishart(scale = diag(1e4, q.k))) 113 | fit.cust <- blmer(y ~ x.1 + x.2 + (1 + x.1 | g.1), testData, control = control, 114 | cov.prior = custom(dwish, chol = TRUE, scale = "dev")) 115 | expect_equal(fit.prof@theta, fit.cust@theta, tolerance = 1e-6) 116 | 117 | fit.prof <- blmer(y ~ x.1 + x.2 + (1 + x.1 | g.1), testData, control = control, 118 | cov.prior = wishart(scale = diag(1e4, q.k), common.scale = FALSE)) 119 | fit.cust <- blmer(y ~ x.1 + x.2 + (1 + x.1 | g.1), testData, control = control, 120 | cov.prior = custom(dwish, chol = TRUE, scale = "dev", common.scale = FALSE)) 121 | expect_equal(c(fit.prof@pp$theta, fit.prof@devcomp$cmp[["sigmaREML"]]), 122 | c(fit.cust@pp$theta, fit.cust@devcomp$cmp[["sigmaREML"]]), tolerance = 5e-5) 123 | }) 124 | 125 | test_that("blmer not confused by cov priors supplied in different forms", { 126 | control$optCtrl <- list(maxfun = 1L) 127 | control$checkConv <- NULL 128 | cov.prior <- list("g.1 ~ invgamma(scale = 2)", "g.2 ~ invgamma(scale = 3)") 129 | expect_is(suppressWarnings(blmer(y ~ x.1 + x.2 + (1 | g.1) + (1 | g.2), testData, cov.prior = cov.prior, control = control)), 130 | "blmerMod") 131 | cov.prior <- list(g.1 ~ invgamma(scale = 2), g.2 ~ invgamma(scale = 3)) 132 | expect_is(suppressWarnings(blmer(y ~ x.1 + x.2 + (1 | g.1) + (1 | g.2), testData, cov.prior = cov.prior, control = control)), 133 | "blmerMod") 134 | expect_is(suppressWarnings(blmer(y ~ x.1 + x.2 + (1 | g.1), testData, cov.prior = wishart, control = control)), "blmerMod") 135 | expect_is(suppressWarnings(blmer(y ~ x.1 + x.2 + (1 | g.1), testData, cov.prior = wishart(), control = control)), "blmerMod") 136 | }) 137 | -------------------------------------------------------------------------------- /R/dist_wishart.R: -------------------------------------------------------------------------------- 1 | setClass("bmerWishartDist", 2 | representation(df = "numeric", 3 | R.scale.inv = "matrix", 4 | log.det.scale = "numeric", 5 | posteriorScale = "character"), 6 | contains = "bmerDist", 7 | validity = function(object) object@posteriorScale == "cov" || object@posteriorScale == "sqrt") 8 | 9 | setClass("bmerInvWishartDist", 10 | representation(df = "numeric", 11 | R.scale = "matrix", 12 | log.det.scale = "numeric", 13 | posteriorScale = "character"), 14 | contains = "bmerDist", 15 | validity = function(object) object@posteriorScale == "cov" || object@posteriorScale == "sqrt") 16 | 17 | toString.bmerWishartDist <- function(x, digits = getOption("digits"), ...) { 18 | if (any(diag(x@R.scale.inv) == 0)) { 19 | scale <- Inf 20 | } else if (any(is.infinite(x@R.scale.inv))) { 21 | scale <- 0 22 | } else { 23 | scale <- solve(tcrossprod(x@R.scale.inv)) 24 | } 25 | 26 | if (length(scale) == 1) { 27 | scaleString <- round(scale, digits) 28 | } else if (nrow(scale) > 2) { 29 | scaleString <- paste("c(", toString(round(scale[1:3], digits)), ", ...)", sep = "") 30 | } else if (nrow(scale) == 2) { 31 | scaleString <- paste("c(", toString(round(scale[1:4], digits)), ")", sep = "") 32 | } 33 | 34 | paste("wishart(", 35 | "df = ", round(x@df, digits), 36 | ", scale = ", scaleString, 37 | ", posterior.scale = ", x@posteriorScale, 38 | ", common.scale = ", x@commonScale, 39 | ")", sep="") 40 | } 41 | 42 | toString.bmerInvWishartDist <- function(x, digits = getOption("digits"), ...) { 43 | if (any(diag(x@R.scale) == 0)) { 44 | scale <- 0 45 | } else if (any(is.infinite(x@R.scale))) { 46 | scale <- Inf 47 | } else { 48 | scale <- crossprod(x@R.scale) 49 | } 50 | 51 | if (length(scale) == 1) { 52 | scaleString <- round(scale, digits) 53 | } else if (nrow(scale) > 2) { 54 | scaleString <- paste("c(", toString(round(scale[1:3], digits)), ", ...)", sep = "") 55 | } else if (nrow(scale) == 2) { 56 | scaleString <- paste("c(", toString(round(scale[1:4], digits)), ")", sep = "") 57 | } 58 | 59 | paste("invwishart(", 60 | "df = ", round(x@df, digits), 61 | ", scale = ", scaleString, 62 | ", posterior.scale = ", x@posteriorScale, 63 | ", common.scale = ", x@commonScale, 64 | ")", sep="") 65 | } 66 | 67 | setMethod("getDFAdjustment", "bmerWishartDist", 68 | function(object) { 69 | factorDim <- nrow(object@R.scale.inv) 70 | if (object@commonScale || !is.finite(object@log.det.scale)) 0 else -factorDim * (object@df - factorDim - 1.0) 71 | } 72 | ) 73 | 74 | setMethod("getDFAdjustment", "bmerInvWishartDist", 75 | function(object) { 76 | factorDim <- nrow(object@R.scale) 77 | if (object@commonScale || !is.finite(object@log.det.scale)) 0 else factorDim * (object@df + factorDim + 1.0) 78 | } 79 | ) 80 | 81 | setMethod("getConstantTerm", "bmerWishartDist", 82 | function(object) { 83 | df <- object@df; R.scale.inv <- object@R.scale.inv 84 | log.det.scale <- object@log.det.scale 85 | 86 | if (is.infinite(log.det.scale)) return (0.0) 87 | 88 | factorDim <- nrow(R.scale.inv) 89 | 90 | result <- df * (factorDim * log(2) + log.det.scale) + 91 | 0.5 * factorDim * (factorDim - 1.0) * log(pi) 92 | for (i in 1:factorDim) 93 | result <- result + 2.0 * lgamma(0.5 * (df + 1.0 - i)) 94 | 95 | result 96 | } 97 | ) 98 | 99 | setMethod("getConstantTerm", "bmerInvWishartDist", 100 | function(object) { 101 | df <- object@df; R.scale <- object@R.scale 102 | log.det.scale <- object@log.det.scale 103 | 104 | if (is.infinite(log.det.scale)) return (0.0) 105 | 106 | factorDim <- nrow(R.scale) 107 | 108 | result <- df * (factorDim * log(2) - log.det.scale) + 109 | 0.5 * factorDim * (factorDim - 1.0) * log(pi) 110 | for (i in 1:factorDim) 111 | result <- result + 2.0 * lgamma(0.5 * (df + 1.0 - i)) 112 | 113 | result 114 | } 115 | ) 116 | 117 | setMethod("getExponentialSigmaPower", "bmerWishartDist", 118 | function (object) { 119 | if (object@commonScale) return(0) 120 | 121 | if (object@posteriorScale == "sqrt") 1 else 2 122 | }) 123 | 124 | setMethod("getExponentialSigmaPower", "bmerInvWishartDist", 125 | function (object) { 126 | if (object@commonScale) return(0) 127 | 128 | if (object@posteriorScale == "sqrt") -1 else -2 129 | }) 130 | 131 | 132 | setMethod("getExponentialTerm", "bmerWishartDist", 133 | function(object, Lambda.t) { 134 | if (is.infinite(object@log.det.scale)) return(c(0, 0.0)) 135 | 136 | if (object@posteriorScale == "cov") { 137 | temp <- Lambda.t %*% object@R.scale.inv 138 | exponential <- sum(temp^2) 139 | 140 | power <- 2 141 | } else { 142 | Sigma <- crossprod(Lambda.t) 143 | decomp <- eigen(Sigma) 144 | Sigma.sqrt <- decomp$vectors %*% tcrossprod(diag(sqrt(decomp$values)), decomp$vectors) 145 | exponential <- sum(Sigma.sqrt * crossprod(object@R.scale.inv)) 146 | 147 | power <- 1 148 | } 149 | 150 | if (object@commonScale) c(0, exponential) else c(power, exponential) 151 | } 152 | ) 153 | 154 | setMethod("getExponentialTerm", "bmerInvWishartDist", 155 | function(object, Lambda.t) { 156 | if (is.infinite(object@log.det.scale)) return(c(0, 0.0)) 157 | 158 | if (object@posteriorScale == "cov") { 159 | power <- -2 160 | 161 | if (any(diag(Lambda.t) == 0)) 162 | return (if (object@commonScale) c(0, Inf) else c(power, Inf)) 163 | 164 | temp <- object@R.scale %*% solve(Lambda.t) 165 | exponential <- sum(temp^2) 166 | 167 | } else { 168 | power <- -1 169 | 170 | if (any(diag(Lambda.t) == 0)) 171 | return (if (object@commonScale) c(0, Inf) else c(power, Inf)) 172 | 173 | Sigma <- crossprod(Lambda.t) 174 | decomp <- eigen(Sigma) 175 | Sigma.inv.sqrt <- decomp$vectors %*% tcrossprod(diag(1 / sqrt(decomp$values)), decomp$vectors) 176 | exponential <- sum(Sigma.inv.sqrt * tcrossprod(object@R.scale)) 177 | } 178 | 179 | if (object@commonScale) c(0, exponential) else c(power, exponential) 180 | } 181 | ) 182 | 183 | setMethod("getPolynomialTerm", "bmerWishartDist", 184 | function(object, Lambda.t) { 185 | factorDim <- nrow(object@R.scale.inv) 186 | lambda <- diag(Lambda.t) 187 | if (any(lambda <= 0.0)) 188 | Inf 189 | else 190 | -2.0 * (object@df - factorDim - 1.0) * sum(log(lambda)) 191 | } 192 | ) 193 | 194 | setMethod("getPolynomialTerm", "bmerInvWishartDist", 195 | function(object, Lambda.t) { 196 | factorDim <- nrow(object@R.scale) 197 | lambda <- diag(Lambda.t) 198 | if (any(lambda <= 0.0)) 199 | Inf 200 | else 201 | 2.0 * (object@df + factorDim + 1.0) * sum(log(lambda)) 202 | } 203 | ) 204 | -------------------------------------------------------------------------------- /R/priorEval.R: -------------------------------------------------------------------------------- 1 | evaluateFixefPrior <- function(fixefPrior, defnEnv, evalEnv) { 2 | if (is.character(fixefPrior)) fixefPrior <- parse(text = fixefPrior)[[1L]] 3 | 4 | if (is.symbol(fixefPrior) && exists(toString(fixefPrior), envir = evalEnv) && 5 | !(as.character(fixefPrior) %in% fixefDistributions)) { 6 | fixefPrior <- get(toString(fixefPrior), envir = evalEnv) 7 | if (is.character(fixefPrior)) fixefPrior <- parse(text = fixefPrior)[[1L]] 8 | } 9 | 10 | if (!is.null(fixefPrior)) { 11 | if (is.symbol(fixefPrior)) fixefPrior <- call(as.character(fixefPrior)) 12 | fixefDistributionName <- as.character(fixefPrior[[1L]]) 13 | if (!(fixefDistributionName %in% fixefDistributions)) stop("unrecognized fixef distribution: '", fixefDistributionName, "'") 14 | 15 | return(eval(fixefPrior, envir = evalEnv)) 16 | } 17 | 18 | NULL 19 | } 20 | 21 | evaluateCovPriors <- function(covPriors, factorColumnNames, numGroupsPerFactor, defnEnv, evalEnv, callingEnv) { 22 | numFactors <- length(factorColumnNames) 23 | factorNames <- names(factorColumnNames) 24 | result <- vector("list", numFactors) 25 | defaultCovPrior <- NULL 26 | 27 | if (is.null(covPriors)) return(result) 28 | 29 | # check to see if it refers to a variable in the calling environment 30 | if (is.symbol(covPriors) && as.character(covPriors) %not_in% covDistributions) { 31 | tryResult <- tryCatch(variableLookup <- get(as.character(covPriors), envir = callingEnv), error = I) 32 | 33 | if (!is(tryResult, "error")) covPriors <- variableLookup 34 | } 35 | 36 | if (is.character(covPriors)) { 37 | covPriors <- gsub("inverse.wishart", "invwishart", covPriors) 38 | covPriors <- gsub("inverse.gamma", "invgamma", covPriors) 39 | covPriors <- parse(text = covPriors)[[1L]] 40 | } 41 | 42 | if (is.call(covPriors) && covPriors[[1L]] == "list") covPriors[[1L]] <- NULL 43 | 44 | if (!is.list(covPriors)) covPriors <- list(covPriors) 45 | 46 | for (i in seq_along(covPriors)) { 47 | covPrior.i <- covPriors[[i]] 48 | ## can't just let 'em re-define "wishart", or use the built-in gamma 49 | if (is.symbol(covPrior.i) && exists(as.character(covPrior.i), envir = evalEnv) && 50 | !(as.character(covPrior.i) %in% covDistributions)) { 51 | covPrior.i <- get(toString(covPrior.i), envir = evalEnv) 52 | if (is.character(covPrior.i)) covPrior.i <- parse(text = covPrior.i)[[1]] 53 | covPriors[[i]] <- covPrior.i 54 | } 55 | } 56 | for (i in seq_along(covPriors)) { 57 | covPrior.i <- covPriors[[i]] 58 | if (is.character(covPrior.i)) { 59 | covPrior.i <- gsub("inverse.wishart", "invwishart", covPrior.i) 60 | covPrior.i <- gsub("inverse.gamma", "invgamma", covPrior.i) 61 | covPrior.i <- parse(text = covPrior.i)[[1]] 62 | } 63 | 64 | ## turn 'wishart' into 'wishart()' 65 | if (is.symbol(covPrior.i)) covPrior.i <- call(as.character(covPrior.i)) 66 | 67 | if (is.formula(covPrior.i)) { 68 | factorName <- as.character(covPrior.i[[2L]]) 69 | 70 | if (!(factorName %in% factorNames)) 71 | stop("grouping factor '", factorName, "' for covariance prior not in model formula") 72 | 73 | ## turn 'group ~ wishart' into 'group ~ wishart()' 74 | if (is.symbol(covPrior.i[[3L]])) covPrior.i[[3L]] <- call(as.character(covPrior.i[[3L]])) 75 | 76 | ## for each grouping factor with the given name, store function call for later 77 | matchingFactors <- which(factorName == factorNames) 78 | for (j in seq_along(matchingFactors)) result[[matchingFactors[j]]] <- covPrior.i[[3L]] 79 | 80 | } else { 81 | ## default 82 | if (!is.null(defaultCovPrior)) warning("more than one default covariance prior specified, only using the last one") 83 | defaultCovPrior <- covPrior.i 84 | } 85 | } 86 | 87 | for (i in seq_len(numFactors)) { 88 | if (is.null(result[[i]]) && is.null(defaultCovPrior)) next 89 | 90 | result.i <- result[[i]] 91 | if (is.null(result[[i]]) && !is.null(defaultCovPrior)) result.i <- defaultCovPrior 92 | 93 | covDistributionName <- as.character(result.i[[1L]]) 94 | if (!(covDistributionName %in% covDistributions)) 95 | stop("unrecognized ranef covariance distribution: '", covDistributionName, "'") 96 | 97 | defnEnv$q.k <- defnEnv$level.dim <- length(factorColumnNames[[i]]) 98 | defnEnv$j.k <- defnEnv$n.grps <- numGroupsPerFactor[i] 99 | 100 | result.i <- eval(result.i, envir = evalEnv) 101 | 102 | if (!is.null(result.i)) result[[i]] <- result.i 103 | } 104 | 105 | result 106 | } 107 | 108 | evaluateResidualPrior <- function(residPrior, defnEnv, evalEnv) { 109 | if (is.character(residPrior)) { 110 | residPrior <- gsub("inverse.gamma", "invgamma", residPrior) 111 | residPrior <- parse(text = residPrior)[[1L]] 112 | } 113 | 114 | if (is.symbol(residPrior) && exists(toString(residPrior), envir = evalEnv)) { 115 | fixefPrior <- get(toString(residPrior), envir = evalEnv) 116 | if (is.character(residPrior)) residPrior <- parse(text = residPrior)[[1]] 117 | } 118 | 119 | if (!is.null(residPrior)) { 120 | if (is.symbol(residPrior)) residPrior <- call(as.character(residPrior)) 121 | residDistributionName <- as.character(residPrior[[1L]]) 122 | if (!(residDistributionName %in% residDistributions)) stop("unrecognized residual variance distribution: '", residDistributionName, "'") 123 | 124 | return(eval(residPrior, envir = evalEnv)) 125 | } 126 | 127 | NULL 128 | } 129 | 130 | evaluatePriorArguments <- function(covPriors, fixefPrior, residPrior, 131 | dims, fixefNames, factorColumnNames, numGroupsPerFactor, callingEnv) { 132 | result <- list() 133 | evalEnv <- new.env(parent = callingEnv) 134 | defnEnv <- new.env() 135 | 136 | defnEnv$p <- defnEnv$n.fixef <- dims[["p"]] 137 | defnEnv$n <- defnEnv$n.obs <- dims[["n"]] 138 | defnEnv$.fixefNames <- fixefNames 139 | isLMM <- dims[["GLMM"]] == 0L 140 | 141 | ## add the names of dist functs to the evaluating env 142 | for (distributionName in names(lmmDistributions)) { 143 | distributionFunction <- lmmDistributions[[distributionName]] 144 | 145 | environment(distributionFunction) <- defnEnv 146 | if (!isLMM) { 147 | ## need both copies to have their envs tweaked, but only one called 148 | distributionFunction <- glmmDistributions[[distributionName]] 149 | if (!is.null(distributionFunction)) environment(distributionFunction) <- defnEnv 150 | } 151 | if (!is.null(distributionFunction)) assign(distributionName, distributionFunction, envir = evalEnv) 152 | } 153 | 154 | result$fixefPrior <- evaluateFixefPrior(fixefPrior, defnEnv, evalEnv) 155 | if ((is(result$fixefPrior, "bmerTDist") || is(result$fixefPrior, "bmerHorseshoeDist")) && isLMM && dims[["REML"]] > 0L) 156 | stop("t/horseshoe distribution for fixed effects only supported when REML = FALSE") 157 | result$covPriors <- evaluateCovPriors(covPriors, factorColumnNames, numGroupsPerFactor, defnEnv, evalEnv, callingEnv) 158 | 159 | if (isLMM) { 160 | environment(residualVarianceGammaPrior) <- defnEnv 161 | environment(residualVarianceInvGammaPrior) <- defnEnv 162 | assign("gamma", residualVarianceGammaPrior, envir = evalEnv) 163 | assign("invgamma", residualVarianceInvGammaPrior, envir = evalEnv) 164 | 165 | result$residPrior <- evaluateResidualPrior(residPrior, defnEnv, evalEnv) 166 | } 167 | 168 | result 169 | } 170 | -------------------------------------------------------------------------------- /man/blmer.Rd: -------------------------------------------------------------------------------- 1 | \name{blme} 2 | \alias{blmer} 3 | \alias{bglmer} 4 | \concept{GLMM}% << so it's found 5 | \concept{NLMM}% << so it's found 6 | \title{Fit Bayesian Linear and Generalized Linear Mixed-Effects Models} 7 | \description{ 8 | Maximum a posteriori estimation for linear and generalized 9 | linear mixed-effects models in a Bayesian setting. Built off of 10 | \code{\link[lme4]{lmer}}. 11 | } 12 | \usage{ 13 | blmer(formula, data = NULL, REML = TRUE, 14 | control = lmerControl(), start = NULL, verbose = 0L, 15 | subset, weights, na.action, offset, contrasts = NULL, 16 | devFunOnly = FALSE, cov.prior = wishart, 17 | fixef.prior = NULL, resid.prior = NULL, \dots) 18 | bglmer(formula, data = NULL, family = gaussian, 19 | control = glmerControl(), start = NULL, verbose = 0L, 20 | nAGQ = 1L, subset, weights, na.action, offset, 21 | contrasts = NULL, mustart, etastart, 22 | devFunOnly = FALSE, cov.prior = wishart, 23 | fixef.prior = NULL, \dots) 24 | } 25 | \arguments{ 26 | \item{cov.prior}{a BLME \link[=bmerDist-class]{prior} or list of priors with allowable 27 | distributions: \code{wishart}, \code{invwishart}, \code{gamma}, 28 | \code{invgamma}, or \code{NULL}. Imposes a prior over the covariance of the random 29 | effects/modeled coefficients. Default is \code{wishart}. The \code{NULL} argument 30 | imposes flat priors over all relevant parameters.} 31 | \item{fixef.prior}{a BLME prior of family \code{normal}, \code{t}, \code{horseshoe}, or \code{NULL}. 32 | Imposes a prior over the fixed effects/modeled coefficients. 33 | Default is \code{NULL}.} 34 | \item{resid.prior}{a BLME prior of family \code{gamma}, \code{invamma}, \code{point} 35 | or \code{NULL}. Imposes a prior over the noise/residual variance, also known as common scale 36 | parameter or the conditional variance given the random effects. 37 | Default is \code{NULL}.} 38 | \item{start}{like the \code{start} arguments for \code{\link[lme4]{lmer}} and 39 | \code{\link[lme4]{glmer}} a numeric vector or named list. Unlike the aforementioned, 40 | list members of \code{fixef} and \code{sigma} are applicable to linear mixed models 41 | provided that numeric optimization is required for these parameters.} 42 | \item{formula, data, REML, family, control, verbose, nAGQ, 43 | mustart, etastart, devFunOnly, \dots}{model specification arguments as in \code{\link[lme4]{lmer}} and \code{\link[lme4]{glmer}}; 44 | see there for details.} 45 | \item{subset, weights, na.action, offset, contrasts}{further model 46 | specification arguments as in \code{\link[stats]{lm}}; see there for 47 | details.} 48 | } 49 | \details{ 50 | The bulk of the usage for \code{blmer} and \code{bglmer} closely 51 | follows the functions \code{\link[lme4]{lmer}} and 52 | \code{\link[lme4]{glmer}}. Those help pages provide a good overview of 53 | fitting linear and generalized linear mixed models. The primary 54 | distinction is that \code{blmer} and \code{bglmer} allow the user to 55 | do Bayesian inference or penalized maximum likelihood, with priors imposed on the different 56 | model components. For the specifics of any distribution listed below, 57 | see the \link[=bmerDist-class]{distributions} page. 58 | 59 | \strong{Covariance Prior} 60 | 61 | The \code{cov.prior} argument applies a prior over the 62 | covariance matrix of the random effects/modeled coefficients. 63 | As there is one covariance matrix for every named grouping factor - 64 | that is every element that appears to the right of a vertical bar 65 | ("|") in the model formula - it is possible to apply as many 66 | different priors as there are said factors. 67 | 68 | The general formats of an argument to \code{blmer} or \code{bglmer} 69 | for such a prior are of the form: 70 | 71 | \itemize{ 72 | \item \code{cov.prior = factor.name ~ covariance.distribution(option1 = value1, \dots)} 73 | \item \code{cov.prior = list(fc.nm ~ dist1, fc.nm ~ dist2, ..., default.distribution)} 74 | } 75 | 76 | If the \dQuote{\code{factor.name ~}} construct is omitted, the prior 77 | is interpretted as a default and applied to all factors that 78 | lack specific priors of their own. Options are not required, 79 | but permit fine-tuning of the model. 80 | 81 | Supported distributions are \code{gamma}, \code{invgamma}, \code{wishart}, 82 | \code{invwishart}, \code{NULL}, and \code{custom}. 83 | 84 | The \code{common.scale} option, a logical, determines whether or 85 | not the prior applies to in the absolute-real world 86 | sense (value = \code{FALSE}), or if the prior is applied to the random effect 87 | covariance divided by the estimated residual variance (\code{TRUE}). As a practical matter, 88 | when false computation can be slower as the profiled common scale may 89 | no longer have a closed-form solution. As such, the default for all 90 | cases is \code{TRUE}. 91 | 92 | Other options are specified along with the specific distributions and 93 | defaults are explained in the blme \link[=bmerDist-class]{distributions} page. 94 | 95 | \strong{Fixed Effects Prior} 96 | 97 | Priors on the fixed effects, or unmodeled coefficients, are specified 98 | in a fashion similar to that of covariance priors. The general format is 99 | 100 | \itemize{\item \code{fixef.prior = multivariate.distribution(options1 = value1, \dots)}} 101 | 102 | At present, the implemented multivariate distributions are \code{normal}, \code{t}, 103 | \code{horseshoe}, and \code{NULL}. \code{t} and \code{horseshoe} priors cannot be used 104 | when \code{REML} is \code{TRUE}, as that integral does not have a closed form solution. 105 | 106 | \strong{Residual Variance Prior} 107 | 108 | The general format for a residual variance prior is the same as for a fixed 109 | effect prior. The supported distributions are \code{point}, \code{gamma}, 110 | \code{invgamma}. 111 | 112 | } 113 | \value{ 114 | An object of class \code{"\linkS4class{bmerMod}"}, for which many methods 115 | are available. See there for details. 116 | } 117 | \seealso{ 118 | \code{\link[lme4]{lmer}}, \code{\link[lme4]{glmer}}, 119 | \code{\link[lme4:merMod-class]{merMod}} class, and \code{\link[stats]{lm}}. 120 | } 121 | \examples{ 122 | data("sleepstudy", package = "lme4") 123 | 124 | ### Examples using a covariance prior ## 125 | 126 | # Here we are ignoring convergence warnings just to illustate how the package 127 | # is used: this is not a good idea in practice.. 128 | control <- lmerControl(check.conv.grad = "ignore") 129 | (fm1 <- blmer(Reaction ~ Days + (0 + Days|Subject), sleepstudy, 130 | control = control, 131 | cov.prior = gamma)) 132 | (fm2 <- blmer(Reaction ~ Days + (0 + Days|Subject), sleepstudy, 133 | control = control, 134 | cov.prior = gamma(shape = 2, rate = 0.5, posterior.scale = 'sd'))) 135 | (fm3 <- blmer(Reaction ~ Days + (1 + Days|Subject), sleepstudy, 136 | control = control, 137 | cov.prior = wishart)) 138 | (fm4 <- blmer(Reaction ~ Days + (1 + Days|Subject), sleepstudy, 139 | control = control, 140 | cov.prior = invwishart(df = 5, scale = diag(0.5, 2)))) 141 | 142 | # Custom prior 143 | penaltyFn <- function(sigma) 144 | dcauchy(sigma, 0, 10, log = TRUE) 145 | (fm5 <- blmer(Reaction ~ Days + (0 + Days|Subject), sleepstudy, 146 | cov.prior = custom(penaltyFn, chol = TRUE, scale = "log"))) 147 | 148 | 149 | ### Examples using a fixed effect prior ### 150 | (fm6 <- blmer(Reaction ~ Days + (1 + Days|Subject), sleepstudy, 151 | cov.prior = NULL, 152 | fixef.prior = normal)) 153 | (fm7 <- blmer(Reaction ~ Days + (1 + Days|Subject), sleepstudy, 154 | cov.prior = NULL, 155 | fixef.prior = normal(cov = diag(0.5, 2), common.scale = FALSE))) 156 | 157 | ### Example using a residual variance prior ### 158 | # This is the "eight schools" data set; the mode should be at the boundary 159 | # of the space. 160 | 161 | control <- lmerControl(check.conv.singular = "ignore", 162 | check.nobs.vs.nRE = "ignore", 163 | check.nobs.vs.nlev = "ignore") 164 | y <- c(28, 8, -3, 7, -1, 1, 18, 12) 165 | sigma <- c(15, 10, 16, 11, 9, 11, 10, 18) 166 | g <- 1:8 167 | 168 | (schools <- blmer(y ~ 1 + (1 | g), control = control, REML = FALSE, 169 | resid.prior = point, cov.prior = NULL, 170 | weights = 1 / sigma^2)) 171 | } 172 | \keyword{models} 173 | \keyword{methods} 174 | -------------------------------------------------------------------------------- /man/bmerDist-class.Rd: -------------------------------------------------------------------------------- 1 | \docType{class} 2 | \name{bmerDist-class} 3 | \title{Bayesian Linear Mixed-Effects Model Prior Representations and bmer*Dist Methods} 4 | % Classes 5 | \alias{bmerDist} 6 | \alias{bmerDist-class} 7 | % Methods 8 | \alias{print,bmerDist-method} 9 | \alias{show,bmerDist-method} 10 | 11 | \description{Objects created in the initialization step of a \pkg{blme} 12 | model that represent the type of prior being applied.} 13 | 14 | \section{Objects from the Class}{Objects can be created by calls of the 15 | form \code{new("bmerPrior", ...)} or, more commonly, as side effects of the 16 | \code{\link{blmer}} and \code{\link{bglmer}} functions. 17 | 18 | When using the main \code{blme} functions, the prior-related arguments can be 19 | passed what essentially 20 | are function calls with the distinction that they are delayed in evaluation 21 | until information about the model is available. At that time, the functions 22 | are \emph{defined} in a special environment and then \emph{evaluated} in an 23 | environment that directly inherits from the one in which \code{blmer} or 24 | \code{bglmer} was called. This is reflected in some of the 25 | prototypes of various prior-creating functions which depend on parameters not 26 | available in the top-level environment. 27 | 28 | Finally, if the trailing parentheses are omitted from a \code{blmer}/\code{bglmer} 29 | prior argument, they are simply added as a form of \dQuote{syntactic sugar}. 30 | } 31 | 32 | \section{Prior Distributions}{ 33 | This section lists the prototypes for the functions that are called to parse 34 | a prior during a model fit. 35 | 36 | \strong{Fixed Effect Priors} 37 | 38 | \itemize{ 39 | \item \code{normal(sd = c(10, 2.5), cov, common.scale = TRUE)} 40 | 41 | Applies a Gaussian prior to the fixed effects. Normal priors are constrained 42 | to have a mean of 0 - non-zero priors are equivalent to shifting covariates. 43 | 44 | The covariance hyperparameter can be specified either as a vector of standard 45 | deviations, using the \code{sd} argument, a vector of variances using the 46 | \code{cov} argument, or the entire variance/covariance matrix itself. When 47 | specifying standard deviations, a vector of length less than the number of fixed effects will 48 | have its tail repeated, while the first element is assumed to apply only 49 | to the intercept term. So in the default of \code{c(10, 2.5)}, the intercept 50 | receives a standard deviation of 10 and the various slopes are all given 51 | a standard deviation of 2.5. 52 | 53 | The \code{common.scale} argument specifies whether or not the 54 | prior is to be interpretted as being on the same scale as the residuals. 55 | To specify a prior in an absolute sense, set to \code{FALSE}. Argument 56 | is only applicable to linear mixed models. 57 | 58 | \item \code{t(df = 3, mean = 0, scale = c(10^2, 2.5^2), common.scale = TRUE)} 59 | 60 | The degrees of freedom - \code{df} argument - must be positive. If \code{mean} is 61 | of length 1, it is repeated for every fixed effect. Length 2 repeats just the second 62 | element for all slopes. Otherwise, the length must be equal to that of the number of 63 | fixed effects. 64 | 65 | If \code{scale} is of length 1, it is repeated along the diagonal for every 66 | component. Length 2 repeats just the second element for all slopes. Length equal 67 | to the number of fixed effects sees the vector simply turned into a diagonal matrix. 68 | Finally, it can be a full scale matrix, so long as it is positive definite. 69 | 70 | \code{t} priors for linear mixed models require that the fixed effects be added to 71 | set of parameters that are numerically optimized, and thus can substantially 72 | increase running time. In addition, when \code{common.scale} is \code{TRUE}, the 73 | residual variance must be numerically optimized as well. \code{normal} priors 74 | on the common scale can be fully profiled and do not suffer from this drawback. 75 | 76 | At present, \code{t} priors cannot be used with the \code{REML = TRUE} argument 77 | as that implies an integral without a closed form solution. 78 | 79 | \item \code{horseshoe(mean = 0, global.shrinkage = 2.5, common.scale = TRUE)} 80 | 81 | The horseshoe shrinkage prior is implemented similarly to the \code{t} prior, in 82 | that it requires adding the fixed effects to the parameter set for numeric optimization. 83 | 84 | \code{global.shrinkage}, also referred to as \eqn{\tau}, must be positive and 85 | is on the scale of a standard deviation. Local shrinkage parameters are treated as 86 | independent across all fixed effects and are integrated out. See 87 | \cite{Carvalho et al. (2009)} in the references. 88 | } 89 | 90 | \strong{Covariance Priors} 91 | 92 | \itemize{ 93 | \item \code{gamma(shape = 2.5, rate = 0, common.scale = TRUE, posterior.scale = "sd")} 94 | 95 | Applicable only for univariate grouping factors. A 96 | rate of \code{0} or a shape of \code{0} imposes an improper prior. The 97 | posterior scale can be \code{"sd"} or \code{"var"} and determines the scale 98 | on which the prior is meant to be applied. 99 | 100 | \item \code{invgamma(shape = 0.5, scale = 10^2, common.scale = TRUE, posterior.scale = "sd")} 101 | 102 | Applicable only for univariate grouping factors. A 103 | scale of \code{0} or a shape of \code{0} imposes an improper prior. Options 104 | are as above. 105 | 106 | \item \code{wishart(df = level.dim + 2.5, scale = Inf, common.scale = TRUE, posterior.scale = "cov")} 107 | 108 | A scale of \code{Inf} or a shape of \code{0} imposes an improper prior. The behavior 109 | for singular matrices with only some infinite eigenvalues is undefined. Posterior scale 110 | can be \code{"cov"} or \code{"sqrt"}, 111 | the latter of which applies to the unique matrix root that is also a valid covariance 112 | matrix. 113 | 114 | \item \code{invwishart(df = level.dim - 0.5, scale = diag(10^2 / (df + level.dim + 1), level.dim), 115 | common.scale = TRUE, posterior.scale = "cov")} 116 | 117 | A scale of \code{0} or a shape of \code{0} imposes an improper prior. The behavior 118 | for singular matrices with only some zero eigenvalues is undefined. 119 | 120 | \item \code{custom(fn, chol = FALSE, common.scale = TRUE, scale = "none")} 121 | 122 | Applies to the given function (\code{fn}). If \code{chol} is \code{TRUE}, \code{fn} is 123 | passed a \emph{right} factor of covariance matrix; \code{FALSE} results in the matrix being 124 | passed directly. \code{scale} can be \code{"none"}, \code{"log"}, or \code{"dev"} corresponding to 125 | \eqn{p(\Sigma)}, \eqn{\log p(\Sigma)}{log p(\Sigma)}, and \eqn{-2 \log p(\Sigma)}{-2 log p(\Sigma)} 126 | respectively. 127 | 128 | Since the prior is may have an arbitrary form, setting \code{common.scale} to \code{FALSE} 129 | for a linear mixed model means that full profiling may no longer be possible. As such, 130 | that parameter is numerically optimized. 131 | } 132 | 133 | \strong{Residual Variance Priors} 134 | 135 | \itemize{ 136 | \item \code{point(value = 1.0, posterior.scale = "sd")} 137 | 138 | Fixes the parameter to a specific value given as either an \code{"sd"} or a \code{"var"}. 139 | 140 | \item \code{gamma(shape = 0, rate = 0, posterior.scale = "var")} 141 | 142 | As above with different defaults. 143 | 144 | \item \code{invgamma(shape = 0, scale = 0, posterior.scale = "var")} 145 | 146 | As above with different defaults. 147 | } 148 | } 149 | 150 | \section{Evaluating Environment}{ 151 | The variables that the defining environment have populated are: 152 | \itemize{ 153 | \item \code{p} aliased to \code{n.fixef} - the number of fixed effects 154 | \item \code{n} aliased to \code{n.obs} - the number of observations 155 | \item \code{q.k} aliased to \code{level.dim} - for covariance priors, the dimension of the grouping factor/grouping level 156 | \item \code{j.k} aliased to \code{n.grps} - also for covariance priors, the number of groups that comprise a specific grouping factor 157 | } 158 | } 159 | 160 | \section{Methods}{ 161 | \describe{ 162 | \item{toString}{Pretty-prints the distribution and its parameters.} 163 | } 164 | } 165 | 166 | \references{ 167 | Carvalho, Carlos M., Nicholas G. Polson, and James G. Scott. 168 | "Handling Sparsity via the Horseshoe." 169 | AISTATS. Vol. 5. 2009. 170 | } 171 | 172 | \seealso{ 173 | \code{\link{blmer}()} and \code{\link{bglmer}()}, 174 | which produce these objects, and \code{\link{bmerMod-class}} objects which contain them. 175 | } 176 | \keyword{classes} 177 | -------------------------------------------------------------------------------- /tests/testthat/test-07-lmm_fixef.R: -------------------------------------------------------------------------------- 1 | context("blmer numerical results with fixef prior") 2 | 3 | source(system.file("common", "lmmData.R", package = "blme")) 4 | lme4Version <- packageVersion("lme4") 5 | control <- lmerControl(optimizer = "bobyqa") 6 | 7 | test_that("blmer fits test data with normal(7, TRUE) prior, matching previous version", { 8 | fixef.prior <- "normal(sd = 7, common.scale = TRUE)" 9 | 10 | startingValues <- c(0.714336877636958, -0.242234853872256, 1.56142829865131, 0.931702840718855, 0.456177995916484, -0.174861679569041, 1.0585277913399, 0.121071648252222, 0.215801873693294) 11 | result <- if (lme4Version < "1.1-4") c(0.714336904883696, -0.242233333549434, 1.56142849039447, 0.931702729108028, 0.456177204451304, -0.174861811614276, 1.05852821195682, 0.121071547240353, 0.215801842870277) else c(0.714336904883696, -0.242233333549434, 1.56142849039447, 0.931702729108028, 0.456177204451304, -0.174861811614276, 1.05852821195682, 0.121071547240353, 0.215801842870277) 12 | 13 | fit <- blmer(y ~ x.1 + x.2 + (1 + x.1 | g.1) + (1 + x.1 + x.2 | g.2), testData, control = control, 14 | cov.prior = NULL, fixef.prior = fixef.prior, start = startingValues) 15 | expect_equal(fit@theta, result, tolerance = 5.0e-5) 16 | }) 17 | 18 | test_that("blmer fits test data with normal(10, FALSE) prior, matching previous version", { 19 | fixef.prior <- "normal(sd = 10, common.scale = FALSE)" 20 | 21 | startingValues <- list(theta = c(0.705301445472825, -0.236130064856711, 1.54070576284237, 0.919298480793096, 0.444958591085821, -0.162201425613492, 1.04498858978601, 0.121905334663798, 0.204897688209115), 22 | sigma = 0.969103097682058) 23 | result <- if (lme4Version < "1.1-4") c(0.705369855182081, -0.236759905121764, 1.54063251814471, 0.919250008248663, 0.444836570608055, -0.162132239807962, 1.04497528986881, 0.121858574203024, 0.204725931113902) else c(0.705369855182081, -0.236759905121764, 1.54063251814471, 0.919250008248663, 0.444836570608055, -0.162132239807962, 1.04497528986881, 0.121858574203024, 0.204725931113902) 24 | 25 | fit <- blmer(y ~ x.1 + x.2 + (1 + x.1 | g.1) + (1 + x.1 + x.2 | g.2), testData, control = control, 26 | cov.prior = NULL, fixef.prior = fixef.prior, start = startingValues) 27 | expect_equal(fit@theta, result, tolerance = 5.0e-5) 28 | expect_equal(fit@devcomp$cmp[["sigmaREML"]], if (lme4Version < "1.1-4") 0.969074276597577 else 0.969074276597577, tolerance = 1.0e-6) 29 | }) 30 | 31 | test_that("blmer fits test data with t prior, matching previous version", { 32 | fixef.prior <- "t(3, scale = c(10^2, 2.5^2), common.scale = FALSE)" 33 | 34 | startingValues <- list(theta = c(0.645289664330177, -0.151604332140352, 1.39404761930357, 0.788435718441722, 0.312013729923666, -0.0155461916762167, 0.949082870229164, 0.117100582888698, 0), 35 | beta = c(5.32508665168687, 1.16859904165051, 4.0443701271478)) 36 | result <- if (lme4Version < "1.1-4") c(0.645289146996319, -0.151634501090343, 1.39403793373549, 0.788432069261316, 0.312010137757441, -0.0155458970707687, 0.949081665570772, 0.117100684805151, 3.13476220325792e-07) else c(0.645289146996319, -0.151634501090343, 1.39403793373549, 0.788432069261316, 0.312010137757441, -0.0155458970707687, 0.949081665570772, 0.117100684805151, 0) 37 | fixefResult <- if (lme4Version < "1.1-4") c(5.32507818836626, 1.16860398465568, 4.04437041491386) else c(5.32507818836626, 1.16860398465568, 4.04437041491386) 38 | 39 | fit <- blmer(y ~ x.1 + x.2 + (1 + x.1 | g.1) + (1 + x.1 + x.2 | g.2), testData, REML = FALSE, control = control, 40 | cov.prior = NULL, fixef.prior = fixef.prior, start = startingValues) 41 | expect_equal(fit@theta, result, tolerance = 5.0e-5) 42 | expect_equal(fit@beta, fixefResult, tolerance = 5.0e-5) 43 | }) 44 | 45 | test_that("blmer fits test data with t prior, pulling coefs towards prior mean", { 46 | fixef.prior <- "t(3, scale = c(10^2, 2.5^2), common.scale = FALSE)" 47 | 48 | startingValues <- list(theta = c(0.645289664330177, -0.151604332140352, 1.39404761930357, 0.788435718441722, 0.312013729923666, -0.0155461916762167, 0.949082870229164, 0.117100582888698, 0), 49 | beta = c(5.32508665168687, 1.16859904165051, 4.0443701271478)) 50 | fit1 <- blmer(y ~ x.1 + x.2 + (1 + x.1 | g.1) + (1 + x.1 + x.2 | g.2), 51 | testData, REML = FALSE, control = control, start = startingValues, 52 | cov.prior = NULL, fixef.prior = fixef.prior) 53 | 54 | fixef.prior <- "t(3, mean = 1, scale = c(10^2, 2.5^2), common.scale = FALSE)" 55 | startingValues <- list(theta = c(0.645231746255695, -0.150874294512127, 1.39279705168843, 0.788899237871713, 0.312993971411181, -0.0165781952291476, 0.9486901278038, 0.116610548693423, 0), 56 | beta = c(5.32921718654553, 1.254377710572, 4.0471360557054)) 57 | fit2 <- blmer(y ~ x.1 + x.2 + (1 + x.1 | g.1) + (1 + x.1 + x.2 | g.2), 58 | testData, REML = FALSE, control = control, start = startingValues, 59 | cov.prior = NULL, fixef.prior = fixef.prior) 60 | 61 | expect_true(all(fit2@beta > fit1@beta)) 62 | }) 63 | 64 | test_that("blme fits test data with normal prior, infinite variances", { 65 | fixef.prior <- "normal(sd = c(Inf, 2.5, Inf), common.scale = TRUE)" 66 | startingValues <- list(theta = c(0.65040570391375, -0.155836402048548, 1.40007024700731, 0.792859752406217, 0.309502757134706, -0.00960238340899774, 0.951434187107545, 0.120357370844577, 3.28141165783528e-08)) 67 | fit1 <- blmer(y ~ x.1 + x.2 + (1 + x.1 | g.1) + (1 + x.1 + x.2 | g.2), 68 | testData, REML = FALSE, control = control, start = startingValues, 69 | cov.prior = NULL, fixef.prior = fixef.prior) 70 | 71 | fixef.prior <- "normal(sd = c(10, 2.5, 10), common.scale = TRUE)" 72 | startingValues <- list(theta = c(0.656112749203895, -0.160153337136109, 1.41411083191824, 0.801072376964595, 0.314002356189888, -0.0102771543211311, 0.96001117254404, 0.121335386913439, 0)) 73 | fit2 <- blmer(y ~ x.1 + x.2 + (1 + x.1 | g.1) + (1 + x.1 + x.2 | g.2), 74 | testData, REML = FALSE, control = control, start = startingValues, 75 | cov.prior = NULL, fixef.prior = fixef.prior) 76 | 77 | ## weak test, but mostly that it runs 78 | expect_true(all(abs(fit2@beta[-2L]) < abs(fit1@beta[-2L]))) 79 | }) 80 | 81 | test_that("blme fits test data with t prior, infinite variances", { 82 | fixef.prior <- "t(3, scale = c(Inf, 2.5^2, Inf), common.scale = FALSE)" 83 | startingValues <- list(theta = c(0.647090004202988, -0.153430452141895, 1.39376002360987, 0.788156951920134, 0.307237491068136, -0.00914717614020565, 0.94737787538623, 0.119813551302683, 0), 84 | beta = c(5.33515365502806, 1.15350643162013, 4.05528441688043)) 85 | fit1 <- blmer(y ~ x.1 + x.2 + (1 + x.1 | g.1) + (1 + x.1 + x.2 | g.2), 86 | testData, REML = FALSE, control = control, start = startingValues, 87 | cov.prior = NULL, fixef.prior = fixef.prior) 88 | 89 | fixef.prior <- "t(3, scale = c(10^2, 2.5^2, 2.5^2), common.scale = FALSE)" 90 | startingValues <- list(theta = c(0.645289664330177, -0.151604332140352, 1.39404761930357, 0.788435718441722, 0.312013729923666, -0.0155461916762167, 0.949082870229164, 0.117100582888698, 0), 91 | beta = c(5.32508665168687, 1.16859904165051, 4.0443701271478)) 92 | fit2 <- blmer(y ~ x.1 + x.2 + (1 + x.1 | g.1) + (1 + x.1 + x.2 | g.2), 93 | testData, REML = FALSE, control = control, start = startingValues, 94 | cov.prior = NULL, fixef.prior = fixef.prior) 95 | 96 | ## weak test, but mostly that it runs 97 | expect_true(abs(fit2@beta[2L]) > abs(fit1@beta[2L])) 98 | }) 99 | 100 | test_that("blme fits test data with horseshoe prior, shrinking coefficients close to 0", { 101 | skip_if_not_installed("expint") 102 | fixef.prior <- "horseshoe(mean = 0, global.shrinkage = 1, common.scale = FALSE)" 103 | 104 | startingValues <- list(theta = c(0.617639687575409, -0.294806814471362, 1.35499090773928, 0.807122870503614, 0.452878790469015, 0.00511880816241064, 1.01339081390872, 0.138288121619745, 5.27691279774817e-05), 105 | beta = c(5.15394746118033, 6.90112633576194e-08, 3.98496350360682)) 106 | 107 | suppressWarnings(fit1 <- blmer(y ~ x.1 + x.2 + (1 + x.1 | g.1) + (1 + x.1 + x.2 | g.2), 108 | testData, REML = FALSE, control = control, start = startingValues, 109 | cov.prior = NULL, fixef.prior = fixef.prior)) 110 | 111 | expect_true(max(abs(fit1@beta)) / min(abs(fit1@beta)) > 1.0e7) 112 | }) 113 | 114 | test_that("blmer fits sleep study example in documentation", { 115 | oldWarnings <- options()$warn 116 | options(warn = 2) 117 | 118 | data("sleepstudy", package = "lme4") 119 | 120 | fit <- blmer(Reaction ~ Days + (1 + Days|Subject), sleepstudy, 121 | cov.prior = NULL, resid.prior = NULL, 122 | fixef.prior = "normal") 123 | expect_is(fit, "blmerMod") 124 | 125 | fit <- blmer(Reaction ~ Days + (1 + Days|Subject), sleepstudy, 126 | cov.prior = NULL, resid.prior = NULL, 127 | fixef.prior = "normal(cov = diag(0.5, 2))") 128 | expect_is(fit, "blmerMod") 129 | 130 | options(warn = oldWarnings) 131 | }) 132 | 133 | -------------------------------------------------------------------------------- /R/devFun.R: -------------------------------------------------------------------------------- 1 | mkBlmerDevfun <- function(fr, X, reTrms, REML = TRUE, start = NULL, 2 | verbose = 0L, control = lmerControl(), priors = NULL, 3 | env = parent.frame(1L), ...) { 4 | devfun <- mkLmerDevfun(fr, X, reTrms, REML, start, verbose, control, ...) 5 | devFunEnv <- environment(devfun) 6 | pred <- devFunEnv$pp 7 | resp <- devFunEnv$resp 8 | 9 | devFunEnv$ranefStructure <- getRanefStructure(pred, resp, reTrms) 10 | 11 | if (is.null(priors)) priors <- list() 12 | devFunEnv$priors <- 13 | evaluatePriorArguments(priors$covPriors, priors$fixefPrior, priors$residPrior, 14 | c(n = nrow(X), p = ncol(X), GLMM = 0L, REML = if (REML) 1L else 0L), 15 | colnames(X), 16 | reTrms$cnms, devFunEnv$ranefStructure$numGroupsPerFactor, 17 | env) 18 | 19 | devFunEnv$blmerControl <- createBlmerControl(pred, resp, devFunEnv$priors) 20 | devFunEnv$parInfo <- getParInfo(pred, resp, devFunEnv$ranefStructure, devFunEnv$blmerControl) 21 | devFunBody <- getBlmerDevianceFunctionBody(devFunEnv) 22 | 23 | if (!is.null(devFunBody)) body(devfun) <- parse(text = devFunBody) 24 | 25 | devfun 26 | } 27 | 28 | mkBglmerDevfun <- function(fr, X, reTrms, family, nAGQ = 1L, verbose = 0L, 29 | maxit = 100L, 30 | control=glmerControl(), 31 | priors = NULL, env = parent.frame(1L), ...) { 32 | devfun <- 33 | if (packageVersion("lme4") <= "1.1.7") { 34 | mkGlmerDevfun(fr, X, reTrms, family, nAGQ, verbose, control, ...) 35 | } else { 36 | mkGlmerDevfun(fr, X, reTrms, family, nAGQ, verbose, maxit, control, ...) 37 | } 38 | 39 | devFunEnv <- environment(devfun) 40 | pred <- devFunEnv$pp 41 | resp <- devFunEnv$resp 42 | 43 | devFunEnv$ranefStructure <- getRanefStructure(pred, resp, reTrms) 44 | if (is.null(priors)) priors <- list() 45 | devFunEnv$priors <- 46 | evaluatePriorArguments(priors$covPriors, priors$fixefPrior, NULL, 47 | c(n = nrow(X), p = ncol(X), GLMM = 1L), 48 | colnames(X), 49 | reTrms$cnms, devFunEnv$ranefStructure, 50 | env) 51 | 52 | 53 | devFunEnv$blmerControl <- createBlmerControl(pred, resp, devFunEnv$priors) 54 | devFunEnv$parInfo <- getParInfo(pred, resp, devFunEnv$ranefStructure, devFunEnv$blmerControl) 55 | 56 | devFunBody <- getBglmerDevianceFunctionBody(devFunEnv, nAGQ != 0L) 57 | 58 | if (!is.null(devFunBody)) body(devfun) <- parse(text = devFunBody) 59 | 60 | devfun 61 | } 62 | 63 | makeRefitDevFun <- function(env, nAGQ = 1L, verbose = 0, maxit=100L, 64 | control = list(), 65 | object) { 66 | lme4Namespace <- asNamespace("lme4") 67 | devfun <- 68 | if (packageVersion("lme4") <= "1.1.7") { 69 | get("mkdevfun", lme4Namespace)(env, nAGQ, verbose, control) 70 | } else 71 | get("mkdevfun", lme4Namespace)(env, nAGQ, maxit, verbose, control) 72 | 73 | pred <- env$pp 74 | resp <- env$resp 75 | 76 | env$maxit <- as.integer(maxit) 77 | env$lower <- object@lower 78 | env$priors <- object@priors 79 | env$ranefStructure <- getRanefStructure(pred, resp, list(cnms = object@cnms, Gp = object@Gp)) 80 | env$blmerControl <- createBlmerControl(pred, resp, env$priors) 81 | env$parInfo <- getParInfo(pred, resp, env$ranefStructure, env$blmerControl) 82 | 83 | devFunBody <- 84 | if (is(resp, "lmerResp")) 85 | getBlmerDevianceFunctionBody(env) 86 | else 87 | getBglmerDevianceFunctionBody(env, nAGQ != 0L) 88 | 89 | if (!is.null(devFunBody)) body(devfun) <- parse(text = devFunBody) 90 | 91 | devfun 92 | } 93 | 94 | ## environment already populated at this point 95 | updateBglmerDevfun <- function(devfun, reTrms, nAGQ = 1L) { 96 | devfun <- updateGlmerDevfun(devfun, reTrms, nAGQ = nAGQ) 97 | devFunEnv <- environment(devfun) 98 | devFunBody <- getBglmerDevianceFunctionBody(devFunEnv, nAGQ != 0L) 99 | 100 | if (!is.null(devFunBody)) body(devfun) <- parse(text = devFunBody) 101 | 102 | devfun 103 | } 104 | 105 | 106 | getBlmerDevianceFunctionBody <- function(devFunEnv) 107 | { 108 | priors <- devFunEnv$priors 109 | 110 | if (!anyPriorsApplied(priors)) return(NULL) 111 | 112 | blmerControl <- devFunEnv$blmerControl 113 | 114 | sigmaOptimizationType <- blmerControl$sigmaOptimizationType 115 | fixefOptimizationType <- blmerControl$fixefOptimizationType 116 | 117 | fixefPrior <- priors$fixefPrior 118 | 119 | devFunBody <- NULL 120 | stringConnection <- textConnection("devFunBody", "w", local=TRUE) 121 | sink(stringConnection) 122 | 123 | cat("{\n") 124 | cat(" expandParsInCurrentFrame(theta, parInfo)\n", 125 | " pp$setTheta(as.double(theta))\n\n", sep = "") 126 | devFunEnv$expandParsInCurrentFrame <- expandParsInCurrentFrame 127 | 128 | if (sigmaOptimizationType == SIGMA_OPTIM_POINT) 129 | cat(" sigma <- priors$residPrior@value\n") 130 | 131 | if (is(fixefPrior, "bmerNormalDist")) { 132 | if (fixefPrior@commonScale == FALSE) { 133 | cat(" pp$updateDecomp(sigma * priors$fixefPrior@R.cov.inv)\n") 134 | } else { 135 | cat(" pp$updateDecomp(priors$fixefPrior@R.cov.inv)\n") 136 | } 137 | } else { 138 | cat(" pp$updateDecomp()\n") 139 | } 140 | 141 | cat("\n") 142 | 143 | cat(" resp$updateMu(pp$linPred(0.0))\n", 144 | " pp$updateRes(resp$wtres)\n", 145 | " pp$solve()\n", 146 | " resp$updateMu(pp$linPred(1.0))\n\n", sep = "") 147 | 148 | if (fixefOptimizationType != FIXEF_OPTIM_NUMERIC) { 149 | cat(" beta <- pp$beta(1.0)\n") 150 | } 151 | cat(" Lambda.ts <- getCovBlocks(pp$Lambdat, ranefStructure)\n") 152 | if (sigmaOptimizationType == SIGMA_OPTIM_NUMERIC || 153 | sigmaOptimizationType == SIGMA_OPTIM_POINT) { 154 | cat(" exponentialTerms <- calculatePriorExponentialTerms(priors, beta, Lambda.ts, sigma)\n") 155 | } else { 156 | cat(" exponentialTerms <- calculatePriorExponentialTerms(priors, beta, Lambda.ts)\n") 157 | } 158 | cat(" polynomialTerm <- calculatePriorPolynomialTerm(priors$covPriors, Lambda.ts)\n\n") 159 | devFunEnv$calculatePriorExponentialTerms <- calculatePriorExponentialTerms 160 | devFunEnv$calculatePriorPolynomialTerm <- calculatePriorPolynomialTerm 161 | devFunEnv$getCovBlocks <- getCovBlocks 162 | 163 | if (fixefOptimizationType == FIXEF_OPTIM_NUMERIC) { 164 | cat(" exponentialTerms <- calculateFixefExponentialTerm(beta, pp$beta(1.0), pp$RX(), exponentialTerms)\n") 165 | devFunEnv$calculateFixefExponentialTerm <- calculateFixefExponentialTerm 166 | } 167 | 168 | if (sigmaOptimizationType != SIGMA_OPTIM_NUMERIC && 169 | sigmaOptimizationType != SIGMA_OPTIM_POINT) { 170 | cat(" sigma <- profileSigma(pp, resp, exponentialTerms, blmerControl)\n\n", sep = "") 171 | devFunEnv$profileSigma <- getSigmaProfiler(priors, blmerControl) 172 | } 173 | 174 | cat(" lmmObjective(pp, resp, sigma, exponentialTerms, polynomialTerm, blmerControl)\n") 175 | devFunEnv$lmmObjective <- lmmObjective 176 | 177 | cat("}\n") 178 | 179 | sink() 180 | close(stringConnection) 181 | 182 | devFunBody 183 | } 184 | 185 | anyPriorsApplied <- function(priors) { 186 | !is.null(priors$fixefPrior) || any(sapply(priors$covPriors, function(cov.prior.i) !is.null(cov.prior.i))) || 187 | !is.null(priors$residPrior) 188 | } 189 | 190 | getSigmaProfiler <- function(priors, blmerControl) { 191 | sigmaOptimizationType <- blmerControl$sigmaOptimizationType 192 | if (sigmaOptimizationType == SIGMA_OPTIM_SQ_LINEAR) { 193 | return (function(pp, resp, exponentialTerms, blmerControl) { 194 | pwrss <- resp$wrss() + pp$sqrL(1.0) 195 | if (!is.null(exponentialTerms[["-2"]])) pwrss <- pwrss + exponentialTerms[["-2"]] 196 | 197 | df <- nrow(pp$X) - resp$REML + blmerControl$df 198 | 199 | sqrt(pwrss / df) 200 | }) 201 | } else if (sigmaOptimizationType == SIGMA_OPTIM_SQ_QUADRATIC) { 202 | return (function(pp, resp, exponentialTerms, blmerControl) { 203 | pwrss <- resp$wrss() + pp$sqrL(1.0) 204 | if (!is.null(exponentialTerms[["-2"]])) pwrss <- pwrss + exponentialTerms[["-2"]] 205 | a <- exponentialTerms[["2"]] 206 | 207 | df <- nrow(pp$X) - resp$REML + blmerControl$df 208 | 209 | disc <- sqrt(df^2 + 4 * pwrss * a) 210 | 211 | sqrt((disc - df) / (2 * a)) 212 | }) 213 | } else if (sigmaOptimizationType == SIGMA_OPTIM_QUADRATIC) { 214 | return (function(pp, resp, exponentialTerms, blmerControl) { 215 | pwrss <- resp$wrss() + pp$sqrL(1.0) 216 | if (!is.null(exponentialTerms[["-2"]])) pwrss <- pwrss + exponentialTerms[["-2"]] 217 | a <- exponentialTerms[["-1"]] 218 | 219 | df <- nrow(pp$X) - resp$REML + blmerControl$df 220 | 221 | disc <- sqrt(a^2 + 16 * df * pwrss) 222 | 223 | 0.25 * (disc + a) / df 224 | }) 225 | } else stop("illegal sigma optimization type") 226 | } 227 | 228 | calculatePriorExponentialTerms <- function(priors, beta, Lambda.ts, sigma = NULL) 229 | { 230 | result <- list() 231 | fixefPrior <- priors$fixefPrior 232 | covPriors <- priors$covPriors 233 | residPrior <- priors$residPrior 234 | 235 | if (!is.null(fixefPrior)) { 236 | if ((is(fixefPrior, "bmerTDist") || is(fixefPrior, "bmerHorseshoeDist")) && fixefPrior@commonScale == TRUE) { 237 | term <- getExponentialTerm(fixefPrior, beta, sigma) 238 | } else { 239 | term <- getExponentialTerm(fixefPrior, beta) 240 | } 241 | result[[toString(term[1L])]] <- term[2L] 242 | } 243 | 244 | for (i in seq_along(covPriors)) { 245 | if (is.null(covPriors[[i]])) next 246 | covPrior.i <- covPriors[[i]] 247 | 248 | if (is(covPrior.i, "bmerCustomDist") && covPrior.i@commonScale == FALSE) { 249 | term <- getExponentialTerm(covPrior.i, Lambda.ts[[i]] * sigma) 250 | } else { 251 | term <- getExponentialTerm(covPrior.i, Lambda.ts[[i]]) 252 | } 253 | power <- toString(term[1L]) 254 | exponential <- term[2L] 255 | if (is.null(result[[power]])) result[[power]] <- exponential 256 | else result[[power]] <- result[[power]] + exponential 257 | } 258 | 259 | if (is.null(residPrior)) return(result) 260 | 261 | term <- getExponentialTerm(residPrior) 262 | power <- toString(term[1L]) 263 | exponential <- term[2L] 264 | if (is.null(result[[power]])) result[[power]] <- exponential 265 | else result[[power]] <- result[[power]] + exponential 266 | 267 | result 268 | } 269 | 270 | calculatePriorPolynomialTerm <- function(covPriors, Lambda.ts) 271 | { 272 | sum(sapply(seq_along(covPriors), function(i) 273 | if (!is.null(covPriors[[i]])) getPolynomialTerm(covPriors[[i]], Lambda.ts[[i]]) else 0)) 274 | } 275 | 276 | calculateFixefExponentialTerm <- function(beta, beta.tilde, RX, exponentialTerms = NULL) 277 | { 278 | exponential <- crossprod(RX %*% (beta - beta.tilde))[1L] 279 | if (is.null(exponentialTerms)) return(exponential) 280 | 281 | if (is.null(exponentialTerms[["-2"]])) { 282 | exponentialTerms[["-2"]] <- exponential 283 | } else { 284 | exponentialTerms[["-2"]] <- exponentialTerms[["-2"]] + exponential 285 | } 286 | exponentialTerms 287 | } 288 | 289 | testGetBglmerDevianceFunctionBody <- function(devFun) 290 | { 291 | devFunEnv <- environment(devFun) 292 | priors <- devFunEnv$priors 293 | 294 | if (!anyPriorsApplied(priors)) return(NULL) 295 | 296 | fixefPrior <- priors$fixefPrior 297 | 298 | devFunBody <- NULL 299 | stringConnection <- textConnection("devFunBody", "w", local = TRUE) 300 | sink(stringConnection) 301 | 302 | cat("{\n", 303 | " Lambda.ts <- getCovBlocks(pp$Lambdat, ranefStructure)\n", 304 | " exponentialTerms <- calculatePriorExponentialTerms(priors, spars, Lambda.ts)\n", 305 | " polynomialTerm <- calculatePriorPolynomialTerm(priors$covPriors, Lambda.ts)\n\n", 306 | " ", 307 | sep = "") 308 | 309 | oldDevFunBody <- deparse(body(devFun)) 310 | cat(oldDevFunBody[-length(oldDevFunBody)], sep = "\n") ## cut trailing "}" 311 | 312 | cat(" } + exponentialTerms[[1]] + polynomialTerm + blmerControl$constant\n", 313 | "}", sep = "") 314 | 315 | sink() 316 | close(stringConnection) 317 | 318 | devFunBody 319 | } 320 | 321 | getBglmerDevianceFunctionBody <- function(devFunEnv, fixefAreParams) 322 | { 323 | priors <- devFunEnv$priors 324 | 325 | if (!anyPriorsApplied(priors)) return(NULL) 326 | 327 | fixefPrior <- priors$fixefPrior 328 | 329 | devFunBody <- NULL 330 | stringConnection <- textConnection("devFunBody", "w", local=TRUE) 331 | sink(stringConnection) 332 | 333 | cat("{\n") 334 | 335 | if (fixefAreParams) 336 | cat(" resp$setOffset(baseOffset)\n") 337 | 338 | cat(" resp$updateMu(lp0)\n") 339 | 340 | if (!fixefAreParams) { 341 | cat(" spars <- rep(0, ncol(pp$X))\n", 342 | " pp$setTheta(as.double(theta))\n", sep = "") 343 | if (packageVersion("lme4") <= "1.1.7") { 344 | cat(" p <- pwrssUpdate(pp, resp, tolPwrss, GHrule(0L), compDev, verbose=verbose)\n") 345 | } else { 346 | cat(" p <- pwrssUpdate(pp, resp, tolPwrss, GHrule(0L), compDev, maxit=maxit, verbose=verbose)\n") 347 | } 348 | } else { 349 | cat(" pp$setTheta(as.double(pars[dpars]))\n", 350 | " spars <- as.numeric(pars[-dpars])\n", 351 | " offset <- if (length(spars) == 0) baseOffset else baseOffset + pp$X %*% spars\n", 352 | " resp$setOffset(offset)\n\n", sep = "") 353 | if (packageVersion("lme4") <= "1.1.7") { 354 | cat(" p <- pwrssUpdate(pp, resp, tolPwrss, GQmat, compDev, fac, verbose=verbose)\n") 355 | } else { 356 | cat(" p <- pwrssUpdate(pp, resp, tolPwrss, GQmat, compDev, fac, maxit=maxit, verbose=verbose)\n") 357 | } 358 | } 359 | 360 | cat(" resp$updateWts()\n\n", 361 | 362 | " Lambda.ts <- getCovBlocks(pp$Lambdat, ranefStructure)\n", 363 | " exponentialTerms <- calculatePriorExponentialTerms(priors, spars, Lambda.ts)\n", 364 | " polynomialTerm <- calculatePriorPolynomialTerm(priors$covPriors, Lambda.ts)\n\n", 365 | 366 | " p + exponentialTerms[[1]] + polynomialTerm + blmerControl$constant\n", 367 | "}\n", 368 | sep = "") 369 | devFunEnv$getCovBlocks <- getCovBlocks 370 | devFunEnv$calculatePriorExponentialTerms <- calculatePriorExponentialTerms 371 | devFunEnv$calculatePriorPolynomialTerm <- calculatePriorPolynomialTerm 372 | 373 | sink() 374 | close(stringConnection) 375 | 376 | devFunBody 377 | } 378 | -------------------------------------------------------------------------------- /inst/doc/jss.cls: -------------------------------------------------------------------------------- 1 | %% 2 | %% This is file `jss.cls', 3 | \def\fileversion{2.2} 4 | \def\filename{jss} 5 | \def\filedate{2013/04/06} 6 | %% 7 | %% Package `jss' to use with LaTeX2e for JSS publications (http://www.jstatsoft.org/) 8 | %% License: GPL-2 9 | %% Copyright: (C) Achim Zeileis 10 | %% Please report errors to Achim.Zeileis@R-project.org 11 | %% 12 | \NeedsTeXFormat{LaTeX2e} 13 | \ProvidesClass{jss}[\filedate\space\fileversion\space jss class by Achim Zeileis] 14 | %% options 15 | \newif\if@article 16 | \newif\if@codesnippet 17 | \newif\if@bookreview 18 | \newif\if@softwarereview 19 | \newif\if@review 20 | \newif\if@shortnames 21 | \newif\if@nojss 22 | \newif\if@notitle 23 | \newif\if@noheadings 24 | \newif\if@nofooter 25 | 26 | \@articletrue 27 | \@codesnippetfalse 28 | \@bookreviewfalse 29 | \@softwarereviewfalse 30 | \@reviewfalse 31 | \@shortnamesfalse 32 | \@nojssfalse 33 | \@notitlefalse 34 | \@noheadingsfalse 35 | \@nofooterfalse 36 | 37 | \DeclareOption{article}{\@articletrue% 38 | \@codesnippetfalse \@bookreviewfalse \@softwarereviewfalse} 39 | \DeclareOption{codesnippet}{\@articlefalse% 40 | \@codesnippettrue \@bookreviewfalse \@softwarereviewfalse} 41 | \DeclareOption{bookreview}{\@articlefalse% 42 | \@codesnippetfalse \@bookreviewtrue \@softwarereviewfalse} 43 | \DeclareOption{softwarereview}{\@articlefalse% 44 | \@codesnippetfalse \@bookreviewfalse \@softwarereviewtrue} 45 | \DeclareOption{shortnames}{\@shortnamestrue} 46 | \DeclareOption{nojss}{\@nojsstrue} 47 | \DeclareOption{notitle}{\@notitletrue} 48 | \DeclareOption{noheadings}{\@noheadingstrue} 49 | \DeclareOption{nofooter}{\@nofootertrue} 50 | 51 | \ProcessOptions 52 | \LoadClass[11pt,a4paper,twoside]{article} 53 | %% required packages 54 | \RequirePackage{graphicx,color,ae,fancyvrb} 55 | \RequirePackage[T1]{fontenc} 56 | \IfFileExists{upquote.sty}{\RequirePackage{upquote}}{} 57 | %% bibliography 58 | \if@shortnames 59 | \usepackage[authoryear,round]{natbib} 60 | \else 61 | \usepackage[authoryear,round,longnamesfirst]{natbib} 62 | \fi 63 | \bibpunct{(}{)}{;}{a}{}{,} 64 | \bibliographystyle{jss} 65 | %% page layout 66 | \topmargin 0pt 67 | \textheight 46\baselineskip 68 | \advance\textheight by \topskip 69 | \oddsidemargin 0.1in 70 | \evensidemargin 0.15in 71 | \marginparwidth 1in 72 | \oddsidemargin 0.125in 73 | \evensidemargin 0.125in 74 | \marginparwidth 0.75in 75 | \textwidth 6.125in 76 | %% paragraphs 77 | \setlength{\parskip}{0.7ex plus0.1ex minus0.1ex} 78 | \setlength{\parindent}{0em} 79 | %% for all publications 80 | \newcommand{\Address}[1]{\def\@Address{#1}} 81 | \newcommand{\Plaintitle}[1]{\def\@Plaintitle{#1}} 82 | \newcommand{\Shorttitle}[1]{\def\@Shorttitle{#1}} 83 | \newcommand{\Plainauthor}[1]{\def\@Plainauthor{#1}} 84 | \newcommand{\Volume}[1]{\def\@Volume{#1}} 85 | \newcommand{\Year}[1]{\def\@Year{#1}} 86 | \newcommand{\Month}[1]{\def\@Month{#1}} 87 | \newcommand{\Issue}[1]{\def\@Issue{#1}} 88 | \newcommand{\Submitdate}[1]{\def\@Submitdate{#1}} 89 | %% for articles and code snippets 90 | \newcommand{\Acceptdate}[1]{\def\@Acceptdate{#1}} 91 | \newcommand{\Abstract}[1]{\def\@Abstract{#1}} 92 | \newcommand{\Keywords}[1]{\def\@Keywords{#1}} 93 | \newcommand{\Plainkeywords}[1]{\def\@Plainkeywords{#1}} 94 | %% for book and software reviews 95 | \newcommand{\Reviewer}[1]{\def\@Reviewer{#1}} 96 | \newcommand{\Booktitle}[1]{\def\@Booktitle{#1}} 97 | \newcommand{\Bookauthor}[1]{\def\@Bookauthor{#1}} 98 | \newcommand{\Publisher}[1]{\def\@Publisher{#1}} 99 | \newcommand{\Pubaddress}[1]{\def\@Pubaddress{#1}} 100 | \newcommand{\Pubyear}[1]{\def\@Pubyear{#1}} 101 | \newcommand{\ISBN}[1]{\def\@ISBN{#1}} 102 | \newcommand{\Pages}[1]{\def\@Pages{#1}} 103 | \newcommand{\Price}[1]{\def\@Price{#1}} 104 | \newcommand{\Plainreviewer}[1]{\def\@Plainreviewer{#1}} 105 | \newcommand{\Softwaretitle}[1]{\def\@Softwaretitle{#1}} 106 | \newcommand{\URL}[1]{\def\@URL{#1}} 107 | %% for internal use 108 | \newcommand{\Seriesname}[1]{\def\@Seriesname{#1}} 109 | \newcommand{\Hypersubject}[1]{\def\@Hypersubject{#1}} 110 | \newcommand{\Hyperauthor}[1]{\def\@Hyperauthor{#1}} 111 | \newcommand{\Footername}[1]{\def\@Footername{#1}} 112 | \newcommand{\Firstdate}[1]{\def\@Firstdate{#1}} 113 | \newcommand{\Seconddate}[1]{\def\@Seconddate{#1}} 114 | \newcommand{\Reviewauthor}[1]{\def\@Reviewauthor{#1}} 115 | %% defaults 116 | \author{Firstname Lastname\\Affiliation} 117 | \title{Title} 118 | \Abstract{---!!!---an abstract is required---!!!---} 119 | \Plainauthor{\@author} 120 | \Volume{VV} 121 | \Year{YYYY} 122 | \Month{MMMMMM} 123 | \Issue{II} 124 | \Submitdate{yyyy-mm-dd} 125 | \Acceptdate{yyyy-mm-dd} 126 | \Address{ 127 | Firstname Lastname\\ 128 | Affiliation\\ 129 | Address, Country\\ 130 | E-mail: \email{name@address}\\ 131 | URL: \url{http://link/to/webpage/} 132 | } 133 | 134 | \Reviewer{Firstname Lastname\\Affiliation} 135 | \Plainreviewer{Firstname Lastname} 136 | \Booktitle{Book Title} 137 | \Bookauthor{Book Author} 138 | \Publisher{Publisher} 139 | \Pubaddress{Publisher's Address} 140 | \Pubyear{YYY} 141 | \ISBN{x-xxxxx-xxx-x} 142 | \Pages{xv + 123} 143 | \Price{USD 69.95 (P)} 144 | \URL{http://link/to/webpage/} 145 | \if@article 146 | \Seriesname{Issue} 147 | \Hypersubject{Journal of Statistical Software} 148 | \Plaintitle{\@title} 149 | \Shorttitle{\@title} 150 | \Plainkeywords{\@Keywords} 151 | \fi 152 | 153 | \if@codesnippet 154 | \Seriesname{Code Snippet} 155 | \Hypersubject{Journal of Statistical Software -- Code Snippets} 156 | \Plaintitle{\@title} 157 | \Shorttitle{\@title} 158 | \Plainkeywords{\@Keywords} 159 | \fi 160 | 161 | \if@bookreview 162 | \Seriesname{Book Review} 163 | \Hypersubject{Journal of Statistical Software -- Book Reviews} 164 | \Plaintitle{\@Booktitle} 165 | \Shorttitle{\@Booktitle} 166 | \Reviewauthor{\@Bookauthor\\ 167 | \@Publisher, \@Pubaddress, \@Pubyear.\\ 168 | ISBN~\@ISBN. \@Pages~pp. \@Price.\\ 169 | \url{\@URL}} 170 | \Plainkeywords{} 171 | \@reviewtrue 172 | \fi 173 | 174 | \if@softwarereview 175 | \Seriesname{Software Review} 176 | \Hypersubject{Journal of Statistical Software -- Software Reviews} 177 | \Plaintitle{\@Softwaretitle} 178 | \Shorttitle{\@Softwaretitle} 179 | \Booktitle{\@Softwaretitle} 180 | \Reviewauthor{\@Publisher, \@Pubaddress. \@Price.\\ 181 | \url{\@URL}} 182 | \Plainkeywords{} 183 | \@reviewtrue 184 | \fi 185 | 186 | \if@review 187 | \Hyperauthor{\@Plainreviewer} 188 | \Keywords{} 189 | \Footername{Reviewer} 190 | \Firstdate{\textit{Published:} \@Submitdate} 191 | \Seconddate{} 192 | \else 193 | \Hyperauthor{\@Plainauthor} 194 | \Keywords{---!!!---at least one keyword is required---!!!---} 195 | \Footername{Affiliation} 196 | \Firstdate{\textit{Submitted:} \@Submitdate} 197 | \Seconddate{\textit{Accepted:} \@Acceptdate} 198 | \fi 199 | %% Sweave(-like) 200 | \DefineVerbatimEnvironment{Sinput}{Verbatim}{fontshape=sl} 201 | \DefineVerbatimEnvironment{Soutput}{Verbatim}{} 202 | \DefineVerbatimEnvironment{Scode}{Verbatim}{fontshape=sl} 203 | \newenvironment{Schunk}{}{} 204 | \DefineVerbatimEnvironment{Code}{Verbatim}{} 205 | \DefineVerbatimEnvironment{CodeInput}{Verbatim}{fontshape=sl} 206 | \DefineVerbatimEnvironment{CodeOutput}{Verbatim}{} 207 | \newenvironment{CodeChunk}{}{} 208 | \setkeys{Gin}{width=0.8\textwidth} 209 | %% footer 210 | \newlength{\footerskip} 211 | \setlength{\footerskip}{2.5\baselineskip plus 2ex minus 0.5ex} 212 | 213 | \newcommand{\makefooter}{% 214 | \vspace{\footerskip} 215 | 216 | \if@nojss 217 | \begin{samepage} 218 | \textbf{\large \@Footername: \nopagebreak}\\[.3\baselineskip] \nopagebreak 219 | \@Address \nopagebreak 220 | \end{samepage} 221 | \else 222 | \begin{samepage} 223 | \textbf{\large \@Footername: \nopagebreak}\\[.3\baselineskip] \nopagebreak 224 | \@Address \nopagebreak 225 | \vfill 226 | \hrule \nopagebreak 227 | \vspace{.1\baselineskip} 228 | {\fontfamily{pzc} \fontsize{13}{15} \selectfont Journal of Statistical Software} 229 | \hfill 230 | \url{http://www.jstatsoft.org/}\\ \nopagebreak 231 | published by the American Statistical Association 232 | \hfill 233 | \url{http://www.amstat.org/}\\[.3\baselineskip] \nopagebreak 234 | {Volume~\@Volume, \@Seriesname~\@Issue} 235 | \hfill 236 | \@Firstdate\\ \nopagebreak 237 | {\@Month{} \@Year} 238 | \hfill 239 | \@Seconddate \nopagebreak 240 | \vspace{.3\baselineskip} 241 | \hrule 242 | \end{samepage} 243 | \fi 244 | } 245 | \if@nofooter 246 | %% \AtEndDocument{\makefooter} 247 | \else 248 | \AtEndDocument{\makefooter} 249 | \fi 250 | %% required packages 251 | \RequirePackage{hyperref} 252 | %% new \maketitle 253 | \def\@myoddhead{ 254 | {\color{white} JSS}\\[-1.42cm] 255 | \hspace{-2em} \includegraphics[height=23mm,keepaspectratio]{jsslogo} \hfill 256 | \parbox[b][23mm]{118mm}{\hrule height 3pt 257 | \center{ 258 | {\fontfamily{pzc} \fontsize{28}{32} \selectfont Journal of Statistical Software} 259 | \vfill 260 | {\it \small \@Month{} \@Year, Volume~\@Volume, \@Seriesname~\@Issue.% 261 | \hfill \href{http://www.jstatsoft.org/}{http://www.jstatsoft.org/}}}\\[0.1cm] 262 | \hrule height 3pt}} 263 | \if@review 264 | \renewcommand{\maketitle}{ 265 | \if@nojss 266 | %% \@oddhead{\@myoddhead}\\[3\baselineskip] 267 | \else 268 | \@oddhead{\@myoddhead}\\[3\baselineskip] 269 | \fi 270 | {\large 271 | \noindent 272 | Reviewer: \@Reviewer 273 | \vspace{\baselineskip} 274 | \hrule 275 | \vspace{\baselineskip} 276 | \textbf{\@Booktitle} 277 | \begin{quotation} \noindent 278 | \@Reviewauthor 279 | \end{quotation} 280 | \vspace{0.7\baselineskip} 281 | \hrule 282 | \vspace{1.3\baselineskip} 283 | } 284 | 285 | \thispagestyle{empty} 286 | \if@nojss 287 | \markboth{\centerline{\@Shorttitle}}{\centerline{\@Hyperauthor}} 288 | \else 289 | \markboth{\centerline{\@Shorttitle}}{\centerline{\@Hypersubject}} 290 | \fi 291 | \pagestyle{myheadings} 292 | } 293 | \else 294 | \def\maketitle{ 295 | \if@nojss 296 | %% \@oddhead{\@myoddhead} \par 297 | \else 298 | \@oddhead{\@myoddhead} \par 299 | \fi 300 | \begingroup 301 | \def\thefootnote{\fnsymbol{footnote}} 302 | \def\@makefnmark{\hbox to 0pt{$^{\@thefnmark}$\hss}} 303 | \long\def\@makefntext##1{\parindent 1em\noindent 304 | \hbox to1.8em{\hss $\m@th ^{\@thefnmark}$}##1} 305 | \@maketitle \@thanks 306 | \endgroup 307 | \setcounter{footnote}{0} 308 | 309 | \if@noheadings 310 | %% \markboth{\centerline{\@Shorttitle}}{\centerline{\@Hypersubject}} 311 | \else 312 | \thispagestyle{empty} 313 | \if@nojss 314 | \markboth{\centerline{\@Shorttitle}}{\centerline{\@Hyperauthor}} 315 | \else 316 | \markboth{\centerline{\@Shorttitle}}{\centerline{\@Hypersubject}} 317 | \fi 318 | \pagestyle{myheadings} 319 | \fi 320 | 321 | \let\maketitle\relax \let\@maketitle\relax 322 | \gdef\@thanks{}\gdef\@author{}\gdef\@title{}\let\thanks\relax 323 | } 324 | 325 | \def\@maketitle{\vbox{\hsize\textwidth \linewidth\hsize 326 | \if@nojss 327 | %% \vskip 1in 328 | \else 329 | \vskip 1in 330 | \fi 331 | {\centering 332 | {\LARGE\bf \@title\par} 333 | \vskip 0.2in plus 1fil minus 0.1in 334 | { 335 | \def\and{\unskip\enspace{\rm and}\enspace}% 336 | \def\And{\end{tabular}\hss \egroup \hskip 1in plus 2fil 337 | \hbox to 0pt\bgroup\hss \begin{tabular}[t]{c}\large\bf\rule{\z@}{24pt}\ignorespaces}% 338 | \def\AND{\end{tabular}\hss\egroup \hfil\hfil\egroup 339 | \vskip 0.1in plus 1fil minus 0.05in 340 | \hbox to \linewidth\bgroup\rule{\z@}{10pt} \hfil\hfil 341 | \hbox to 0pt\bgroup\hss \begin{tabular}[t]{c}\large\bf\rule{\z@}{24pt}\ignorespaces} 342 | \hbox to \linewidth\bgroup\rule{\z@}{10pt} \hfil\hfil 343 | \hbox to 0pt\bgroup\hss \begin{tabular}[t]{c}\large\bf\rule{\z@}{24pt}\@author 344 | \end{tabular}\hss\egroup 345 | \hfil\hfil\egroup} 346 | \vskip 0.3in minus 0.1in 347 | \hrule 348 | \begin{abstract} 349 | \@Abstract 350 | \end{abstract}} 351 | \textit{Keywords}:~\@Keywords. 352 | \vskip 0.1in minus 0.05in 353 | \hrule 354 | \vskip 0.2in minus 0.1in 355 | }} 356 | \fi 357 | %% sections, subsections, and subsubsections 358 | \newlength{\preXLskip} 359 | \newlength{\preLskip} 360 | \newlength{\preMskip} 361 | \newlength{\preSskip} 362 | \newlength{\postMskip} 363 | \newlength{\postSskip} 364 | \setlength{\preXLskip}{1.8\baselineskip plus 0.5ex minus 0ex} 365 | \setlength{\preLskip}{1.5\baselineskip plus 0.3ex minus 0ex} 366 | \setlength{\preMskip}{1\baselineskip plus 0.2ex minus 0ex} 367 | \setlength{\preSskip}{.8\baselineskip plus 0.2ex minus 0ex} 368 | \setlength{\postMskip}{.5\baselineskip plus 0ex minus 0.1ex} 369 | \setlength{\postSskip}{.3\baselineskip plus 0ex minus 0.1ex} 370 | 371 | \newcommand{\jsssec}[2][default]{\vskip \preXLskip% 372 | \pdfbookmark[1]{#1}{Section.\thesection.#1}% 373 | \refstepcounter{section}% 374 | \centerline{\textbf{\Large \thesection. #2}} \nopagebreak 375 | \vskip \postMskip \nopagebreak} 376 | \newcommand{\jsssecnn}[1]{\vskip \preXLskip% 377 | \centerline{\textbf{\Large #1}} \nopagebreak 378 | \vskip \postMskip \nopagebreak} 379 | 380 | \newcommand{\jsssubsec}[2][default]{\vskip \preMskip% 381 | \pdfbookmark[2]{#1}{Subsection.\thesubsection.#1}% 382 | \refstepcounter{subsection}% 383 | \textbf{\large \thesubsection. #2} \nopagebreak 384 | \vskip \postSskip \nopagebreak} 385 | \newcommand{\jsssubsecnn}[1]{\vskip \preMskip% 386 | \textbf{\large #1} \nopagebreak 387 | \vskip \postSskip \nopagebreak} 388 | 389 | \newcommand{\jsssubsubsec}[2][default]{\vskip \preSskip% 390 | \pdfbookmark[3]{#1}{Subsubsection.\thesubsubsection.#1}% 391 | \refstepcounter{subsubsection}% 392 | {\large \textit{#2}} \nopagebreak 393 | \vskip \postSskip \nopagebreak} 394 | \newcommand{\jsssubsubsecnn}[1]{\vskip \preSskip% 395 | {\textit{\large #1}} \nopagebreak 396 | \vskip \postSskip \nopagebreak} 397 | 398 | \newcommand{\jsssimplesec}[2][default]{\vskip \preLskip% 399 | %% \pdfbookmark[1]{#1}{Section.\thesection.#1}% 400 | \refstepcounter{section}% 401 | \textbf{\large #1} \nopagebreak 402 | \vskip \postSskip \nopagebreak} 403 | \newcommand{\jsssimplesecnn}[1]{\vskip \preLskip% 404 | \textbf{\large #1} \nopagebreak 405 | \vskip \postSskip \nopagebreak} 406 | 407 | \if@review 408 | \renewcommand{\section}{\secdef \jsssimplesec \jsssimplesecnn} 409 | \renewcommand{\subsection}{\secdef \jsssimplesec \jsssimplesecnn} 410 | \renewcommand{\subsubsection}{\secdef \jsssimplesec \jsssimplesecnn} 411 | \else 412 | \renewcommand{\section}{\secdef \jsssec \jsssecnn} 413 | \renewcommand{\subsection}{\secdef \jsssubsec \jsssubsecnn} 414 | \renewcommand{\subsubsection}{\secdef \jsssubsubsec \jsssubsubsecnn} 415 | \fi 416 | %% colors 417 | \definecolor{Red}{rgb}{0.5,0,0} 418 | \definecolor{Blue}{rgb}{0,0,0.5} 419 | \if@review 420 | \hypersetup{% 421 | hyperindex = {true}, 422 | colorlinks = {true}, 423 | linktocpage = {true}, 424 | plainpages = {false}, 425 | linkcolor = {Blue}, 426 | citecolor = {Blue}, 427 | urlcolor = {Red}, 428 | pdfstartview = {Fit}, 429 | pdfpagemode = {None}, 430 | pdfview = {XYZ null null null} 431 | } 432 | \else 433 | \hypersetup{% 434 | hyperindex = {true}, 435 | colorlinks = {true}, 436 | linktocpage = {true}, 437 | plainpages = {false}, 438 | linkcolor = {Blue}, 439 | citecolor = {Blue}, 440 | urlcolor = {Red}, 441 | pdfstartview = {Fit}, 442 | pdfpagemode = {UseOutlines}, 443 | pdfview = {XYZ null null null} 444 | } 445 | \fi 446 | \if@nojss 447 | \AtBeginDocument{ 448 | \hypersetup{% 449 | pdfauthor = {\@Hyperauthor}, 450 | pdftitle = {\@Plaintitle}, 451 | pdfkeywords = {\@Plainkeywords} 452 | } 453 | } 454 | \else 455 | \AtBeginDocument{ 456 | \hypersetup{% 457 | pdfauthor = {\@Hyperauthor}, 458 | pdftitle = {\@Plaintitle}, 459 | pdfsubject = {\@Hypersubject}, 460 | pdfkeywords = {\@Plainkeywords} 461 | } 462 | } 463 | \fi 464 | \if@notitle 465 | %% \AtBeginDocument{\maketitle} 466 | \else 467 | \AtBeginDocument{\maketitle} 468 | \fi 469 | %% commands 470 | \newcommand\code{\bgroup\@makeother\_\@makeother\~\@makeother\$\@codex} 471 | \def\@codex#1{{\normalfont\ttfamily\hyphenchar\font=-1 #1}\egroup} 472 | %%\let\code=\texttt 473 | \let\proglang=\textsf 474 | \newcommand{\pkg}[1]{{\fontseries{b}\selectfont #1}} 475 | \newcommand{\email}[1]{\href{mailto:#1}{\normalfont\texttt{#1}}} 476 | \ifx\csname urlstyle\endcsname\relax 477 | \newcommand\@doi[1]{doi:\discretionary{}{}{}#1}\else 478 | \newcommand\@doi{doi:\discretionary{}{}{}\begingroup 479 | \urlstyle{tt}\Url}\fi 480 | \newcommand{\doi}[1]{\href{http://dx.doi.org/#1}{\normalfont\texttt{\@doi{#1}}}} 481 | \newcommand{\E}{\mathsf{E}} 482 | \newcommand{\VAR}{\mathsf{VAR}} 483 | \newcommand{\COV}{\mathsf{COV}} 484 | \newcommand{\Prob}{\mathsf{P}} 485 | \endinput 486 | %% 487 | %% End of file `jss.cls'. 488 | -------------------------------------------------------------------------------- /R/dist.R: -------------------------------------------------------------------------------- 1 | setClass("bmerDist", representation(commonScale = "logical"), 2 | contains = "VIRTUAL") 3 | 4 | if (!isGeneric("getDFAdjustment")) 5 | setGeneric("getDFAdjustment", function(object, ...) standardGeneric("getDFAdjustment")) 6 | if (!isGeneric("getConstantTerm")) 7 | setGeneric("getConstantTerm", function(object, ...) standardGeneric("getConstantTerm")) 8 | ## what power sigma has if prior induces exp(-0.5 * sigma^pow * stuff) 9 | if (!isGeneric("getExponentialSigmaPower")) 10 | setGeneric("getExponentialSigmaPower", function(object, ...) standardGeneric("getExponentialSigmaPower")) 11 | ## whatever is going on in the exponent, and what power sigma has connected with it 12 | ## note, relative to -1 / 2 13 | if (!isGeneric("getExponentialTerm")) 14 | setGeneric("getExponentialTerm", function(object, ...) standardGeneric("getExponentialTerm")) 15 | if (!isGeneric("getPolynomialTerm")) 16 | setGeneric("getPolynomialTerm", function(object, ...) standardGeneric("getPolynomialTerm")) 17 | 18 | setMethod("getDFAdjustment", "ANY", function(object, ...) 0) 19 | setMethod("getConstantTerm", "ANY", function(object, ...) 0) 20 | setMethod("getExponentialSigmaPower", "ANY", function(object, ...) 0) 21 | setMethod("getExponentialTerm", "ANY", function(object, ...) c(0, 0)) 22 | setMethod("getPolynomialTerm", "ANY", function(object, ...) 0) 23 | 24 | 25 | fixefDistributions <- c("flat", "normal", "t", "horseshoe") 26 | covDistributions <- c("flat", "wishart", "invwishart", 27 | "gamma", "invgamma", "custom") 28 | residDistributions <- c("flat", "gamma", "invgamma", "point") 29 | 30 | # Attempts to limit the burden of having to call eval to lookup function 31 | # arguments every time. Distribution functions are evaluated in an 32 | # env that descends from the caller, so anything user-defined comes 33 | # from there. However, we also want them to be able to access various 34 | # bits of data-specific information, like the level dimension. That is 35 | # stored in the environment that the distribution functions are defined 36 | # in. In order to be able to access both, we construct an eval call 37 | # and use that defining environment as the enclos arg. 38 | eval_with_enclosure <- function(expr) { 39 | expr <- match.call()$expr 40 | tryResult <- tryCatch(eval(expr, parent.frame(1L)), error = function(e) e) 41 | if (inherits(tryResult, "error")) { 42 | expr <- parent.frame()[["matchedCall"]][[expr]] 43 | eval(expr, parent.frame(1L), enclos = parent.env(parent.frame(1L))) 44 | } else { 45 | tryResult 46 | } 47 | } 48 | 49 | lmmDistributions <- list( 50 | flat = function() NULL, 51 | normal = function(sd = c(10, 2.5), cov, common.scale = TRUE) { 52 | matchedCall <- match.call() 53 | if (!is.null(matchedCall$sd)) sd <- eval_with_enclosure(sd) 54 | if (!is.null(matchedCall$cov)) cov <- eval_with_enclosure(cov) 55 | if (!is.null(matchedCall$sd) && !is.null(matchedCall$cov)) 56 | warning("both sd and cov supplied to normal - only cov will be used") 57 | common.scale <- blme:::deparseCommonScale(common.scale) 58 | 59 | if (missing(cov) && !is.null(sd)) { 60 | if (!is.null(names(sd)) && any(names(sd) %not_in% .fixefNames & names(sd) != "")) 61 | stop("unrecognized fixed effects for normal prior: '", 62 | paste0(names(sd)[names(sd) %not_in% .fixefNames & names(sd) != ""], collapse = "', '"), "'") 63 | 64 | sd <- sd^2 65 | if (length(sd) == 1L) { 66 | cov <- if (!is.null(names(sd))) { 67 | diag(c(rep_len(Inf, which(.fixefNames %in% names(sd)) - 1L), 68 | sd, 69 | rep_len(Inf, p - which(.fixefNames %in% names(sd)))), p) 70 | } else { diag(sd, p) } 71 | } else if (length(sd) == 2L && p > 2L) { 72 | if (!is.null(names(sd)) && any(names(sd) != "")) { 73 | if (!any(names(sd) == "")) 74 | stop("for 2-parameter default normal prior specification with names, the default name must be left blank") 75 | sd <- c(rep_len(sd[names(sd) == ""], which(.fixefNames %in% names(sd)) - 1L), 76 | sd[names(sd) != ""], 77 | rep_len(sd[names(sd) == ""], p - which(.fixefNames %in% names(sd)))) 78 | } else { 79 | sd <- c(sd[1L], rep_len(sd[2L], p - 1L)) 80 | } 81 | cov <- diag(sd, p) 82 | } else { 83 | if (length(sd) > p) warning("length of sd in normal prior exceeds number of fixed effects") 84 | 85 | sd.names <- names(sd) 86 | 87 | sd <- rep_len(sd, p) 88 | if (!is.null(sd.names)) { 89 | names(sd) <- rep_len(sd.names, p) 90 | ind <- match(.fixefNames, names(sd)) 91 | ind[is.na(ind)] <- which(names(sd) %not_in% .fixefNames) 92 | sd <- sd[ind] 93 | } 94 | cov <- diag(sd, p) 95 | } 96 | } 97 | if (missing(cov) || is.null(cov)) { 98 | stop("normal prior requires either sd or cov to be specified") 99 | } 100 | if (length(cov) == p) { 101 | cov <- diag(cov, p) 102 | } else if (length(cov) != p * p) { 103 | stop("normal prior covariance of improper length") 104 | } 105 | 106 | if (any(cov != t(cov))) stop("normal covariance not symmetric") 107 | 108 | logDet <- determinant(cov, TRUE) 109 | if (logDet$sign < 0) 110 | stop("normal prior covariance negative semi-definite") 111 | if (is.infinite(logDet$modulus)) { 112 | if (any(cov[upper.tri(cov) | lower.tri(cov)] != 0)) 113 | stop("normal prior covariance infinite") 114 | ## special case for diagonal scale matrices with infinite variances 115 | R.cov.inv <- diag(1 / sqrt(diag(cov))) 116 | } else { 117 | R.cov.inv <- solve(chol(cov)) 118 | } 119 | 120 | new("bmerNormalDist", commonScale = common.scale, R.cov.inv = R.cov.inv) 121 | }, 122 | t = function(df = 3, mean = 0, scale = c(10^2, 2.5^2), common.scale = TRUE) { 123 | matchedCall <- match.call() 124 | if (!is.null(matchedCall$df)) df <- eval_with_enclosure(df) 125 | if (!is.null(matchedCall$mean)) mean <- eval_with_enclosure(mean) 126 | if (!is.null(matchedCall$scale)) scale <- eval_with_enclosure(scale) 127 | common.scale <- blme:::deparseCommonScale(common.scale) 128 | 129 | if (df <= 0) stop("t prior requires positive degrees of freedom") 130 | 131 | if (length(mean) == 1L) { 132 | mean <- rep_len(mean, p) 133 | } else if (length(mean) == 2L && p > 1L) { 134 | mean <- c(mean[1L], rep_len(mean[2L], p - 1L)) 135 | } else if (length(mean) != p) { 136 | stop("t prior mean of improper length") 137 | } 138 | 139 | if (length(scale) == 1L) { 140 | scale <- diag(scale, p) 141 | } else if (length(scale) == 2L && p > 1L) { 142 | scale <- diag(c(scale[1L], rep_len(scale[2L], p - 1L)), p) 143 | } else if (length(scale) == p) { 144 | scale <- diag(scale, p) 145 | } else if (length(scale) != p * p) { 146 | stop("t prior scale of improper length") 147 | } 148 | 149 | if (any(scale != base::t(scale))) stop("t scale not symmetric") 150 | 151 | logDet <- determinant(scale, TRUE) 152 | if (logDet$sign < 0) 153 | stop("t prior scale negative semi-definite") 154 | if (is.infinite(logDet$modulus)) { 155 | if (any(scale[upper.tri(scale) | lower.tri(scale)] != 0)) 156 | stop("t prior scale infinite") 157 | ## special case for diagonal scale matrices with infinite variances 158 | R.scale.inv <- diag(1 / sqrt(diag(scale))) 159 | d <- sum(is.finite(diag(scale))) 160 | } else { 161 | R.scale.inv <- solve(chol(scale)) 162 | d <- nrow(R.scale.inv) 163 | } 164 | 165 | new("bmerTDist", commonScale = common.scale, df = df, beta.0 = mean, d = d, R.scale.inv = R.scale.inv) 166 | }, 167 | horseshoe = function(mean = 0, global.shrinkage = 2.5, common.scale = TRUE) { 168 | matchedCall <- match.call() 169 | 170 | if (!is.null(matchedCall$mean)) mean <- eval_with_enclosure(mean) 171 | if (!is.null(matchedCall$global.shrinkage)) global.shrinkage <- eval_with_enclosure(global.shrinkage) 172 | common.scale <- blme:::deparseCommonScale(common.scale) 173 | 174 | if (length(mean) == 1L) { 175 | mean <- rep_len(mean, p) 176 | } else if (length(mean) == 2L && p > 1L) { 177 | mean <- c(mean[1L], rep_len(mean[2L], p - 1L)) 178 | } else if (length(mean) != p) { 179 | stop("horseshoe prior mean of improper length") 180 | } 181 | 182 | if (global.shrinkage <= 0) 183 | stop("horseshoe prior global.shrinkage parameter must be positive") 184 | if (length(global.shrinkage) != 1L) 185 | stop("horseshoe prior global.shrinkage must be of length 1") 186 | 187 | new("bmerHorseshoeDist", beta.0 = mean, tau.sq = global.shrinkage^2, commonScale = common.scale) 188 | }, 189 | gamma = function(shape = 2.5, rate = 0, common.scale = TRUE, posterior.scale = "sd") { 190 | matchedCall <- match.call() 191 | if (!is.null(matchedCall$shape)) shape <- eval_with_enclosure(shape) 192 | if (!is.null(matchedCall$rate)) rate <- eval_with_enclosure(rate) 193 | common.scale <- blme:::deparseCommonScale(common.scale) 194 | 195 | if (level.dim > 1L) { 196 | warning("gamma prior applied to multivariate grouping level will be ignored") 197 | return(NULL) 198 | } 199 | 200 | if (shape < 0) stop("gamma prior shape must be positive") 201 | if (rate < 0) stop("gamma prior rate must be positive") 202 | 203 | new("bmerGammaDist", commonScale = common.scale, shape = shape, rate = rate, posteriorScale = posterior.scale) 204 | }, 205 | invgamma = function(shape = 0.001, scale = shape + 0.05, common.scale = TRUE, posterior.scale = "var") { 206 | matchedCall <- match.call() 207 | if (!is.null(matchedCall$shape)) shape <- eval_with_enclosure(shape) 208 | if (!is.null(matchedCall$scale)) scale <- eval_with_enclosure(scale) 209 | common.scale <- blme:::deparseCommonScale(common.scale) 210 | 211 | if (level.dim > 1L) { 212 | warning("inverse gamma prior applied to multivariate grouping level will be ignored") 213 | return(NULL) 214 | } 215 | 216 | if (shape < 0) stop("invgamma prior shape must be positive") 217 | if (scale < 0) stop("invgamma prior scale must be positive") 218 | 219 | new("bmerInvGammaDist", commonScale = common.scale, shape = shape, scale = scale, posteriorScale = posterior.scale) 220 | }, 221 | wishart = function(df = level.dim + 2.5, scale = Inf, common.scale = TRUE, posterior.scale = "cov") { 222 | matchedCall <- match.call() 223 | if (!is.null(matchedCall$df)) df <- eval_with_enclosure(df) 224 | if (!is.null(matchedCall$scale)) scale <- eval_with_enclosure(scale) 225 | common.scale <- blme:::deparseCommonScale(common.scale) 226 | 227 | if (df <= level.dim - 1L) 228 | stop("wishart dists for degrees of freedom less than or equal to (level.dim - 1) are singular or non-existent") 229 | 230 | log.det.scale <- NULL 231 | if (length(scale) == 1L) { 232 | if (is.infinite(scale)) { 233 | R.scale.inv <- diag(0, level.dim) 234 | log.det.scale <- Inf 235 | } else { 236 | if (scale[1L] < 0) stop("wishart prior scale negative definite") 237 | R.scale.inv <- diag(1 / sqrt(scale[1L]), level.dim) 238 | } 239 | } else if (length(scale) == level.dim) { 240 | if (any(scale < 0)) stop("wishart prior scale negative definite") 241 | R.scale.inv <- diag(1 / sqrt(scale), level.dim) 242 | } else if (length(scale) != level.dim * level.dim) { 243 | stop("wishart prior scale of improper length") 244 | } else { 245 | if (all(is.infinite(scale))) { 246 | R.scale.inv <- diag(0, level.dim) 247 | log.det.scale <- Inf 248 | } 249 | R.scale.inv <- solve(chol(scale)) 250 | } 251 | if (is.null(log.det.scale)) { 252 | if (any(diag(R.scale.inv) < 0)) stop("wishart prior scale negative definite") 253 | 254 | if (any(is.infinite(diag(R.scale.inv)))) 255 | log.det.scale <- Inf 256 | else 257 | log.det.scale <- -2.0 * sum(log(diag(R.scale.inv))) 258 | } 259 | 260 | new("bmerWishartDist", commonScale = common.scale, df = df, R.scale.inv = R.scale.inv, 261 | log.det.scale = log.det.scale, 262 | posteriorScale = posterior.scale) 263 | }, 264 | invwishart = function(df = level.dim - 0.998, scale = diag(df + 0.1, level.dim), 265 | common.scale = TRUE, posterior.scale = "cov") { 266 | matchedCall <- match.call() 267 | if (!is.null(matchedCall$df)) df <- eval_with_enclosure(df) 268 | if (!is.null(matchedCall$scale)) scale <- eval_with_enclosure(scale) 269 | common.scale <- blme:::deparseCommonScale(common.scale) 270 | 271 | if (df <= level.dim - 1L) 272 | stop("inverse wishart dists for degrees of freedom less than or equal to (level.dim - 1) are singular or non-existent") 273 | 274 | log.det.scale <- NULL 275 | if (length(scale) == 1L) { 276 | if (scale == 0) { 277 | R.scale <- diag(0, level.dim) 278 | log.det.scale <- -Inf 279 | } else { 280 | if (scale[1L] < 0) stop("inverse wishart prior scale negative definite") 281 | R.scale <- diag(sqrt(scale[1L]), level.dim) 282 | } 283 | } else if (length(scale) == level.dim) { 284 | if (any(scale < 0)) stop("inverse wishart prior scale negative definite") 285 | R.scale <- diag(sqrt(scale), level.dim) 286 | } else if (length(scale) != level.dim * level.dim) { 287 | stop("inverse wishart prior scale of improper length") 288 | } else { 289 | if (all(scale == 0)) { 290 | R.scale <- diag(0, level.dim) 291 | log.det.scale <- -Inf 292 | } 293 | R.scale <- chol(scale) 294 | } 295 | if (is.null(log.det.scale)) { 296 | if (any(diag(R.scale) < 0)) stop("inverse wishart prior scale negative definite") 297 | 298 | if (any(diag(R.scale) == 0)) 299 | log.det.scale <- -Inf 300 | else 301 | log.det.scale <- 2.0 * sum(log(diag(R.scale))) 302 | } 303 | 304 | new("bmerInvWishartDist", commonScale = common.scale, df = df, R.scale = R.scale, 305 | log.det.scale = log.det.scale, 306 | posteriorScale = posterior.scale) 307 | }, 308 | point = function(value = 1.0, posterior.scale = "sd") { 309 | matchedCall <- match.call() 310 | if (!is.null(matchedCall$value)) value <- eval_with_enclosure(value) 311 | 312 | if (!(posterior.scale %in% c("sd", "var"))) 313 | stop("point prior scale '", posterior.scale, "' unrecognized") 314 | 315 | if (posterior.scale == "var") value <- sqrt(value) 316 | 317 | if (value <= 0) stop("residual variance must be positive") 318 | 319 | new("bmerPointDist", commonScale = FALSE, value = value) 320 | }, 321 | custom = function(fn, chol = FALSE, common.scale = TRUE, scale = "none") { 322 | matchedCall <- match.call() 323 | 324 | if (!is.null(matchedCall$chol)) chol <- eval_with_enclosure(chol) 325 | if (!is.null(matchedCall$scale)) scale <- eval_with_enclosure(scale) 326 | common.scale <- blme:::deparseCommonScale(common.scale) 327 | 328 | new("bmerCustomDist", fnName = matchedCall$fn, fn = fn, 329 | chol = chol, scale = scale, commonScale = common.scale) 330 | } 331 | ) 332 | 333 | ## closure out the common scale param 334 | glmmDistributions <- list( 335 | flat = lmmDistributions$flat, 336 | normal = function(sd = c(10, 2.5), cov) { 337 | .prior <- blme:::lmmDistributions$normal 338 | environment(.prior) <- environment() 339 | 340 | matchedCall <- match.call() 341 | if (!is.null(matchedCall$sd) && !is.null(matchedCall$cov)) 342 | warning("both sd and cov supplied to normal - only cov will be used") 343 | if (!is.null(matchedCall$cov)) { 344 | eval(substitute(.prior(cov = cov, common.scale = FALSE), environment()), 345 | parent.frame()) 346 | } else { 347 | eval(substitute(.prior(sd = sd, common.scale = FALSE), environment()), 348 | parent.frame()) 349 | } 350 | }, 351 | t = function(df = 3, mean = 0, scale = c(10^2, 2.5^2)) { 352 | .prior <- blme:::lmmDistributions$t 353 | environment(.prior) <- environment() 354 | 355 | eval(substitute(.prior(df, mean, scale, FALSE), environment()), 356 | parent.frame()) 357 | }, 358 | horseshoe = function(mean = 0, global.shrinkage = 2.5) { 359 | .prior <- blme:::lmmDistributions$horseshoe 360 | environment(.prior) <- environment() 361 | 362 | eval(substitute(.prior(mean, global.shrinkage, FALSE), environment()), 363 | parent.frame()) 364 | }, 365 | gamma = function(shape = 2.5, rate = 0, posterior.scale = "sd") { 366 | .prior <- blme:::lmmDistributions$gamma 367 | environment(.prior) <- environment() 368 | 369 | eval(substitute(.prior(shape, rate, TRUE, posterior.scale), environment()), 370 | parent.frame()) 371 | }, 372 | invgamma = function(shape = 0.5, scale = 10^2, posterior.scale = "sd") { 373 | .prior <- blme:::lmmDistributions$invgamma 374 | environment(.prior) <- environment() 375 | eval(substitute(.prior(shape, scale, TRUE, posterior.scale), environment()), 376 | parent.frame()) 377 | }, 378 | wishart = function(df = level.dim + 2.5, scale = Inf, posterior.scale = "cov") { 379 | .prior <- blme:::lmmDistributions$wishart 380 | environment(.prior) <- environment() 381 | 382 | eval(substitute(.prior(df, scale, TRUE, posterior.scale), environment()), 383 | parent.frame()) 384 | }, 385 | invwishart = function(df = level.dim - 0.5, scale = diag(10^2 / (df + level.dim + 1), level.dim), 386 | posterior.scale = "cov") { 387 | .prior <- blme:::lmmDistributions$invwishart 388 | environment(.prior) <- environment() 389 | eval(substitute(.prior(df, scale, TRUE, posterior.scale), environment()), 390 | parent.frame()) 391 | }, 392 | custom = function(fn, chol = FALSE, scale = "none") { 393 | .prior <- blme:::lmmDistributions$custom 394 | environment(.prior) <- environment() 395 | eval(substitute(.prior(fn, chol, TRUE, scale), environment()), 396 | parent.frame()) 397 | } 398 | ) 399 | 400 | residualVarianceGammaPrior <- function(shape = 0, rate = 0, posterior.scale = "var") { 401 | matchedCall <- match.call() 402 | if (!is.null(matchedCall$shape)) shape <- eval_with_enclosure(shape) 403 | if (!is.null(matchedCall$rate)) rate <- eval_with_enclosure(rate) 404 | 405 | if (shape < 0) stop("gamma prior shape must be positive") 406 | if (rate < 0) stop("gamma prior rate must be positive") 407 | 408 | new("bmerGammaDist", commonScale = FALSE, shape = shape, rate = rate, posteriorScale = posterior.scale) 409 | } 410 | 411 | residualVarianceInvGammaPrior <- function(shape = 0, scale = 0, posterior.scale = "var") { 412 | matchedCall <- match.call() 413 | if (!is.null(matchedCall$shape)) shape <- eval_with_enclosure(shape) 414 | if (!is.null(matchedCall$scale)) scale <- eval_with_enclosure(scale) 415 | 416 | if (shape < 0) stop("invgamma prior shape must be positive") 417 | if (scale < 0) stop("invgamma prior scale must be positive") 418 | 419 | new("bmerInvGammaDist", commonScale = FALSE, shape = shape, scale = scale, posteriorScale = posterior.scale) 420 | } 421 | 422 | 423 | ## rather annoying problem of legacy interface allowing character strings of "true" or 424 | ## what not 425 | deparseCommonScale <- function(common.scale) { 426 | if (is.null(common.scale)) return(TRUE) 427 | if (is.character(common.scale)) { 428 | if (common.scale == "TRUE" || common.scale == "true") return(TRUE) 429 | if (common.scale == "FALSE" || common.scale == "false") return(FALSE) 430 | return(eval(parse(text = common.scale)[[1L]])) 431 | } 432 | 433 | common.scale 434 | } 435 | -------------------------------------------------------------------------------- /inst/doc/generalizedLinearOptimization.tex: -------------------------------------------------------------------------------- 1 | \documentclass[10pt]{article} 2 | 3 | \usepackage{amsmath} 4 | \usepackage{verbatim} 5 | \usepackage{mathrsfs} 6 | \usepackage{url} 7 | \usepackage{undertilde} 8 | \usepackage{bm} 9 | \usepackage{bbold} 10 | \usepackage[top=1in,bottom=1in,left=1in,right=1in]{geometry} 11 | 12 | \let\proglang=\textsf 13 | \newcommand{\pkg}[1]{{\fontseries{b}\selectfont #1}} 14 | 15 | \newcommand{\E}{\mathsf{E}} 16 | \newcommand{\VAR}{\mathsf{VAR}} 17 | \newcommand{\COV}{\mathsf{COV}} 18 | \newcommand{\SD}{\mathsf{SD}} 19 | \newcommand{\Prob}{\mathsf{P}} 20 | 21 | 22 | \begin{document} 23 | 24 | In a generalized linear model, we typically have two things to 25 | specify: 26 | 27 | \begin{enumerate} 28 | \item the distributional family from which we believe the data to have 29 | come, 30 | \item and the ``link'' function that expresses the relationship 31 | between the linear predictor and the expected value of the response. 32 | \end{enumerate} 33 | 34 | Point 2 above is given by the notion: 35 | 36 | \begin{align*} 37 | \eta_i & = x_i^\top\beta + z_i^\top\theta, \\ 38 | \mu(\eta_i) & = E_{\eta_i}[y_i \mid x_i, z_i], \\ 39 | & = g^{-1}(\eta_i). 40 | \end{align*} 41 | 42 | Point 1 is determined by restricting our focus to the exponential 43 | family. We can write down a density as: 44 | 45 | \begin{equation*} 46 | p(y_i, \mid \theta, \beta, \tau) = \exp\left\{\frac{y_i \gamma(\theta, 47 | \beta) - b(\theta, \beta)}{c(\tau)} - h(\tau, y_i)\right\}. 48 | \end{equation*} 49 | 50 | \noindent $\eta$ is the ``linear predictor'', and $g$ is the link 51 | function. $\gamma$ is known as the ``natural parameter'', and is 52 | occasionally a convenient way of parameterizing the distribution. 53 | 54 | One good way of describing $\gamma$ is as a function the mean of the 55 | distribution, $\mu$, so that it remains independent of our choice of 56 | link function. Thus we have $\gamma(\mu)$ as a function, or more 57 | specifically $\gamma(\mu(\eta(\theta, \beta)))$. 58 | 59 | $b$ is part of the normalizing constant of the distribution, and thus 60 | it might make sense to write it down as a function of the natural 61 | parameter, $\gamma$. For any particular distribution, this can be 62 | written down explictly. However, we can go one step further by taking the derivative with respect to $\gamma$ 63 | of the integral of the density: 64 | 65 | \begin{align*} 66 | 1 & = \int \exp\left\{\frac{y \gamma - b(\gamma)}{c(\tau)} - h(\tau, y)\right\} 67 | \,\mathrm{d}y, \\ 68 | 0 & = \frac{1}{c(\tau)} \int \left(y - \frac{\partial 69 | b}{\partial\gamma} \right) 70 | \exp\left\{\frac{y \gamma - b(\gamma)}{c(\tau)} - h(\tau, y)\right\} 71 | \,\mathrm{d}y, \\ 72 | \mu & = \frac{\partial b}{\partial\gamma}. 73 | \end{align*} 74 | 75 | \noindent This relationship comes into play when we take the log and 76 | take a derivative, such that we are never that interested in $b$ 77 | itself. 78 | 79 | One further relationship is required before we can optimize. Consider taking the 80 | derivative with respect to $\mu$ of the mean. 81 | 82 | \begin{align*} 83 | \mu & = \int y \exp\left\{\frac{y \gamma - b(\gamma)}{c(\tau)} - h(\tau, y)\right\} 84 | \,\mathrm{d}y, \\ 85 | 1 & = \frac{1}{c(\tau)} \int \left( y^2 86 | \frac{\partial\gamma}{\partial\mu} - y 87 | \frac{\partial b}{\partial\gamma} 88 | \frac{\partial\gamma}{\partial\mu} \right) 89 | \exp\left\{\frac{y \gamma - b(\gamma)}{c(\tau)} - h(\tau, y)\right\} 90 | \,\mathrm{d}y, \\ 91 | & = \frac{1}{c(\tau)} \left(\E[y^2] - \mu^2\right)\frac{\partial\gamma}{\partial\mu},\\ 92 | \frac{\partial\gamma}{\partial\mu} & = \frac{c(\tau)}{\VAR[y]}. 93 | \end{align*} 94 | 95 | To complete the model, assume: 96 | 97 | \begin{equation*} 98 | \theta \mid \Sigma, \tau \sim N(0, c(\tau)\Sigma). 99 | \end{equation*} 100 | 101 | Our goal is to maximize: 102 | \begin{align*} 103 | L(\Sigma, \beta, \tau; \bm{y}) & = p(\bm{y} \mid \Sigma, 104 | \beta, \tau), \\ 105 | & = \int p(\bm{y} \mid \theta, \beta, \tau) p(\theta \mid \Sigma, 106 | \tau) \, \mathrm{d}\theta. 107 | \end{align*} 108 | 109 | As this integral is often intractable, we consider the Laplace 110 | approximation which will hold as the number of observations per group gets large. The 111 | Laplace approximation requires finding the mode of the joint with 112 | respect to $\theta$. Hereafter, we will vectorize what components we 113 | can, with $\gamma$ and $\mu$ being the component-wise application of 114 | the respective functions. 115 | 116 | Ignoring data-alone and constant terms, the overall density is proportional to : 117 | 118 | \begin{equation*} 119 | \left|\Sigma\right|^{-1/2} \exp\left\{\dfrac{1}{c(\tau)}\left[ 120 | \bm{y}^\top\gamma - \sum_{i=1}^Nb(\gamma_i) \right] - 121 | \sum_{i=1}^Nh(\tau, y_i) - \dfrac{1}{2c(\tau)}\theta^\top\Sigma^{-1}\theta 122 | \right\}. 123 | \end{equation*} 124 | 125 | Considering only the parts that live under the integral - 126 | i.e. involving \(\theta\) (generally through $\gamma$) we have: 127 | 128 | \begin{align*} 129 | l(\theta, \beta, \tau) & \propto \log \left[ p(\bm{y} \mid \theta, \beta, \tau) 130 | p(\theta \mid \Sigma, \tau) \right], \\ 131 | & = \dfrac{1}{c(\tau)}\left[\bm{y}^\top\gamma - \sum_{i=1}^N b(\gamma_i) \right] - 132 | \dfrac{1}{2c(\tau)}\theta^\top\Sigma^{-1}\theta. 133 | \end{align*} 134 | 135 | Assuming that \(c(\tau)\) is not \(0\) or \(\infty\), the maximum in 136 | \(l\) will not depend upon the scale so that it is sufficient to 137 | consider the function: 138 | \begin{align*} 139 | l(\theta, \beta) & = \bm{y}^\top\gamma - \sum_{i=1}^Nb(\gamma_i) - 140 | \frac{1}{2}\theta^\top\Sigma^{-1}\theta, \\ 141 | l(\theta, \beta) & = \bm{y}^\top\gamma(\mu(\eta(\theta, \beta))) - 142 | \sum_{i=1}^Nb(\gamma_i(\mu_i(\eta_i(\theta, \beta)))) - 143 | \frac{1}{2}\theta^\top\Sigma^{-1}\theta, \\ 144 | \end{align*} 145 | 146 | This is also a function of \(\Sigma\), but at this point we 147 | can consider it fixed and omit it from our notation. During 148 | optimization, $\beta$ is fixed as well, but for simulation purposes we 149 | will want to be able to derive their joint maximum. 150 | 151 | The following will require taking a variety of vector-valued and 152 | matrix derivatives. We follow the convention that: 153 | 154 | \begin{align*} 155 | \mathrm{D}f(\bm{X}) & =\frac{\mathrm{d}f(\bm{X})}{\mathrm{d}\bm{X}}, \\ 156 | & = \frac{\mathrm{d}f(\bm{X}):}{\mathrm{d}\bm{X}^\top :}, 157 | \end{align*} 158 | 159 | where ``$:$'' is the ``vectorization'' operator that stacks the 160 | columns of its argument. The transpose in the denominator is to signal 161 | that the derivative goes across with regards to the elements of 162 | $\bm{X}:$. If $F: \mathbb{R}^{n\times m} \rightarrow 163 | \mathbb{R}^{p\times q}$, then $\mathrm{D}F$ is 164 | $pq\times nm$. 165 | 166 | For the most part, derivatives will be obtained by using the product 167 | rule as given by $\mathrm{D}FG = [G^\top 168 | \otimes I]\mathrm{D}F+ [I \otimes F]\mathrm{D}G$. We will cheat and 169 | write simpler matrices whenever it makes the calculations more easy to 170 | read, but will be sure to point out when we do so. 171 | 172 | In order of hierarchy, the parameters in our model are $\gamma$, 173 | $\mu$, $\eta$, and finally $\theta$ and $\beta$. $\gamma$ and $\mu$ are 174 | both maps from $\mathbb{R}^N$ to $\mathbb{R}^N$ so that 175 | $\frac{\partial\gamma}{\partial\mu}$ and 176 | $\frac{\partial\mu}{\partial\eta}$ are $N\times N$ matrices that have 177 | elements strictly on the diagaonal. 178 | 179 | $\eta$ maps the number coefficients to an $N$ dimensional object, so its 180 | derivative is a $N \times Q$, $N \times P$, or $N \times (Q + P)$ matrix, 181 | depending on the context ($Q$ is the number of modeled coefficients, 182 | $P$ is the number of unmodeled ones). Specifically, we have 183 | $\frac{\partial\eta}{\partial\theta} = \bm{Z}$, 184 | $\frac{\partial\eta}{\partial\beta} = \bm{X}$, and the derivative with 185 | respect to both components is just the matrices concatenated. 186 | 187 | Returning to the log-joint: 188 | 189 | \begin{align*} 190 | \dfrac{\partial}{\partial \theta}l(\theta, \beta) & = 191 | \bm{y}^\top\frac{\partial\gamma}{\partial\mu} 192 | \frac{\partial\mu}{\partial\eta} 193 | \frac{\partial\eta}{\partial\theta} 194 | - \left.\frac{\partial b}{\partial\gamma}\right|_{b(\gamma)} 195 | \frac{\partial\gamma}{\partial\mu} 196 | \frac{\partial\mu}{\partial\eta} 197 | \frac{\partial\eta}{\partial\theta} 198 | - \theta^\top\Sigma^{-1}, \\ 199 | & = (\bm{y} - \mu)^\top \frac{\partial\gamma}{\partial\mu} 200 | \frac{\partial\mu}{\partial\eta} \bm{Z} - \theta^\top\Sigma^{-1}, \\ 201 | \dfrac{\partial}{\partial\beta}l(\theta, \beta) & = 202 | (\bm{y} - \mu)^\top \frac{\partial\gamma}{\partial\mu} 203 | \frac{\partial\mu}{\partial\eta} \bm{X}. 204 | \end{align*} 205 | 206 | We will signify by $\nabla l$ the column vector that results from 207 | differentiation, i.e. the transpose of the above. (Once again, we will 208 | only need the derivative with respect to $\theta$ for optimization, 209 | but that with respect to $\beta$ as well for simulation). We can simplify the above by writing 210 | 211 | \begin{align*} 212 | \nabla l(\beta, \theta) & = 213 | \begin{bmatrix} 214 | \bm{Z}^\top \\ \bm{X}^\top 215 | \end{bmatrix} 216 | \frac{\partial\gamma}{\partial\mu} 217 | \frac{\partial\mu}{\partial\eta} 218 | \left(\bm{y} - 219 | \mu\right) - 220 | \begin{bmatrix} 221 | \Sigma^{-1}\theta \\ 222 | \utilde{0}_P 223 | \end{bmatrix}, \\ 224 | & = \begin{bmatrix} 225 | \bm{Z}^\top \\ \bm{X}^\top 226 | \end{bmatrix} 227 | \frac{c(\tau)}{\VAR[\bm{y}]} 228 | \frac{\mathrm{d} g^{-1}}{\mathrm{d}x} 229 | \left(\bm{y} - 230 | \mu\right) - 231 | \begin{bmatrix} 232 | \Sigma^{-1}\theta \\ 233 | \utilde{0}_P 234 | \end{bmatrix}. 235 | \end{align*} 236 | 237 | \noindent The last line is included as a reminder as to what the 238 | derivatives mean in a practical sense, as well as what functions need 239 | to be written down for computation. 240 | 241 | To obtain a root to the above, we use Newton's method. Suppressed in 242 | the above notation is that the partials above remain functions of the coefficients, so that we will be required to take their derivatives as 243 | well. For notational simplicity, let $B = \begin{bmatrix} 244 | \bm{Z} & \bm{X} \end{bmatrix}$, $\Gamma' = 245 | \frac{\partial\gamma}{\partial\mu}$, and $U' = \frac{\partial\mu}{\partial\eta}$. The data part requires the most work to differentiate, but 246 | using the product rule on it we obtain: 247 | 248 | \begin{align*} 249 | \mathrm{D}\left[ B^\top \Gamma'U'(\bm{y} - \mu) \right] & = 250 | \left[(\bm{y} - \mu)^\top \otimes I 251 | \right] \mathrm{D}(B^\top\Gamma'U') - 252 | \left[I_1 \otimes B^\top\Gamma'U'\right] 253 | \frac{\partial\mu}{\partial\eta}\frac{\partial\eta}{\partial (\theta, 254 | \beta)}, \\ 255 | & = \left[(\bm{y} - \mu)^\top \otimes I 256 | \right] \left[I \otimes B^\top\right] \mathrm{D}(\Gamma'U') - B^\top 257 | \Gamma'U' U' B, \\ 258 | & = \left[(\bm{y} - \mu)^\top \otimes B^\top 259 | \right] \mathrm{D}(\Gamma'U') - B^\top 260 | U' \Gamma'U' B. 261 | \end{align*} 262 | 263 | \noindent In the first term, the remaining derivative is with respect 264 | to a diagonal matrix with each term depending only on a single, 265 | corresponding input. It is possible to take this derivative and 266 | work out the product to see that it still functions as a diagonal matrix despite 267 | the Kronecker, but we can provide some intutition for this result 268 | as well. For vectors $v$ and $u$, 269 | $\mathrm{diag}(v) u = \mathrm{diag}(u) v$, with the main goal being to 270 | create a weighted vector. Thus, we can write $\Gamma'U'(\bm{y} 271 | - \mu)$ as $\mathrm{diag}(\bm{y} - \mu)(\utilde{\gamma}' \times \utilde{\mu})$, 272 | $\utilde{\gamma}\times\utilde{\mu}'$ being a vector of the 273 | element-wise product of first derivatives. 274 | 275 | The derivative of this with respect to $\mu$ will turn $\utilde{\gamma}'\times\utilde{\mu}$ into an $N\times N$ matrix with 276 | elements only on the diagonal, such that we have 277 | $\mathrm{diag}(\bm{y} - 278 | \mu)\times\mathrm{diag}(\utilde{\gamma}''\times\utilde{\mu}'^2 + 279 | \utilde{\gamma}'\times\utilde{\mu}')$. Interchanging 280 | the order of the product of diagonal matrices, we chose to denote this 281 | as: $\bm{R}(U'\Gamma''U' + \Gamma'U'')$, $\bm{R}$ standing 282 | for the matrix with residuals along the diagonal. Summing up: 283 | 284 | \begin{equation*} 285 | \mathrm{D}\left[ B^\top \Gamma'U'(\bm{Y} - \mu) \right] = 286 | B^\top\left[\bm{R}(U'\Gamma''U' +\Gamma'U'') - U'\Gamma'U'\right] B. 287 | \end{equation*} 288 | 289 | Consequently, 290 | 291 | \begin{equation*} 292 | \nabla^2 l(\beta, \theta) = 293 | \begin{bmatrix} \bm{Z}^\top \\ \bm{X}^\top \end{bmatrix} 294 | \left[\bm{R}\left(\frac{\partial\mu}{\partial\eta} 295 | \frac{\partial^2\gamma}{\partial\mu^2} 296 | \frac{\partial\mu}{\partial\eta} + 297 | \frac{\partial\gamma}{\partial\mu} 298 | \frac{\partial^2\mu}{\partial\eta^2} \right) - 299 | \frac{\partial\mu}{\partial\eta} 300 | \frac{\partial\gamma}{\partial\mu} 301 | \frac{\partial\mu}{\partial\eta}\right] 302 | \begin{bmatrix} \bm{Z} & \bm{X} \end{bmatrix} - 303 | \begin{bmatrix} \Sigma^{-1} & \bm{0}_{Q\times P} \\ 304 | \bm{0}_{P\times Q} & \bm{0}_{P\times P} 305 | \end{bmatrix}. 306 | \end{equation*} 307 | 308 | We may also consider replacing this quantity by its expectation under 309 | \(\bm{Y} \mid \bm{X}, \bm{Z}\), in which case $\bm{R}$ vanishes. This prouduces: 310 | 311 | \begin{align*} 312 | I(\beta, \theta) & = 313 | \begin{bmatrix} \bm{Z}^\top \\ \bm{X}^\top \end{bmatrix} 314 | \frac{\partial\mu}{\partial\eta} 315 | \frac{\partial\gamma}{\partial\mu} 316 | \frac{\partial\mu}{\partial\eta} 317 | \begin{bmatrix} \bm{Z} & \bm{X} \end{bmatrix} + 318 | \begin{bmatrix} \Sigma^{-1} & \bm{0}_{Q\times P} \\ 319 | \bm{0}_{P\times Q} & \bm{0}_{P\times P} 320 | \end{bmatrix}, \\ 321 | & = 322 | \begin{bmatrix} \bm{Z}^\top \\ \bm{X}^\top \end{bmatrix} 323 | \frac{\mathrm{d}g^{-1}}{\mathrm{d}x} 324 | \frac{c(\tau)}{\VAR[\bm{y}]} 325 | \frac{\mathrm{d}g^{-1}}{\mathrm{d}x} 326 | \begin{bmatrix} \bm{Z} & \bm{X} \end{bmatrix} + 327 | \begin{bmatrix} \Sigma^{-1} & \bm{0}_{Q\times P} \\ 328 | \bm{0}_{P\times Q} & \bm{0}_{P\times P} 329 | \end{bmatrix}. 330 | \end{align*} 331 | 332 | We can turn this into a penalized, weighted least squares problem by 333 | using a weight matrix that is the inverse of the variance and rolling 334 | $\mathrm{d}g^{-1}/\mathrm{d}x$ into the data. For $\theta$ alone, as is done in the 335 | optimization, let $\bm{A} = \frac{\partial\mu}{\partial\eta}\bm{Z}$, $\bm{W} = 336 | \frac{\partial\gamma}{\partial\mu}$. The the updates in a 337 | Newton-Raphson optimization with Fisher scoring are: 338 | 339 | \begin{equation*} 340 | \left[\bm{A}^\top \bm{W} \bm{A} + \Sigma^{-1}\right]\delta_\theta = \bm{A}^\top \bm{W}(\bm{y} - 341 | \mu) - \Sigma^{-1}\theta. 342 | \end{equation*} 343 | 344 | Changing gears slightly, if we use a ``canonical'' link function, then 345 | $\gamma(\mu(\eta)) = g(\mu(\eta)) = \eta$, so that 346 | $\frac{\partial\gamma}{\partial\mu} \frac{\partial\mu}{\partial\eta} = 347 | 1$. This produces: 348 | 349 | \begin{align*} 350 | \nabla l(\beta, \theta) & = 351 | \begin{bmatrix} 352 | \bm{Z}^\top \\ \bm{X}^\top 353 | \end{bmatrix} 354 | (\bm{y} - \mu) - 355 | \begin{bmatrix} 356 | \Sigma^{-1}\theta \\ \utilde{0}_P 357 | \end{bmatrix}, \\ 358 | I(\beta, \theta) & = 359 | \begin{bmatrix} 360 | \bm{Z}^\top \\ \bm{X}^\top 361 | \end{bmatrix} 362 | \frac{\partial\mu}{\partial\eta} 363 | \begin{bmatrix} 364 | \bm{Z} & \bm{X} 365 | \end{bmatrix} + 366 | \begin{bmatrix} \Sigma^{-1} & \bm{0}_{Q\times P} \\ 367 | \bm{0}_{P\times Q} & \bm{0}_{P\times P} 368 | \end{bmatrix}. 369 | \end{align*} 370 | 371 | 372 | 373 | \begin{comment} 374 | From this, we find \(\tilde{\theta}\) and \(\tilde{\beta}\), the modes 375 | of the integrand. Returning to our integral, we change scales 376 | slightly and let 377 | \begin{align*} 378 | f(\beta, \theta) & = -\frac{1}{2}d(\beta, \theta), \\ 379 | & = \bm{Y}^\top\gamma(\eta) - \utilde{1}^\top_N b(\eta) - 380 | \theta^\top\Sigma^{-1}\theta 381 | \end{align*} 382 | be the part in the exponent under the integral, up to a few constants 383 | and \(c(\tau)\). We approximate \(f(\beta, \theta)\) around its 384 | maximum: 385 | \begin{align*} 386 | f(\beta, \theta) & = f\left(\tilde\beta, \tilde\theta\right) + 387 | \dfrac{1}{2}\begin{bmatrix} \theta - \tilde\theta \\ \beta - 388 | \tilde\beta \end{bmatrix}^\top 389 | \nabla ^2 f\left(\tilde\beta, \tilde\theta\right) 390 | \begin{bmatrix} \theta - \tilde\theta \\ \beta - 391 | \tilde\beta \end{bmatrix} + 392 | O\left( \begin{Vmatrix} \theta - \tilde\theta \\ \beta - 393 | \tilde\beta \end{Vmatrix}^3 \right)o_p\left(n^3\right). 394 | \end{align*} 395 | The \(o_p\left(n^3\right)\) comes from the fact that \(f\) behaves like 396 | an estimating equation. 397 | \begin{align*} 398 | \int \exp\left\{\frac{1}{c(\tau)}f(\beta,\theta)\right\} \, 399 | \mathrm{d}\theta & = \int 400 | \exp\left\{\frac{1}{c(\tau)}\left[ 401 | f\left(\tilde\beta, \tilde\theta\right) + 402 | \dfrac{1}{2}\begin{bmatrix} \theta - \tilde\theta \\ \beta - 403 | \tilde\beta \end{bmatrix}^\top 404 | \nabla ^2 f\left(\tilde\beta, \tilde\theta\right) 405 | \begin{bmatrix} \theta - \tilde\theta \\ \beta - 406 | \tilde\beta \end{bmatrix} + 407 | o_p\left(n^3\right)\right]\right\} \, \mathrm{d}\theta, \\ 408 | & \approx \exp\left\{\frac{1}{c(\tau)} f(\tilde\beta,\tilde\theta) 409 | \right\} 410 | \int \exp \left\{-\dfrac{1}{2c(\tau)}\begin{bmatrix} \theta - \tilde\theta \\ \beta - 411 | \tilde\beta \end{bmatrix}^\top 412 | I\left(\tilde\beta, \tilde\theta\right) 413 | \begin{bmatrix} \theta - \tilde\theta \\ \beta - 414 | \tilde\beta \end{bmatrix} \right\} \, \mathrm{d}\theta. 415 | \end{align*} 416 | We now relabel the elements of the covariance matrix 417 | \begin{equation*} 418 | I(\beta,\theta) = \begin{bmatrix} I_{\theta\theta} & I_{\theta\beta} \\ 419 | I_{\beta\theta} & I_{\beta\beta} \end{bmatrix}. 420 | \end{equation*} 421 | \begin{align*} 422 | \begin{bmatrix} \theta - \tilde\theta \\ \beta - 423 | \tilde\beta \end{bmatrix}^\top 424 | I\left(\tilde\beta, \tilde\theta\right) 425 | \begin{bmatrix} \theta - \tilde\theta \\ \beta - 426 | \tilde\beta \end{bmatrix} & = 427 | (\theta - \tilde\theta)^\top I_{\tilde\theta\tilde\theta} (\theta - 428 | \tilde\theta) 429 | + 2\theta^\top I_{\tilde\theta\tilde\beta}(\beta - \tilde\beta) 430 | - 2\tilde\theta^\top I_{\tilde\theta\tilde\beta}(\beta - \tilde\beta) 431 | + (\beta - \tilde\beta)^\top I_{\tilde\beta\tilde\beta}(\beta - \tilde\beta), \\ 432 | & = 433 | \left(\theta - I_{\tilde\theta\tilde\theta}^{-1}\left( 434 | I_{\tilde\theta\tilde\theta}\tilde\theta + I_{\tilde\theta\tilde\beta}(\tilde\beta 435 | - \beta)\right)\right)^\top 436 | I_{\tilde\theta\tilde\theta}\left(\theta - I_{\tilde\theta\tilde\theta}^{-1}\left( 437 | I_{\tilde\theta\tilde\theta}\tilde\theta + I_{\tilde\theta\tilde\beta}(\tilde\beta 438 | - \beta)\right)\right) +\tilde\theta^\top I_{\tilde\theta\tilde\theta}\tilde\theta\\ 439 | & + (\beta - \tilde\beta)^\top I_{\tilde\beta\tilde\beta}(\beta - \tilde\beta) 440 | - \left(I_{\tilde\theta\tilde\theta}\tilde\theta + 441 | I_{\tilde\theta\tilde\beta}(\tilde\beta - \beta)\right)^\top 442 | I_{\tilde\theta\tilde\theta}^{-1}\left(I_{\tilde\theta\tilde\theta}\tilde\theta + 443 | I_{\tilde\theta\tilde\beta}(\tilde\beta - \beta)\right) 444 | -2\tilde\theta^\top I_{\tilde\theta\tilde\beta}(\beta - \tilde\beta), \\ 445 | & = \left\|I_{\tilde\theta\tilde\theta}^{1/2}\left(\theta - I_{\tilde\theta\tilde\theta}^{-1}\left( 446 | I_{\tilde\theta\tilde\theta}\tilde\theta + I_{\tilde\theta\tilde\beta}(\tilde\beta 447 | - \beta)\right)\right)\right\|^2 + (\beta - 448 | \tilde\beta)^\top (I_{\tilde\beta\tilde\beta} - 449 | I_{\tilde\beta\tilde\theta}I_{\tilde\theta\tilde\theta}^{-1}I_{\tilde\theta\tilde\beta}) 450 | (\beta - \tilde\beta), \\ 451 | & = \left\|I_{\tilde\theta\tilde\theta}^{1/2}\left(\theta - I_{\tilde\theta\tilde\theta}^{-1}\left( 452 | I_{\tilde\theta\tilde\theta}\tilde\theta + I_{\tilde\theta\tilde\beta}(\tilde\beta 453 | - \beta)\right)\right)\right\|^2 + (\beta - 454 | \tilde\beta)^\top {I^{\tilde\beta\tilde\beta}}^{-1} 455 | (\beta - \tilde\beta). 456 | \end{align*} 457 | Here we use the common notation \(I^{\beta\beta} = 458 | \left(I_{\beta\beta} - 459 | I_{\beta\theta}I_{\theta\theta}^{-1}I_{\theta\beta}\right)^{-1}\), 460 | as this is the submatrix corresponding to \(\beta\) in the inverse of 461 | the information matrix. 462 | \begin{align*} 463 | \int \exp\left\{\frac{1}{c(\tau)}f(\beta,\theta)\right\} \, 464 | \mathrm{d}\theta & \approx 465 | \left(2\pi c(\tau)\right)^{M/2} 466 | \left|I_{\tilde\theta\tilde\theta}\right|^{-1/2} 467 | \exp\left\{\dfrac{1}{c(\tau)}\left[f\left(\tilde\beta,\tilde\theta\right) - 468 | \dfrac{1}{2} \left\|{I^{\tilde\beta\tilde\beta}}^{-1/2}(\beta - \tilde\beta)\right\|^2\right]\right\} 469 | \end{align*} 470 | Utilizing the above result we can approximate the likelihood. 471 | \begin{align*} 472 | p(\bm{Y} \mid \beta, \Sigma, \tau) & \approx \left|\Sigma\right|^{-1/2} 473 | \left|I_{\tilde\theta\tilde\theta}\right|^{-1/2} 474 | \exp\left\{\dfrac{1}{c(\tau)}\left[f\left(\tilde\beta, 475 | \tilde\theta\right) - \dfrac{1}{2} 476 | \left\|{I^{\tilde\beta\tilde\beta}}^{-1/2}(\beta - 477 | \tilde\beta)\right\|^2\right] - 478 | \sum_{i=1}^Nh(\tau, y_i)\right\} \\ 479 | & = \left|\Sigma\right|^{-1/2} 480 | \left|I_{\tilde\theta\tilde\theta}\right|^{-1/2} 481 | p(\bm{Y} \mid \tilde\theta, \tilde\beta, \tau) \exp\left\{ 482 | -\dfrac{1}{2c(\tau)} \left[ \left\|{I^{\tilde\beta\tilde\beta}}^{-1/2}(\beta - 483 | \tilde\beta)\right\|^2 + 484 | \tilde\theta^\top\Sigma^{-1}\tilde\theta\right] 485 | \right\}. 486 | \end{align*} 487 | At this point, it is worth observing that \(I_{\theta\theta}\) and \(I^{\beta\beta}\) are 488 | non-trivial functions of \(\Sigma\). 489 | 490 | To optimize, the approximate maximum likelihood estimate of \(\beta\) 491 | is given by \(\tilde\beta\). The maximum in \(\tau\) will depend on 492 | \(c\) and \(h\), although for many models there is no dispersion 493 | parameter. Finally, for \(\Sigma\), the approximate likelihood is maximized 494 | by any brute force technique. 495 | 496 | \end{comment} 497 | 498 | \end{document} --------------------------------------------------------------------------------