blme/0000755000176200001440000000000012537135352011177 5ustar liggesusersblme/inst/0000755000176200001440000000000012537063347012160 5ustar liggesusersblme/inst/CITATION0000644000176200001440000000105712357275573013326 0ustar liggesusersbibentry(bibtype = "article", title = "A nondegenerate penalized likelihood estimator for variance parameters in multilevel models", author = c(person("Yeojin", "Chung"), person("Sophia", "Rabe-Hesketh"), person("Vincent", "Dorie"), person("Andrew", "Gelman"), person("Jingchen", "Liu")), year = 2013, journal = "Psychometrika", volume = 78, number = 4, pages = "685--709", publisher = "Springer", url = "http://gllamm.org/") blme/inst/common/0000755000176200001440000000000012531656100013435 5ustar liggesusersblme/inst/common/lmmData.R0000644000176200001440000000151612214662126015145 0ustar liggesusersgetLMMData <- function() { set.seed(0, "Mersenne-Twister", "Inversion"); N <- 100; J.1 <- 5; J.2 <- 5; beta <- c(5, 2, 4); theta.1 <- matrix(rnorm(J.1 * 2), J.1, 2); theta.2 <- matrix(rnorm(J.2 * 3), J.2, 3); x.1 <- rnorm(N); x.2 <- rnorm(N); g.1 <- rmultinom(N, 1, runif(J.1)); g.2 <- rmultinom(N, 1, runif(J.2)); g.1 <- sapply(1:N, function(i) which(g.1[,i] == 1)); g.2 <- sapply(1:N, function(i) which(g.2[,i] == 1)); y <- 1 * (beta[1] + theta.1[g.1,1] + theta.2[g.2,1]) + x.1 * (beta[2] + theta.1[g.1,2] + theta.2[g.2,2]) + x.2 * (beta[3] + theta.2[g.2,3]) + rnorm(N); weights <- runif(N); weights <- weights / sum(weights); return(data.frame(y = y, x.1 = x.1, x.2 = x.2, g.1 = g.1, g.2 = g.2, w = weights)); } testData <- getLMMData(); rm(getLMMData); blme/inst/common/glmmData.R0000644000176200001440000000066012214662073015314 0ustar liggesusersgetGLMMData <- function() { set.seed(3, "Mersenne-Twister", "Inversion"); J <- 4; n <- 8; N <- J * n; x.1 <- rnorm(N); x.2 <- rnorm(N); theta <- rnorm(J, 0, 2); theta.g <- rep(theta, rep(n, J)); eta <- 3 * x.1 + 2 * x.2 + theta.g; mu <- exp(eta) / (1 + exp(eta)); y <- rbinom(N, 1, mu); g <- gl(J, n); return(data.frame(y = y, x.1 = x.1, x.2 = x.2, g = g)); } testData <- getGLMMData(); rm(getGLMMData); blme/inst/common/checkWarning.R0000644000176200001440000000341212203471225016162 0ustar liggesuserscheckWarning <- function (expr, msg = "", silent = getOption("RUnit")$silent) { tryWarn <- function (expr, silent = FALSE) { tryCatch(expr, warning = function(e) { call <- conditionCall(e) if (!is.null(call)) { if (identical(call[[1L]], quote(doTryCatch))) call <- sys.call(-4L) dcall <- deparse(call)[1L] prefix <- paste("Warning in", dcall, ": ") LONG <- 75L msg <- conditionMessage(e) sm <- strsplit(msg, "\n")[[1L]] w <- 14L + nchar(dcall, type = "w") + nchar(sm[1L], type = "w") if (is.na(w)) w <- 14L + nchar(dcall, type = "b") + nchar(sm[1L], type = "b") if (w > LONG) prefix <- paste(prefix, "\n ", sep = "") } else prefix <- "Warning : " msg <- paste(prefix, conditionMessage(e), "\n", sep = "") .Internal(seterrmessage(msg[1L])) if (!silent && identical(getOption("show.error.messages"), TRUE)) { cat(msg, file = stderr()) .Internal(printDeferredWarnings()) } invisible(structure(msg, class = "try-error")) }) } if (missing(expr)) { stop("'expr' is missing") } if (is.null(silent)) { silent <- FALSE warning("'silent' has to be of type 'logical'. Was NULL. Set to FALSE.") } if (RUnit:::.existsTestLogger()) { .testLogger$incrementCheckNum() } if (!inherits(tryWarn(eval(expr, envir = parent.frame()), silent = silent), "try-error")) { if (RUnit:::.existsTestLogger()) { .testLogger$setFailure() } stop("Warning not generated as expected\n", msg) } else { return(TRUE) } } blme/ToDo0000644000176200001440000000024612303474561011770 0ustar liggesusersHigh Priority: sim for ranef covariance Medium Priority: investigate overdispersed models Low Priority: Consider optimal scaling for random effect covariancesblme/tests/0000755000176200001440000000000012537063347012345 5ustar liggesusersblme/tests/testthat/0000755000176200001440000000000012537063347014205 5ustar liggesusersblme/tests/testthat/test-04-fixef_errors.R0000644000176200001440000000301212531657227020217 0ustar liggesuserscontext("b(g)lmer, fixef.prior argument") test_that("fixef.prior argument raises appropriate errors for blmer fits", { source(system.file("common", "lmmData.R", package = "blme")) fit <- blmer(y ~ x.1 + (1 | g.1), testData, cov.prior = NULL, fixef.prior = NULL, resid.prior = NULL) parsePrior <- blme:::parsePrior expect_error(parsePrior(fit, fixef.prior = "normal(common.scale = 'crazy')")) expect_error(parsePrior(fit, fixef.prior = "normal(cov = diag(3))")) negDefiniteMatrix <- matrix(c(1, 0, 0, -0.1), 2, 2) expect_error(parsePrior(fit, fixef.prior = "normal(cov = negDefiniteMatrix)")) asymmetricMatrix <- matrix(c(1, 0.5, 0.3, 0.7), 2, 2) expect_error(parsePrior(fit, fixef.prior = "normal(cov = asymmetricMatrix)")) expect_error(parsePrior(fit, fixef.prior = "t")) fit <- blmer(y ~ x.1 + (1 | g.1), testData, REML = FALSE, cov.prior = NULL, fixef.prior = NULL, resid.prior = NULL) expect_error(parsePrior(fit, fixef.prior = "t(df = 0)")) expect_error(parsePrior(fit, fixef.prior = "t(scale = c(-1, 2))")) }) test_that("fixef.prior argument raises appropriate errors for bglmer fits", { source(system.file("common", "glmmData.R", package = "blme")) parsePrior <- blme:::parsePrior bglmerFit <- bglmer(y ~ x.1 + x.2 + (1 | g), testData, family = binomial(), cov.prior = NULL) expect_error(parsePrior(bglmerFit, fixef.prior = normal(common.scale = TRUE))) expect_error(parsePrior(bglmerFit, fixef.prior = t(common.scale = TRUE))) }) blme/tests/testthat/test-10-refit.R0000644000176200001440000000340512536023760016630 0ustar liggesusers## for old versions of lme4, the refit for g/lmer doesn't move very ## far from the fit so we just suppress the test lme4Version <- packageVersion("lme4") if (lme4Version >= "1.1-6") { context("refit generic for blmerMod and bglmerMod classes") test_that("refit for blmer matches original, not lmer", { source(system.file("common", "lmmData.R", package = "blme")) control <- lmerControl(optimizer = "Nelder_Mead") cov.prior <- "g.1 ~ wishart(scale = 2)" fit <- blmer(y ~ x.1 + x.2 + (1 + x.1 | g.1), testData, cov.prior = cov.prior, control = control) blmerRefit <- refit(fit) lmerRefit <- getS3method("refit", "merMod")(fit) expect_equal(fit@theta, blmerRefit@theta, tolerance = 1.0e-02) expect_equal(fit@beta, blmerRefit@beta, tolerance = 1.0e-03) expect_false(all(abs(fit@theta - lmerRefit@theta) <= 1.0e-02)) expect_false(all(abs(fit@beta - lmerRefit@beta) <= 1.0e-03)) }) test_that("refit for bglmer matches original, not glmer", { source(system.file("common", "glmmData.R", package = "blme")) control <- if (lme4Version >= "1.1-8") glmerControl(optimizer = "Nelder_Mead", nAGQ0initStep = FALSE) else glmerControl(optimizer = "Nelder_Mead") fit <- bglmer(y ~ x.1 + x.2 + (1 | g), testData, family = binomial(), control = control, cov.prior = wishart) bglmerRefit <- refit(fit) glmerRefit <- getS3method("refit", "merMod")(fit) expect_equal(fit@theta, bglmerRefit@theta, tolerance = 1.0e-3) expect_equal(fit@beta, bglmerRefit@beta, tolerance = 1.0e-3) expect_false(all(abs(fit@theta - glmerRefit@theta) <= 1.0e-3)) expect_false(all(abs(fit@beta - glmerRefit@beta) <= 1.0e-3)) }) } blme/tests/testthat/test-05-covariance_errors.R0000644000176200001440000000371112531654024021227 0ustar liggesuserscontext("blmer, cov.prior argument") test_that("cov.prior argument raises appropriate errors", { source(system.file("common", "lmmData.R", package = "blme")) lmerFit <- lmer(y ~ x.1 + (1 | g.1), testData) blmerFit <- blmer(y ~ x.1 + (1 | g.1), testData, cov.prior = NULL, fixef.prior = NULL, resid.prior = NULL) parsePrior <- blme:::parsePrior # Morally speaking, parsePrior isn't exposed to the user # so perhaps this first set of tests is excessive. expect_error(parsePrior()) expect_error(parsePrior(NULL)) expect_error(parsePrior(notAValidObject)) expect_error(parsePrior(lmerFit)) expect_error(parsePrior(blmerFit, numeric(0))) expect_error(parsePrior(blmerFit, list(numeric(0)))) expect_error(parsePrior(blmerFit, "not a prior")) expect_error(parsePrior(blmerFit, list("not a", "prior"))) expect_error(parsePrior(blmerFit, "notAGroup ~ gamma")) expect_error(parsePrior(blmerFit, "invgamma(shape = 'not a number')")) expect_error(parsePrior(blmerFit, "invgamma(shape = -1)")) expect_error(parsePrior(blmerFit, "invgamma(scale = -1)")) expect_error(parsePrior(blmerFit, "wishart(df = 'not a number')")) expect_error(parsePrior(blmerFit, "wishart(df = 0)")) expect_error(parsePrior(blmerFit, "wishart(scale = 'not a number')")) expect_error(parsePrior(blmerFit, "wishart(scale = -0.01)")) expect_error(parsePrior(blmerFit, "invwishart(df = 'not a number')")) expect_error(parsePrior(blmerFit, "invwishart(df = 0)")) expect_error(parsePrior(blmerFit, "invwishart(scale = 'not a number')")) expect_error(parsePrior(blmerFit, "invwishart(scale = -0.01)")) expect_error(parsePrior(blmerFit, "gamma(posterior.scale = 'not a scale')")) expect_error(parsePrior(blmerFit, "gamma(common.scale = 'not a boolean')")) blmerFit <- blmer(y ~ x.1 + (1 + x.1 | g.1), testData, cov.prior = NULL, fixef.prior = NULL, resid.prior = NULL) expect_warning(parsePrior(blmerFit, "gamma")) }) blme/tests/testthat/test-08-lmm_covariance.R0000644000176200001440000001264112531661257020513 0ustar liggesuserscontext("blmer numerical results with cov prior") source(system.file("common", "lmmData.R", package = "blme")) lme4Version <- packageVersion("lme4") control <- lmerControl(optimizer = "Nelder_Mead") test_that("blmer fits test data with gamma prior(TRUE), matching previous version", { cov.prior <- "g.1 ~ gamma(rate = 0.5)" fit <- blmer(y ~ x.1 + x.2 + (1 | g.1), testData, cov.prior = cov.prior, control = control) if (lme4Version < "1.1-8") { expect_equal(fit@theta, 0.626025390625) } else { expect_equal(fit@theta, 0.626021723159) } }) test_that("blmer fits test data with invgamma prior(TRUE), matching previous version", { cov.prior <- "g.1 ~ invgamma(scale = 2.0)" fit <- blmer(y ~ x.1 + x.2 + (1 | g.1), testData, cov.prior = cov.prior, control = control) if (lme4Version < "1.1-4") { expect_equal(fit@theta, 0.93956054688) } else if (lme4Version < "1.1-8") { expect_equal(fit@theta, 0.93955078125) } else { expect_equal(fit@theta, 0.93955687941) } }) test_that("blmer fits test data with wishart prior(TRUE), matching previous version", { cov.prior <- "g.1 ~ wishart(scale = 2)" fit <- blmer(y ~ x.1 + x.2 + (1 + x.1 | g.1), testData, cov.prior = cov.prior, control = control) expect_equal(fit@theta, c(0.677745102365688, -0.439777135132983, 1.48026251108622)) }) test_that("blmer fits test data with invwishart prior(TRUE), matching previous version", { cov.prior <- "g.1 ~ invwishart(scale = 2)" fit <- blmer(y ~ x.1 + x.2 + (1 + x.1 | g.1), testData, cov.prior = cov.prior, control = control) expect_equal(fit@theta, c(0.627739008945695, -0.137563742254117, 1.05679359569432)) }) test_that("blmer fits test data with gamma prior('var', FALSE), matching previous version", { cov.prior <- "g.1 ~ gamma(shape = 1.75, rate = 2, posterior.scale = 'var', common.scale = FALSE)" fit <- blmer(y ~ x.1 + x.2 + (1 | g.1), testData, cov.prior = cov.prior, control = control) if (lme4Version < "1.1-8") { expect_equal(fit@theta, 0.435458984375) } else { expect_equal(fit@theta, 0.435465082534) } }) test_that("blmer fits test data with invgamma prior('var', FALSE), matching previous version", { cov.prior <- "g.1 ~ invgamma(scale = 0.5, posterior.scale = 'var', common.scale = FALSE)" fit <- blmer(y ~ x.1 + x.2 + (1 | g.1), testData, cov.prior = cov.prior, control = control) if (lme4Version < "1.1-4") { expect_equal(fit@theta, 0.460400390625) } else if (lme4Version < "1.1-8") { expect_equal(fit@theta, 0.460410156250) } else { expect_equal(fit@theta, 0.460406488784) } }) test_that("blmer fits test data with gamma prior('sd', FALSE), matching previous version", { cov.prior <- "g.1 ~ gamma(rate = 2, posterior.scale = 'sd', common.scale = FALSE)" fit <- blmer(y ~ x.1 + x.2 + (1 | g.1), testData, cov.prior = cov.prior, control = control) if (lme4Version < "1.1-8") { expect_equal(fit@theta, 0.476779702210) } else { expect_equal(fit@theta, 0.476774614593) } }) test_that("blmer fits test data with invgamma prior('sd', FALSE), matching previous version", { cov.prior <- "g.1 ~ invgamma(scale = 0.5, posterior.scale = 'sd', common.scale = FALSE)" fit <- blmer(y ~ x.1 + x.2 + (1 | g.1), testData, cov.prior = cov.prior, control = control) if (lme4Version < "1.1-4") { expect_equal(fit@theta, 0.452841796875) } else if (lme4Version < "1.1-8") { expect_equal(fit@theta, 0.452832031250) } else { expect_equal(fit@theta, 0.452838129409) } }) test_that("blmer fits test data with wishart prior(FALSE), matching previous version", { cov.prior <- "g.1 ~ wishart(scale = 2, common.scale = FALSE)" fit <- blmer(y ~ x.1 + x.2 + (1 + x.1 | g.1), testData, cov.prior = cov.prior, control = control) expect_equal(fit@pp$theta, c(0.63996739265564, -0.340538787006457, 1.34228986794088)) }) test_that("blmer fits test data with invwishart prior(FALSE), matching previous version", { cov.prior <- "g.1 ~ invwishart(scale = 2, common.scale = FALSE)" fit <- blmer(y ~ x.1 + x.2 + (1 + x.1 | g.1), testData, cov.prior = cov.prior, control = control) expect_equal(fit@pp$theta, c(0.505864621989816, -0.137623340382083, 0.979903012179649)) }) test_that("blmer fits test data with custom prior, matching builtin wishart", { dwish <- function(R) { d <- nrow(R) nu <- d + 1 + 1.5 R.scale.inv <- diag(1e-2, d) const <- nu * (d * log(2) - 2 * sum(log(diag(R.scale.inv)))) + 0.5 * d * (d - 1) * log(pi) for (i in 1:d) const <- const + 2 * lgamma(0.5 * (nu + 1.0 - i)) det <- 2 * sum(log(diag(R))) const - (nu - d - 1) * det + sum((R %*% R.scale.inv)^2) } fit.prof <- blmer(y ~ x.1 + x.2 + (1 + x.1 | g.1), testData, control = control, cov.prior = wishart(scale = diag(1e4, q.k))) fit.cust <- blmer(y ~ x.1 + x.2 + (1 + x.1 | g.1), testData, control = control, cov.prior = custom(dwish, chol = TRUE, scale = "dev")) expect_equal(fit.prof@theta, fit.cust@theta, tolerance = 1e-6) fit.prof <- blmer(y ~ x.1 + x.2 + (1 + x.1 | g.1), testData, control = control, cov.prior = wishart(scale = diag(1e4, q.k), common.scale = FALSE)) fit.cust <- blmer(y ~ x.1 + x.2 + (1 + x.1 | g.1), testData, control = control, cov.prior = custom(dwish, chol = TRUE, scale = "dev", common.scale = FALSE)) expect_equal(c(fit.prof@pp$theta, fit.prof@devcomp$cmp[["sigmaREML"]]), c(fit.cust@pp$theta, fit.cust@devcomp$cmp[["sigmaREML"]]), tolerance = 5e-5) }) blme/tests/testthat/test-07-lmm_fixef.R0000644000176200001440000001022512532116340017462 0ustar liggesuserscontext("blmer numerical results with fixef prior") source(system.file("common", "lmmData.R", package = "blme")) lme4Version <- packageVersion("lme4") control <- lmerControl(optimizer = "bobyqa") test_that("blmer fits test data with normal(7, TRUE) prior, matching previous version", { fixef.prior <- "normal(sd = 7, common.scale = TRUE)" startingValues <- c(0.714336877636958, -0.242234853872256, 1.56142829865131, 0.931702840718855, 0.456177995916484, -0.174861679569041, 1.0585277913399, 0.121071648252222, 0.215801873693294) 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) fit <- blmer(y ~ x.1 + x.2 + (1 + x.1 | g.1) + (1 + x.1 + x.2 | g.2), testData, control = control, cov.prior = NULL, fixef.prior = fixef.prior, start = startingValues) expect_equal(fit@theta, result, tolerance = 5.0e-5) }) test_that("blmer fits test data with normal(10, FALSE) prior, matching previous version", { fixef.prior <- "normal(sd = 10, common.scale = FALSE)" startingValues <- list(theta = c(0.705301445472825, -0.236130064856711, 1.54070576284237, 0.919298480793096, 0.444958591085821, -0.162201425613492, 1.04498858978601, 0.121905334663798, 0.204897688209115), sigma = 0.969103097682058) 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) fit <- blmer(y ~ x.1 + x.2 + (1 + x.1 | g.1) + (1 + x.1 + x.2 | g.2), testData, control = control, cov.prior = NULL, fixef.prior = fixef.prior, start = startingValues) expect_equal(fit@theta, result, tolerance = 5.0e-5) expect_equal(fit@devcomp$cmp[["sigmaREML"]], if (lme4Version < "1.1-4") 0.969074276597577 else 0.969074276597577, tolerance = 1.0e-6) }) test_that("blmer fits test data with t prior, matching previous version", { fixef.prior <- "t(3, c(10^2, 2.5^2), common.scale = FALSE)" startingValues <- list(theta = c(0.645289664330177, -0.151604332140352, 1.39404761930357, 0.788435718441722, 0.312013729923666, -0.0155461916762167, 0.949082870229164, 0.117100582888698, 0), beta = c(5.32508665168687, 1.16859904165051, 4.0443701271478)) 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) fixefResult <- if (lme4Version < "1.1-4") c(5.32507818836626, 1.16860398465568, 4.04437041491386) else c(5.32507818836626, 1.16860398465568, 4.04437041491386) fit <- blmer(y ~ x.1 + x.2 + (1 + x.1 | g.1) + (1 + x.1 + x.2 | g.2), testData, REML = FALSE, control = control, cov.prior = NULL, fixef.prior = fixef.prior, start = startingValues) expect_equal(fit@theta, result, tolerance = 5.0e-5) expect_equal(fit@beta, fixefResult, tolerance = 5.0e-5) }) test_that("blmer fits sleep study example in documentation", { oldWarnings <- options()$warn options(warn = 2) data("sleepstudy", package = "lme4") fit <- blmer(Reaction ~ Days + (1 + Days|Subject), sleepstudy, cov.prior = NULL, resid.prior = NULL, fixef.prior = "normal") expect_is(fit, "blmerMod") fit <- blmer(Reaction ~ Days + (1 + Days|Subject), sleepstudy, cov.prior = NULL, resid.prior = NULL, fixef.prior = "normal(cov = diag(0.5, 2))") expect_is(fit, "blmerMod") options(warn = oldWarnings) }) blme/tests/testthat/test-01-lmm.R0000644000176200001440000000120512531657135016304 0ustar liggesuserscontext("lmer and blmer") test_that("blmer matches lmer exactly", { source(system.file("common", "lmmData.R", package = "blme")) control <- lmerControl(optimizer = "bobyqa") lmerFit <- lmer(y ~ x.1 + x.2 + (1 + x.1 | g.1) + (1 + x.1 + x.2 | g.2), testData, control = control) blmerFit <- blmer(y ~ x.1 + x.2 + (1 + x.1 | g.1) + (1 + x.1 + x.2 | g.2), testData, control = control, cov.prior = NULL, fixef.prior = NULL, resid.prior = NULL) expect_equal(lmerFit@pp$theta, blmerFit@pp$theta) expect_equal(lmerFit@pp$u(1.0), blmerFit@pp$u(1.0)) expect_equal(lmerFit@pp$beta(1.0), blmerFit@pp$beta(1.0)) }) blme/tests/testthat/test-09-glmm_priors.R0000644000176200001440000000236512531670652020070 0ustar liggesuserscontext("bglmer numerical results with fixef and cov priors") source(system.file("common", "glmmData.R", package = "blme")) control <- glmerControl(optimizer = "Nelder_Mead") lme4Version <- packageVersion("lme4") test_that("bglmer fits test data with fixef prior, matching previous version", { fit <- bglmer(y ~ x.1 + x.2 + (1 | g), testData, family = binomial(), control = control, cov.prior = NULL, fixef.prior = normal) if (lme4Version < "1.1-4") { expect_equal(fit@theta, 1.26501253837861) expect_equal(fit@beta, c(0.873121247636467, 2.46647249930796, 1.32070156863358)) } else { expect_equal(fit@theta, 1.26501385482573) expect_equal(fit@beta, c(0.873131216784199, 2.46647899095567, 1.32070496549675)) } }) test_that("bglmer fits test data with cov prior, matching previous version", { fit <- bglmer(y ~ x.1 + x.2 + (1 | g), testData, family = binomial(), control = control, cov.prior = wishart) if (lme4Version < "1.1-4") { expect_equal(fit@theta, 2.96766525351892) expect_equal(fit@beta, c(1.0963789854971, 3.67790570859986, 1.75655010020603)) } else { expect_equal(fit@theta, 2.96767284827046) expect_equal(fit@beta, c(1.0963789854971, 3.67790570859986, 1.75655010020603)) } }) blme/tests/testthat/test-03-resid_errors.R0000644000176200001440000000317512531654041020224 0ustar liggesuserscontext("blmer, resid.prior argument") test_that("resid.prior argument raises apprprioate errors", { source(system.file("common", "lmmData.R", package = "blme")) blmerFit <- blmer(y ~ x.1 + (1 | g.1), testData, cov.prior = NULL, fixef.prior = NULL, resid.prior = NULL) parsePrior <- blme:::parsePrior expect_error(parsePrior(blmerFit, resid.prior = numeric(0))) expect_error(parsePrior(blmerFit, resid.prior = list(numeric(0)))) expect_error(parsePrior(blmerFit, resid.prior = "not a prior")) expect_error(parsePrior(blmerFit, resid.prior = "point(()")) expect_error(parsePrior(blmerFit, resid.prior = "point(value = 2, notAParam = 0)")) expect_error(parsePrior(blmerFit, resid.prior = "point(value = 'not a number')")) expect_error(parsePrior(blmerFit, resid.prior = "point(value = 0)")) expect_error(parsePrior(blmerFit, resid.prior = "point(value = 2, posterior.scale = 'not a scale')")) expect_error(parsePrior(blmerFit, resid.prior = "invgamma(-1)")) expect_error(parsePrior(blmerFit, resid.prior = "invgamma(scale = -1)")) expect_error(parsePrior(blmerFit, resid.prior = "invgamma(notAParam = 0)")) expect_error(parsePrior(blmerFit, resid.prior = "invgamma(common.scale = 'anything')")) expect_error(parsePrior(blmerFit, resid.prior = "invgamma(posterior.scale = 'not a scale')")) expect_error(parsePrior(blmerFit, resid.prior = "gamma(-1)")) expect_error(parsePrior(blmerFit, resid.prior = "gamma(rate = -1)")) expect_error(parsePrior(blmerFit, resid.prior = "gamma(notAParam = 0)")) expect_error(parsePrior(blmerFit, resid.prior = "gamma(posterior.scale = 'not a scale')")) }) blme/tests/testthat/test-06-lmm_resid.R0000644000176200001440000000202512531656075017502 0ustar liggesuserscontext("blmer numerical results with residual variance prior") test_that("blmer fits the eight schools example correctly", { # eight schools y <- c(28, 8, -3, 7, -1, 1, 18, 12) sigma <- c(15, 10, 16, 11, 9, 11, 10, 18) y.z <- (y - mean(y)) / sigma g <- 1:8 eightSchools <- blmer(y.z ~ 1 + (1 | g), resid.prior = point, cov.prior = NULL, fixef.prior = NULL) expect_equal(eightSchools@theta, 0, tolerance = 1.0e-7) }) test_that("blmer fits test data with inv.gamma prior, matching previous version", { source(system.file("common", "lmmData.R", package = "blme")) fit <- blmer(y ~ x.1 + x.2 + (1 + x.1 | g.1) + (1 + x.1 + x.2 | g.2), testData, control = lmerControl(optimizer = "bobyqa"), cov.prior = NULL, resid.prior = invgamma(2, 1.0)) expect_equal(fit@pp$theta, c(0.725321928185923, -0.251272308917427, 1.5828609906233, 0.946932542474828, 0.467970716580088, -0.183212783510381, 1.07158442297183, 0.122067368879505, 0.223238050522642), tolerance = 1.0e-6) }) blme/tests/testthat/test-02-glmm.R0000644000176200001440000000107212531661421016447 0ustar liggesuserscontext("glmer and bglmer") test_that("bglmer matches glmer exactly", { source(system.file("common", "glmmData.R", package = "blme")) control <- glmerControl(optimizer = "Nelder_Mead") glmerFit <- glmer(y ~ x.1 + x.2 + (1 | g), testData, family = binomial(), control = control) bglmerFit <- bglmer(y ~ x.1 + x.2 + (1 | g), testData, family = binomial(), control = control, cov.prior = NULL) expect_equal(glmerFit@theta, bglmerFit@theta) expect_equal(glmerFit@beta, bglmerFit@beta) expect_equal(glmerFit@u, bglmerFit@u) }) blme/tests/test-all.R0000644000176200001440000000021412531707617014211 0ustar liggesusersif (require(testthat, quietly = TRUE)) { test_check("blme") } else { cat("package 'testthat' not available; cannot run unit tests\n") } blme/NAMESPACE0000644000176200001440000000177212536607162012427 0ustar liggesusersexport(blmer, bglmer) exportClasses(bmerMod, blmerMod, bglmerMod) S3method(print, bmerMod) S3method(print, summary.bmerMod) S3method(summary, bmerMod) S3method(summary, summary.bmerMod) S3method(vcov, summary.bmerMod) S3method(refit, bmerMod) S3method(toString, bmerNormalDist) S3method(toString, bmerPointDist) S3method(toString, bmerWishartDist) S3method(toString, bmerInvWishartDist) S3method(toString, bmerGammaDist) S3method(toString, bmerInvGammaDist) importFrom(methods, is, isGeneric, new, representation, show) importFrom(methods, setClass, setGeneric, setMethod) importFrom(stats, gaussian, vcov) importFrom(utils, data, getS3method) importClassesFrom(lme4, merMod, lmerMod, glmerMod) importFrom(lme4, lmer, glmer) importFrom(lme4, lFormula, glFormula) importFrom(lme4, lmerControl, glmerControl) importFrom(lme4, mkMerMod) importFrom(lme4, optimizeGlmer) importFrom(lme4, mkLmerDevfun, mkGlmerDevfun, updateGlmerDevfun) importFrom(lme4, isLMM, isGLMM, mkRespMod, GHrule, isREML) importFrom(lme4, refit)blme/R/0000755000176200001440000000000012536634161011401 5ustar liggesusersblme/R/string.R0000644000176200001440000000214012531671067013030 0ustar liggesuserscovariancePriorsToString <- function(covPriors, numGroupsPerFactor, digits) { result <- character(0) resultIndex <- 1 numFactors <- length(numGroupsPerFactor) factorNames <- names(numGroupsPerFactor) for (i in 1:numFactors) { prior.i <- covPriors[[i]] if (is.null(prior.i)) next result[resultIndex] <- paste(factorNames[i], " ~ ", toString(prior.i, digits), sep = "") resultIndex <- resultIndex + 1 } result } printPriors <- function(priors, numGroupsPerFactor, digits) { covariancePriorOutput <- covariancePriorsToString(priors$covPriors, numGroupsPerFactor, digits) if (length(covariancePriorOutput) > 0) { cat("Cov prior : ", covariancePriorOutput[1], "\n", sep="") if (length(covariancePriorOutput) > 1) { for (i in 2:length(covariancePriorOutput)) cat(" : ", covariancePriorOutput[i], "\n", sep="") } } if (!is.null(priors$fixefPrior)) cat("Fixef prior: ", toString(priors$fixefPrior, digits), "\n", sep="") if (!is.null(priors$residPrior)) cat("Resid prior: ", toString(priors$residPrior, digits, FALSE), "\n", sep="") } blme/R/dist_wishart.R0000644000176200001440000001351512531670277014240 0ustar liggesuserssetClass("bmerWishartDist", representation(df = "numeric", R.scale.inv = "matrix", log.det.scale = "numeric", posteriorScale = "character"), contains = "bmerDist", validity = function(object) object@posteriorScale == "cov" || object@posteriorScale == "sqrt") setClass("bmerInvWishartDist", representation(df = "numeric", R.scale = "matrix", log.det.scale = "numeric", posteriorScale = "character"), contains = "bmerDist", validity = function(object) object@posteriorScale == "cov" || object@posteriorScale == "sqrt") toString.bmerWishartDist <- function(x, digits = getOption("digits"), ...) { if (any(diag(x@R.scale.inv) == 0)) { scale <- Inf } else if (any(is.infinite(x@R.scale.inv))) { scale <- 0 } else { scale <- solve(tcrossprod(x@R.scale.inv)) } if (length(scale) == 1) { scaleString <- round(scale, digits) } else if (nrow(scale) > 2) { scaleString <- paste("c(", toString(round(scale[1:3], digits)), ", ...)", sep = "") } else if (nrow(scale) == 2) { scaleString <- paste("c(", toString(round(scale[1:4], digits)), ")", sep = "") } paste("wishart(", "df = ", round(x@df, digits), ", scale = ", scaleString, ", posterior.scale = ", x@posteriorScale, ", common.scale = ", x@commonScale, ")", sep="") } toString.bmerInvWishartDist <- function(x, digits = getOption("digits"), ...) { if (any(diag(x@R.scale) == 0)) { scale <- 0 } else if (any(is.infinite(x@R.scale))) { scale <- Inf } else { scale <- crossprod(x@R.scale) } if (length(scale) == 1) { scaleString <- round(scale, digits) } else if (nrow(scale) > 2) { scaleString <- paste("c(", toString(round(scale[1:3], digits)), ", ...)", sep = "") } else if (nrow(scale) == 2) { scaleString <- paste("c(", toString(round(scale[1:4], digits)), ")", sep = "") } paste("invwishart(", "df = ", round(x@df, digits), ", scale = ", scaleString, ", posterior.scale = ", x@posteriorScale, ", common.scale = ", x@commonScale, ")", sep="") } setMethod("getDFAdjustment", "bmerWishartDist", function(object) { factorDim <- nrow(object@R.scale.inv) if (object@commonScale || !is.finite(object@log.det.scale)) 0 else -factorDim * (object@df - factorDim - 1.0) } ) setMethod("getDFAdjustment", "bmerInvWishartDist", function(object) { factorDim <- nrow(object@R.scale) if (object@commonScale || !is.finite(object@log.det.scale)) 0 else factorDim * (object@df + factorDim + 1.0) } ) setMethod("getConstantTerm", "bmerWishartDist", function(object) { df <- object@df; R.scale.inv <- object@R.scale.inv log.det.scale <- object@log.det.scale if (is.infinite(log.det.scale)) return (0.0) factorDim <- nrow(R.scale.inv) result <- df * (factorDim * log(2) + log.det.scale) + 0.5 * factorDim * (factorDim - 1.0) * log(pi) for (i in 1:factorDim) result <- result + 2.0 * lgamma(0.5 * (df + 1.0 - i)) result } ) setMethod("getConstantTerm", "bmerInvWishartDist", function(object) { df <- object@df; R.scale <- object@R.scale log.det.scale <- object@log.det.scale if (is.infinite(log.det.scale)) return (0.0) factorDim <- nrow(R.scale) result <- df * (factorDim * log(2) - log.det.scale) + 0.5 * factorDim * (factorDim - 1.0) * log(pi) for (i in 1:factorDim) result <- result + 2.0 * lgamma(0.5 * (df + 1.0 - i)) result } ) setMethod("getExponentialSigmaPower", "bmerWishartDist", function (object) { if (object@commonScale) return(0) if (object@posteriorScale == "sqrt") 1 else 2 }) setMethod("getExponentialSigmaPower", "bmerInvWishartDist", function (object) { if (object@commonScale) return(0) if (object@posteriorScale == "sqrt") -1 else -2 }) setMethod("getExponentialTerm", "bmerWishartDist", function(object, Lambda.t) { if (is.infinite(object@log.det.scale)) return(c(0, 0.0)) if (object@posteriorScale == "cov") { temp <- Lambda.t %*% object@R.scale.inv exponential <- sum(temp^2) power <- 2 } else { Sigma <- crossprod(Lambda.t) decomp <- eigen(Sigma) Sigma.sqrt <- decomp$vectors %*% tcrossprod(diag(sqrt(decomp$values)), decomp$vectors) exponential <- sum(Sigma.sqrt * crossprod(object@R.scale.inv)) power <- 1 } if (object@commonScale) c(0, exponential) else c(power, exponential) } ) setMethod("getExponentialTerm", "bmerInvWishartDist", function(object, Lambda.t) { if (is.infinite(object@log.det.scale)) return(c(0, 0.0)) if (object@posteriorScale == "cov") { power <- -2 if (any(diag(Lambda.t) == 0)) return (if (object@commonScale) c(0, Inf) else c(power, Inf)) temp <- object@R.scale %*% solve(Lambda.t) exponential <- sum(temp^2) } else { power <- -1 if (any(diag(Lambda.t) == 0)) return (if (object@commonScale) c(0, Inf) else c(power, Inf)) Sigma <- crossprod(Lambda.t) decomp <- eigen(Sigma) Sigma.inv.sqrt <- decomp$vectors %*% tcrossprod(diag(1 / sqrt(decomp$values)), decomp$vectors) exponential <- sum(Sigma.inv.sqrt * tcrossprod(object@R.scale)) } if (object@commonScale) c(0, exponential) else c(power, exponential) } ) setMethod("getPolynomialTerm", "bmerWishartDist", function(object, Lambda.t) { factorDim <- nrow(object@R.scale.inv) -2.0 * (object@df - factorDim - 1.0) * sum(log(diag(Lambda.t))) } ) setMethod("getPolynomialTerm", "bmerInvWishartDist", function(object, Lambda.t) { factorDim <- nrow(object@R.scale) 2.0 * (object@df + factorDim + 1.0) * sum(log(diag(Lambda.t))) } ) blme/R/priorEval.R0000644000176200001440000001420112532115157013460 0ustar liggesusersevaluateFixefPrior <- function(fixefPrior, defnEnv, evalEnv) { if (is.character(fixefPrior)) fixefPrior <- parse(text = fixefPrior)[[1]] if (is.symbol(fixefPrior) && exists(toString(fixefPrior), envir = evalEnv) && !(as.character(fixefPrior) %in% fixefDistributions)) { fixefPrior <- get(toString(fixefPrior), envir = evalEnv) if (is.character(fixefPrior)) fixefPrior <- parse(text = fixefPrior)[[1]] } if (!is.null(fixefPrior)) { if (is.symbol(fixefPrior)) fixefPrior <- call(as.character(fixefPrior)) fixefDistributionName <- as.character(fixefPrior[[1]]) if (!(fixefDistributionName %in% fixefDistributions)) stop("unrecognized fixef distribution: '", fixefDistributionName, "'") return(eval(fixefPrior, envir = evalEnv)) } NULL } evaluateCovPriors <- function(covPriors, factorColumnNames, numGroupsPerFactor, defnEnv, evalEnv) { numFactors <- length(factorColumnNames) factorNames <- names(factorColumnNames) result <- vector("list", numFactors) defaultCovPrior <- NULL if (is.null(covPriors)) return(result) if (is.character(covPriors)) { covPriors <- gsub("inverse.wishart", "invwishart", covPriors) covPriors <- gsub("inverse.gamma", "invgamma", covPriors) covPriors <- parse(text = covPriors)[[1]] } if (is.call(covPriors) && covPriors[[1]] == "list") covPriors[[1]] <- NULL if (!is.list(covPriors)) covPriors <- list(covPriors) for (i in 1:length(covPriors)) { covPrior.i <- covPriors[[i]] ## can't just let 'em re-define "wishart", or use the built-in gamma if (is.symbol(covPrior.i) && exists(toString(covPrior.i), envir = evalEnv) && !(as.character(covPrior.i) %in% covDistributions)) { covPrior.i <- get(toString(covPrior.i), envir = evalEnv) if (is.character(covPrior.i)) covPrior.i <- parse(text = covPrior.i)[[1]] covPriors[[i]] <- covPrior.i } } for (i in 1:length(covPriors)) { covPrior.i <- covPriors[[i]] if (is.character(covPrior.i)) { covPrior.i <- gsub("inverse.wishart", "invwishart", covPrior.i) covPrior.i <- gsub("inverse.gamma", "invgamma", covPrior.i) covPrior.i <- parse(text = covPrior.i)[[1]] } ## turn 'wishart' into 'wishart()' if (is.symbol(covPrior.i)) covPrior.i <- call(as.character(covPrior.i)) if (is.formula(covPrior.i)) { factorName <- as.character(covPrior.i[[2]]) if (!(factorName %in% factorNames)) stop("grouping factor '", factorName, "' for covariance prior not in model formula") ## turn 'group ~ wishart' into 'group ~ wishart()' if (is.symbol(covPrior.i[[3]])) covPrior.i[[3]] <- call(as.character(covPrior.i[[3]])) ## for each grouping factor with the given name, store function call for later matchingFactors <- which(factorName == factorNames) for (j in 1:length(matchingFactors)) result[[matchingFactors[j]]] <- covPrior.i[[3]] } else { ## default if (!is.null(defaultCovPrior)) warning("more than one default covariance prior specified, only using the last one") defaultCovPrior <- covPrior.i } } for (i in 1:numFactors) { if (is.null(result[[i]]) && is.null(defaultCovPrior)) next result.i <- result[[i]] if (is.null(result[[i]]) && !is.null(defaultCovPrior)) result.i <- defaultCovPrior covDistributionName <- as.character(result.i[[1]]) if (!(covDistributionName %in% covDistributions)) stop("unrecognized ranef covariance distribution: '", covDistributionName, "'") defnEnv$q.k <- defnEnv$level.dim <- length(factorColumnNames[[i]]) defnEnv$j.k <- defnEnv$n.grps <- numGroupsPerFactor[i] result.i <- eval(result.i, envir = evalEnv) if (!is.null(result.i)) result[[i]] <- result.i } result } evaluateResidualPrior <- function(residPrior, defnEnv, evalEnv) { if (is.character(residPrior)) { residPrior <- gsub("inverse.gamma", "invgamma", residPrior) residPrior <- parse(text = residPrior)[[1]] } if (is.symbol(residPrior) && exists(toString(residPrior), envir = evalEnv)) { fixefPrior <- get(toString(residPrior), envir = evalEnv) if (is.character(residPrior)) residPrior <- parse(text = residPrior)[[1]] } if (!is.null(residPrior)) { if (is.symbol(residPrior)) residPrior <- call(as.character(residPrior)) residDistributionName <- as.character(residPrior[[1]]) if (!(residDistributionName %in% residDistributions)) stop("unrecognized residual variance distribution: '", residDistributionName, "'") return(eval(residPrior, envir = evalEnv)) } NULL } evaluatePriorArguments <- function(covPriors, fixefPrior, residPrior, dims, factorColumnNames, numGroupsPerFactor, parentEnv) { result <- list() evalEnv <- new.env(parent = parentEnv) defnEnv <- new.env() defnEnv$p <- defnEnv$n.fixef <- dims[["p"]] defnEnv$n <- defnEnv$n.obs <- dims[["n"]] isLMM <- dims[["GLMM"]] == 0 ## add the names of dist functs to the evaluating env for (distributionName in names(lmmDistributions)) { distributionFunction <- lmmDistributions[[distributionName]] environment(distributionFunction) <- defnEnv if (!isLMM) { ## need both copies to have their envs tweaked, but only one called distributionFunction <- glmmDistributions[[distributionName]] if (!is.null(distributionFunction)) environment(distributionFunction) <- defnEnv } if (!is.null(distributionFunction)) assign(distributionName, distributionFunction, envir = evalEnv) } result$fixefPrior <- evaluateFixefPrior(fixefPrior, defnEnv, evalEnv) if (is(result$fixefPrior, "bmerTDist") && isLMM && dims[["REML"]] > 0L) stop("t distribution for fixed effects only supported when REML = FALSE") result$covPriors <- evaluateCovPriors(covPriors, factorColumnNames, numGroupsPerFactor, defnEnv, evalEnv) if (isLMM) { environment(residualVarianceGammaPrior) <- defnEnv environment(residualVarianceInvGammaPrior) <- defnEnv assign("gamma", residualVarianceGammaPrior, envir = evalEnv) assign("invgamma", residualVarianceInvGammaPrior, envir = evalEnv) result$residPrior <- evaluateResidualPrior(residPrior, defnEnv, evalEnv) } result } blme/R/devFun.R0000644000176200001440000003065412535631562012764 0ustar liggesusersmkBlmerDevfun <- function(fr, X, reTrms, REML = TRUE, start = NULL, verbose = 0L, control = lmerControl(), priors = NULL, ...) { devfun <- mkLmerDevfun(fr, X, reTrms, REML, start, verbose, control, ...) devFunEnv <- environment(devfun) pred <- devFunEnv$pp resp <- devFunEnv$resp devFunEnv$ranefStructure <- getRanefStructure(pred, resp, reTrms) if (is.null(priors)) priors <- list() devFunEnv$priors <- evaluatePriorArguments(priors$covPriors, priors$fixefPrior, priors$residPrior, c(n = nrow(X), p = ncol(X), GLMM = 0L, REML = if (REML) 1L else 0L), reTrms$cnms, devFunEnv$ranefStructure$numGroupsPerFactor, parent.frame(2L)) devFunEnv$blmerControl <- createBlmerControl(pred, resp, devFunEnv$priors) devFunEnv$parInfo <- getParInfo(pred, resp, devFunEnv$ranefStructure, devFunEnv$blmerControl) devFunBody <- getBlmerDevianceFunctionBody(devFunEnv) if (!is.null(devFunBody)) body(devfun) <- parse(text = devFunBody) devfun } mkBglmerDevfun <- function(fr, X, reTrms, family, nAGQ = 1L, verbose = 0L, maxit = 100L, control=glmerControl(), priors = NULL, ...) { devfun <- if (packageVersion("lme4") <= "1.1.7") { mkGlmerDevfun(fr, X, reTrms, family, nAGQ, verbose, control, ...) } else { mkGlmerDevfun(fr, X, reTrms, family, nAGQ, verbose, maxit, control, ...) } devFunEnv <- environment(devfun) pred <- devFunEnv$pp resp <- devFunEnv$resp devFunEnv$ranefStructure <- getRanefStructure(pred, resp, reTrms) if (is.null(priors)) priors <- list() devFunEnv$priors <- evaluatePriorArguments(priors$covPriors, priors$fixefPrior, NULL, c(n = nrow(X), p = ncol(X), GLMM = 1L), reTrms$cnms, devFunEnv$ranefStructure, parent.frame(2L)) devFunEnv$blmerControl <- createBlmerControl(pred, resp, devFunEnv$priors) devFunEnv$parInfo <- getParInfo(pred, resp, devFunEnv$ranefStructure, devFunEnv$blmerControl) devFunBody <- getBglmerDevianceFunctionBody(devFunEnv, nAGQ != 0L) if (!is.null(devFunBody)) body(devfun) <- parse(text = devFunBody) devfun } makeRefitDevFun <- function(env, nAGQ = 1L, verbose = 0, maxit=100L, control = list(), object) { lme4Namespace <- asNamespace("lme4") devfun <- if (packageVersion("lme4") <= "1.1.7") { get("mkdevfun", lme4Namespace)(env, nAGQ, verbose, control) } else get("mkdevfun", lme4Namespace)(env, nAGQ, maxit, verbose, control) pred <- env$pp resp <- env$resp env$maxit <- as.integer(maxit) env$lower <- object@lower env$priors <- object@priors env$ranefStructure <- getRanefStructure(pred, resp, list(cnms = object@cnms, Gp = object@Gp)) env$blmerControl <- createBlmerControl(pred, resp, env$priors) env$parInfo <- getParInfo(pred, resp, env$ranefStructure, env$blmerControl) devFunBody <- if (is(resp, "lmerResp")) getBlmerDevianceFunctionBody(env) else getBglmerDevianceFunctionBody(env, nAGQ != 0L) if (!is.null(devFunBody)) body(devfun) <- parse(text = devFunBody) devfun } ## environment already populated at this point updateBglmerDevfun <- function(devfun, reTrms, nAGQ = 1L) { devfun <- updateGlmerDevfun(devfun, reTrms, nAGQ = nAGQ) devFunEnv <- environment(devfun) devFunBody <- getBglmerDevianceFunctionBody(devFunEnv, nAGQ != 0L) if (!is.null(devFunBody)) body(devfun) <- parse(text = devFunBody) devfun } getBlmerDevianceFunctionBody <- function(devFunEnv) { priors <- devFunEnv$priors if (!anyPriorsApplied(priors)) return(NULL) blmerControl <- devFunEnv$blmerControl sigmaOptimizationType <- blmerControl$sigmaOptimizationType fixefOptimizationType <- blmerControl$fixefOptimizationType fixefPrior <- priors$fixefPrior devFunBody <- NULL stringConnection <- textConnection("devFunBody", "w", local=TRUE) sink(stringConnection) cat("{\n") cat(" expandParsInCurrentFrame(theta, parInfo);\n", " pp$setTheta(as.double(theta));\n\n", sep = "") devFunEnv$expandParsInCurrentFrame <- expandParsInCurrentFrame if (sigmaOptimizationType == SIGMA_OPTIM_POINT) cat(" sigma <- priors$residPrior@value;\n") if (is(fixefPrior, "bmerNormalDist")) { if (fixefPrior@commonScale == FALSE) { cat(" pp$updateDecomp(sigma * priors$fixefPrior@R.cov.inv);\n") } else { cat(" pp$updateDecomp(priors$fixefPrior@R.cov.inv);\n") } } else { cat(" pp$updateDecomp();\n") } cat("\n") cat(" resp$updateMu(pp$linPred(0.0));\n", " pp$updateRes(resp$wtres);\n", " pp$solve();\n", " resp$updateMu(pp$linPred(1.0));\n\n", sep = "") if (fixefOptimizationType != FIXEF_OPTIM_NUMERIC) { cat(" beta <- pp$beta(1.0);\n") } cat(" Lambda.ts <- getCovBlocks(pp$Lambdat, ranefStructure);\n") if (sigmaOptimizationType == SIGMA_OPTIM_NUMERIC || sigmaOptimizationType == SIGMA_OPTIM_POINT) { cat(" exponentialTerms <- calculatePriorExponentialTerms(priors, beta, Lambda.ts, sigma);\n") } else { cat(" exponentialTerms <- calculatePriorExponentialTerms(priors, beta, Lambda.ts);\n") } cat(" polynomialTerm <- calculatePriorPolynomialTerm(priors$covPriors, Lambda.ts);\n\n") devFunEnv$calculatePriorExponentialTerms <- calculatePriorExponentialTerms devFunEnv$calculatePriorPolynomialTerm <- calculatePriorPolynomialTerm devFunEnv$getCovBlocks <- getCovBlocks if (fixefOptimizationType == FIXEF_OPTIM_NUMERIC) { cat(" exponentialTerms <- calculateFixefExponentialTerm(beta, pp$beta(1.0), pp$RX(), exponentialTerms);\n") devFunEnv$calculateFixefExponentialTerm <- calculateFixefExponentialTerm } if (sigmaOptimizationType != SIGMA_OPTIM_NUMERIC && sigmaOptimizationType != SIGMA_OPTIM_POINT) { cat(" sigma <- profileSigma(pp, resp, exponentialTerms, blmerControl);\n\n", sep = "") devFunEnv$profileSigma <- getSigmaProfiler(priors, blmerControl) } cat(" lmmObjective(pp, resp, sigma, exponentialTerms, polynomialTerm, blmerControl);\n") devFunEnv$lmmObjective <- lmmObjective cat("}\n") sink() close(stringConnection) devFunBody } anyPriorsApplied <- function(priors) { !is.null(priors$fixefPrior) || any(sapply(priors$covPriors, function(cov.prior.i) !is.null(cov.prior.i))) || !is.null(priors$residPrior) } getSigmaProfiler <- function(priors, blmerControl) { sigmaOptimizationType <- blmerControl$sigmaOptimizationType if (sigmaOptimizationType == SIGMA_OPTIM_SQ_LINEAR) { return (function(pp, resp, exponentialTerms, blmerControl) { pwrss <- resp$wrss() + pp$sqrL(1.0) if (!is.null(exponentialTerms[["-2"]])) pwrss <- pwrss + exponentialTerms[["-2"]] df <- nrow(pp$X) - resp$REML + blmerControl$df sqrt(pwrss / df) }) } else if (sigmaOptimizationType == SIGMA_OPTIM_SQ_QUADRATIC) { return (function(pp, resp, exponentialTerms, blmerControl) { pwrss <- resp$wrss() + pp$sqrL(1.0) if (!is.null(exponentialTerms[["-2"]])) pwrss <- pwrss + exponentialTerms[["-2"]] a <- exponentialTerms[["2"]] df <- nrow(pp$X) - resp$REML + blmerControl$df disc <- sqrt(df^2 + 4 * pwrss * a) sqrt((disc - df) / (2 * a)) }) } else if (sigmaOptimizationType == SIGMA_OPTIM_QUADRATIC) { return (function(pp, resp, exponentialTerms, blmerControl) { pwrss <- resp$wrss() + pp$sqrL(1.0) if (!is.null(exponentialTerms[["-2"]])) pwrss <- pwrss + exponentialTerms[["-2"]] a <- exponentialTerms[["-1"]] df <- nrow(pp$X) - resp$REML + blmerControl$df disc <- sqrt(a^2 + 16 * df * pwrss) 0.25 * (disc + a) / df }) } else stop("illegal sigma optimization type") } calculatePriorExponentialTerms <- function(priors, beta, Lambda.ts, sigma = NULL) { result <- list() fixefPrior <- priors$fixefPrior covPriors <- priors$covPriors residPrior <- priors$residPrior if (!is.null(fixefPrior)) { if (is(fixefPrior, "bmerTDist") && fixefPrior@commonScale == TRUE) { term <- getExponentialTerm(fixefPrior, beta / sigma) } else { term <- getExponentialTerm(fixefPrior, beta) } result[[toString(term[1])]] <- term[2] } for (i in 1:length(covPriors)) { if (is.null(covPriors[[i]])) next covPrior.i <- covPriors[[i]] if (is(covPrior.i, "bmerCustomDist") && covPrior.i@commonScale == FALSE) { term <- getExponentialTerm(covPrior.i, Lambda.ts[[i]] * sigma) } else { term <- getExponentialTerm(covPrior.i, Lambda.ts[[i]]) } power <- toString(term[1]) exponential <- term[2] if (is.null(result[[power]])) result[[power]] <- exponential else result[[power]] <- result[[power]] + exponential } if (is.null(residPrior)) return(result) term <- getExponentialTerm(residPrior) power <- toString(term[1]) exponential <- term[2] if (is.null(result[[power]])) result[[power]] <- exponential else result[[power]] <- result[[power]] + exponential result } calculatePriorPolynomialTerm <- function(covPriors, Lambda.ts) { sum(sapply(1:length(covPriors), function(i) if (!is.null(covPriors[[i]])) getPolynomialTerm(covPriors[[i]], Lambda.ts[[i]]) else 0)) } calculateFixefExponentialTerm <- function(beta, beta.tilde, RX, exponentialTerms = NULL) { exponential <- crossprod(RX %*% (beta - beta.tilde))[1] if (is.null(exponentialTerms)) return(exponential) if (is.null(exponentialTerms[["-2"]])) { exponentialTerms[["-2"]] <- exponential } else { exponentialTerms[["-2"]] <- exponentialTerms[["-2"]] + exponential } exponentialTerms } testGetBglmerDevianceFunctionBody <- function(devFun) { devFunEnv <- environment(devFun) priors <- devFunEnv$priors if (!anyPriorsApplied(priors)) return(NULL) fixefPrior <- priors$fixefPrior devFunBody <- NULL stringConnection <- textConnection("devFunBody", "w", local = TRUE) sink(stringConnection) cat("{\n", " Lambda.ts <- getCovBlocks(pp$Lambdat, ranefStructure)\n", " exponentialTerms <- calculatePriorExponentialTerms(priors, spars, Lambda.ts)\n", " polynomialTerm <- calculatePriorPolynomialTerm(priors$covPriors, Lambda.ts)\n\n", " ", sep = "") oldDevFunBody <- deparse(body(devFun)) cat(oldDevFunBody[-length(oldDevFunBody)], sep = "\n") ## cut trailing "}" cat(" } + exponentialTerms[[1]] + polynomialTerm + blmerControl$constant\n", "}", sep = "") sink() close(stringConnection) devFunBody } getBglmerDevianceFunctionBody <- function(devFunEnv, fixefAreParams) { priors <- devFunEnv$priors if (!anyPriorsApplied(priors)) return(NULL) fixefPrior <- priors$fixefPrior devFunBody <- NULL stringConnection <- textConnection("devFunBody", "w", local=TRUE) sink(stringConnection) cat("{\n") if (fixefAreParams) cat(" resp$setOffset(baseOffset);\n") cat(" resp$updateMu(lp0);\n") if (!fixefAreParams) { cat(" spars <- rep(0, ncol(pp$X));\n", " pp$setTheta(as.double(theta));\n", sep = "") if (packageVersion("lme4") <= "1.1.7") { cat(" p <- pwrssUpdate(pp, resp, tolPwrss, GHrule(0L), compDev, verbose=verbose);\n") } else { cat(" p <- pwrssUpdate(pp, resp, tolPwrss, GHrule(0L), compDev, maxit=maxit, verbose=verbose);\n") } } else { cat(" pp$setTheta(as.double(pars[dpars]));\n", " spars <- as.numeric(pars[-dpars]);\n", " offset <- if (length(spars) == 0) baseOffset else baseOffset + pp$X %*% spars;\n", " resp$setOffset(offset);\n\n", sep = "") if (packageVersion("lme4") <= "1.1.7") { cat(" p <- pwrssUpdate(pp, resp, tolPwrss, GQmat, compDev, fac, verbose=verbose);\n") } else { cat(" p <- pwrssUpdate(pp, resp, tolPwrss, GQmat, compDev, fac, maxit=maxit, verbose=verbose);\n") } } cat(" resp$updateWts();\n\n", " Lambda.ts <- getCovBlocks(pp$Lambdat, ranefStructure);\n", " exponentialTerms <- calculatePriorExponentialTerms(priors, spars, Lambda.ts);\n", " polynomialTerm <- calculatePriorPolynomialTerm(priors$covPriors, Lambda.ts);\n\n", " p + exponentialTerms[[1]] + polynomialTerm + blmerControl$constant\n", "}\n", sep = "") devFunEnv$getCovBlocks <- getCovBlocks devFunEnv$calculatePriorExponentialTerms <- calculatePriorExponentialTerms devFunEnv$calculatePriorPolynomialTerm <- calculatePriorPolynomialTerm sink() close(stringConnection) devFunBody } blme/R/dist_custom.R0000644000176200001440000000161412531667547014074 0ustar liggesuserssetClass("bmerCustomDist", representation(fnName = "name", fn = "function", chol = "logical", scale = "character"), contains = "bmerDist", validity = function(object) object@scale == "log" || object@scale == "dev" || object@scale == "none") toString.bmerCustomDist <- function(x, digits = getOption("digits"), ...) { paste("custom(fn = ", x@fnName, ", chol = ", x@chol, ", scale = ", x@scale, ", common.scale = ", x@commonScale, ")", sep = "") } setMethod("getExponentialTerm", "bmerCustomDist", function(object, Lambda.t) { result <- object@fn(if (object@chol) Lambda.t else crossprod(Lambda.t)) if (object@scale == "log") { result <- -2 * result } else if (object@scale == "none") { result <- -2 * log(result) } c(0, result) }) blme/R/dist_normal.R0000644000176200001440000000332012531670054014031 0ustar liggesuserssetClass("bmerNormalDist", representation(R.cov.inv = "matrix"), contains = "bmerDist") toString.bmerNormalDist <- function(x, digits = getOption("digits"), ...) { cov <- solve(tcrossprod(x@R.cov.inv)) sds <- sqrt(diag(cov)) corrs <- diag(1 / sds) %*% cov %*% diag(1 / sds) sds <- round(sds, digits) corrs <- round(corrs[lower.tri(corrs)], digits) if (nrow(cov) > 2) { covString <- paste("sd = c(", toString(round(sds[1:2], digits)), ", ...), corr = c(", toString(round(corrs[1], digits)), " ...)", sep = "") } else if (nrow(cov) == 2) { covString <- paste("sd = c(", toString(round(sds[1:2], digits)), "), corr = ", toString(round(corrs[1], digits)), sep = "") } else { covString <- paste("sd = ", toString(round(sds[1], digits)), sep = "") } paste("normal(", covString, ", common.scale = ", x@commonScale, ")", sep="") } setMethod("getDFAdjustment", "bmerNormalDist", function(object) { if (object@commonScale == TRUE) sum(diag(object@R.cov.inv) != 0) else 0 } ) setMethod("getConstantTerm", "bmerNormalDist", function(object) { R.cov.inv <- object@R.cov.inv if (any(diag(R.cov.inv) < 0)) return(NA) nonZeroes <- diag(R.cov.inv) != 0 rank <- sum(nonZeroes) rank * log(2 * pi) - 2.0 * sum(log(diag(R.cov.inv)[nonZeroes])) } ) setMethod("getExponentialSigmaPower", "bmerNormalDist", function(object) { if (object@commonScale == TRUE) -2 else 0 } ) setMethod("getExponentialTerm", "bmerNormalDist", function(object, beta) { exponential <- tcrossprod(crossprod(beta, object@R.cov.inv))[1] if (object@commonScale == TRUE) c(-2, exponential) else c(0, exponential) } ) blme/R/AllClass.R0000644000176200001440000000030612203775113013213 0ustar liggesuserssetClass("bmerMod", representation(priors = "list"), contains = "merMod"); setClass("blmerMod", contains=c("lmerMod", "bmerMod")); setClass("bglmerMod", contains=c("glmerMod", "bmerMod")); blme/R/control.R0000644000176200001440000001137112531701616013202 0ustar liggesusers## "control" refers to how optimization should proceed, i.e. which parameters ## need numeric and which can be profiled out ## hack this as on "common scale" is really inconvenient here getResidPriorDFAdjustment <- function(residPrior) { if (is(residPrior, "bmerGammaDist")) { return(-(residPrior@shape - 1.0) * if (residPrior@posteriorScale == 'sd') 1 else 2) } else if (is(residPrior, "bmerInvGammaDist")) { return( (residPrior@shape + 1.0) * if (residPrior@posteriorScale == 'sd') 1 else 2) } 0 } getThetaLowerBoundsForDimension <- function(d) { if (d == 1) return(0) c(0, rep(-Inf, d - 1), getThetaLowerBoundsForDimension(d - 1)) } ## TODO: this should eventually not assume the ranef structure but instead ## suck it from Lind and theta, if possible getRanefStructure <- function(pred, resp, reTrms) { ranefStructure <- list(numCovParameters = sum(sapply(reTrms$cnms, function(cnm) { d <- length(cnm); d * (d + 1) / 2; })), numRanefPerFactor = diff(reTrms$Gp), numCoefPerFactor = as.integer(sapply(reTrms$cnms, length)), numFactors = length(reTrms$cnms)) ranefStructure$numGroupsPerFactor <- as.integer(ranefStructure$numRanefPerFactor / ranefStructure$numCoefPerFactor + 0.5) ranefStructure$lower <- as.numeric(unlist(sapply(ranefStructure$numCoefPerFactor, getThetaLowerBoundsForDimension))) ranefStructure } createBlmerControl <- function(pred, resp, priors) { df <- 0 ## adjustment to polynomial (sigma.sq)^{-df/2} constant <- 0 ## normalizing constants and the like. On deviance (-2 log) scale numFactors <- length(priors$covPriors) df <- df + getDFAdjustment(priors$fixefPrior) + getResidPriorDFAdjustment(priors$residPrior) constant <- constant + getConstantTerm(priors$fixefPrior) + getConstantTerm(priors$residPrior) for (i in 1:numFactors) { df <- df + getDFAdjustment(priors$covPrior[[i]]) constant <- constant + getConstantTerm(priors$covPrior[[i]]) } fixefOptimizationType <- getFixefOptimizationType(pred, resp, priors) sigmaOptimizationType <- getSigmaOptimizationType(resp, priors) namedList(df, constant, fixefOptimizationType, sigmaOptimizationType) } FIXEF_OPTIM_NA <- "na" ## no fixefs in model FIXEF_OPTIM_NUMERIC <- "numeric" ## brute force by adding to numeric optimizer FIXEF_OPTIM_LINEAR <- "linear" ## mle found by root of linear equation. or, don't worry about it getFixefOptimizationType <- function(pred, resp, priors) { if (length(pred$X) == 0) return(FIXEF_OPTIM_NA) if (!is(resp, "lmerResp")) return(FIXEF_OPTIM_NUMERIC) fixefPrior <- priors$fixefPrior if (is(fixefPrior, "bmerTDist")) return(FIXEF_OPTIM_NUMERIC) FIXEF_OPTIM_LINEAR } ## determines how to optimize over sigma ## possible values are: SIGMA_OPTIM_NA <- "na" ## doesn't apply SIGMA_OPTIM_NUMERIC <- "numeric" ## brute force by adding to numeric optimizer SIGMA_OPTIM_POINT <- "point" ## sigma is fixed to a particular value SIGMA_OPTIM_SQ_LINEAR <- "sigma.sq.linear" ## sigma.sq.hat is root to linear equation SIGMA_OPTIM_SQ_QUADRATIC <- "sigma.sq.quadratic" ## sigma.sq.hat is root to quadratic equation SIGMA_OPTIM_QUADRATIC <- "sigma.quadratic" ## sigma.hat is root to quadratic equation getSigmaOptimizationType <- function(resp, priors) { if (!is(resp, "lmerResp")) return(SIGMA_OPTIM_NA) fixefPrior <- priors$fixefPrior covPriors <- priors$covPriors residPrior <- priors$residPrior if (is(residPrior, "bmerPointDist")) return(SIGMA_OPTIM_POINT) if (is(fixefPrior, "bmerNormalDist") && fixefPrior@commonScale == FALSE) return(SIGMA_OPTIM_NUMERIC) if (is(fixefPrior, "bmerTDist") && fixefPrior@commonScale == TRUE) return(SIGMA_OPTIM_NUMERIC) exponentialTerms <- c() for (i in 1:length(covPriors)) { covPrior.i <- covPriors[[i]] if (is(covPrior.i, "bmerCustomDist") && covPrior.i@commonScale == FALSE) return(SIGMA_OPTIM_NUMERIC) exponentialTerm <- getExponentialSigmaPower(covPrior.i) if (exponentialTerm != 0) exponentialTerms <- union(exponentialTerms, exponentialTerm) } exponentialTerm <- getExponentialSigmaPower(residPrior) if (exponentialTerm != 0) exponentialTerms <- union(exponentialTerms, exponentialTerm) ## exp(-0.5 * sigma^-2 * stuff) always happens, so other terms are "extra" extraExponentialTerms <- setdiff(exponentialTerms, -2) if (length(extraExponentialTerms) == 0) return(SIGMA_OPTIM_SQ_LINEAR) if (length(extraExponentialTerms) > 1 || !(extraExponentialTerms %in% c(-1, 2))) return(SIGMA_OPTIM_NUMERIC) if (extraExponentialTerms == -1) return(SIGMA_OPTIM_QUADRATIC) if (extraExponentialTerms == 2) return(SIGMA_OPTIM_SQ_QUADRATIC) ## should be unreachable SIGMA_OPTIM_NUMERIC } blme/R/blmer.R0000644000176200001440000006413712536606750012643 0ustar liggesusers## copyright note: ## a lot of of this was copy/pasted from the lme4 package (http://cran.r-project.org/web/packages/lme4/index.html, GPL-2) ## a lot of it was not ## ideally, blme wouldn't have to recreate the functions with minor tweaks but we're just no there yet ## for R-check wishart <- "ignored" blmer <- function(formula, data = NULL, REML = TRUE, control = lmerControl(), start = NULL, verbose = 0L, subset, weights, na.action, offset, contrasts = NULL, devFunOnly = FALSE, cov.prior = wishart, fixef.prior = NULL, resid.prior = NULL, ...) { mc <- mcout <- match.call() missCtrl <- missing(control) missCovPrior <- missing(cov.prior) ## see functions in modular.R for the body ... if (!missCtrl && !inherits(control, "lmerControl")) { if(!is.list(control)) stop("'control' is not a list; use lmerControl()") ## back-compatibility kluge warning("passing control as list is deprecated: please use lmerControl() instead", immediate.=TRUE) control <- do.call(lmerControl, control) } if (!is.null(list(...)[["family"]])) { warning("calling lmer with 'family' is deprecated; please use glmer() instead") mc[[1]] <- quote(lme4::glmer) if(missCtrl) mc$control <- glmerControl() return(eval(mc, parent.frame(1L))) } fixef.prior <- mc$fixef.prior ## for delayed evaluation, get quoted versions cov.prior <- if (!missCovPrior) mc$cov.prior else formals(blmer)$cov.prior resid.prior <- mc$resid.prior if (!is.null(mc$var.prior)) resid.prior <- parse(text = mc$var.prior)[[1]] mc$fixef.prior <- NULL mc$cov.prior <- NULL mc$resid.prior <- NULL mc$var.prior <- NULL sigmaIsFixed <- !is.null(resid.prior) && (grepl("^\\W*point", resid.prior) || (is.call(resid.prior) && resid.prior[[1]] == "point")) if (sigmaIsFixed) { control$checkControl$check.nobs.vs.nlev <- "ignore" control$checkControl$check.nobs.vs.rankZ <- "ignore" control$checkControl$check.nobs.vs.nRE <- "ignore" } hasPseudoData <- !is.null(fixef.prior) && (grepl("^\\W*normal", fixef.prior) || (is.call(fixef.prior) && fixef.prior[[1]] == "normal")) if (hasPseudoData) { control$checkControl$check.rankX <- "ignore" } mc$control <- control ## update for back-compatibility kluge ## https://github.com/lme4/lme4/issues/50 ## parse data and formula mc[[1]] <- quote(lme4::lFormula) lmod <- eval(mc, parent.frame(1L)) mcout$formula <- lmod$formula lmod$formula <- NULL ## peel off the starting values lmer stuff expects to see lmerStart <- NULL if (!is.null(start) && is.list(start) && length(start) > 1) lmerStart <- start$theta devfun <- do.call(mkBlmerDevfun, c(lmod, lmod$X, lmod$reTrms, list(priors = list(covPriors = cov.prior, fixefPrior = fixef.prior, residPrior = resid.prior), start = lmerStart, verbose = verbose, control = control))) if (devFunOnly) return(devfun) devFunEnv <- environment(devfun) opt <- optimizeLmer(devfun, optimizer=control$optimizer, restart_edge=control$restart_edge, boundary.tol=control$boundary.tol, control=control$optCtrl, verbose=verbose, start=start, calc.derivs=control$calc.derivs, use.last.params=control$use.last.params) ## dirty hacks to give some backwards lme4 compatibility cc <- NULL lme4Namespace <- getNamespace("lme4") if (exists("checkConv", lme4Namespace)) { cc <- get("checkConv", lme4Namespace)(attr(opt,"derivs"), opt$par, ctrl = control$checkConv, lbound = environment(devfun)$lower) } args <- list(rho = devFunEnv, opt = opt, reTrms = lmod$reTrms, fr = lmod$fr, mc = mcout) if ("lme4conv" %in% names(formals(mkMerMod))) args$lme4conv <- cc result <- do.call(mkMerMod, args, TRUE, sys.frame(0)) result <- repackageMerMod(result, opt, devFunEnv) return(result) } bglmer <- function(formula, data = NULL, family = gaussian, control = glmerControl(), start = NULL, verbose = 0L, maxit = 100L, nAGQ = 1L, subset, weights, na.action, offset, contrasts = NULL, mustart, etastart, devFunOnly = FALSE, cov.prior = wishart, fixef.prior = NULL, ...) { covPriorMissing <- missing(cov.prior) if (!inherits(control, "glmerControl")) { if(!is.list(control)) stop("'control' is not a list; use glmerControl()") ## back-compatibility kluge msg <- "Use control=glmerControl(..) instead of passing a list" if(length(cl <- class(control))) msg <- paste(msg, "of class", dQuote(cl[1])) warning(msg, immediate.=TRUE) control <- do.call(glmerControl, control) } mc <- mcout <- match.call() fixef.prior <- mc$fixef.prior ## for delayed evaluation, store as quoted cov.prior <- if (!covPriorMissing) mc$cov.prior else formals(bglmer)$cov.prior mc$fixef.prior <- NULL mc$cov.prior <- NULL ## family-checking code duplicated here and in glFormula (for now) since ## we really need to redirect at this point; eventually deprecate formally ## and clean up if (is.character(family)) family <- get(family, mode = "function", envir = parent.frame(2)) if( is.function(family)) family <- family() if (isTRUE(all.equal(family, gaussian()))) { ## redirect to lmer (with warning) warning("calling glmer() with family=gaussian (identity link) as a shortcut to lmer() is deprecated;", " please call lmer() directly") mc[[1]] <- quote(lme4::lmer) mc["family"] <- NULL # to avoid an infinite loop return(eval(mc, parent.frame())) } ## see https://github.com/lme4/lme4/issues/50 ## parse the formula and data mc[[1]] <- quote(lme4::glFormula) glmod <- eval(mc, parent.frame(1L)) mcout$formula <- glmod$formula glmod$formula <- NULL ## create deviance function for covariance parameters (theta) devfun <- do.call(mkBglmerDevfun, c(glmod, glmod$X, glmod$reTrms, list(priors = list(covPriors = cov.prior, fixefPrior = fixef.prior), verbose = verbose, maxit = maxit, control = control, nAGQ = 0))) if (nAGQ==0 && devFunOnly) return(devfun) ## optimize deviance function over covariance parameters if (is.list(start)) { start.bad <- setdiff(names(start),c("theta","fixef")) if (length(start.bad)>0) { stop(sprintf("bad name(s) for start vector (%s); should be %s and/or %s", paste(start.bad,collapse=", "), shQuote("theta"), shQuote("fixef")),call.=FALSE) } if (!is.null(start$fixef) && nAGQ==0) stop("should not specify both start$fixef and nAGQ==0") } if (packageVersion("lme4") <= "1.1-7" || identical(control$nAGQ0initStep, TRUE)) { args <- list(devfun = devfun, optimizer = control$optimizer[[1]], restart_edge = if (nAGQ == 0) control$restart_edge else FALSE, control = control$optCtrl, start = start, nAGQ = 0, verbose = verbose) if (!is.null(formals(optimizeGlmer)$boundary.tol)) args$boundary.tol <- if (nAGQ == 0) control$boundary.tol else 0 if (!is.null(formals(optimizeGlmer)[["..."]])) args$calc.derivs <- FALSE opt <- do.call(optimizeGlmer, args, TRUE, sys.frame(0)) } if(nAGQ > 0L) { start <- get("updateStart", getNamespace("lme4"))(start,theta=opt$par) ## update deviance function to include fixed effects as inputs devfun <- updateBglmerDevfun(devfun, glmod$reTrms, nAGQ = nAGQ) if (devFunOnly) return(devfun) args <- list(devfun = devfun, optimizer = control$optimizer[[2]], restart_edge = control$restart_edge, start = start, nAGQ = nAGQ, verbose = verbose, stage = 2) if (!is.null(formals(optimizeGlmer)$boundary.tol)) args$boundary.tol <- control$boundary.tol if (!is.null(formals(optimizeGlmer)[["..."]])) { args$calc.derivs <- control$calc.derivs args$use.last.params <- control$use.last.params } ## reoptimize deviance function over covariance parameters and fixed effects opt <- do.call(optimizeGlmer, args, TRUE, sys.frame(0)) } lme4Namespace <- getNamespace("lme4") cc <- if (!is.null(control$calc.derivs) && !control$calc.derivs) NULL else { if (verbose > 10) cat("checking convergence\n") if (exists("checkConv", lme4Namespace)) get("checkConv", lme4Namespace)(attr(opt,"derivs"), opt$par, ctrl = control$checkConv, lbound = environment(devfun)$lower) else NULL } ## prepare output args <- list(rho = environment(devfun), opt = opt, reTrms = glmod$reTrms, fr = glmod$fr, mc = mcout) if ("lme4conv" %in% names(formals(mkMerMod))) args$lme4conv <- cc result <- do.call(mkMerMod, args, TRUE, sys.frame(0)) result <- repackageMerMod(result, opt, environment(devfun)) return(result) } lmmObjective <- function(pp, resp, sigma, exponentialTerms, polynomialTerm, blmerControl) { sigma.sq <- sigma^2 result <- resp$objective(pp$ldL2(), pp$ldRX2(), pp$sqrL(1.0), sigma.sq) exponentialTerm <- 0 for (i in 1:length(exponentialTerms)) { power <- as.numeric(names(exponentialTerms)[[i]]) value <- exponentialTerms[[i]] if (!is.finite(value)) return(value) exponentialTerm <- exponentialTerm + value * sigma^power } priorPenalty <- exponentialTerm + polynomialTerm + blmerControl$constant + blmerControl$df * log(sigma.sq) result <- result + priorPenalty return(result) } repackageMerMod <- function(merMod, opt, devFunEnv) { isLMM <- is(merMod, "lmerMod") blmerControl <- devFunEnv$blmerControl priors <- devFunEnv$priors if (isLMM) { expandParsInCurrentFrame(opt$par, devFunEnv$parInfo) if (blmerControl$fixefOptimizationType != FIXEF_OPTIM_NUMERIC) beta <- merMod@pp$beta(1.0) else merMod@beta <- beta } else { beta <- opt$par[-devFunEnv$dpars] } if (!is.null(merMod@optinfo)) { parLength <- devFunEnv$parInfo$theta$length + if (!isLMM) devFunEnv$parInfo$beta$length else 0 if (parLength != length(merMod@optinfo$val)) { merMod@optinfo$val_full <- merMod@optinfo$val merMod@optinfo$derivs_full <- merMod@optinfo$derivs merMod@optinfo$val <- merMod@optinfo$val[parLength] merMod@optinfo$derivs$gradient <- merMod@optinfo$derivs$gradient[parLength] merMod@optinfo$derivs$Hessian <- merMod@optinfo$derivs$Hessian[parLength, parLength, drop = FALSE] } } Lambda.ts <- getCovBlocks(merMod@pp$Lambdat, devFunEnv$ranefStructure) exponentialTerms <- calculatePriorExponentialTerms(priors, beta, Lambda.ts, sigma) if (isLMM) { if (blmerControl$fixefOptimizationType == FIXEF_OPTIM_NUMERIC) { fixefExponentialTerm <- calculateFixefExponentialTerm(beta, merMod@pp$beta(1.0), merMod@pp$RX()) if (is.null(exponentialTerms[["-2"]])) { exponentialTerms[["-2"]] <- fixefExponentialTerm } else { exponentialTerms[["-2"]] <- exponentialTerms[["-2"]] + fixefExponentialTerm } } if (!is.null(exponentialTerms[["-2"]])) merMod@devcomp$cmp[["pwrss"]] <- merMod@devcomp$cmp[["pwrss"]] + as.numeric(exponentialTerms[["-2"]]) ## recover sigma sigmaOptimizationType <- blmerControl$sigmaOptimizationType if (sigmaOptimizationType == SIGMA_OPTIM_POINT) { sigma <- priors$residPrior@value } else if (sigmaOptimizationType != SIGMA_OPTIM_NUMERIC) { profileSigma <- getSigmaProfiler(priors, blmerControl) sigma <- profileSigma(merMod@pp, merMod@resp, exponentialTerms, blmerControl) } ## set sigma in final object numObs <- merMod@devcomp$dims[["n"]] numFixef <- merMod@devcomp$dims[["p"]] if (merMod@devcomp$dims[["REML"]] > 0L) { merMod@devcomp$cmp[["sigmaREML"]] <- sigma merMod@devcomp$cmp[["sigmaML"]] <- sigma * sqrt((numObs - numFixef) / numObs) } else { merMod@devcomp$cmp[["sigmaML"]] <- sigma merMod@devcomp$cmp[["sigmaREML"]] <- sigma * sqrt(numObs / (numObs - numFixef)) } objectiveValue <- merMod@resp$objective(merMod@pp$ldL2(), merMod@pp$ldRX2(), merMod@pp$sqrL(1.0), sigma^2) if (blmerControl$fixefOptimizationType == FIXEF_OPTIM_NUMERIC) objectiveValue <- objectiveValue + fixefExponentialTerm / sigma^2 if (merMod@devcomp$dims[["REML"]] > 0L) { priorPenalty <- merMod@devcomp$cmp[["REML"]] - objectiveValue merMod@devcomp$cmp[["REML"]] <- objectiveValue } else { priorPenalty <- merMod@devcomp$cmp[["dev"]] - objectiveValue merMod@devcomp$cmp[["dev"]] <- objectiveValue } merMod@devcomp$cmp[["penalty"]] <- priorPenalty return(new("blmerMod", resp = merMod@resp, Gp = merMod@Gp, call = merMod@call, frame = merMod@frame, flist = merMod@flist, cnms = merMod@cnms, lower = merMod@lower, theta = merMod@theta, beta = beta, u = merMod@u, devcomp = merMod@devcomp, pp = merMod@pp, optinfo = merMod@optinfo, priors = priors)) } else { if (length(exponentialTerms) > 0) priorPenalty <- exponentialTerms[[1]] + calculatePriorPolynomialTerm(priors$covPriors, Lambda.ts) + blmerControl$constant else priorPenalty <- 0 merMod@devcomp$cmp[["dev"]] <- merMod@devcomp$cmp[["dev"]] - priorPenalty merMod@devcomp$cmp[["penalty"]] <- priorPenalty return(new("bglmerMod", resp = merMod@resp, Gp = merMod@Gp, call = merMod@call, frame = merMod@frame, flist = merMod@flist, cnms = merMod@cnms, lower = merMod@lower, theta = merMod@theta, beta = merMod@beta, u = merMod@u, devcomp = merMod@devcomp, pp = merMod@pp, optinfo = merMod@optinfo, priors = priors)) } } validateRegressionArgument <- function(regression, regressionName) { if (missing(regression)) stop("'regression' missing.") # check for existence and null-ness if (is.null(regression)) stop("object '", regressionName, "' is null.") if (!is(regression, "bmerMod")) stop("object '", regressionName, "' does not inherit from S4 class 'bmerMod'.") } setPrior <- function(regression, cov.prior = NULL, fixef.prior = NULL, resid.prior = NULL, envir = parent.frame(1L), ...) { matchedCall <- match.call() covMissing <- missing(cov.prior) fixefMissing <- missing(fixef.prior) residMissing <- missing(resid.prior) validateRegressionArgument(regression, matchedCall$regression) if (residMissing && !is.null(matchedCall$var.prior)) { matchedCall$resid.prior <- matchedCall$var.prior residMissing <- FALSE } priors <- evaluatePriorArguments(matchedCall$cov.prior, matchedCall$fixef.prior, matchedCall$resid.prior, regression@devcomp$dim, regression@cnms, as.integer(diff(regression@Gp) / sapply(regression@cnms, length)), envir) if (!covMissing) regression@covPriors <- priors$covPriors if (!fixefMissing) regression@fixefPrior <- priors$fixefPrior if (!residMissing) regression@residPrior <- priors$residPrior return (regression) } parsePrior <- function(regression, cov.prior = NULL, fixef.prior = NULL, resid.prior = NULL, envir = parent.frame(), ...) { matchedCall <- match.call() covMissing <- missing(cov.prior) fixefMissing <- missing(fixef.prior) residMissing <- missing(resid.prior) validateRegressionArgument(regression, matchedCall$regression) if (residMissing && !is.null(matchedCall$var.prior)) { matchedCall$resid.prior <- matchedCall$var.prior residMissing <- FALSE } priors <- evaluatePriorArguments(matchedCall$cov.prior, matchedCall$fixef.prior, matchedCall$resid.prior, regression@devcomp$dim, regression@cnms, as.integer(diff(regression@Gp) / sapply(regression@cnms, length)), envir) result <- list() if (!covMissing) result$covPriors <- priors$covPriors if (!fixefMissing) result$fixefPrior <- priors$fixefPrior if (!residMissing) result$residPrior <- priors$residPrior if (length(result) == 1) return(result[[1]]) return(result) } if (FALSE) { runOptimizer <- function(regression, verbose = FALSE) { validateRegressionArgument(regression, match.call()$regression) if (verbose) { regression@dims[["verb"]] <- as.integer(1) } else { regression@dims[["verb"]] <- as.integer(0) } return (mer_finalize(regression)) } runOptimizerWithPrior <- function(regression, cov.prior = NULL, fixef.prior = NULL, var.prior = NULL, verbose = FALSE, envir = parent.frame()) { validateRegressionArgument(regression, match.call()$regression) regression <- setPrior(regression, cov.prior, fixef.prior, var.prior, envir) return(runOptimizer(regression, verbose)) } } refit.bmerMod <- function(object, newresp = NULL, rename.response = FALSE, maxit = 100L, ...) { lme4Namespace <- getNamespace("lme4") lme4Version <- packageVersion("lme4") newControl <- NULL if (ll <- length(l... <- list(...)) > 0) { if ((ll == 1L) && (names(l...)[1] == "control")) { newControl <- l...$control } else { warning("additional arguments to refit.bmerMod ignored") } } ## TODO: not clear whether we should reset the names ## to the new response variable. Maybe not. ## retrieve name before it gets mangled by operations on newresp newrespSub <- substitute(newresp) ## for backward compatibility/functioning of refit(fit,simulate(fit)) if (is.list(newresp)) { if (length(newresp) == 1) { na.action <- attr(newresp,"na.action") newresp <- newresp[[1]] attr(newresp, "na.action") <- na.action } else { stop("refit not implemented for lists with length > 1: ", "consider ", sQuote("lapply(object, refit)")) } } oldresp <- object@resp$y # need to set this before deep copy, # otherwise it gets reset with the call # to setResp below ## somewhat repeated from profile.merMod, but sufficiently ## different that refactoring is slightly non-trivial ## "three minutes' thought would suffice ..." ignore.pars <- c("xst", "xt") control.internal <- object@optinfo$control if (length(ign <- which(names(control.internal) %in% ignore.pars)) > 0) control.internal <- control.internal[-ign] if (!is.null(newControl)) { control <- newControl if (length(control$optCtrl) == 0) control$optCtrl <- control.internal } else { control <- if (isGLMM(object)) glmerControl() else lmerControl() } ## we need this stuff defined before we call .glmerLaplace below ... pp <- object@pp$copy() dc <- object@devcomp nAGQ <- unname(dc$dims["nAGQ"]) # possibly NA # blme change nth <- dc$dims[["nth"]] verbose <- l...$verbose; if (is.null(verbose)) verbose <- 0L if (!is.null(newresp)) { ## update call and model frame with new response rcol <- attr(attr(model.frame(object), "terms"), "response") if (rename.response) { attr(object@frame,"formula")[[2]] <- object@call$formula[[2]] <- newrespSub names(object@frame)[rcol] <- deparse(newrespSub) } if (!is.null(na.act <- attr(object@frame,"na.action")) && is.null(attr(newresp, "na.action"))) { ## will only get here if na.action is 'na.omit' or 'na.exclude' ## *and* newresp does not have an 'na.action' attribute ## indicating that NAs have already been filtered newresp <- if (is.matrix(newresp)) newresp[-na.act, ] else newresp[-na.act] } object@frame[,rcol] <- newresp ## modFrame <- model.frame(object) ## modFrame[, attr(terms(modFrame), "response")] <- newresp } rr <- if (isLMM(object)) mkRespMod(model.frame(object), REML = isREML(object)) else if (isGLMM(object)) { modelFrame <- model.frame(object) ## blme change if (lme4Version <= "1.1-6") modelFrame$mustart <- object@resp$mu mkRespMod(modelFrame, family = family(object)) } else stop("refit.bmerMod not working for nonlinear mixed models") if (!is.null(newresp)) { if (family(object)$family == "binomial") { ## re-do conversion of two-column matrix and factor ## responses to proportion/weights format if (is.matrix(newresp) && ncol(newresp) == 2) { ntot <- rowSums(newresp) ## FIXME: test what happens for (0,0) rows newresp <- newresp[,1] / ntot rr$setWeights(ntot) } if (is.factor(newresp)) { ## FIXME: would be better to do this consistently with ## whatever machinery is used in glm/glm.fit/glmer ... ?? newresp <- as.numeric(newresp) - 1 } } ## if (isGLMM(object) && rr$family$family=="binomial") { ## } stopifnot(length(newresp <- as.numeric(as.vector(newresp))) == length(rr$y)) } ## hacking around to try to get internals properly set up ## for refitting. This helps, but not all the way ... ## oldresp <- rr$y # set this above from before copy ## rr$setResp(newresp) ## rr$setResp(oldresp) ## rr$setResp(newresp) glmerPwrssUpdate <- get("glmerPwrssUpdate", lme4Namespace) if (isGLMM(object)) { GQmat <- GHrule(nAGQ) if (nAGQ <= 1) { if (lme4Version <= "1.1-7") glmerPwrssUpdate(pp, rr, control$tolPwrss, GQmat) else glmerPwrssUpdate(pp, rr, control$tolPwrss, GQmat, maxit = maxit) } else { if (lme4Version <= "1.1-7") glmerPwrssUpdate(pp, rr, control$tolPwrss, GQmat, grpFac = object@flist[[1]]) else glmerPwrssUpdate(pp, rr, control$tolPwrss, GQmat, maxit = maxit, grpFac = object@flist[[1]]) } baseOffset <- object@resp$offset } ## .Call(glmerLaplace, pp$ptr(), rr$ptr(), nAGQ, ## control$tolPwrss, as.integer(30), verbose) ## nAGQ, ## control$tolPwrss, as.integer(30), # maxit = 30 ## verbose) ## lp0 <- pp$linPred(1) # each pwrss opt begins at this eta devlist <- if (isGLMM(object)) list(tolPwrss = dc$cmp [["tolPwrss"]], compDev = dc$dims[["compDev"]], nAGQ = nAGQ, lp0 = pp$linPred(1), ## object@resp$eta - baseOffset, baseOffset = baseOffset, pwrssUpdate = glmerPwrssUpdate, ## save GQmat in the object and use that instead of nAGQ GQmat = GHrule(nAGQ), fac = object@flist[[1]], pp = pp, resp = rr, u0 = pp$u0, verbose = verbose, dpars = seq_len(nth)) else list(pp = pp, resp = rr, u0 = pp$u0, verbose = verbose, dpars = seq_len(nth)) ## blme changes ff <- makeRefitDevFun(list2env(devlist), nAGQ = nAGQ, verbose = verbose, maxit = maxit, object = object) reTrms <- list(flist = object@flist, cnms = object@cnms, Gp = object@Gp, lower = object@lower) if (isGLMM(object)) ff <- updateBglmerDevfun(ff, reTrms, nAGQ) ## commenting out xst (not used) and x0, which we grab elsewhere ## xst <- rep.int(0.1, nth) ## x0 <- pp$theta ## lower <- object@lower lower <- environment(ff)$lower ## if (!is.na(nAGQ) && nAGQ > 0L) { ## xst <- c(xst, sqrt(diag(pp$unsc()))) ## x0 <- c(x0, unname(fixef(object))) ## lower <- c(lower, rep(-Inf, length(x0) - length(lower))) ##} ## blme end ## control <- c(control, list(xst = 0.2 * xst, xt = xst * 0.0001)) ## FIX ME: allow use.last.params to be passed through calc.derivs <- !is.null(object@optinfo$derivs) ## if (isGLMM(object)) { ## rho$resp$updateWts() ## rho$pp$updateDecomp() ## rho$lp0 <- rho$pp$linPred(1) ## } ## blme changes below opt <- if (isLMM(object)) { optimizeLmer(ff, optimizer = object@optinfo$optimizer, control = control$optCtrl, verbose = verbose, start = extractParameterListFromFit(object, environment(ff)$blmerControl), calc.derivs = calc.derivs, use.last.params = if (!is.null(control$use.last.params)) control$use.last.params else FALSE) } else { args <- list(devfun = ff, optimizer = object@optinfo$optimizer, start = extractParameterListFromFit(object, environment(ff)$blmerControl), nAGQ = nAGQ, boundary.tol = 1.0e-5, verbose = verbose, stage = 2) if (!is.null(formals(optimizeGlmer)[["..."]])) { args$calc.derivs <- calc.derivs args$use.last.params <- if (!is.null(control$use.last.params)) control$use.last.params else FALSE } do.call(optimizeGlmer, args, TRUE, sys.frame(0)) } cc <- NULL if (exists("checkConv", lme4Namespace)) { cc <- get("checkConv", lme4Namespace)(attr(opt,"derivs"), opt$par, ctrl = control$checkConv, lbound = lower) } if (isGLMM(object)) rr$setOffset(baseOffset) args <- list(rho = environment(ff), opt = opt, reTrms = reTrms, fr = object@frame, mc = getCall(object)) if ("lme4conv" %in% names(formals(mkMerMod))) args$lme4conv <- cc result <- do.call(mkMerMod, args, TRUE, sys.frame(0)) repackageMerMod(result, opt, environment(ff)) } blme/R/generics.R0000644000176200001440000000337612536607117013335 0ustar liggesusers## This is modeled a bit after print.summary.lm : ## Prints *both* 'mer' and 'merenv' - as it uses summary(x) mainly printBmerenv <- function(x, digits = max(3, getOption("digits") - 3), correlation = NULL, symbolic.cor = FALSE, signif.stars = getOption("show.signif.stars"), ranef.comp = c("Variance", "Std.Dev."), ...) { printPriors(x$priors, x$ngrps, digits) cat("Prior dev : ", round(x$devcomp$cmp[["penalty"]], digits), "\n\n", sep = "") printMethod <- getS3method("print", "summary.merMod") result <- printMethod(x, digits, correlation, symbolic.cor, signif.stars, ranef.comp, ...) invisible(result) } print.bmerMod <- function(x, digits = max(3, getOption("digits") - 3), correlation = NULL, symbolic.cor = FALSE, signif.stars = getOption("show.signif.stars"), ranef.comp = "Std.Dev.", ...) { printPriors(x@priors, x@cnms, digits) cat("Prior dev : ", round(x@devcomp$cmp[["penalty"]], digits), "\n\n", sep = "") printMethod <- getS3method("print", "merMod") result <- printMethod(x, digits, correlation, symbolic.cor, signif.stars, ranef.comp, ...) invisible(result) } setMethod("show", "bmerMod", function(object) print.bmerMod(object)) print.summary.bmerMod <- printBmerenv summary.bmerMod <- function(object, ...) { result <- NextMethod(.Generic, object = object, ...) result$priors <- object@priors structure(result, class = c("summary.bmerMod", "summary.merMod")) } summary.summary.bmerMod <- function(object, varcov = TRUE, ...) { getS3method("summary", "summary.merMod")(object, varcov, ...) } vcov.summary.bmerMod <- function(object, correlation = TRUE, ...) { getS3method("vcov", "summary.merMod")(object, correlation, ...) } blme/R/dist_t.R0000644000176200001440000000266112477624214013021 0ustar liggesuserssetClass("bmerTDist", representation(df = "numeric", R.scale.inv = "matrix"), contains = "bmerDist") toString.bmerTDist <- function(x, digits = getOption("digits"), ...) { scaleString <- "" scale <- crossprod(solve(x@R.scale.inv)) if (nrow(scale) > 2) { scaleString <- paste("scale = c(", toString(round(scale[1:4], digits)), ", ...)", sep = "") } else if (nrow(scale) == 2) { scaleString <- paste("scale = c(", toString(round(scale[1:4], digits)), ")", sep = "") } else { scaleString <- paste("scale = ", toString(round(scale[1], digits)), sep = "") } paste("t(df = ", x@df, ", ", scaleString, ", common.scale = ", x@commonScale, ")", sep="") } setMethod("getDFAdjustment", "bmerTDist", function(object) { if (object@commonScale == TRUE) nrow(object@R.scale.inv) else 0 } ) setMethod("getConstantTerm", "bmerTDist", function(object) { R.scale.inv <- object@R.scale.inv d <- nrow(R.scale.inv) df <- object@df -2.0 * lgamma(0.5 * (df + d)) + 2.0 * lgamma(0.5 * df) + d * (log(df) + log(pi)) - 2.0 * sum(log(diag(R.scale.inv))) } ) setMethod("getExponentialTerm", "bmerTDist", function(object, beta) { R.scale.inv <- object@R.scale.inv d <- nrow(R.scale.inv) df <- object@df dist <- tcrossprod(crossprod(beta, R.scale.inv))[1] exponential <- (df + d) * log(1 + dist / df) c(0, exponential) } ) blme/R/dist_gamma.R0000644000176200001440000001003012531667702013625 0ustar liggesuserssetClass("bmerGammaDist", representation(shape = "numeric", rate = "numeric", posteriorScale = "character"), contains = "bmerDist", validity = function(object) object@posteriorScale == "var" || object@posteriorScale == "sd") setClass("bmerInvGammaDist", representation(shape = "numeric", scale = "numeric", posteriorScale = "character"), contains = "bmerDist", validity = function(object) object@posteriorScale == "var" || object@posteriorScale == "sd") toString.bmerGammaDist <- function(x, digits = getOption("digits"), includeCommonScale = TRUE, ...) { paste("gamma(shape = ", round(x@shape, digits), ", rate = ", round(x@rate, digits), ", posterior.scale = ", x@posteriorScale, if (includeCommonScale) paste(", common.scale = ", x@commonScale, sep = "") else "", ")", sep="") } toString.bmerInvGammaDist <- function(x, digits = getOption("digits"), includeCommonScale = TRUE, ...) { paste("gamma(shape = ", round(x@shape, digits), ", scale = ", round(x@scale, digits), ", posterior.scale = ", x@posteriorScale, if (includeCommonScale) paste(", common.scale = ", x@commonScale, sep = "") else "", ")", sep="") } setMethod("getDFAdjustment", "bmerGammaDist", function(object) { if (object@commonScale) 0 else { if (object@posteriorScale == 'sd') -(object@shape - 1.0) else -2.0 * (object@shape - 1.0) } } ) setMethod("getDFAdjustment", "bmerInvGammaDist", function(object) { if (object@commonScale) 0 else { if (object@posteriorScale == 'sd') (object@shape + 1.0) else 2.0 * (object@shape + 1.0) } } ) setMethod("getConstantTerm", "bmerGammaDist", function(object) { shape <- object@shape; rate <- object@rate if (shape == 0.0 || rate == 0.0) return(0.0) if (shape < 0.0 || rate < 0.0) return(NaN) -2.0 * (shape * log(rate) - lgamma(shape)) } ) setMethod("getConstantTerm" ,"bmerInvGammaDist", function(object) { shape <- object@shape; scale <- object@scale if (shape == 0.0 || scale == 0.0) return(0.0) if (shape < 0.0 || scale < 0.0) return(NaN) -2.0 * (shape * log(scale) - lgamma(shape)) } ) setMethod("getExponentialSigmaPower", "bmerGammaDist", function (object) { if (object@commonScale || object@rate == 0) return(0) if (object@posteriorScale == "sd") 1 else 2 }) setMethod("getExponentialSigmaPower", "bmerInvGammaDist", function (object) { if (object@commonScale || object@scale == 0) return(0) if (object@posteriorScale == "sd") -1 else -2 }) setMethod("getExponentialTerm", "bmerGammaDist", function(object, lambda) { if (object@rate == 0) return (c(0, 0.0)) if (missing(lambda)) lambda <- 1.0 if (object@posteriorScale == "var") { exponential <- 2.0 * lambda^2 * object@rate power <- 2 } else { exponential <- 2.0 * lambda * object@rate power <- 1 } if (object@commonScale == TRUE) c(0, exponential) else c(power, exponential) }) setMethod("getExponentialTerm", "bmerInvGammaDist", function(object, lambda) { if (object@scale == 0) return (c(0, 0.0)) if (missing(lambda)) lambda <- 1.0 if (object@posteriorScale == "var") { exponential <- 2.0 * object@scale / lambda^2 power <- -2 } else { exponential <- 2.0 * object@scale / lambda power <- -1 } if (object@commonScale == TRUE) c(0, exponential) else c(power, exponential) }) setMethod("getPolynomialTerm", "bmerGammaDist", function(object, lambda) { if (object@posteriorScale == "var") -4 * (object@shape - 1.0) * log(lambda) else -2 * (object@shape - 1.0) * log(lambda) } ) setMethod("getPolynomialTerm", "bmerInvGammaDist", function(object, lambda) { if (object@posteriorScale == "var") 4.0 * (object@shape + 1.0) * log(lambda) else 2.0 * (object@shape + 1.0) * log(lambda) } ) blme/R/optimize.R0000644000176200001440000000631612531775450013374 0ustar liggesusers##' @rdname modular ##' @inheritParams lmer ##' @inheritParams lmerControl ##' @param devfun a deviance function, as generated by \code{\link{mkLmerDevfun}} ##' @return \bold{optimizeLmer}: Results of an optimization. ##' \cr ##' \cr ##' @export optimizeLmer <- function(devfun, optimizer = formals(lmerControl)$optimizer, restart_edge = formals(lmerControl)$restart_edge, boundary.tol = formals(lmerControl)$boundary.tol, start = NULL, verbose = 0L, control = list(), ...) { verbose <- as.integer(verbose) rho <- environment(devfun) lme4Env <- asNamespace("lme4") parInfo <- rho$parInfo startingValues <- getStartingValues(start, rho, parInfo) lowerBounds <- getLowerBounds(parInfo) rho$lower <- lowerBounds ## b/c lower bounds are pulled from devfunenv to check convergence thetaLowerBounds <- lowerBounds[1:length(rho$pp$theta)] ## if (is.null(start)) { ## start <- getStart(start, rho) ## start <- setLowerBounds(start, rho) ##} ##startingValues <- foldPars(start) ##lowerBounds <- foldLowers(start) optwrap <- get("optwrap", lme4Env) lme4IsOld <- is.null(formals(optwrap)[["calc.derivs"]]) opt <- if (!lme4IsOld) optwrap(optimizer, devfun, startingValues, lower = lowerBounds, control = control, adj = FALSE, verbose = verbose, ...) else optwrap(optimizer, devfun, startingValues, lower = lowerBounds, control = control, adj = FALSE, verbose = verbose) if (restart_edge) { ## FIXME: should we be looking at rho$pp$theta or opt$par ## at this point??? in koller example (for getData(13)) we have ## rho$pp$theta=0, opt$par=0.08 if (length(bvals <- which(rho$pp$theta==thetaLowerBounds))>0) { par <- opt$par ## *don't* use numDeriv -- cruder but fewer dependencies, no worries ## about keeping to the interior of the allowed space theta0 <- new("numeric",rho$pp$theta) ## 'deep' copy ... d0 <- devfun(par) btol <- 1e-5 ## FIXME: make user-settable? bgrad <- sapply(bvals, function(i) { bndval <- rho$lower[i] par[1:length(theta0)] <- theta0 par[i] <- bndval+btol (devfun(par)-d0)/btol }) ## what do I need to do to reset rho$pp$theta to original value??? par[1:length(theta0)] <- theta0 devfun(par) ## reset rho$pp$theta after tests ## FIXME: allow user to specify ALWAYS restart if on boundary? if (any(bgrad<0)) { if (verbose) message("some theta parameters on the boundary, restarting") opt <- if (!lme4IsOld) optwrap(optimizer, devfun, opt$par, lower = lowerBounds, control = control, adj = FALSE, verbose = verbose, ...) else optwrap(optimizer, devfun, opt$par, lower = lowerBounds, control = control, adj = FALSE, verbose = verbose) } } } if (!is.null(boundary.tol) && boundary.tol > 0) { if (exists("check.boundary", lme4Env)) opt <- get("check.boundary", lme4Env)(rho, opt, devfun, boundary.tol) } return(opt) } blme/R/dist_point.R0000644000176200001440000000036112531670062013673 0ustar liggesuserssetClass("bmerPointDist", representation(value = "numeric"), contains = "bmerDist") toString.bmerPointDist <- function(x, digits = getOption("digits"), ...) paste("point(value = ", round(x@value, digits), ")", sep = "") blme/R/dist.R0000644000176200001440000003156712531670473012504 0ustar liggesuserssetClass("bmerDist", representation(commonScale = "logical"), contains = "VIRTUAL") if (!isGeneric("getDFAdjustment")) setGeneric("getDFAdjustment", function(object, ...) standardGeneric("getDFAdjustment")) if (!isGeneric("getConstantTerm")) setGeneric("getConstantTerm", function(object, ...) standardGeneric("getConstantTerm")) ## what power sigma has if prior induces exp(-0.5 * sigma^pow * stuff) if (!isGeneric("getExponentialSigmaPower")) setGeneric("getExponentialSigmaPower", function(object, ...) standardGeneric("getExponentialSigmaPower")) ## whatever is going on in the exponent, and what power sigma has connected with it ## note, relative to 1 / 2 if (!isGeneric("getExponentialTerm")) setGeneric("getExponentialTerm", function(object, ...) standardGeneric("getExponentialTerm")) if (!isGeneric("getPolynomialTerm")) setGeneric("getPolynomialTerm", function(object, ...) standardGeneric("getPolynomialTerm")) setMethod("getDFAdjustment", "ANY", function(object, ...) 0) setMethod("getConstantTerm", "ANY", function(object, ...) 0) setMethod("getExponentialSigmaPower", "ANY", function(object, ...) 0) setMethod("getExponentialTerm", "ANY", function(object, ...) c(0, 0)) setMethod("getPolynomialTerm", "ANY", function(object, ...) 0) fixefDistributions <- c("flat", "normal", "t") covDistributions <- c("flat", "wishart", "invwishart", "gamma", "invgamma", "custom") residDistributions <- c("flat", "gamma", "invgamma", "point") lmmDistributions <- list( flat = function() NULL, normal = function(sd = c(10, 2.5), cov, common.scale = TRUE) { matchedCall <- match.call() if (!is.null(matchedCall$sd)) sd <- eval(matchedCall$sd) if (!is.null(matchedCall$cov)) cov <- eval(matchedCall$cov) if (!is.null(matchedCall$sd) && !is.null(matchedCall$cov)) warning("both sd and cov supplied to normal - only cov will be used") common.scale <- blme:::deparseCommonScale(common.scale) if (missing(cov) && !is.null(sd)) { sd <- sd^2 if (length(sd) == 1) { cov <- diag(sd, p) } else if (length(sd) == 2) { cov <- diag(sd[c(1, rep(2, p - 1))], p) } else { sd <- rep(sd, p %/% length(sd) + 1)[1:p] cov <- diag(sd, p) } } if (missing(cov) || is.null(cov)) { stop("normal prior requires either sd or cov to be specified") } if (length(cov) == p) { cov <- diag(cov, p) } else if (length(cov) != p^2) { stop("normal prior covariance of improper length") } if (any(cov != t(cov))) stop("normal covariance not symmetric") logDet <- determinant(cov, TRUE) if (logDet$sign < 0 || is.infinite(logDet$modulus)) stop("normal prior covariance negative semi-definite") new("bmerNormalDist", commonScale = common.scale, R.cov.inv = solve(chol(cov))) }, t = function(df = 3, scale = c(10^2, 2.5^2), common.scale = TRUE) { matchedCall <- match.call() if (!is.null(matchedCall$df)) df <- eval(matchedCall$df) if (!is.null(matchedCall$scale)) scale <- eval(matchedCall$scale) common.scale <- blme:::deparseCommonScale(common.scale) if (df <= 0) stop("t prior requires positive degrees of freedom") if (length(scale) == 1) { scale <- diag(scale, p) } else if (length(scale) == 2) { scale <- diag(scale[c(1, rep(2, p - 1))], p) } else if (length(scale) == p) { scale <- diag(scale, p) } else if (length(scale) != p^2) { stop("t prior scale of improper length") } if (any(scale != base::t(scale))) stop("t scale not symmetric") logDet <- determinant(scale, TRUE) if (logDet$sign < 0 || is.infinite(logDet$modulus)) stop("t prior scale negative semi-definite") new("bmerTDist", commonScale = common.scale, df = df, R.scale.inv = solve(chol(scale))) }, gamma = function(shape = 2.5, rate = 0, common.scale = TRUE, posterior.scale = "sd") { matchedCall <- match.call() if (!is.null(matchedCall$shape)) shape <- eval(matchedCall$shape) if (!is.null(matchedCall$rate)) rate <- eval(matchedCall$rate) common.scale <- blme:::deparseCommonScale(common.scale) if (level.dim > 1) { warning("gamma prior applied to multivariate grouping level will be ignored") return(NULL) } if (shape < 0) stop("gamma requires a shape >= 0") if (rate < 0) stop("gamma requires a rate >= 0") new("bmerGammaDist", commonScale = common.scale, shape = shape, rate = rate, posteriorScale = posterior.scale) }, invgamma = function(shape = 0.001, scale = shape + 0.05, common.scale = TRUE, posterior.scale = "var") { matchedCall <- match.call() if (!is.null(matchedCall$shape)) shape <- eval(matchedCall$shape) if (!is.null(matchedCall$scale)) scale <- eval(matchedCall$scale) common.scale <- blme:::deparseCommonScale(common.scale) if (level.dim > 1) { warning("inverse gamma prior applied to multivariate grouping level will be ignored") return(NULL) } if (shape < 0) stop("invgamma requires a shape >= 0") if (scale < 0) stop("invgamma requires a scale >= 0") new("bmerInvGammaDist", commonScale = common.scale, shape = shape, scale = scale, posteriorScale = posterior.scale) }, wishart = function(df = level.dim + 2.5, scale = Inf, common.scale = TRUE, posterior.scale = "cov") { matchedCall <- match.call() if (!is.null(matchedCall$df)) df <- eval(matchedCall$df) if (!is.null(matchedCall$scale)) scale <- eval(matchedCall$scale) common.scale <- blme:::deparseCommonScale(common.scale) if (df <= level.dim - 1) stop("wishart dists for degrees of freedom less than or equal to (level.dim - 1) are singular or non-existent") log.det.scale <- NULL if (length(scale) == 1) { if (is.infinite(scale)) { R.scale.inv <- diag(0, level.dim) log.det.scale <- Inf } else { if (scale[1] < 0) stop("wishart prior scale negative definite") R.scale.inv <- diag(1 / sqrt(scale[1]), level.dim) } } else if (length(scale) == level.dim) { if (any(scale < 0)) stop("wishart prior scale negative definite") R.scale.inv <- diag(1 / sqrt(scale), level.dim) } else if (length(scale) != level.dim^2) { stop("wishart prior scale of improper length") } else { if (all(is.infinite(scale))) { R.scale.inv <- diag(0, level.dim) log.det.scale <- Inf } R.scale.inv <- solve(chol(scale)) } if (is.null(log.det.scale)) { if (any(diag(R.scale.inv) < 0)) stop("wishart prior scale negative definite") if (any(is.infinite(diag(R.scale.inv)))) log.det.scale <- Inf else log.det.scale <- -2.0 * sum(log(diag(R.scale.inv))) } new("bmerWishartDist", commonScale = common.scale, df = df, R.scale.inv = R.scale.inv, log.det.scale = log.det.scale, posteriorScale = posterior.scale) }, invwishart = function(df = level.dim - 0.998, scale = diag(df + 0.1, level.dim), common.scale = TRUE, posterior.scale = "cov") { matchedCall <- match.call() if (!is.null(matchedCall$df)) df <- eval(matchedCall$df) if (!is.null(matchedCall$scale)) scale <- eval(matchedCall$scale) common.scale <- blme:::deparseCommonScale(common.scale) if (df <= level.dim - 1) stop("inverse wishart dists for degrees of freedom less than or equal to (level.dim - 1) are singular or non-existent") log.det.scale <- NULL if (length(scale) == 1) { if (scale == 0) { R.scale <- diag(0, level.dim) log.det.scale <- -Inf } else { if (scale[1] < 0) stop("inverse wishart prior scale negative definite") R.scale <- diag(sqrt(scale[1]), level.dim) } } else if (length(scale) == level.dim) { if (any(scale < 0)) stop("inverse wishart prior scale negative definite") R.scale <- diag(sqrt(scale), level.dim) } else if (length(scale) != level.dim^2) { stop("inverse wishart prior scale of improper length") } else { if (all(scale == 0)) { R.scale <- diag(0, level.dim) log.det.scale <- -Inf } R.scale <- chol(scale) } if (is.null(log.det.scale)) { if (any(diag(R.scale) < 0)) stop("inverse wishart prior scale negative definite") if (any(diag(R.scale) == 0)) log.det.scale <- -Inf else log.det.scale <- 2.0 * sum(log(diag(R.scale))) } new("bmerInvWishartDist", commonScale = common.scale, df = df, R.scale = R.scale, log.det.scale = log.det.scale, posteriorScale = posterior.scale) }, point = function(value = 1.0, posterior.scale = "sd") { matchedCall <- match.call() if (!is.null(matchedCall$value)) value <- eval(matchedCall$value) if (!(posterior.scale %in% c("sd", "var"))) stop("point prior scale '", posterior.scale, "' unrecognized") if (posterior.scale == "var") value <- sqrt(value) if (value <= 0) stop("residual variance must be positive") new("bmerPointDist", commonScale = FALSE, value = value) }, custom = function(fn, chol = FALSE, common.scale = TRUE, scale = "none") { matchedCall <- match.call() if (!is.null(matchedCall$chol)) chol <- eval(matchedCall$chol) if (!is.null(matchedCall$scale)) scale <- eval(matchedCall$scale) common.scale <- blme:::deparseCommonScale(common.scale) new("bmerCustomDist", fnName = matchedCall$fn, fn = fn, chol = chol, scale = scale, commonScale = common.scale) } ) ## closure out the common scale param glmmDistributions <- list( flat = lmmDistributions$flat, normal = function(sd = c(10, 2.5), cov) { normal <- blme:::lmmDistributions$normal environment(normal) <- environment() matchedCall <- match.call() if (!is.null(matchedCall$sd) && !is.null(matchedCall$cov)) warning("both sd and cov supplied to normal - only cov will be used") if (!is.null(matchedCall$cov)) { cov <- eval(matchedCall$cov) return(normal(cov = cov, common.scale = FALSE)) } if (!is.null(matchedCall$sd)) sd <- eval(matchedCall$sd) normal(sd = sd, common.scale = FALSE) }, t = function(df = 3, scale = c(10^2, 2.5^2)) { t <- blme:::lmmDistributions$t environment(t) <- environment() matchedCall <- match.call() if (!is.null(matchedCall$df)) df <- eval(matchedCall$df) if (!is.null(matchedCall$scale)) scale <- eval(matchedCall$scale) t(df = df, scale = scale, common.scale = FALSE) }, gamma = function(shape = 2.5, rate = 0, posterior.scale = "sd") { gamma <- blme:::lmmDistributions$gamma environment(gamma) <- environment() gamma(shape, rate, TRUE, posterior.scale) }, invgamma = function(shape = 0.5, scale = 10^2, posterior.scale = "sd") { invgamma <- blme:::lmmDistributions$invgamma environment(invgamma) <- environment() invgamma(shape, scale, TRUE, posterior.scale) }, wishart = function(df = level.dim + 2.5, scale = Inf, common.scale = TRUE, posterior.scale = "cov") { wishart <- blme:::lmmDistributions$wishart environment(wishart) <- environment() wishart(df, scale, TRUE, posterior.scale) }, invwishart = function(df = level.dim - 0.5, scale = diag(10^2 / (df + level.dim + 1), level.dim), common.scale = TRUE, posterior.scale = "cov") { invwishart <- blme:::lmmDistributions$invwishart environment(invwishart) <- environment() invwishart(df, scale, TRUE, posterior.scale) }, custom = function(fn, chol = FALSE, scale = "none") { custom <- blme:::lmmDistributions$custom environment(custom) <- environment() custom(fn, chol, scale, TRUE) } ) residualVarianceGammaPrior <- function(shape = 0, rate = 0, posterior.scale = "var") { matchedCall <- match.call() if (!is.null(matchedCall$shape)) shape <- eval(matchedCall$shape) if (!is.null(matchedCall$rate)) rate <- eval(matchedCall$rate) if (shape < 0) stop("gamma requires a shape >= 0") if (rate < 0) stop("gamma requires a rate >= 0") new("bmerGammaDist", commonScale = FALSE, shape = shape, rate = rate, posteriorScale = posterior.scale) } residualVarianceInvGammaPrior <- function(shape = 0, scale = 0, posterior.scale = "var") { matchedCall <- match.call() if (!is.null(matchedCall$shape)) shape <- eval(matchedCall$shape) if (!is.null(matchedCall$scale)) scale <- eval(matchedCall$scale) if (shape < 0) stop("invgamma requires a shape >= 0") if (scale < 0) stop("invgamma requires a scale >= 0") new("bmerInvGammaDist", commonScale = FALSE, shape = shape, scale = scale, posteriorScale = posterior.scale) } ## rather annoying problem of legacy interface allowing character strings of "true" or ## what not deparseCommonScale <- function(common.scale) { if (is.null(common.scale)) return(TRUE) if (is.character(common.scale)) { if (common.scale == "TRUE" || common.scale == "true") return(TRUE) if (common.scale == "FALSE" || common.scale == "false") return(FALSE) return(eval(parse(text = common.scale)[[1]])) } common.scale } blme/R/util.R0000644000176200001440000000175312532115105012473 0ustar liggesusersgetCovBlocks <- function(cov, ranefStructure) { index <- 0 result <- list() for (i in 1:ranefStructure$numFactors) { result[[i]] <- as.matrix(cov[index + 1:ranefStructure$numCoefPerFactor[i], index + 1:ranefStructure$numCoefPerFactor[i]]) index <- index + ranefStructure$numRanefPerFactor[i] } return(result) } ## from lme4 namedList <- function(...) { result <- list(...) substituteNames <- sapply(substitute(list(...)), deparse)[-1] if (is.null(resultNames <- names(result))) resultNames <- substituteNames if (any(noNames <- resultNames == "")) resultNames[noNames] <- substituteNames[noNames] setNames(result, resultNames) } is.formula <- function(term) is.language(term) && term[[1]] == '~' #quoteInNamespace <- function(name, character.only = FALSE) { # result <- quote(a + b) # result[[1]] <- as.symbol(":::") # result[[2]] <- as.symbol("blme") # # result[[3]] <- if (character.only) name else match.call()[[2]] # result #} blme/R/parameters.R0000644000176200001440000001002112532111277013653 0ustar liggesusers## "parInfo" is a named list, each member also being a list containing ## length ## default - function of rho, aka the environment of the dev fun ## lower - lower bounds for par ## the order of elements in it is the order that they are passed to the optimizer ## not that that should matter to a downstream user. if they care, construct it by ## index ## for models with a single parameter vector, the name "theta" is sufficient ## so we can return without further analysis expandParsInCurrentFrame <- function(parVector, parInfo) { if (length(parInfo) == 1) return(invisible(NULL)) parentEnv <- parent.frame() parNames <- names(parInfo) index <- 0 for (i in 1:length(parInfo)) { parLength <- parInfo[[i]]$length parName <- parNames[[i]] parentEnv[[parName]] <- parVector[index + 1:parLength] index <- index + parLength } invisible(NULL) } getStartingValues <- function(userStart, devFunEnv, parInfo) { if (is.null(userStart)) userStart <- list() if (is.numeric(userStart)) userStart <- list(theta = userStart) if (is.list(userStart) && length(userStart) == 1 && is.null(names(userStart))) names(userStart) <- "theta" invalidStartingValues <- !(names(userStart) %in% names(parInfo)) if (any(invalidStartingValues)) warning("starting values for parameter(s) '", toString(names(userStart)[invalidStartingValues]), "' not part of model and will be ignored") start <- numeric(sum(sapply(parInfo, function(par.i) par.i$length))) offset <- 0L for (i in 1:length(parInfo)) { parName <- names(parInfo)[[i]] parLength <- parInfo[[i]]$length userValue <- userStart[[parName]] useDefault <- TRUE if (!is.null(userValue)) { if (length(userValue) != parLength) { warning("parameter '", parName, "' is of length ", parLength, ", yet supplied vector is of length ", length(userValue), ". start will be ignored") } else { start[offset + 1:parLength] <- userValue useDefault <- FALSE } } if (useDefault) start[offset + 1:parLength] <- parInfo[[i]]$default(devFunEnv) offset <- offset + parLength } start } extractParameterListFromFit <- function(fit, blmerControl) { result <- list(theta = fit@theta) if (blmerControl$fixefOptimizationType == FIXEF_OPTIM_NUMERIC) { if (fit@devcomp$dims[["GLMM"]] != 0L) result$fixef <- fit@beta else result$beta <- fit@beta } if (fit@devcomp$dims[["GLMM"]] == 0L && blmerControl$fixefOptimizationType == SIGMA_OPTIM_NUMERIC) { result$sigma <- if (fit@devcomp$dims[["REML"]] == 0L) fit@devcomp$cmp[["sigmaML"]] else fit@devcomp$cmp[["sigmaREML"]] } result } getLowerBounds <- function(parInfo) { result <- numeric(sum(sapply(parInfo, function(par.i) par.i$length))) offset <- 0L for (i in 1:length(parInfo)) { parName <- names(parInfo)[[i]] parLength <- parInfo[[i]]$length parLower <- parInfo[[i]]$lower if (parLength != length(parLower)) stop("length of lower bounds for parameter '", parName, "' does not equal length of vector") result[offset + 1:parLength] <- parLower offset <- offset + parLength } result } getParInfo <- function(pred, resp, ranefStructure, blmerControl) { numPars <- 1 result <- list(theta = list(length = ranefStructure$numCovParameters, lower = ranefStructure$lower, default = function(devFunEnv) pred$theta)) if (blmerControl$fixefOptimizationType == FIXEF_OPTIM_NUMERIC) { numPars <- numPars + 1 numFixef <- if (length(pred$X) > 0) ncol(pred$X) else 0 result[[numPars]] <- list(length = numFixef, lower = rep(-Inf, numFixef), default = function(devFunEnv) pred$beta0 + pred$delb) names(result)[[numPars]] <- "beta" } if (blmerControl$sigmaOptimizationType == SIGMA_OPTIM_NUMERIC) { numPars <- numPars + 1 result[[numPars]] <- list(length = 1L, lower = 0, default = function(devFunEnv) sd(resp$y)) names(result)[[numPars]] <- "sigma" } result } blme/README.md0000644000176200001440000000162612532325466012465 0ustar liggesusersblme ==== Bayesian Linear Mixed Effect Models A package for R. Built off of 'lme4' (http://cran.r-project.org/web/packages/lme4/index.html) Pre-built binaries of the package are available on http://cran.r-project.org/web/packages/blme/index.html. These can be installed from within R using the typical `install.packages()` mechanism. Steps to install from source: 1. Install development tools for your operating system: 1. Linux/Unix should already have this installed 2. OS X: 1. Xcode (https://developer.apple.com/xcode/downloads/) 2. gfortran (https://gcc.gnu.org/wiki/GFortranBinaries#MacOS) 3. Windows: Rtools (http://cran.r-project.org/bin/windows/Rtools/) 4. (This step may be omitted if all upstream dependencies are already available) 2. Install the devtools package from within R: `install.packages("devtools")` 3. Run: `install_github("vdorie/blme")` blme/MD50000644000176200001440000000413612537135352011513 0ustar liggesuserse09fa27bd130c20feae65866a847f007 *ChangeLog b77e11bfcb9d5562f35ca80714594177 *DESCRIPTION 9b475e43b94f28d4c0b2d64db20f88c9 *NAMESPACE 0c9008cb11be04f2d73fc012ace594c7 *R/AllClass.R c25aa5a3ac937042f20208742adc734e *R/blmer.R 477164ed17b96e8515f3ae28121bacac *R/control.R d59b73e50929793455bfb83b716a5307 *R/devFun.R 584805ab8926c4a46cf914608642e276 *R/dist.R a914b08748e50e2989ffba35d181d996 *R/dist_custom.R d8abd8c0ff925982860aa55eb7caa1c2 *R/dist_gamma.R 0fd4b71220ab0d2e0cb4864ef15b1273 *R/dist_normal.R 61d9f7374b392d826acdd52864fbf861 *R/dist_point.R 6d27e2a218962a5f1419a0741420c582 *R/dist_t.R 7c8fda83f545e270c8de78f12d2a2262 *R/dist_wishart.R 7ade0ade7c4b7eea5411a0ccecebbafe *R/generics.R 5622103d77c16e93c912560624f50f0d *R/optimize.R eff56bea27e3a1fe2ed0b46a97132d54 *R/parameters.R e6c1c6fbfe4dfdd7bd4c2f0f18a60306 *R/priorEval.R 5cc64020ad8fe30617dc9bdfa6320d3f *R/string.R d8155ee72667b9d5bb190ed733cca69d *R/util.R 31d5b4efed69e616fb64883a3526c3f2 *README.md 11736e486101b008e30da58754f3e81c *ToDo 5a048275a28cbb9c02819acd3f257eaa *inst/CITATION 6f7a24a171895cd167d92dce6ee2dc70 *inst/common/checkWarning.R cd4c9728d3ce9acbac622559c57e1224 *inst/common/glmmData.R 5b5b5d726ca3f2139eb91fbeca696d1b *inst/common/lmmData.R d0ca0cb3e2b2f475a28f03f6e5c5150b *man/blmer.Rd ac027e4c1b4b18917fc54d6fc4d1acbe *man/bmerDist-class.Rd 50101bfe271bb70f1c71aa53062eeb33 *man/bmerMod-class.Rd ec4ab5f4a812c5d7e62329b2decffce8 *tests/test-all.R e9d84cb2aefec2c5aadbdef804f0b3c9 *tests/testthat/test-01-lmm.R 03c7a1b6f390dd599dfa2cee0191811d *tests/testthat/test-02-glmm.R 635ffc0a9ba15d70ab0664e25fbe588e *tests/testthat/test-03-resid_errors.R f8c39c75de862fc22ec9e6b3ac1dfda0 *tests/testthat/test-04-fixef_errors.R df20eec483386f2095be88981173c474 *tests/testthat/test-05-covariance_errors.R 3005757e4cc8b841aa8881805f60e1da *tests/testthat/test-06-lmm_resid.R aa12cb69e0e09255ac9c90235b417bbb *tests/testthat/test-07-lmm_fixef.R 9543fd088363adbcb7ab873696a3489d *tests/testthat/test-08-lmm_covariance.R c5dd4ea726fef672b009fab0d7105d71 *tests/testthat/test-09-glmm_priors.R f37cbc37d580ae1c2c2db8cbd038fa5d *tests/testthat/test-10-refit.R blme/DESCRIPTION0000644000176200001440000000132112537135352012702 0ustar liggesusersPackage: blme Version: 1.0-4 Date: 2015-06-13 Title: Bayesian Linear Mixed-Effects Models Author: Vincent Dorie Maintainer: Vincent Dorie Description: Maximum a posteriori estimation for linear and generalized linear mixed-effects models in a Bayesian setting. Extends 'lme4' by Douglas Bates, Martin Maechler, Ben Bolker, and Steve Walker. Depends: R (>= 3.0-0), lme4 (>= 1.0-6) Imports: methods, stats, utils Suggests: testthat (>= 0.9-0) License: GPL (>= 2) URL: https://github.com/vdorie/blme BugReports: https://github.com/vdorie/blme/issues NeedsCompilation: no Packaged: 2015-06-13 17:22:47 UTC; vdorie Repository: CRAN Date/Publication: 2015-06-14 01:21:14 blme/ChangeLog0000644000176200001440000000671212531710201012741 0ustar liggesusers2015-05-28 Vincent Dorie * Changed testing framework to testthat from RUnit * Brought parity with lme4 1.1-8 * Overload refit generic so that it gets the correct deviance function 2015-03-10 Vincent Dorie * Fixed bug with t prior display on scalar variable 2014-08-14 Vincent Dorie * Now correctly stores lme4 convergence warnings 2014-07-09 Vincent Dorie * added CITATION file 2014-02-05 16:56 Vincent Dorie * Brought to parity with the latest lme4 release (1.1-6). * Bug fixes: quadratic term for normal priors calculated incorrectly when using non-zero correlations glmms could fail to apply full penalty term for mixed use of covariance priors * New features: t priors for fixed effects custom priors for ranef covariances 2013-09-13 03:30 Vincent Dorie * Complete re-write for lme4 version 1.0. 2013-08-12 10:25 Vincent Dorie * Minor addition to testing suite set of functions. Upgraded to lme4 0.999999-2. * Changed dependency to lme4.0. 2012-11-13 10:25 Vincent Dorie * Common scale is now optional for random effect covariance, specified with the "common.scale" parameter and taking values TRUE/FALSE. * Covariance priors can now all be improper. * Common scale prior can now be inverse gamma on sd, or gamma. * Reworked how the penalized weighted residual sum of squares is calculated, as it may not make sense depending on what priors are used. * Brought to parity with the latest version of lme4, 0.999999 or so. * Eliminated a false zero problem wherein the optimizer takes an initial step to the boundary and get stuck due to a flat likelihood. 2012-10-13 10:11 Vincent Dorie * 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. ** * 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. * Fixed a few typos in the documentation. * Cleaned up imports from NAMESPACE file. * Replaced a .Internal call. 2012-03-09 13:01 Vincent Dorie * Fixed off-by one bug on termination of the optimization loop which caused gradient evaluation steps to be reported a the maximum. * REML optimization for sigma with a fixef prior was slightly off. * sigma now accepts inverse gamma priors (improper, as well). * Internal version of sim(). 2011-12-15 17:40 Vincent Dorie * 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. 2011-11-15 17:03 Vincent Dorie * Fixed a bug related to the scaling of priors to the data in the presence of interactions. * Added point priors on the common scale, enabling meta-analyses. 2010-12-19 19:27 Vincent Dorie * Initial version. blme/man/0000755000176200001440000000000012535631562011754 5ustar liggesusersblme/man/bmerMod-class.Rd0000644000176200001440000000264612213446234014734 0ustar liggesusers\docType{class} \name{bmerMod-class} \title{Class "bmerMod" of Fitted Mixed-Effect Models} \alias{blmerMod-class} \alias{bglmerMod-class} \alias{bmerMod} \alias{bmerMod-class} \alias{print.bmerMod} \alias{print.summary.bmerMod} \alias{show,bmerMod-method} \alias{show.bmerMod} \alias{summary.bmerMod} \alias{summary.summary.bmerMod} \alias{vcov.summary.bmerMod} \description{The \code{bmerMod} class represents linear or generalized linear or nonlinear mixed-effects models with possible priors over model components. It inherits from the \code{\linkS4class{merMod}} class. } \section{Objects from the Class}{ Objects are created by calls to \code{\link{blmer}} or \code{\link{bglmer}}. } \section{Slots}{ A \code{bmerMod} object contains one additional slot beyond the base \code{merMod} class: \describe{ \item{\code{priors}:}{A named list comprised of \code{covPriors}, \code{fixefPrior}, and \code{residPrior}.} } In addition, the \code{devcomp} slot, element \code{cmp} includes the \code{penalty} item which is the computed deviance for the priors. Add this to the regular deviance to obtain the value of the objective function that is used in optimization. } \seealso{ \code{\link{blmer}} and \code{\link{bglmer}}, which produce these objects. \cr \code{\linkS4class{merMod}}, from which this class inherits. } \examples{ showClass("bmerMod") methods(class = "bmerMod") } \keyword{classes} blme/man/bmerDist-class.Rd0000644000176200001440000001564312303750270015117 0ustar liggesusers\docType{class} \name{bmerDist-class} \title{Bayesian Linear Mixed-Effects Model Prior Representations and bmer*Dist Methods} % Classes \alias{bmerDist} \alias{bmerDist-class} % Methods \alias{print,bmerDist-method} \alias{show,bmerDist-method} \description{Objects created in the initialization step of a \pkg{blme} model that represent the type of prior being applied.} \section{Objects from the Class}{Objects can be created by calls of the form \code{new("bmerPrior", ...)} or, more commonly, as side effects of the \code{\link{blmer}} and \code{\link{bglmer}} functions. When using the main \code{blme} functions, the prior-related arguments can be passed what essentially are function calls with the distinction that they are delayed in evaluation until information about the model is available. At that time, the functions are \emph{defined} in a special environment and then \emph{evaluated} in an environment that directly inherits form the one in which \code{blmer} or \code{bglmer} was called. This is reflected in some of the prototypes of various prior-creating functions which depend on parameters not available in the top-level environment. Finally, if the trailing parentheses are omitted from a \code{blmer}/\code{bglmer} prior argument, they are simply added as a form of \dQuote{syntactic sugar}. } \section{Prior Distributions}{ This section lists the prototypes for the functions that are called to parse a prior during a model fit. \strong{Fixed Effect Priors} \itemize{ \item \code{normal(sd = c(10, 2.5), cov, common.scale = TRUE)} Applies a Gaussian prior to the fixed effects. Normal priors are constrained to have a mean of 0 - non-zero priors are equivalent to shifting covariates. The covariance hyperparameter can be specified either as a vector of standard deviations, using the \code{sd} argument, a vector of variances using the \code{cov} argument, or the entire variance/covariance matrix itself. When specifying standard deviations, a vector of length less than the number of fixed effects will have its tail repeated, while the first element is assumed to apply only to the intercept term. So in the default of \code{c(10, 2.5)}, the intercept receives a standard deviation of 10 and the various slopes are all given a standard deviation of 2.5. The \code{common.scale} argument specifies whether or not the prior is to be interpretted as being on the same scale as the residuals. To specify a prior in an absolute sense, set to \code{FALSE}. Argument is only applicable to linear mixed models. \item \code{t(df = 3, scale = c(10^2, 2.5^2), common.scale = TRUE)} The degrees of freedom - \code{df} argument - must be positive. If \code{scale} is of length 1, it is repeated along the diagonal for every component. Length 2 repeats just the second element for all slopes. Length equal to the number of fixed effects sees the vector simply turned into a diagonal matrix. Finally, it can a full scale matrix, so long as it is positive definite. \code{t} priors for linear mixed models require that the fixed effects be added to set of parameters that are numerically optimized, and thus can substantially increase running time. In addition, when \code{common.scale} is \code{TRUE}, the residual variance must be numerically optimized as well. \code{normal} priors on the common scale can be fully profiled and do not suffer from this drawback. At present, \code{t} priors cannot be used with the \code{REML = TRUE} argument as that implies an integral without a closed form solution. } \strong{Covariance Priors} \itemize{ \item \code{gamma(shape = 2.5, rate = 0, common.scale = TRUE, posterior.scale = "sd")} Applicable only for univariate grouping factors. A rate of \code{0} or a shape of \code{0} imposes an improper prior. The posterior scale can be \code{"sd"} or \code{"var"} and determines the scale on which the prior is meant to be applied. \item \code{invgamma(shape = 0.5, scale = 10^2, common.scale = TRUE, posterior.scale = "sd")} Applicable only for univariate grouping factors. A scale of \code{0} or a shape of \code{0} imposes an improper prior. Options are as above. \item \code{wishart(df = level.dim + 2.5, scale = Inf, common.scale = TRUE, posterior.scale = "cov")} A scale of \code{Inf} or a shape of \code{0} imposes an improper prior. The behavior for singular matrices with only some infinite eigenvalues is undefined. Posterior scale can be \code{"cov"} or \code{"sqrt"}, the latter of which applies to the unique matrix root that is also a valid covariance matrix. \item \code{invwishart(df = level.dim - 0.5, scale = diag(10^2 / (df + level.dim + 1), level.dim), common.scale = TRUE, posterior.scale = "cov")} A scale of \code{0} or a shape of \code{0} imposes an improper prior. The behavior for singular matrices with only some zero eigenvalues is undefined. \item \code{custom(fn, chol = FALSE, common.scale = TRUE, scale = "none")} Applies to the given function (\code{fn}). If \code{chol} is \code{TRUE}, \code{fn} is passed a \emph{right} factor of covariance matrix; \code{FALSE} results in the matrix being passed directly. \code{scale} can be \code{"none"}, \code{"log"}, or \code{"dev"} corresponding to \eqn{p(\Sigma)}, \eqn{\log p(\Sigma)}{log p(\Sigma)}, and \eqn{-2 \log p(\Sigma)}{-2 log p(\Sigma)} respectively. Since the prior is may have an arbitrary form, setting \code{common.scale} to \code{FALSE} for a linear mixed model means that full profiling may no longer be possible. As such, that parameter is numerically optimized. } \strong{Residual Variance Priors} \itemize{ \item \code{point(value = 1.0, posterior.scale = "sd")} Fixes the parameter to a specific value given as either an \code{"sd"} or a \code{"var"}. \item \code{gamma(shape = 0, rate = 0, posterior.scale = "var")} As above with different defaults. \item \code{invgamma(shape = 0, scale = 0, posterior.scale = "var")} As above with different defaults. } } \section{Evaluating Environment}{ The variables that the defining environment have populated are: \itemize{ \item \code{p} aliased to \code{n.fixef} - the number of fixed effects \item \code{n} aliased to \code{n.obs} - the number of observations \item \code{q.k} aliased to \code{level.dim} - for covariance priors, the dimension of the grouping factor/grouping level \item \code{j.k} aliased to \code{n.grps} - also for covariance priors, the number of groups that comprise a specific grouping factor } } \section{Methods}{ \describe{ \item{toString}{Pretty-prints the distribution and its parameters.} } } \seealso{ \code{\link{blmer}()} and \code{\link{bglmer}()}, which produce these objects, and \code{\link{bmerMod-class}} objects which contain them. } \keyword{classes} blme/man/blmer.Rd0000644000176200001440000001575612535631562013362 0ustar liggesusers\name{blme} \alias{blmer} \alias{bglmer} \concept{GLMM}% << so it's found \concept{NLMM}% << so it's found \title{Fit Bayesian Linear and Generalized Linear Mixed-Effects Models} \description{ Maximum a posteriori estimation for linear and generalized linear mixed-effects models in a Bayesian setting. Built off of \code{\link[lme4]{lmer}}. } \usage{ blmer(formula, data, REML = TRUE, control = lmerControl(), start = NULL, verbose = 0L, subset, weights, na.action, offset, contrasts = NULL, devFunOnly = FALSE, cov.prior = wishart, fixef.prior = NULL, resid.prior = NULL, \dots) bglmer(formula, data, family = gaussian, control = glmerControl(), start = NULL, verbose = 0L, maxit = 100L, nAGQ = 1L, subset, weights, na.action, offset, contrasts = NULL, mustart, etastart, devFunOnly = FALSE, cov.prior = wishart, fixef.prior = NULL, \dots) } \arguments{ \item{cov.prior}{a BLME \link[=bmerDist-class]{prior} or list of priors with allowable distributions: \code{wishart}, \code{invwishart}, \code{gamma}, \code{invgamma}, or \code{NULL}. Imposes a prior over the covariance of the random effects/modeled coefficients. Default is \code{wishart}. The \code{NULL} argument imposes flat priors over all relevant parameters.} \item{fixef.prior}{a BLME prior of family \code{normal}, \code{t}, or \code{NULL}. Imposes a prior over the fixed effects/modeled coefficients. Default is \code{NULL}.} \item{resid.prior}{a BLME prior of family \code{gamma}, \code{invamma}, \code{point} or \code{NULL}. Imposes a prior over the noise/residual variance, also known as common scale parameter or the conditional variance given the random effects. Default is \code{NULL}.} \item{start}{like the \code{start} arguments for \code{\link[lme4]{lmer}} and \code{\link[lme4]{glmer}} a numeric vector or named list. Unlike the aforementioned, list members of \code{fixef} and \code{sigma} are applicable to linear mixed models provided that numeric optimization is required for these parameters.} \item{formula, data, REML, family, control, verbose, maxit, nAGQ, mustart, etastart, devFunOnly, \dots}{model specification arguments as in \code{\link[lme4]{lmer}} and \code{\link[lme4]{glmer}}; see there for details.} \item{subset, weights, na.action, offset, contrasts}{further model specification arguments as in \code{\link[stats]{lm}}; see there for details.} } \details{ The bulk of the usage for \code{blmer} and \code{bglmer} closely follows the functions \code{\link[lme4]{lmer}} and \code{\link[lme4]{glmer}}. Those help pages provide a good overview of fitting linear and generalized linear mixed models. The primary distinction is that \code{blmer} and \code{bglmer} allow the user to do Bayesian inference or penalized maximum likelihood, with priors imposed on the different model components. For the specifics of any distribution listed below, see the \link[=bmerDist-class]{distributions} page. \strong{Covariance Prior} The \code{cov.prior} argument applies a prior over the covariance matrix of the random effects/modeled coefficients. As there is one covariance matrix for every named grouping factor - that is every element that appears to the right of a vertical bar ("|") in the model formula - it is possible to apply as many different priors as there are said factors. The general formats of an argument to \code{blmer} or \code{bglmer} for such a prior are of the form: \itemize{ \item \code{cov.prior = factor.name ~ covariance.distribution(option1 = value1, \dots)} \item \code{cov.prior = list(fc.nm ~ dist1, fc.nm ~ dist2, ..., default.distribution)} } If the \dQuote{\code{factor.name ~}} construct is ommitted, the prior is interpretted as a default and applied to all factors that lack specific priors of their own. Options are not required, but permit fine-tuning of the model. Supported distributions are \code{gamma}, \code{invgamma}, \code{wishart}, \code{invwishart}, \code{NULL}, and \code{custom}. The \code{common.scale} option, a logical, determines whether or not the prior applies to in the absolute-real world sense (value = \code{FALSE}), or if the prior is applied to the random effect covariance divided by the estimated residual variance (\code{TRUE}). As a practical matter, when false computation can be slower as the profiled common scale may no longer have a closed-form solution. As such, the default for all cases is \code{TRUE}. Other options are specified along with the specific distributions and defaults are explained in the blme \link[=bmerDist-class]{distributions} page. \strong{Fixed Effects Prior} Priors on the fixed effects, or unmodeled coefficients, are specified in a fashion similar to that of covariance priors. The general format is \itemize{\item \code{fixef.prior = multivariate.distribution(options1 = value1, \dots)}} At present, the implemented multivariate distributions are \code{normal}, \code{t}, and \code{NULL}. \code{t} priors cannot be used when \code{REML} is \code{TRUE}, as that integral does not have a closed form solution. \strong{Residual Variance Prior} The general format for a residual variance prior is the same as for a fixed effect prior. The supported distributions are \code{point}, \code{gamma}, \code{invgamma}. } \value{ An object of class \code{"\linkS4class{bmerMod}"}, for which many methods are available. See there for details. } \seealso{ \code{\link[lme4]{lmer}}, \code{\link[lme4]{glmer}}, \code{\linkS4class{merMod}} class, and \code{\link[stats]{lm}}. } \examples{ ## covariance prior data("sleepstudy", package = "lme4") (fm1 <- blmer(Reaction ~ Days + (0 + Days|Subject), sleepstudy, cov.prior = gamma)) (fm2 <- blmer(Reaction ~ Days + (0 + Days|Subject), sleepstudy, cov.prior = gamma(shape = 2, rate = 0.5, posterior.scale = 'sd'))) (fm3 <- blmer(Reaction ~ Days + (1 + Days|Subject), sleepstudy, cov.prior = wishart)) (fm4 <- blmer(Reaction ~ Days + (1 + Days|Subject), sleepstudy, cov.prior = invwishart(df = 5, scale = diag(0.5, 2)))) ## custom prior penaltyFn <- function(sigma) dcauchy(sigma, 0, 10, log = TRUE) (fm5 <- blmer(Reaction ~ Days + (0 + Days|Subject), sleepstudy, cov.prior = custom(penaltyFn, chol = TRUE, scale = "log"))) ## fixed effect prior (fm6 <- blmer(Reaction ~ Days + (1 + Days|Subject), sleepstudy, cov.prior = NULL, fixef.prior = normal)) (fm7 <- blmer(Reaction ~ Days + (1 + Days|Subject), sleepstudy, cov.prior = NULL, fixef.prior = normal(cov = diag(0.5, 2), common.scale = FALSE))) ## residual variance prior ## eight schools example y <- c(28, 8, -3, 7, -1, 1, 18, 12); sigma <- c(15, 10, 16, 11, 9, 11, 10, 18); g <- 1:8; (schools <- blmer(y ~ 1 + (1 | g), resid.prior = point, cov.prior = NULL, REML = FALSE, weights = 1 / sigma^2)); } \keyword{models} \keyword{methods}