brms/0000755000176200001440000000000015060003132011203 5ustar liggesusersbrms/tests/0000755000176200001440000000000015057753141012367 5ustar liggesusersbrms/tests/testthat/0000755000176200001440000000000015060003132014205 5ustar liggesusersbrms/tests/testthat/tests.brmsfit-helpers.R0000644000176200001440000002223715053254240020617 0ustar liggesuserscontext("Tests for brmsfit helper functions") test_that("first_greater returns expected results", { A <- cbind(1:10, 11:20, 21:30) x <- c(5, 25, 7, 15, 7, 10, 15, 19, 3, 11) expect_equal(first_greater(A, x), c(2, 3, 2, 3, 2, 2, 2, 3, 1, 2)) expect_equal(first_greater(A, x, i = 2), c(2, 3, 2, 3, 2, 2, 2, 3, 2, 2)) }) test_that("array2list performs correct conversion", { A <- array(1:27, dim = c(3,3,3)) B <- list(matrix(1:9,3,3), matrix(10:18,3,3), matrix(19:27,3,3)) expect_equal(brms:::array2list(A), B) }) test_that("probit and probit_approx produce similar results", { expect_equal(brms:::inv_link(-10:10, "probit"), brms:::inv_link(-10:10, "probit_approx"), tolerance = 1e-3) }) test_that("autocorrelation matrices are computed correctly", { ar <- 0.5 ma <- 0.3 ar_mat <- brms:::get_cor_matrix_ar1(ar = matrix(ar), nobs = 4) expected_ar_mat <- 1 / (1 - ar^2) * cbind(c(1, ar, ar^2, ar^3), c(ar, 1, ar, ar^2), c(ar^2, ar, 1, ar), c(ar^3, ar^2, ar, 1)) expect_equal(ar_mat[1, , ], expected_ar_mat) ma_mat <- brms:::get_cor_matrix_ma1(ma = matrix(ma), nobs = 4) expected_ma_mat <- cbind(c(1+ma^2, ma, 0, 0), c(ma, 1+ma^2, ma, 0), c(0, ma, 1+ma^2, ma), c(0, 0, ma, 1+ma^2)) expect_equal(ma_mat[1, , ], expected_ma_mat) arma_mat <- brms:::get_cor_matrix_arma1( ar = matrix(ar), ma = matrix(ma), nobs = 4 ) g0 <- 1 + ma^2 + 2 * ar * ma g1 <- (1 + ar * ma) * (ar + ma) expected_arma_mat <- 1 / (1 - ar^2) * cbind(c(g0, g1, g1 * ar, g1 * ar^2), c(g1, g0, g1, g1 * ar), c(g1 * ar, g1, g0, g1), c(g1 * ar^2, g1 * ar, g1, g0)) expect_equal(arma_mat[1, , ], expected_arma_mat) cosy <- 0.6 cosy_mat <- brms:::get_cor_matrix_cosy(cosy = as.matrix(cosy), nobs = 4) expected_cosy_mat <- matrix(cosy, 4, 4) diag(expected_cosy_mat) <- 1 expect_equal(cosy_mat[1, , ], expected_cosy_mat) ident_mat <- brms:::get_cor_matrix_ident(ndraws = 10, nobs = 4) expected_ident_mat <- diag(1, 4) expect_equal(ident_mat[1, , ], expected_ident_mat) }) test_that("evidence_ratio returns expected results", { ps <- -4:10 prs <- -2:12 expect_true(evidence_ratio(ps, prior_samples = prs) > 1) expect_true(is.na(evidence_ratio(ps))) expect_equal(evidence_ratio(ps, cut = 0.5, wsign = "greater"), 10/5) expect_equal(evidence_ratio(ps, cut = 0.5, wsign = "less"), 5/10) }) test_that("find_vars finds all valid variable names in a string", { string <- "x + b.x - .5 + abc(a__3) : 1/2 - 0.2" expect_equal(find_vars(string), c("x", "b.x", "a__3")) }) test_that(".predictor_arma runs without errors", { ns <- 20 nobs <- 30 Y = rnorm(nobs) J_lag = c(1:3, 3, 3, rep(c(0:3, 3), 4), 0:3, 0) ar <- matrix(rnorm(ns * 3), nrow = ns, ncol = 3) ma <- matrix(rnorm(ns * 1), nrow = ns, ncol = 1) eta <- matrix(rnorm(ns * nobs), nrow = ns, ncol = nobs) expect_equal(.predictor_arma(eta, Y = Y, J_lag = J_lag), eta) expect_silent(.predictor_arma(eta, Y = Y, J_lag = J_lag, ar = ar)) expect_silent(.predictor_arma(eta, Y = Y, J_lag = J_lag, ma = ma)) expect_silent(.predictor_arma(eta, Y = Y, J_lag = J_lag, ar = ar, ma = ma)) }) test_that("make_conditions works correctly", { conds <- make_conditions(epilepsy, c("zBase", "zAge")) expect_equal(dim(conds), c(9, 3)) expect_equal(conds$cond__[3], "zBase = -1 & zAge = 1") }) test_that("brmsfit_needs_refit works correctly", { cache_tmp <- tempfile(fileext = ".rds") expect_null(read_brmsfit(cache_tmp)) saveRDS(list(a = 1), file = cache_tmp) expect_error(read_brmsfit(cache_tmp)) data_model1 <- data.frame(y = rnorm(10), x = rnorm(10)) fake_fit <- brm(y ~ x, data = data_model1, empty = TRUE) expect_error(summary(fake_fit), NA) fake_fit_file <- fake_fit # align windows with unix encoding of file paths fake_fit_file$file <- gsub("\\", "/", cache_tmp, fixed = TRUE) scode_model1 <- make_stancode(y ~ x, data = data_model1) sdata_model1 <- make_standata(y ~ x, data = data_model1) data_model2 <- data_model1 data_model2$x[1] <- data_model2$x[1] + 1 scode_model2 <- make_stancode(y ~ 0 + x, data = data_model2) sdata_model2 <- make_standata(y ~ 0 + x, data = data_model2) write_brmsfit(fake_fit, file = cache_tmp) cache_res <- read_brmsfit(file = cache_tmp) expect_error(summary(cache_res), NA) expect_equal(cache_res, fake_fit_file) expect_false(brmsfit_needs_refit( cache_res, sdata = sdata_model1, scode = scode_model1, algorithm = "sampling", silent = TRUE)) expect_false(brmsfit_needs_refit( cache_res, sdata = sdata_model1, scode = scode_model1, algorithm = NULL, silent = TRUE)) expect_false(brmsfit_needs_refit( cache_res, sdata = sdata_model1, scode = NULL, algorithm = "sampling", silent = TRUE)) expect_false(brmsfit_needs_refit( cache_res, sdata = NULL, scode = scode_model1, algorithm = "sampling", silent = TRUE)) expect_true(brmsfit_needs_refit( cache_res, sdata = sdata_model2, scode = scode_model1, algorithm = "sampling", silent = TRUE)) expect_true(brmsfit_needs_refit( cache_res, sdata = sdata_model1, scode = scode_model2, algorithm = "sampling", silent = TRUE)) expect_true(brmsfit_needs_refit( cache_res, sdata = sdata_model2, scode = scode_model2, algorithm = "sampling", silent = TRUE)) expect_true(brmsfit_needs_refit( cache_res, sdata = sdata_model1, scode = scode_model1, algorithm = "optimize", silent = TRUE)) expect_true(brmsfit_needs_refit( cache_res, sdata = make_standata(y ~ x, data = data_model1, sample_prior = "only"), scode = scode_model1, algorithm = NULL, silent = TRUE)) }) test_that("insert_refcat() works correctly", { source(testthat::test_path(file.path("helpers", "insert_refcat_ch.R"))) source(testthat::test_path(file.path("helpers", "simopts_catlike.R"))) for (ndraws in ndraws_vec) { for (nobsv in nobsv_vec) { for (ncat in ncat_vec) { cats <- paste0("cat", 1:ncat) ref_list <- list( ref1 = 1, reflast = ncat ) fam_list <- list( fam_ref1 = categorical(refcat = cats[1]), fam_reflast = categorical(refcat = cats[ncat]) ) if (ncat > 2) { ref_list <- c(ref_list, list(ref2 = 2)) fam_list <- c(fam_list, list(fam_ref2 = categorical(refcat = cats[2]))) } eta_test_list <- list(array(rnorm(ndraws * nobsv * (ncat - 1)), dim = c(ndraws, nobsv, ncat - 1))) if (nobsv == 1) { eta_test_list <- c( eta_test_list, list(matrix(rnorm(ndraws * (ncat - 1)), nrow = ndraws)) ) } for (eta_test in eta_test_list) { for (i in seq_along(fam_list)) { # Emulate content of `fam` after fit: fam <- fam_list[[i]] if (is.null(fam$refcat)) { fam$refcat <- cats[1] } fam$cats <- cats ref <- ref_list[[i]] # Perform the check: eta_ref <- insert_refcat(eta_test, ref) eta_ref_ch <- insert_refcat_ch(eta_test, fam) expect_equivalent(eta_ref, eta_ref_ch) if (length(dim(eta_test)) == 3) { expect_equal(dim(eta_ref), c(ndraws, nobsv, ncat)) } else if (length(dim(eta_test)) == 2) { expect_equal(dim(eta_ref), c(ndraws, ncat)) } } } } } } }) # split_folder_and_file test_that("split_folder_and_file returns expected results", { files <- c("somefile", "./somefile" , "somepath/somefolder/somefile" ) result <- base::lapply(files, split_folder_and_file) exp_result <- list( list( folder = '.' , file= 'somefile' ) , list( folder = '.' , file= 'somefile' ) , list( folder = 'somepath/somefolder' , file= 'somefile' ) ) expect_equal(result ,exp_result ) }) # check_brmsfit_file test_that("check_brmsfit_file returns expected results", { files <- c("somefile", "./somefile" , "somefile.rds" , "somepath/somefolder/somefile" ) result <- base::lapply(files, function(x) check_brmsfit_file(x , .check_folder = F )) exp_result <- list( "./somefile.rds" , "./somefile.rds" , "./somefile.rds" , "somepath/somefolder/somefile.rds" ) expect_equal(result ,exp_result ) }) # get_cache_folder test_that("get_cache_folder returns expected results", { old_val <- getOption("brms.cache_folder", NULL) options(brms.cache_folder = "SomeFolder") on.exit({ if (is.null(old_val)) { options(your.option.name = NULL) } else { options(your.option.name = old_val) } }, add = TRUE) files <- c("somefile", "./somefile", "abcde/somefile.rds" , "somepath/somefolder/somefile") result <- base::lapply(files, brms:::get_cache_folder) exp_result <- list( "SomeFolder" , "SomeFolder" , "abcde" , "somepath/somefolder" ) expect_equal(result, exp_result) }) brms/tests/testthat/tests.brmsformula.R0000644000176200001440000000366514213413565020052 0ustar liggesuserscontext("Tests for brmsformula") test_that("brmsformula validates formulas of non-linear parameters", { expect_error(bf(y ~ a, ~ 1, a ~ 1), "Additional formulas must be named") expect_error(bf(y ~ a^x, a.b ~ 1), "not contain dots or underscores") expect_error(bf(y ~ a^(x+b), a_b ~ 1), "not contain dots or underscores") }) test_that("brmsformula validates formulas of auxiliary parameters", { expect_error(bf(y ~ a, ~ 1, sigma ~ 1), "Additional formulas must be named") }) test_that("brmsformula detects use if '~~'", { # checks fix of issue #749 expect_error(bf(y~~x), "~~") }) test_that("brmsformula does not change a 'brmsformula' object", { form <- bf(y ~ a, sigma ~ 1) expect_identical(form, bf(form)) form <- bf(y ~ a, sigma ~ 1, a ~ x, nl = TRUE) expect_identical(form, bf(form)) }) test_that("brmsformula detects auxiliary parameter equations", { expect_error(bf(y~x, sigma1 = "sigmaa2"), "Can only equate parameters of the same class") expect_error(bf(y~x, mu3 = "mu2"), "Equating parameters of class 'mu' is not allowed") expect_error(bf(y~x, sigma1 = "sigma1"), "Equating 'sigma1' with itself is not meaningful") expect_error(bf(y~x, shape1 ~ x, shape2 = "shape1"), "Cannot use predicted parameters on the right-hand side") expect_error(bf(y~x, shape1 = "shape3", shape2 = "shape1"), "Cannot use fixed parameters on the right-hand side") }) test_that("update_adterms works correctly", { form <- y | trials(size) ~ x expect_equal( update_adterms(form, ~ trials(10)), y | trials(10) ~ x ) expect_equal( update_adterms(form, ~ weights(w)), y | trials(size) + weights(w) ~ x ) expect_equal( update_adterms(form, ~ weights(w), action = "replace"), y | weights(w) ~ x ) expect_equal( update_adterms(y ~ x, ~ trials(10)), y | trials(10) ~ x ) }) brms/tests/testthat/tests.brmsterms.R0000644000176200001440000000770614213413565017537 0ustar liggesuserscontext("Tests for formula parsing functions") test_that("brmsterms finds all variables in very long formulas", { expect_equal( all.vars(brmsterms(t2_brand_recall ~ psi_expsi + psi_api_probsolv + psi_api_ident + psi_api_intere + psi_api_groupint)$all), all.vars(t2_brand_recall ~ t2_brand_recall + psi_expsi + psi_api_probsolv + psi_api_ident + psi_api_intere + psi_api_groupint) ) }) test_that("brmsterms handles very long RE terms", { # tests issue #100 covariate_vector <- paste0("xxxxx", 1:80, collapse = "+") formula <- paste(sprintf("y ~ 0 + trait + trait:(%s)", covariate_vector), sprintf("(1+%s|id)", covariate_vector), sep = " + ") bterms <- brmsterms(as.formula(formula)) expect_equal(bterms$dpars$mu$re$group, "id") }) test_that("brmsterms correctly handles auxiliary parameter 'mu'", { bterms1 <- brmsterms(y ~ x + (x|g)) bterms2 <- brmsterms(bf(y ~ 1, mu ~ x + (x|g))) expect_equal(bterms1$dpars$mu, bterms2$dpars$mu) # commented out for now as updating is not yet enabled # bterms1 <- brmsterms(bf(y ~ z + x + (x|g))) # bterms2 <- brmsterms(bf(y ~ z, lf(mu ~ x + (x|g)))) # expect_equal(bterms1$dpars$mu, bterms2$dpars$mu) # # bterms1 <- brmsterms(bf(y ~ z, lf(mu ~ x + (x|g), cmc = FALSE))) # expect_true(!attr(bterms1$dpars$mu$fe, "cmc")) # # expect_error(brmsterms(bf(y ~ z, mu ~ x + (x|g), nl = TRUE)), # "Cannot combine non-linear formulas") }) test_that("brmsterms correctly check fixed auxiliary parameters", { bform <- bf(y~1, sigma = 4, family = gaussian) expect_true(is.brmsterms(brmsterms(bform))) bform <- bf(y~1, zi = 0.5, family = zero_inflated_beta()) expect_true(is.brmsterms(brmsterms(bform))) bform <- bf(y~1, shape = -2, family = Gamma()) expect_error(brmsterms(bform), "Parameter 'shape' must be positive") bform <- bf(y~1, quantile = 1.5, family = asym_laplace()) expect_error(brmsterms(bform), "Parameter 'quantile' must be between 0 and 1") }) test_that("check_re_formula returns correct REs", { old_form <- y ~ x + (1|patient) + (Trt_c|visit) form <- check_re_formula(~ (1 | visit), old_form) expect_equivalent(form, ~ (1 | gr(visit))) form <- check_re_formula(~ (1 + Trt_c|visit), old_form) expect_equivalent(form, ~ (1 + Trt_c | gr(visit))) form <- check_re_formula(~ (0 + Trt_c | visit) + (1|patient), old_form) expect_equivalent(form, ~ (1|gr(patient)) + (0 + Trt_c | gr(visit))) # checks for fix of issue #844 old_form <- y ~ 0 + x1 + x2 + (0 + x1 + x2 | x3) expect_error( check_re_formula(~ (0 + x2 + x1 | x3), old_form), "Order of terms in 're_formula' should match the original order" ) }) test_that("update_re_terms works correctly", { expect_equivalent(update_re_terms(y ~ x, ~ (1|visit)), y ~ x) expect_equivalent(update_re_terms(y ~ x*z + (1+Trt_c|patient), ~ (1|patient)), y ~ x*z + (1|gr(patient))) expect_equivalent(update_re_terms(y ~ x + (1|patient), ~ 1), y ~ x) expect_equivalent(update_re_terms(y ~ 1|patient, ~ 1), y ~ 1) expect_equivalent(update_re_terms(y ~ -1 + x + (1+visit|patient), NA), y ~ -1 + x) expect_equivalent(update_re_terms(y ~ x + (1+visit|patient), NULL), y ~ x + (1+visit|patient)) expect_equivalent(update_re_terms(y ~ (1|patient), NA), y ~ 1) expect_equivalent(update_re_terms(y ~ x + (1+x|visit), ~ (1|visit)), y ~ x + (1|gr(visit))) expect_equivalent(update_re_terms(y ~ x + (1|visit), ~ (1|visit) + (x|visit)), y ~ x + (1|gr(visit))) expect_equal(update_re_terms(bf(y ~ x, sigma = ~ x + (x|g)), ~ (1|g)), bf(y ~ x, sigma = ~ x + (1|gr(g)))) expect_equal(update_re_terms(bf(y ~ x, x ~ z + (1|g), nl = TRUE), ~ (1|g)), bf(y ~ x, x ~ z + (1|gr(g)), nl = TRUE)) }) test_that("unused variables are correctly incorporated", { bterms <- brmsterms(bf(y ~ 1, unused = ~ x)) expect_true("x" %in% all.vars(bterms$allvars)) }) brms/tests/testthat/tests.distributions.R0000644000176200001440000005514115053072461020416 0ustar liggesuserscontext("Tests for distribution functions") test_that("student distribution works correctly", { expect_equal(integrate(dstudent_t, -100, 100, df = 15, mu = 10, sigma = 5)$value, 1) expect_equal(dstudent_t(1, df = 10, mu = 0, sigma = 5), dt(1/5, df = 10)/5) expect_equal(pstudent_t(2, df = 20, mu = 2, sigma = 0.4), pt(0, df = 20)) ps <- c(-1,0,0.7,1,1.5) SW(expect_equal(qstudent_t(ps, df = 5, mu = 2, sigma = 3), 2 + 3*qt(ps, df = 5))) expect_equal(length(rstudent_t(10, df = 10, mu = rnorm(10), sigma = 1:10)), 10) }) test_that("multivariate normal and student distributions work correctly", { mu <- rnorm(3) Sigma <- cov(matrix(rnorm(300), ncol = 3)) expect_equal(dmulti_normal(1:3, mu = mu, Sigma = Sigma), mnormt::dmnorm(1:3, mu, Sigma)) expect_equal(dmulti_student_t(1:3, mu = mu, Sigma = Sigma, df = 10, log = TRUE), mnormt::dmt(1:3, df = 10, mean = mu, S = Sigma, log = TRUE)) expect_equal(dim(rmulti_normal(7, mu = mu, Sigma = Sigma)), c(7, 3)) expect_equal(dim(rmulti_student_t(7, mu = mu, Sigma = Sigma, df = 10)), c(7, 3)) # test errors expect_error(dmulti_normal(1:3, mu = rnorm(2), Sigma = Sigma, check = TRUE), "Dimension of mu is incorrect") expect_error(dmulti_normal(1:3, mu = mu, Sigma = Sigma[1:2, 1:2], check = TRUE), "Dimension of Sigma is incorrect") expect_error(dmulti_normal(1:3, mu = mu, Sigma = Sigma[1:3, 3:1], check = TRUE), "Sigma must be a symmetric matrix") expect_error(rmulti_normal(1.5, mu = mu, Sigma = Sigma, check = TRUE), "n must be a positive integer") expect_error(rmulti_normal(10, mu = mu, Sigma = Sigma[1:3, 3:1], check = TRUE), "Sigma must be a symmetric matrix") expect_error(dmulti_student_t(rnorm(3), mu = mu, Sigma = Sigma, df = -1, check = TRUE), "df must be greater than 0") expect_error(dmulti_student_t(rnorm(3), mu = mu, Sigma = Sigma[1:3, 3:1], df = 30, check = TRUE), "Sigma must be a symmetric matrix") expect_error(rmulti_student_t(10, mu = mu, Sigma = Sigma, df = -1, check = TRUE), "df must be greater than 0") }) test_that("von_mises distribution functions run without errors", { n <- 10 res <- dvon_mises(runif(n, -pi, pi), mu = 1, kappa = 1:n) expect_true(length(res) == n) res <- pvon_mises(runif(n, -pi, pi), mu = rnorm(n), kappa = 0:(n-1)) expect_true(length(res) == n) res <- rvon_mises(n, mu = rnorm(n), kappa = 0:(n-1)) expect_true(length(res) == n) }) test_that("skew_normal distribution functions run without errors", { n <- 10 x <- rnorm(n, 10, 3) res <- dskew_normal(x, mu = 1, sigma = 2, alpha = 1) expect_true(length(res) == n) res <- pskew_normal(x, mu = rnorm(n), sigma = 1:n, alpha = 3, log.p = TRUE) expect_true(length(res) == n) p <- log(runif(n, 0, 1)) res <- qskew_normal(p, mu = rnorm(n), sigma = 1:n, alpha = 3, log.p = TRUE) expect_true(length(res) == n) ps <- c(-1, 0, 0.5, 1, 1.5) res <- SW(qskew_normal(ps)) expect_equal(res, c(NA, -Inf, 0, Inf, NA)) res <- rskew_normal(n, mu = rnorm(n), sigma = 10, alpha = -4:5) expect_true(length(res) == n) }) test_that("exgaussian distribution functions run without errors", { n <- 10 x <- rnorm(n, 10, 3) res <- dexgaussian(x, mu = 1, sigma = 2, beta = 1) expect_true(length(res) == n) res <- pexgaussian(x, mu = rnorm(n), sigma = 1:n, beta = 3, log.p = TRUE) expect_true(length(res) == n) res <- rexgaussian(n, mu = rnorm(n), sigma = 10, beta = 1:10) expect_true(length(res) == n) }) test_that("frechet distribution functions run without errors", { n <- 10 x <- 21:30 res <- dfrechet(x, loc = 1, scale = 2, shape = 1, log = TRUE) expect_true(length(res) == n) loc <- 1:10 res <- pfrechet(x, loc = loc, scale = 1:n, shape = 3) expect_true(length(res) == n) q <- qfrechet(res, loc = loc, scale = 1:n, shape = 3) expect_equal(x, q) ps <- c(-1, 0, 1, 1.5) res <- SW(qfrechet(ps)) expect_equal(res, c(NA, 0, Inf, NA)) res <- rfrechet(n, loc = loc, scale = 10, shape = 1:10) expect_true(length(res) == n) }) test_that("inv_gaussian distribution functions run without errors", { n <- 10 x <- rgamma(n, 10, 3) res <- dinv_gaussian(x, mu = 1, shape = 1) expect_true(length(res) == n) res <- pinv_gaussian(x, mu = abs(rnorm(n)), shape = 3) expect_true(length(res) == n) res <- rinv_gaussian(n, mu = abs(rnorm(n)), shape = 1:10) expect_true(length(res) == n) }) test_that("beta_binomial distribution functions run without errors", { skip_if_not_installed("extraDistr") n <- 10 x <- rpois(n, lambda = 1) res <- dbeta_binomial(x, c(2, 10), mu = 0.4, phi = 1) expect_true(length(res) == n) res <- pbeta_binomial(x, c(2, 10), mu = 0.4, phi = 1) expect_true(length(res) == n) res <- rbeta_binomial(n, c(2, 10), mu = 0.4, phi = 1) expect_true(length(res) == n) }) test_that("gen_extreme_value distribution functions run without errors", { n <- 10 x <- rgamma(n, 10, 3) res <- dgen_extreme_value(x, mu = 1, sigma = 2, xi = 1) expect_true(length(res) == n) mu <- rnorm(n) res <- pgen_extreme_value(x, mu = mu, sigma = 1:n, xi = 3) expect_true(length(res) == n) q <- qgen_extreme_value(res, mu = mu, sigma = 1:n, xi = 3) expect_equal(x, q) res <- rgen_extreme_value(n, mu = mu, sigma = 10, xi = 1:10) expect_true(length(res) == n) }) test_that("asym_laplace distribution functions run without errors", { n <- 10 x <- rnorm(n, 10, 3) res <- dasym_laplace(x, mu = 1, sigma = 2, quantile = 0.5) expect_true(length(res) == n) res <- pasym_laplace(x, mu = rnorm(n), sigma = 1:n, quantile = 0.3) expect_true(length(res) == n) res <- rasym_laplace(n, mu = rnorm(n), sigma = 10, quantile = runif(n, 0, 1)) expect_true(length(res) == n) }) test_that("zero-inflated distribution functions run without errors", { skip_if_not_installed("extraDistr") n <- 10 x <- rpois(n, lambda = 1) res <- dzero_inflated_poisson(x, lambda = 1, zi = 0.1) expect_true(length(res) == n) res <- pzero_inflated_poisson(x, lambda = 1, zi = 0.1) expect_true(length(res) == n) res <- dzero_inflated_negbinomial(x, mu = 2, shape = 5, zi = 0.1) expect_true(length(res) == n) res <- pzero_inflated_negbinomial(x, mu = 2, shape = 5, zi = 0.1) expect_true(length(res) == n) res <- dzero_inflated_binomial(x, size = c(2, 10), prob = 0.4, zi = 0.1) expect_true(length(res) == n) res <- pzero_inflated_binomial(x, size = c(2, 10), prob = 0.4, zi = 0.1) expect_true(length(res) == n) res <- dzero_inflated_beta_binomial(x, c(2, 10), mu = 0.4, phi = 1, zi = 0.1) expect_true(length(res) == n) res <- pzero_inflated_beta_binomial(x, c(2, 10), mu = 0.4, phi = 1, zi = 0.1) expect_true(length(res) == n) x <- c(rbeta(n - 2, shape1 = 2, shape2 = 3), 0, 0) res <- dzero_inflated_beta(x, shape1 = 2, shape2 = 3, zi = 0.1) expect_true(length(res) == n) res <- pzero_inflated_beta(x, shape1 = 2, shape2 = 3, zi = 0.1) expect_true(length(res) == n) }) test_that("hurdle distribution functions run without errors", { n <- 10 x <- rpois(n, lambda = 1) res <- dhurdle_poisson(x, lambda = 1, hu = 0.1) expect_true(length(res) == n) res <- phurdle_poisson(x, lambda = 1, hu = 0.1) expect_true(length(res) == n) res <- dhurdle_negbinomial(x, mu = 2, shape = 5, hu = 0.1) expect_true(length(res) == n) res <- phurdle_negbinomial(x, mu = 2, shape = 5, hu = 0.1) expect_true(length(res) == n) res <- dhurdle_gamma(x, shape = 1, scale = 3, hu = 0.1) expect_true(length(res) == n) res <- phurdle_gamma(x, shape = 1, scale = 3, hu = 0.1) expect_true(length(res) == n) res <- dhurdle_lognormal(x, mu = 2, sigma = 5, hu = 0.1) expect_true(length(res) == n) res <- phurdle_lognormal(x, mu = 2, sigma = 5, hu = 0.1) expect_true(length(res) == n) }) test_that("wiener distribution functions run without errors", { skip_if_not_installed("RWiener") set.seed(1234) n <- 10 x <- seq(0.1, 1, 0.1) alpha <- rexp(n) tau <- 0.05 beta <- 0.5 delta <- rnorm(n) resp <- sample(c(0, 1), n, TRUE) d1 <- dwiener(x, alpha, tau, beta, delta, resp, backend = "Rwiener") d2 <- dwiener(x, alpha, tau, beta, delta, resp, backend = "rtdists") expect_equal(d1, d2) r1 <- rwiener(n, alpha, tau, beta, delta, backend = "Rwiener") r2 <- rwiener(n, alpha, tau, beta, delta, backend = "rtdists") expect_equal(names(r1), names(r2)) expect_equal(dim(r1), dim(r2)) }) test_that("d() works correctly", { source(testthat::test_path(file.path("helpers", "inv_link_ordinal_ch.R"))) source(testthat::test_path(file.path("helpers", "simopts_catlike_oneobs.R"))) for (ndraws in ndraws_vec) { for (ncat in ncat_vec) { thres_test <- matrix(rnorm(ndraws * (ncat - 1)), nrow = ndraws) # Emulate no category-specific effects (i.e., only a single vector of # linear predictors) as well as category-specific effects (i.e., a matrix # of linear predictors): eta_test_list <- list( rnorm(ndraws), matrix(rnorm(ndraws * (ncat - 1)), nrow = ndraws) ) for (eta_test in eta_test_list) { thres_eta <- if (is.matrix(eta_test)) { stopifnot(identical(dim(eta_test), dim(thres_test))) thres_test - eta_test } else { # Just to try something different: sweep(thres_test, 1, as.array(eta_test)) } eta_thres <- if (is.matrix(eta_test)) { stopifnot(identical(dim(eta_test), dim(thres_test))) eta_test - thres_test } else { # Just to try something different: sweep(-thres_test, 1, as.array(eta_test), FUN = "+") } for (link in c("logit", "probit", "cauchit", "cloglog")) { # cumulative(): d_cumul <- dcumulative(seq_len(ncat), eta_test, thres_test, link = link) d_cumul_ch <- inv_link_cumulative_ch(thres_eta, link = link) expect_equivalent(d_cumul, d_cumul_ch) expect_equal(dim(d_cumul), c(ndraws, ncat)) # sratio(): d_sratio <- dsratio(seq_len(ncat), eta_test, thres_test, link = link) d_sratio_ch <- inv_link_sratio_ch(thres_eta, link = link) expect_equivalent(d_sratio, d_sratio_ch) expect_equal(dim(d_sratio), c(ndraws, ncat)) # cratio(): d_cratio <- dcratio(seq_len(ncat), eta_test, thres_test, link = link) d_cratio_ch <- inv_link_cratio_ch(eta_thres, link = link) expect_equivalent(d_cratio, d_cratio_ch) expect_equal(dim(d_cratio), c(ndraws, ncat)) # acat(): d_acat <- dacat(seq_len(ncat), eta_test, thres_test, link = link) d_acat_ch <- inv_link_acat_ch(eta_thres, link = link) expect_equivalent(d_acat, d_acat_ch) expect_equal(dim(d_acat), c(ndraws, ncat)) } } } } }) test_that("inv_link_() works correctly for arrays", { source(testthat::test_path(file.path("helpers", "inv_link_ordinal_ch.R"))) source(testthat::test_path(file.path("helpers", "simopts_catlike.R"))) for (ndraws in ndraws_vec) { for (nobsv in nobsv_vec) { for (ncat in ncat_vec) { x_test <- array(rnorm(ndraws * nobsv * (ncat - 1)), dim = c(ndraws, nobsv, ncat - 1)) nx_test <- -x_test for (link in c("logit", "probit", "cauchit", "cloglog")) { # cumulative(): il_cumul <- inv_link_cumulative(x_test, link = link) il_cumul_ch <- inv_link_cumulative_ch(x_test, link = link) expect_equivalent(il_cumul, il_cumul_ch) expect_equal(dim(il_cumul), c(ndraws, nobsv, ncat)) # sratio(): il_sratio <- inv_link_sratio(x_test, link = link) il_sratio_ch <- inv_link_sratio_ch(x_test, link = link) expect_equivalent(il_sratio, il_sratio_ch) expect_equal(dim(il_sratio), c(ndraws, nobsv, ncat)) # cratio(): il_cratio <- inv_link_cratio(nx_test, link = link) il_cratio_ch <- inv_link_cratio_ch(nx_test, link = link) expect_equivalent(il_cratio, il_cratio_ch) expect_equal(dim(il_cratio), c(ndraws, nobsv, ncat)) # acat(): il_acat <- inv_link_acat(nx_test, link = link) il_acat_ch <- inv_link_acat_ch(nx_test, link = link) expect_equivalent(il_acat, il_acat_ch) expect_equal(dim(il_acat), c(ndraws, nobsv, ncat)) } } } } }) test_that("link_() works correctly for arrays", { source(testthat::test_path(file.path("helpers", "link_ordinal_ch.R"))) source(testthat::test_path(file.path("helpers", "simopts_catlike.R"))) for (ndraws in ndraws_vec) { for (nobsv in nobsv_vec) { for (ncat in ncat_vec) { x_test <- array(rdirichlet(ndraws * nobsv, alpha = rep(1, ncat)), dim = c(ndraws, nobsv, ncat)) for (link in c("logit", "probit", "cauchit", "cloglog")) { # cumulative(): l_cumul <- link_cumulative(x_test, link = link) l_cumul_ch <- link_cumulative_ch(x_test, link = link) expect_equivalent(l_cumul, l_cumul_ch) expect_equal(dim(l_cumul), c(ndraws, nobsv, ncat - 1)) # sratio(): l_sratio <- link_sratio(x_test, link = link) l_sratio_ch <- link_sratio_ch(x_test, link = link) expect_equivalent(l_sratio, l_sratio_ch) expect_equal(dim(l_sratio), c(ndraws, nobsv, ncat - 1)) # cratio(): l_cratio <- link_cratio(x_test, link = link) l_cratio_ch <- link_cratio_ch(x_test, link = link) expect_equivalent(l_cratio, l_cratio_ch) expect_equal(dim(l_cratio), c(ndraws, nobsv, ncat - 1)) # acat(): l_acat <- link_acat(x_test, link = link) l_acat_ch <- link_acat_ch(x_test, link = link) expect_equivalent(l_acat, l_acat_ch) expect_equal(dim(l_acat), c(ndraws, nobsv, ncat - 1)) } } } } }) test_that("inv_link_() inverts link_()", { source(testthat::test_path(file.path("helpers", "simopts_catlike.R"))) for (ndraws in ndraws_vec) { for (nobsv in nobsv_vec) { for (ncat in ncat_vec) { x_test <- array(rdirichlet(ndraws * nobsv, alpha = rep(1, ncat)), dim = c(ndraws, nobsv, ncat)) for (link in c("logit", "probit", "cauchit", "cloglog")) { # cumulative(): l_cumul <- link_cumulative(x_test, link = link) il_cumul <- inv_link_cumulative(l_cumul, link = link) expect_equivalent(il_cumul, x_test) # sratio(): l_sratio <- link_sratio(x_test, link = link) il_sratio <- inv_link_sratio(l_sratio, link = link) expect_equivalent(il_sratio, x_test) # cratio(): l_cratio <- link_cratio(x_test, link = link) il_cratio <- inv_link_cratio(l_cratio, link = link) expect_equivalent(il_cratio, x_test) # acat(): l_acat <- link_acat(x_test, link = link) il_acat <- inv_link_acat(l_acat, link = link) expect_equivalent(il_acat, x_test) } } } } }) test_that("link_() inverts inv_link_()", { source(testthat::test_path(file.path("helpers", "simopts_catlike.R"))) for (ndraws in ndraws_vec) { for (nobsv in nobsv_vec) { for (ncat in ncat_vec) { x_test <- array(rnorm(ndraws * nobsv * (ncat - 1)), dim = c(ndraws, nobsv, ncat - 1)) nx_test <- -x_test for (link in c("logit", "probit", "cauchit", "cloglog")) { # cumulative(): il_cumul <- inv_link_cumulative(x_test, link = link) l_cumul <- link_cumulative(il_cumul, link = link) expect_equivalent(l_cumul, x_test) # sratio(): il_sratio <- inv_link_sratio(x_test, link = link) l_sratio <- link_sratio(il_sratio, link = link) expect_equivalent(l_sratio, x_test) # cratio(): il_cratio <- inv_link_cratio(x_test, link = link) l_cratio <- link_cratio(il_cratio, link = link) expect_equivalent(l_cratio, x_test) # acat(): il_acat <- inv_link_acat(x_test, link = link) l_acat <- link_acat(il_acat, link = link) expect_equivalent(l_acat, x_test) } } } } }) test_that(paste( "dsratio() and dcratio() give the same results for symmetric distribution", "functions" ), { source(testthat::test_path(file.path("helpers", "simopts_catlike_oneobs.R"))) for (ndraws in ndraws_vec) { for (ncat in ncat_vec) { thres_test <- matrix(rnorm(ndraws * (ncat - 1)), nrow = ndraws) # Emulate no category-specific effects (i.e., only a single vector of # linear predictors) as well as category-specific effects (i.e., a matrix # of linear predictors): eta_test_list <- list( rnorm(ndraws), matrix(rnorm(ndraws * (ncat - 1)), nrow = ndraws) ) for (eta_test in eta_test_list) { for (link in c("logit", "probit", "cauchit", "cloglog")) { d_sratio <- dsratio(seq_len(ncat), eta_test, thres_test, link = link) d_cratio <- dcratio(seq_len(ncat), eta_test, thres_test, link = link) if (link != "cloglog") { expect_equal(d_sratio, d_cratio) } else { expect_false(isTRUE(all.equal(d_sratio, d_cratio))) } } } } } }) test_that(paste( "inv_link_sratio() and inv_link_cratio() applied to arrays give the same", "results for symmetric distribution functions (when respecting the sign", "appropriately)." ), { source(testthat::test_path(file.path("helpers", "simopts_catlike.R"))) for (ndraws in ndraws_vec) { for (nobsv in nobsv_vec) { for (ncat in ncat_vec) { x_test <- array(rnorm(ndraws * nobsv * (ncat - 1)), dim = c(ndraws, nobsv, ncat - 1)) nx_test <- -x_test for (link in c("logit", "probit", "cauchit", "cloglog")) { il_sratio <- inv_link_sratio(x_test, link = link) il_cratio <- inv_link_cratio(nx_test, link = link) if (link != "cloglog") { expect_equal(il_sratio, il_cratio) } else { expect_false(isTRUE(all.equal(il_sratio, il_cratio))) } } } } } }) test_that(paste( "link_sratio() and link_cratio() applied to arrays give the same", "results for symmetric distribution functions (when respecting the sign", "appropriately)." ), { source(testthat::test_path(file.path("helpers", "simopts_catlike.R"))) for (ndraws in ndraws_vec) { for (nobsv in nobsv_vec) { for (ncat in ncat_vec) { x_test <- array(rdirichlet(ndraws * nobsv, alpha = rep(1, ncat)), dim = c(ndraws, nobsv, ncat)) for (link in c("logit", "probit", "cauchit", "cloglog")) { l_sratio <- link_sratio(x_test, link = link) l_cratio <- link_cratio(x_test, link = link) if (link != "cloglog") { expect_equal(l_sratio, -l_cratio) } else { expect_false(isTRUE(all.equal(l_sratio, -l_cratio))) } } } } } }) test_that("dcategorical() works correctly", { source(testthat::test_path(file.path("helpers", "inv_link_categorical_ch.R"))) source(testthat::test_path(file.path("helpers", "simopts_catlike_oneobs.R"))) for (ndraws in ndraws_vec) { for (ncat in ncat_vec) { eta_test_list <- list(cbind( 0, matrix(rnorm(ndraws * (ncat - 1)), nrow = ndraws) )) if (ndraws == 1) { eta_test_list <- c(eta_test_list, list(c(0, rnorm(ncat - 1)))) } for (eta_test in eta_test_list) { d_categorical <- dcategorical(seq_len(ncat), eta_test) d_categorical_ch <- inv_link_categorical_ch(eta_test, refcat_ins = FALSE) expect_equivalent(d_categorical, d_categorical_ch) expect_equal(dim(d_categorical), c(ndraws, ncat)) } } } }) test_that("inv_link_categorical() works correctly for arrays", { source(testthat::test_path(file.path("helpers", "inv_link_categorical_ch.R"))) source(testthat::test_path(file.path("helpers", "simopts_catlike.R"))) for (ndraws in ndraws_vec) { for (nobsv in nobsv_vec) { for (ncat in ncat_vec) { x_test <- array(rnorm(ndraws * nobsv * (ncat - 1)), dim = c(ndraws, nobsv, ncat - 1)) il_categorical <- inv_link_categorical(x_test) il_categorical_ch <- inv_link_categorical_ch(x_test) expect_equivalent(il_categorical, il_categorical_ch) expect_equal(dim(il_categorical), c(ndraws, nobsv, ncat)) } } } }) test_that("link_categorical() works correctly for arrays", { source(testthat::test_path(file.path("helpers", "link_categorical_ch.R"))) source(testthat::test_path(file.path("helpers", "simopts_catlike.R"))) for (ndraws in ndraws_vec) { for (nobsv in nobsv_vec) { for (ncat in ncat_vec) { x_test <- array(rdirichlet(ndraws * nobsv, alpha = rep(1, ncat)), dim = c(ndraws, nobsv, ncat)) l_categorical <- link_categorical(x_test) l_categorical_ch <- link_categorical_ch(x_test) expect_equivalent(l_categorical, l_categorical_ch) expect_equal(dim(l_categorical), c(ndraws, nobsv, ncat - 1)) } } } }) test_that("inv_link_categorical() inverts link_categorical()", { source(testthat::test_path(file.path("helpers", "simopts_catlike.R"))) for (ndraws in ndraws_vec) { for (nobsv in nobsv_vec) { for (ncat in ncat_vec) { x_test <- array(rdirichlet(ndraws * nobsv, alpha = rep(1, ncat)), dim = c(ndraws, nobsv, ncat)) l_categorical <- link_categorical(x_test) il_categorical <- inv_link_categorical(l_categorical) expect_equivalent(il_categorical, x_test) } } } }) test_that("link_categorical() inverts inv_link_categorical()", { source(testthat::test_path(file.path("helpers", "simopts_catlike.R"))) for (ndraws in ndraws_vec) { for (nobsv in nobsv_vec) { for (ncat in ncat_vec) { x_test <- array(rnorm(ndraws * nobsv * (ncat - 1)), dim = c(ndraws, nobsv, ncat - 1)) il_categorical <- inv_link_categorical(x_test) l_categorical <- link_categorical(il_categorical) expect_equivalent(l_categorical, x_test) } } } }) brms/tests/testthat/tests.emmeans.R0000644000176200001440000000265315053072461017141 0ustar liggesuserscontext("Tests for emmeans support") skip_if_not_installed("emmeans") skip_on_cran() require(emmeans) SW <- suppressWarnings fit1 <- rename_pars(brms:::brmsfit_example1) fit2 <- rename_pars(brms:::brmsfit_example2) fit4 <- rename_pars(brms:::brmsfit_example4) fit6 <- rename_pars(brms:::brmsfit_example6) test_that("emmeans returns expected output structure", { em <- summary(emmeans(fit1, "Age", by = "Trt")) expect_equal(nrow(em), 2) em <- summary(emmeans(fit1, "Trt", dpar = "sigma")) expect_equal(nrow(em), 2) em <- summary(emmeans(fit1, "Age", by = "Exp")) expect_equal(nrow(em), 5) em <- summary(emmeans(fit1, "Exp")) expect_equal(nrow(em), 5) em <- SW(summary(emmeans(fit2, "Age", nlpar = "a"))) expect_equal(nrow(em), 1) em <- SW(summary(emmeans(fit4, "x1", dpar = "mu"))) expect_equal(nrow(em), 1) }) test_that("emmeans supports 'epred' predictions", { em <- summary(emmeans(fit2, "Age", epred = TRUE)) expect_equal(nrow(em), 1) em <- summary(emmeans(fit2, "Age", by = "Trt", epred = TRUE)) expect_equal(nrow(em), 2) # test for a multivariate model em <- summary(emmeans(fit6, "Age", by = "Trt", epred = TRUE)) expect_equal(nrow(em), 2) }) test_that("emmeans supports multilevel terms", { em <- summary(emmeans(fit1, "Age", by = "Trt", re_formula = NULL)) expect_equal(nrow(em), 2) em <- SW(summary(emmeans(fit2, "Age", nlpar = "a", re_formula = NULL))) expect_equal(nrow(em), 1) }) brms/tests/testthat/tests.families.R0000644000176200001440000001311715053072461017302 0ustar liggesuserscontext("Tests for family functions") test_that("family functions returns expected results", { expect_equal(student(identity)$link, "identity") expect_equal(student()$link, "identity") expect_equal(bernoulli(logit)$link, "logit") expect_error(bernoulli("sqrt"), "bernoulli") expect_equal(negbinomial(sqrt)$link, "sqrt") expect_error(negbinomial(inverse), "inverse") expect_equal(geometric(identity)$link, "identity") expect_error(geometric("inv"), "geometric") expect_equal(exponential(log)$link, "log") expect_error(exponential("cloglog"), "exponential") expect_equal(weibull()$family, "weibull") expect_error(weibull(sqrt), "weibull") expect_equal(Beta("probit")$link, "probit") expect_error(Beta("1/mu^2"), "beta") expect_equal(hurdle_poisson()$link, "log") expect_equal(hurdle_negbinomial(log)$link, "log") expect_error(hurdle_negbinomial("inverse"), "hurdle_negbinomial") expect_equal(hurdle_gamma()$family, "hurdle_gamma") expect_error(hurdle_gamma(sqrt), "hurdle_gamma") expect_equal(zero_inflated_poisson(log)$link, "log") expect_error(zero_inflated_poisson(list(1)), "zero_inflated_poisson") expect_equal(zero_inflated_negbinomial("log")$link, "log") expect_error(zero_inflated_negbinomial("logit"), "zero_inflated_negbinomial") expect_equal(zero_inflated_beta(logit)$family, "zero_inflated_beta") expect_equivalent(zero_inflated_binomial()$link_zi, "logit") expect_error(zero_inflated_binomial(y~x), "zero_inflated_binomial") expect_equal(categorical()$link, "logit") expect_error(categorical(probit), "probit") expect_equal(cumulative(cauchit)$family, "cumulative") expect_equal(sratio(probit_approx)$link, "probit_approx") expect_equal(cratio("cloglog")$family, "cratio") expect_equal(acat(cloglog)$link, "cloglog") expect_equal(brmsfamily("gaussian", inverse)$link, "inverse") expect_equal(brmsfamily("geometric", "identity")$family, "geometric") expect_equal(brmsfamily("zi_poisson")$link_zi, "logit") expect_error(weibull(link_shape = "logit"), "'logit' is not a supported link for parameter 'shape'") expect_error(weibull(link_shape = c("log", "logit")), "Cannot coerce 'alink' to a single character value") expect_equal(beta_binomial()$link, "logit") expect_equal(beta_binomial('probit')$link, "probit") expect_equal(beta_binomial()$link_phi, "log") expect_error(beta_binomial('log')) expect_error(beta_binomial(link_phi = 'logit')) expect_equal(zero_inflated_beta_binomial()$link, "logit") expect_equal(zero_inflated_beta_binomial('probit')$link, "probit") expect_equal(zero_inflated_beta_binomial()$link_phi, "log") expect_equal(zero_inflated_beta_binomial()$link_zi, "logit") expect_equal(zero_inflated_beta_binomial(link_zi = "identity")$link_zi, "identity") expect_error(zero_inflated_beta_binomial('sqrt')) expect_error(zero_inflated_beta_binomial(link_phi = 'logit')) expect_error(zero_inflated_beta_binomial(link_zi = 'log')) expect_equal(hurdle_cumulative()$link, "logit") expect_equal(hurdle_cumulative('probit')$link, "probit") expect_equal(hurdle_cumulative('cauchit')$link, "cauchit") expect_equal(hurdle_cumulative()$link_hu, "logit") expect_equal(hurdle_cumulative()$link_disc, "log") expect_error(hurdle_cumulative(link = "log")$link) expect_error(hurdle_cumulative(link_hu = "probit")$link_hu) expect_error(hurdle_cumulative(link_disc = "logit")$link_disc) expect_equal(xbeta()$link, "logit") expect_equal(xbeta("probit")$link, "probit") expect_equal(xbeta("cloglog")$link, "cloglog") expect_error(xbeta("1/mu"), "xbeta") expect_equal(xbeta(link_phi = "log")$link_phi, "log") expect_equal(xbeta(link_phi = "softplus")$link_phi, "softplus") expect_error(xbeta(link_phi = "sqrt")$link_phi, "sqrt") expect_equal(xbeta(link_kappa = "identity")$link_kappa, "identity") expect_equal(xbeta(link_kappa = "log")$link_kappa, "log") }) test_that("print brmsfamily works correctly", { expect_output(print(weibull()), "Family: weibull \nLink function: log") expect_output(print(xbeta()), "Family: xbeta \nLink function: logit") }) test_that("mixture returns expected results and errors", { mix <- mixture(gaussian, nmix = 3) expect_equal(brms:::family_names(mix), rep("gaussian", 3)) mix <- mixture(gaussian, student, weibull, nmix = 3:1) expect_equal( brms:::family_names(mix), c(rep("gaussian", 3), rep("student", 2), "weibull") ) expect_error(mixture(gaussian, "x"), "x is not a supported family") expect_error(mixture(poisson(), categorical()), "Some of the families are not allowed in mixture models") expect_error(mixture(poisson, "cumulative"), "Cannot mix ordinal and non-ordinal families") expect_error(mixture(lognormal, exgaussian, poisson()), "Cannot mix families with real and integer support") expect_error(mixture(lognormal), "Expecting at least 2 mixture components") expect_error(mixture(poisson, binomial, order = "x"), "Argument 'order' is invalid") }) test_that("response interval is defined correctly", { expect_equal(xbeta()$closed, rep(TRUE, 2)) expect_equal(xbeta()$ybounds, c(0, 1)) expect_equal(xbeta()$type, "real") }) test_that("distributional parameters are as expected", { expect_identical(xbeta()$dpars, c("mu", "phi", "kappa")) }) test_that("default priors are as expected", { expect_output(print(xbeta()$prior), "gamma\\(0.01, 0.01\\)") expect_output(print(xbeta()$prior), "student\\_t\\(3, 0, 2.5\\)") }) test_that("correct STAN code is used", { expect_equal(xbeta()$include, "fun_xbeta.stan") }) brms/tests/testthat/tests.exclude_pars.R0000644000176200001440000000317014424475714020176 0ustar liggesuserscontext("Tests for exclude_pars helper functions") test_that("exclude_pars returns expected parameter names", { dat <- data.frame(y = 1:10, x1 = rnorm(10), x2 = rnorm(10), g = rep(1:5, 2), h = factor(rep(1:5, each = 2))) fit <- brm(y ~ x1*x2 + (x1*x2|g) + (1 | h), dat, empty = TRUE) ep <- brms:::exclude_pars(fit) expect_true(all(c("r_1", "r_2") %in% ep)) fit <- brm(y ~ x1*x2 + (x1*x2|g) + (1 | h), dat, empty = TRUE, save_pars = save_pars(all = TRUE)) ep <- brms:::exclude_pars(fit) expect_true(!any(c("z_1", "z_2") %in% ep)) fit <- brm(y ~ x1*x2 + (x1*x2|g) + (1 | h), dat, empty = TRUE, save_pars = save_pars(group = FALSE)) ep <- brms:::exclude_pars(fit) expect_true("r_1_1" %in% ep) fit <- brm(y ~ x1*x2 + (x1 | g) + (1 | h), dat, empty = TRUE, save_pars = save_pars(group = "h")) ep <- brms:::exclude_pars(fit) expect_true(!"r_1_3" %in% ep) fit <- brm(y ~ s(x1) + x2, dat, empty = TRUE) ep <- brms:::exclude_pars(fit) expect_true("zs_1_1" %in% ep) fit <- brm(bf(y ~ eta, eta ~ x1 + s(x2), nl = TRUE), dat, empty = TRUE) ep <- brms:::exclude_pars(fit) expect_true("zs_eta_1_1" %in% ep) fit <- brm(y ~ me(x1, g), dat, empty = TRUE) ep <- brms:::exclude_pars(fit) expect_true("Xme_1" %in% ep) fit <- brm(y ~ me(x1, g), dat, empty = TRUE, save_pars = save_pars(latent = "x1")) ep <- brms:::exclude_pars(fit) expect_true(!"Xme_1" %in% ep) fit <- brm(y ~ me(x1, g), dat, empty = TRUE, save_pars = save_pars(manual = "Lme_1")) ep <- brms:::exclude_pars(fit) expect_true(!"Lme_1" %in% ep) }) brms/tests/testthat/tests.priors.R0000644000176200001440000001530715053072461017032 0ustar liggesusers# most tests of prior related stuff can be found in tests.stancode.R context("Tests for prior generating functions") test_that("default_prior finds all classes for which priors can be specified", { expect_equal( sort( default_prior( count ~ zBase * Trt + (1|patient) + (1+Trt|visit), data = epilepsy, family = "poisson" )$class ), sort(c(rep("b", 4), c("cor", "cor"), "Intercept", rep("sd", 6))) ) expect_equal( sort( default_prior( rating ~ treat + period + cse(carry), data = inhaler, family = sratio(threshold = "equidistant") )$class ), sort(c(rep("b", 4), "delta", rep("Intercept", 1))) ) }) test_that("set_prior allows arguments to be vectors", { bprior <- set_prior("normal(0, 2)", class = c("b", "sd")) expect_is(bprior, "brmsprior") expect_equal(bprior$prior, rep("normal(0, 2)", 2)) expect_equal(bprior$class, c("b", "sd")) }) test_that("print for class brmsprior works correctly", { expect_output(print(set_prior("normal(0,1)")), fixed = TRUE, "b ~ normal(0,1)") expect_output(print(set_prior("normal(0,1)", coef = "x")), "b_x ~ normal(0,1)", fixed = TRUE) expect_output(print(set_prior("cauchy(0,1)", class = "sd", group = "x")), "sd_x ~ cauchy(0,1)", fixed = TRUE) expect_output(print(set_prior("target += normal_lpdf(x | 0,1))", check = FALSE)), "target += normal_lpdf(x | 0,1))", fixed = TRUE) }) test_that("default_prior returns correct nlpar names for random effects pars", { # reported in issue #47 dat <- data.frame(y = rnorm(10), x = rnorm(10), g = rep(1:2, 5)) bform <- bf(y ~ a - b^x, a + b ~ (1+x|g), nl = TRUE) gp <- default_prior(bform, data = dat) expect_equal(sort(unique(gp$nlpar)), c("", "a", "b")) }) test_that("default_prior returns correct fixed effect names for GAMMs", { dat <- data.frame(y = rnorm(10), x = rnorm(10), z = rnorm(10), g = rep(1:2, 5)) prior <- default_prior(y ~ z + s(x) + (1|g), data = dat) expect_equal(prior[prior$class == "b", ]$coef, c("", "sx_1", "z")) prior <- default_prior(bf(y ~ lp, lp ~ z + s(x) + (1|g), nl = TRUE), data = dat) expect_equal(prior[prior$class == "b", ]$coef, c("", "Intercept", "sx_1", "z")) }) test_that("default_prior returns correct prior names for auxiliary parameters", { dat <- data.frame(y = rnorm(10), x = rnorm(10), z = rnorm(10), g = rep(1:2, 5)) bform <- bf(y ~ 1, phi ~ z + (1|g), family = Beta()) prior <- default_prior(bform, data = dat) prior <- prior[prior$dpar == "phi", ] pdata <- data.frame(class = c("b", "b", "Intercept", rep("sd", 3)), coef = c("", "z", "", "", "", "Intercept"), group = c(rep("", 4), "g", "g"), stringsAsFactors = FALSE) pdata <- pdata[with(pdata, order(class, group, coef)), ] expect_equivalent(prior[, c("class", "coef", "group")], pdata) }) test_that("default_prior returns correct priors for multivariate models", { dat <- data.frame(y1 = rnorm(10), y2 = c(1, rep(1:3, 3)), x = rnorm(10), g = rep(1:2, 5)) bform <- bf(mvbind(y1, y2) ~ x + (x|ID1|g)) + set_rescor(TRUE) # check global priors prior <- default_prior(bform, dat, family = gaussian()) expect_equal(prior[prior$resp == "y1" & prior$class == "b", "coef"], c("", "x")) expect_equal(prior[prior$class == "rescor", "prior"], "lkj(1)") # check family and autocor specific priors family <- list(gaussian, Beta()) bform <- bf(y1 ~ x + (x|ID1|g) + ar()) + bf(y2 ~ 1) prior <- default_prior(bform, dat, family = family) expect_true(any(with(prior, class == "sigma" & resp == "y1"))) expect_true(any(with(prior, class == "ar" & resp == "y1"))) expect_true(any(with(prior, class == "phi" & resp == "y2"))) expect_true(!any(with(prior, class == "ar" & resp == "y2"))) }) test_that("default_prior returns correct priors for categorical models", { # check global priors dat <- data.frame(y2 = c(1, rep(1:3, 3)), x = rnorm(10), g = rep(1:2, 5)) prior <- default_prior(y2 ~ x + (x|ID1|g), data = dat, family = categorical()) expect_equal(prior[prior$dpar == "mu2" & prior$class == "b", "coef"], c("", "x")) }) test_that("set_prior alias functions produce equivalent results", { expect_equal(set_prior("normal(0, 1)", class = "sd"), prior(normal(0, 1), class = sd)) expect_equal(set_prior("normal(0, 1)", class = "sd", nlpar = "a"), prior(normal(0, 1), class = "sd", nlpar = a)) expect_equal(set_prior("normal(0, 1)", class = "sd", nlpar = "a"), prior_(~normal(0, 1), class = ~sd, nlpar = quote(a))) expect_equal(set_prior("normal(0, 1)", class = "sd"), prior_string("normal(0, 1)", class = "sd")) }) test_that("external interface of validate_prior works correctly", { prior1 <- prior(normal(0,10), class = b) + prior(cauchy(0,2), class = sd) prior1 <- validate_prior( prior1, count ~ zAge + zBase * Trt + (1|patient), data = epilepsy, family = poisson() ) expect_true(all(c("b", "Intercept", "sd") %in% prior1$class)) expect_equal(nrow(prior1), 9) }) test_that("overall intercept priors are adjusted for the intercept", { dat <- data.frame(y = rep(c(1, 3), each = 5), off = 10) prior1 <- default_prior(y ~ 1 + offset(off), dat) int_prior <- prior1$prior[prior1$class == "Intercept"] expect_equal(int_prior, "student_t(3, -8, 2.5)") }) test_that("as.brmsprior works correctly", { dat <- data.frame(prior = "normal(0,1)", x = "test", coef = c("a", "b")) bprior <- as.brmsprior(dat) expect_equal(bprior$prior, rep("normal(0,1)", 2)) expect_equal(bprior$class, rep("b", 2)) expect_equal(bprior$coef, c("a", "b")) expect_equal(bprior$x, NULL) expect_equal(bprior$lb, rep(NA_character_, 2)) }) test_that("prior tags are correctly applied", { prior1 <- prior(normal(0, 1), class = sd, tag = "prior_tag1") prior2 <- prior(normal(0, 5), class = b, tag = "prior_tag2") prior3 <- prior(normal(0, 0.5), coef = "Trt1", tag = "prior_tag3") prior4 <- prior(normal(0, 10), class = "Intercept", tag = "prior_tag4") prior5 <- prior(lkj_corr_cholesky(3), class = "L", group = "visit", tag = "prior_tag5") v <- validate_prior( c(prior1, prior2, prior3, prior4, prior5), formula = count ~ zBase * Trt + (1 | patient) + (1 + Trt | visit), data = epilepsy, family = poisson()) expect_equal(v[which(v$class == "sd"),]$tag[[1]], "prior_tag1") expect_equal(v[which(v$class == "b" & v$coef != "Trt1"),]$tag[[1]], "prior_tag2") expect_equal(v[which(v$class == "b" & v$coef == "Trt1"),]$tag, "prior_tag3") expect_equal(v[which(v$class == "Intercept"),]$tag, "prior_tag4") expect_equal(v[which(v$class == "L"),]$tag[[2]], "prior_tag5") }) brms/tests/testthat/tests.misc.R0000644000176200001440000000547615053072461016455 0ustar liggesuserscontext("Tests for miscellaneous functions") test_that("p performs correct indexing", { expect_equal(p(1:10), 1:10) x <- rnorm(10) expect_equal(p(x, i = 3), x[3]) A <- matrix(x, nrow = 5) expect_equal(p(A, i = 3), A[3, , drop = FALSE]) expect_equal(p(A, i = 2, row = FALSE), A[, 2, drop = FALSE]) }) test_that("rmNULL removes all NULL entries", { expect_equal(rmNULL(list(a = NULL, b = 1, c = list(NULL, 1))), list(b = 1, c = list(1))) expect_equal(rmNULL(list(a = NULL, b = 1, c = NULL)), list(b = 1)) }) test_that("rename returns an error on duplicated names", { expect_error(rename(c(letters[1:4],"a()","a["), check_dup = TRUE), fixed = TRUE, paste("Occured for: 'a', 'a()', 'a['")) expect_error(rename(c("aDb","a/b","b"), check_dup = TRUE), fixed = TRUE, paste("Occured for: 'aDb', 'a/b'")) expect_error(rename(c("log(a,b)","logab","bac","ba"), check_dup = TRUE), fixed = TRUE, paste("Occured for: 'log(a,b)', 'logab'")) }) test_that("rename perform correct renaming", { names <- c("acd", "a[23]", "b__") expect_equal( rename(names, c("[", "]", "__"), c(".", ".", ":")), c("acd", "a.23.", "b:") ) expect_equal( rename(names, c("^\\[", "\\]", "__$"), c(".", ".", ":"), fixed = FALSE), c("acd", "a[23.", "b:") ) }) test_that("collapse_lists performs correct collapsing after names", { x <- list(a = "a <- ", b = "b <- ") y <- list(b = "cauchy(1,2)", c = "normal(0,1)", a = "gamma(1,1)") expect_equal(collapse_lists(list()), list()) expect_equal(collapse_lists(x, y), list(a = "a <- gamma(1,1)", b = "b <- cauchy(1,2)", c = "normal(0,1)")) expect_equal(collapse_lists(ls = list(c(x, c = "c <- "), y)), list(a = "a <- gamma(1,1)", b = "b <- cauchy(1,2)", c = "c <- normal(0,1)")) }) test_that("nlist works correctly", { x <- 1 y <- 2:3 exlist <- list(x = x, y = y) expect_equal(nlist(x = x, y = y), exlist) expect_equal(nlist(x, y), exlist) expect_equal(nlist(x = x, y), exlist) }) test_that("use_alias works correctly", { a <- 2 b <- 3 expect_warning(use_alias(a, b), fixed = TRUE, "'b' is deprecated. Please use argument 'a' instead.") dots <- list(c = 1) expect_warning(use_alias(a, dots$c), fixed = TRUE, "'c' is deprecated. Please use argument 'a' instead.") expect_equal(use_alias(a, dots$c, warn = FALSE), dots$c) }) test_that("rhs keeps attributes", { form <- structure(y~x, test = TRUE) expect_equal(attributes(form), attributes(rhs(form))) }) test_that("lsp works correctly", { expect_equal( lsp("base", pattern = "^log"), c("log", "log10", "log1p", "log2", "logb", "logical") ) expect_equal( lsp("brms", pattern = "^inv_logit"), c("inv_logit", "inv_logit_scaled") ) }) brms/tests/testthat/tests.stancode.R0000644000176200001440000034561715053305627017331 0ustar liggesuserscontext("Tests for stancode") # simplifies manual calling of tests expect_match2 <- brms:::expect_match2 SW <- brms:::SW # parsing the Stan code ensures syntactical correctness of models # setting this option to FALSE speeds up testing not_cran <- identical(Sys.getenv("NOT_CRAN"), "true") options(brms.parse_stancode = not_cran, brms.backend = "rstan") test_that("specified priors appear in the Stan code", { dat <- data.frame(y = 1:10, x1 = rnorm(10), x2 = rnorm(10), g = rep(1:5, 2), h = factor(rep(1:5, each = 2))) prior <- c(prior(std_normal(), coef = x1), prior(normal(0,2), coef = x2), prior(normal(0,5), Intercept, lb = 0), prior(cauchy(0,1), sd, group = g, lb = "", ub = 5), prior(cauchy(0,2), sd, group = g, coef = x1), prior(gamma(1, 1), sd, group = h, ub = 10)) scode <- stancode(y ~ x1*x2 + (x1*x2|g) + (1 | h), dat, prior = prior, sample_prior = "yes") expect_match2(scode, "vector[M_1] sd_1;") expect_match2(scode, "vector[M_2] sd_2;") expect_match2(scode, "target += lprior;") expect_match2(scode, "lprior += std_normal_lpdf(b[1])") expect_match2(scode, "lprior += normal_lpdf(b[2] | 0, 2)") expect_match2(scode, "lprior += normal_lpdf(Intercept | 0, 5)") expect_match2(scode, "lprior += cauchy_lpdf(sd_1[1] | 0, 1)") expect_match2(scode, "- 1 * cauchy_lcdf(5 | 0, 1)") expect_match2(scode, "lprior += cauchy_lpdf(sd_1[2] | 0, 2)") expect_match2(scode, "lprior += student_t_lpdf(sigma | 3, 0, 3.7)") expect_match2(scode, "- 1 * student_t_lccdf(0 | 3, 0, 3.7)") expect_match2(scode, "lprior += gamma_lpdf(sd_2 | 1, 1)") expect_match2(scode, "prior_b__1 = normal_rng(0,1);") expect_match2(scode, "prior_sd_1__1 = cauchy_rng(0,1)") expect_match2(scode, "while (prior_sd_1__1 > 5)") expect_match2(scode, "prior_sd_2 = gamma_rng(1,1)") expect_match2(scode, "while (prior_sd_2 < 0 || prior_sd_2 > 10)") prior <- c(prior(lkj(0.5), class = cor, group = g), prior(normal(0, 1), class = b), prior(normal(0, 5), class = Intercept), prior(cauchy(0, 5), class = sd)) scode <- stancode(y ~ x1 + cs(x2) + (0 + x1 + x2 | g), data = dat, family = acat(), prior = prior, sample_prior = TRUE) expect_match2(scode, "lprior += normal_lpdf(b | 0, 1)") expect_match2(scode, "lprior += normal_lpdf(Intercept | 0, 5)") expect_match2(scode, "lprior += cauchy_lpdf(sd_1 | 0, 5)") expect_match2(scode, "lprior += lkj_corr_cholesky_lpdf(L_1 | 0.5)") expect_match2(scode, "lprior += normal_lpdf(to_vector(bcs) | 0, 1)") expect_match2(scode, "prior_bcs = normal_rng(0,1)") prior <- c(prior(normal(0,5), nlpar = a), prior(normal(0,10), nlpar = b), prior(cauchy(0,1), class = sd, nlpar = a), prior(lkj(2), class = cor, group = g)) scode <- stancode( bf(y ~ a * exp(-b * x1), a + b ~ (1|ID|g), nl = TRUE), data = dat, prior = prior, sample_prior = TRUE ) expect_match2(scode, "lprior += normal_lpdf(b_a | 0, 5)") expect_match2(scode, "lprior += normal_lpdf(b_b | 0, 10)") expect_match2(scode, "lprior += cauchy_lpdf(sd_1[1] | 0, 1)") expect_match2(scode, "lprior += lkj_corr_cholesky_lpdf(L_1 | 2)") expect_match2(scode, "prior_b_a = normal_rng(0,5)") expect_match2(scode, "prior_sd_1__2 = student_t_rng(3,0,3.7)") expect_match2(scode, "prior_cor_1 = lkj_corr_rng(M_1,2)[1, 2]") prior <- c(prior(lkj(2), rescor), prior(cauchy(0, 5), sigma, resp = y), prior(cauchy(0, 1), sigma, resp = x1)) form <- bf(mvbind(y, x1) ~ x2) + set_rescor(TRUE) scode <- stancode(form, dat, prior = prior, sample_prior = TRUE) expect_match2(scode, "lprior += lkj_corr_cholesky_lpdf(Lrescor | 2)") expect_match2(scode, "prior_sigma_y = cauchy_rng(0,5)") expect_match2(scode, "prior_rescor = lkj_corr_rng(nresp,2)[1, 2]") prior <- c(prior(uniform(-1, 1), ar), prior(normal(0, 0.5), ma), prior(normal(0, 5))) scode <- stancode(y ~ mo(g) + arma(cov = TRUE), dat, prior = prior, sample_prior = TRUE) expect_match2(scode, "vector[Kar] ar;") expect_match2(scode, "vector[Kma] ma;") expect_match2(scode, "lprior += uniform_lpdf(ar | -1, 1)") expect_match2(scode, "lprior += normal_lpdf(ma | 0, 0.5)") expect_match2(scode, "- 1 * log_diff_exp(normal_lcdf(1 | 0, 0.5), normal_lcdf(-1 | 0, 0.5))" ) expect_match2(scode, "lprior += normal_lpdf(bsp | 0, 5)") expect_match2(scode, "lprior += dirichlet_lpdf(simo_1 | con_simo_1)") expect_match2(scode, "prior_simo_1 = dirichlet_rng(con_simo_1)") expect_match2(scode, "prior_ar = uniform_rng(-1,1)") expect_match2(scode, "while (prior_ar < -1 || prior_ar > 1)") # test for problem described in #213 prior <- c(prior(normal(0, 1), coef = x1), prior(normal(0, 2), coef = x1, dpar = sigma)) scode <- stancode(bf(y ~ x1, sigma ~ x1), dat, prior = prior) expect_match2(scode, "lprior += normal_lpdf(b[1] | 0, 1);") expect_match2(scode, "lprior += normal_lpdf(b_sigma[1] | 0, 2);") prior <- c(set_prior("target += normal_lpdf(b[1] | 0, 1)", check = FALSE), set_prior("", class = "sigma")) scode <- stancode(y ~ x1, dat, prior = prior, sample_prior = TRUE) expect_match2(scode, "target += normal_lpdf(b[1] | 0, 1)") expect_true(!grepl("sigma \\|", scode)) # tests use of default priors stored in families #1614 scode <- stancode(y ~ x1, dat, family = negbinomial()) expect_match2(scode, "lprior += inv_gamma_lpdf(shape | 0.4, 0.3);") scode <- stancode(y ~ x2, dat, family = von_mises()) expect_match2(scode, "lprior += student_t_lpdf(Intercept | 1, 0, 1);") prior <- prior(gamma(0, 1), coef = x1) expect_warning(stancode(y ~ x1, dat, prior = prior), "no natural lower bound") prior <- prior(uniform(0,5), class = sd) expect_warning(stancode(y ~ x1 + (1|g), dat, prior = prior), "no natural upper bound") prior <- prior(uniform(-1, 1), class = cor) expect_error( stancode(y ~ x1 + (x1|g), dat, prior = prior), "prior for correlation matrices is the 'lkj' prior" ) }) test_that("special shrinkage priors appear in the Stan code", { dat <- data.frame(y = 1:10, x1 = rnorm(10), x2 = rnorm(10), g = rep(1:2, each = 5), x3 = sample(1:5, 10, TRUE)) # horseshoe prior hs <- horseshoe(7, scale_global = 2, df_global = 3, df_slab = 6, scale_slab = 3) scode <- stancode(y ~ x1*x2, data = dat, prior = set_prior(hs), sample_prior = TRUE) expect_match2(scode, "vector[Kscales] hs_local;") expect_match2(scode, "real hs_global;") expect_match2(scode, "target += student_t_lpdf(hs_local | hs_df, 0, 1)" ) expect_match2(scode, "lprior += student_t_lpdf(hs_global | hs_df_global, 0, hs_scale_global * sigma)" ) expect_match2(scode, "lprior += inv_gamma_lpdf(hs_slab | 0.5 * hs_df_slab, 0.5 * hs_df_slab)" ) expect_match2(scode, "scales = scales_horseshoe(hs_local, hs_global, hs_scale_slab^2 * hs_slab);" ) scode <- stancode(y ~ x1*x2, data = dat, poisson(), prior = prior(horseshoe(scale_global = 3))) expect_match2(scode, "scales = scales_horseshoe(hs_local, hs_global, hs_scale_slab^2 * hs_slab);" ) scode <- stancode(x1 ~ mo(y), dat, prior = prior(horseshoe())) expect_match2(scode, "target += std_normal_lpdf(zbsp);") expect_match2(scode, "target += student_t_lpdf(hs_local | hs_df, 0, 1)" ) expect_match2(scode, "scales = scales_horseshoe(hs_local, hs_global, hs_scale_slab^2 * hs_slab);" ) # R2D2 prior scode <- stancode(y ~ x1*x2, data = dat, prior = prior(R2D2(0.5, 10)), sample_prior = TRUE) expect_match2(scode, "scales = scales_R2D2(R2D2_phi, R2D2_tau2);") expect_match2(scode, "target += dirichlet_lpdf(R2D2_phi | R2D2_cons_D2);") expect_match2(scode, "lprior += beta_lpdf(R2D2_R2 | R2D2_mean_R2 * R2D2_prec_R2, (1 - R2D2_mean_R2) * R2D2_prec_R2);") expect_match2(scode, "R2D2_tau2 = sigma^2 * R2D2_R2 / (1 - R2D2_R2);") # shrinkage priors applied in a non-linear model hs_a1 <- horseshoe(7, scale_global = 2, df_global = 3) R2D2_a2 <- R2D2(0.5, 10) scode <- SW(stancode( bf(y ~ a1 + a2, a1 ~ x1, a2 ~ 0 + x2, nl = TRUE), data = dat, sample_prior = TRUE, prior = c(set_prior(hs_a1, nlpar = "a1"), set_prior(R2D2_a2, nlpar = "a2")) )) expect_match2(scode, "vector[Kscales_a1] hs_local_a1;") expect_match2(scode, "real hs_global_a1;") expect_match2(scode, "target += student_t_lpdf(hs_local_a1 | hs_df_a1, 0, 1)" ) expect_match2(scode, "lprior += student_t_lpdf(hs_global_a1 | hs_df_global_a1, 0, hs_scale_global_a1 * sigma)" ) expect_match2(scode, "lprior += inv_gamma_lpdf(hs_slab_a1 | 0.5 * hs_df_slab_a1, 0.5 * hs_df_slab_a1)" ) expect_match2(scode, "scales_a1 = scales_horseshoe(hs_local_a1, hs_global_a1, hs_scale_slab_a1^2 * hs_slab_a1);" ) expect_match2(scode, "scales_a2 = scales_R2D2(R2D2_phi_a2, R2D2_tau2_a2);") # shrinkage priors can be applied globally bform <- bf(y ~ x1*mo(x3) + (1|g) + (1|x1) + gp(x3) + s(x2) + arma(p = 2, q = 2, gr = g)) bprior <- prior(R2D2(main = TRUE), class = b) + prior(R2D2(), class = sd) + prior(R2D2(), class = sds) + prior(R2D2(), class = sdgp) + prior(R2D2(), class = ar) + prior(R2D2(), class = ma) scode <- stancode(bform, data = dat, prior = bprior) expect_match2(scode, "sdb = scales[(1):(Kc)];") expect_match2(scode, "sdbsp = scales[(1+Kc):(Kc+Ksp)];") expect_match2(scode, "sdbs = scales[(1+Kc+Ksp):(Kc+Ksp+Ks)];") expect_match2(scode, "sds_1 = scales[(1+Kc+Ksp+Ks):(Kc+Ksp+Ks+nb_1)];") expect_match2(scode, "sdgp_1 = scales[(1+Kc+Ksp+Ks+nb_1):(Kc+Ksp+Ks+nb_1+Kgp_1)];") expect_match2(scode, "sdar = scales[(1+Kc+Ksp+Ks+nb_1+Kgp_1):(Kc+Ksp+Ks+nb_1+Kgp_1+Kar)];") expect_match2(scode, "sdma = scales[(1+Kc+Ksp+Ks+nb_1+Kgp_1+Kar):(Kc+Ksp+Ks+nb_1+Kgp_1+Kar+Kma)];") expect_match2(scode, "sd_1 = scales[(1+Kc+Ksp+Ks+nb_1+Kgp_1+Kar+Kma):(Kc+Ksp+Ks+nb_1+Kgp_1+Kar+Kma+M_1)];") expect_match2(scode, "sd_2 = scales[(1+Kc+Ksp+Ks+nb_1+Kgp_1+Kar+Kma+M_1):(Kc+Ksp+Ks+nb_1+Kgp_1+Kar+Kma+M_1+M_2)];") expect_match2(scode, "bsp = zbsp .* sdbsp; // scale coefficients") expect_match2(scode, "ar = zar .* sdar; // scale coefficients") # check error messages expect_error(stancode(y ~ x1*x2, data = dat, prior = prior(horseshoe(-1))), "Degrees of freedom of the local priors") expect_error(stancode(y ~ x1*x2, data = dat, prior = prior(horseshoe(1, -1))), "Scale of the global prior") expect_error(stancode(y ~ cs(x1), dat, acat(), prior = prior(R2D2())), "Special priors are not yet allowed") bprior <- prior(horseshoe()) + prior(normal(0, 1), coef = "y") expect_error(stancode(x1 ~ y, dat, prior = bprior), "Defining separate priors for single coefficients") expect_error(stancode(x1 ~ y, dat, prior = prior(horseshoe(), lb = 0)), "Setting boundaries on coefficients is not allowed") expect_error( stancode(y ~ x1*x2, data = dat, prior = prior(lasso(2, scale = 10))), "The lasso prior is no longer supported" ) }) test_that("priors can be fixed to constants", { dat <- data.frame(y = 1:12, x1 = rnorm(12), x2 = rnorm(12), g = rep(1:6, each = 2), h = factor(rep(1:2, each = 6))) prior <- prior(normal(0, 1), b) + prior(constant(3), b, coef = x1) + prior(constant(-1), b, coef = x2) + prior(constant(10), Intercept) + prior(normal(0, 5), sd) + prior(constant(1), sd, group = g, coef = x2) + prior(constant(2), sd, group = g, coef = x1) + prior(constant(0.3), sigma) scode <- stancode(y ~ x1*x2 + (x1*x2 | g), dat, prior = prior) expect_match2(scode, "b[1] = 3;") expect_match2(scode, "b[2] = -1;") expect_match2(scode, "b[3] = par_b_3;") expect_match2(scode, "lprior += normal_lpdf(b[3] | 0, 1);") expect_match2(scode, "Intercept = 1") expect_match2(scode, "sd_1[3] = 1;") expect_match2(scode, "sd_1[2] = 2;") expect_match2(scode, "sd_1[4] = par_sd_1_4;") expect_match2(scode, "lprior += normal_lpdf(sd_1[4] | 0, 5)") expect_match2(scode, "sigma = 0.3;") prior <- prior(constant(3)) scode <- stancode(y ~ x2 + x1 + cs(g), dat, family = sratio(), prior = prior) expect_match2(scode, "b = rep_vector(3, rows(b));") expect_match2(scode, "bcs = rep_matrix(3, rows(bcs), cols(bcs));") prior <- prior(normal(0, 3)) + prior(constant(3), coef = x1) + prior(constant(-1), coef = g) scode <- stancode(y ~ x1 + cs(x2) + cs(g), dat, family = sratio(), prior = prior) expect_match2(scode, "b[1] = 3;") expect_match2(scode, "bcs[1] = par_bcs_1;") expect_match2(scode, "lprior += normal_lpdf(bcs[1] | 0, 3);") expect_match2(scode, "bcs[2] = rep_row_vector(-1, cols(bcs[2]));") prior <- prior(constant(3), class = "sd", group = "g") + prior(constant("[[1, 0], [0, 1]]"), class = "cor") scode <- stancode(y ~ x1 + (x1 | gr(g, by = h)), dat, prior = prior) expect_match2(scode, "sd_1 = rep_matrix(3, rows(sd_1), cols(sd_1));") expect_match2(scode, "L_1[2] = [[1, 0], [0, 1]];") prior <- prior(constant(0.5), class = lscale, coef = gpx1h1) + prior(normal(0, 10), class = lscale, coef = gpx1h2) scode <- stancode(y ~ gp(x1, by = h), dat, prior = prior) expect_match2(scode, "lscale_1[1][1] = 0.5;") expect_match2(scode, "lscale_1[2][1] = par_lscale_1_2_1;") expect_match2(scode, "lprior += normal_lpdf(lscale_1[2][1] | 0, 10)") # test that improper base priors are correctly recognized (#919) prior <- prior(constant(-1), b, coef = x2) scode <- stancode(y ~ x1*x2, dat, prior = prior) expect_match2(scode, "real par_b_1;") expect_match2(scode, "b[3] = par_b_3;") # test error messages prior <- prior(normal(0, 1), Intercept) + prior(constant(3), Intercept, coef = 2) expect_error( stancode(y ~ x1, data = dat, family = cumulative(), prior = prior), "Can either estimate or fix all values" ) }) test_that("link functions appear in the Stan code", { dat <- data.frame(y = 1:10, x = rnorm(10)) expect_match2(stancode(y ~ s(x), dat, family = poisson()), "target += poisson_log_lpmf(Y | mu);") expect_match2(stancode(mvbind(y, y + 1) ~ x, dat, family = skew_normal("log")), "mu_y = exp(mu_y);") expect_match2(stancode(y ~ x, dat, family = von_mises(tan_half)), "mu = inv_tan_half(mu);") expect_match2(stancode(y ~ x, dat, family = weibull()), "mu = exp(mu);") expect_match2(stancode(y ~ x, dat, family = poisson("sqrt")), "mu = square(mu);") expect_match2(stancode(y ~ s(x), dat, family = bernoulli()), "target += bernoulli_logit_lpmf(Y | mu);") scode <- stancode(y ~ x, dat, family = beta_binomial('logit')) expect_match2(scode, "mu = inv_logit(mu);") scode <- stancode(y ~ x, dat, family = beta_binomial('cloglog')) expect_match2(scode, "mu = inv_cloglog(mu);") scode <- stancode(y ~ x, dat, family = beta_binomial('cauchit')) expect_match2(scode, "mu = inv_cauchit(mu);") scode <- stancode(y ~ x, dat, family = cumulative('cauchit')) expect_match2(scode, "p = inv_cauchit(disc * (thres[1] - mu));") }) test_that("Stan GLM primitives are applied correctly", { dat <- data.frame(x = rnorm(10), y = 1:10) scode <- stancode(y ~ x, dat, family = gaussian) expect_match2(scode, "normal_id_glm_lpdf(Y | Xc, Intercept, b, sigma)") scode <- stancode(y ~ x, dat, family = bernoulli) expect_match2(scode, "bernoulli_logit_glm_lpmf(Y | Xc, Intercept, b)") scode <- stancode(y ~ x, dat, family = poisson) expect_match2(scode, "poisson_log_glm_lpmf(Y | Xc, Intercept, b)") scode <- stancode(y ~ x, dat, family = negbinomial) expect_match2(scode, "neg_binomial_2_log_glm_lpmf(Y | Xc, Intercept, b, shape)" ) scode <- stancode(y ~ x, dat, family = brmsfamily("negbinomial2")) expect_match2(scode, "neg_binomial_2_log_glm_lpmf(Y | Xc, Intercept, b, inv(sigma))" ) scode <- stancode(y ~ 0 + x, dat, family = gaussian) expect_match2(scode, "normal_id_glm_lpdf(Y | X, 0, b, sigma)") bform <- bf(y ~ x) + bf(x ~ 1, family = negbinomial()) + set_rescor(FALSE) scode <- stancode(bform, dat, family = gaussian) expect_match2(scode, "normal_id_glm_lpdf(Y_y | Xc_y, Intercept_y, b_y, sigma_y)" ) scode <- stancode(bf(y ~ x, decomp = "QR"), dat, family = gaussian) expect_match2(scode, "normal_id_glm_lpdf(Y | XQ, Intercept, bQ, sigma);") }) test_that("customized covariances appear in the Stan code", { M <- diag(1, nrow = length(unique(inhaler$subject))) rownames(M) <- unique(inhaler$subject) dat2 <- list(M = M) scode <- stancode(rating ~ treat + (1 | gr(subject, cov = M)), data = inhaler, data2 = dat2) expect_match2(scode, "r_1_1 = (sd_1[1] * (Lcov_1 * z_1[1]))") scode <- stancode(rating ~ treat + (1 + treat | gr(subject, cov = M)), data = inhaler, data2 = dat2) expect_match2(scode, "r_1 = scale_r_cor_cov(z_1, sd_1, L_1, Lcov_1);") expect_match2(scode, "cor_1[choose(k - 1, 2) + j] = Cor_1[j, k];") scode <- stancode(rating ~ (1 + treat | gr(subject, cor = FALSE, cov = M)), data = inhaler, data2 = dat2) expect_match2(scode, "r_1_1 = (sd_1[1] * (Lcov_1 * z_1[1]));") expect_match2(scode, "r_1_2 = (sd_1[2] * (Lcov_1 * z_1[2]));") inhaler$by <- inhaler$subject %% 2 scode <- stancode(rating ~ (1 + treat | gr(subject, by = by, cov = M)), data = inhaler, data2 = dat2) expect_match2(scode, "r_1 = scale_r_cor_by_cov(z_1, sd_1, L_1, Jby_1, Lcov_1);") expect_warning( scode <- stancode(rating ~ treat + period + carry + (1|subject), data = inhaler, cov_ranef = list(subject = 1)), "Argument 'cov_ranef' is deprecated" ) expect_match2(scode, "r_1_1 = (sd_1[1] * (Lcov_1 * z_1[1]))") }) test_that("truncation appears in the Stan code", { scode <- stancode(time | trunc(0) ~ age + sex + disease, data = kidney, family = "gamma") expect_match2(scode, "target += gamma_lpdf(Y[n] | shape, shape ./ mu[n]) -") expect_match2(scode, "gamma_lccdf(lb[n] | shape, shape ./ mu[n]);") scode <- stancode(time | trunc(ub = 100) ~ age + sex + disease, data = kidney, family = student("log")) expect_match2(scode, "target += student_t_lpdf(Y[n] | nu, mu[n], sigma) -") expect_match2(scode, "student_t_lcdf(ub[n] | nu, mu[n], sigma);") scode <- stancode(count | trunc(0, 150) ~ Trt, data = epilepsy, family = "poisson") expect_match2(scode, "target += poisson_lpmf(Y[n] | mu[n]) -") expect_match2(scode, "log_diff_exp(poisson_lcdf(ub[n] | mu[n]), poisson_lcdf(lb[n] - 1 | mu[n]));" ) }) test_that("stancode handles models without fixed effects", { expect_match2(stancode(count ~ 0 + (1|patient) + (1+Trt|visit), data = epilepsy, family = "poisson"), "mu = rep_vector(0.0, N);") }) test_that("stancode correctly restricts FE parameters", { data <- data.frame(y = rep(0:1, each = 5), x = rnorm(10)) scode <- stancode(y ~ x, data, prior = set_prior("", lb = 2)) expect_match2(scode, "vector[Kc] b") scode <- stancode( y ~ x, data, prior = set_prior("normal (0, 2)", ub = "4") ) expect_match2(scode, "vector[Kc] b") expect_match2(scode, "- 1 * normal_lcdf(4 | 0, 2)") prior <- set_prior("normal(0,5)", lb = "-3", ub = 5) scode <- stancode(y ~ 0 + x, data, prior = prior) expect_match2(scode, "vector[K] b") }) test_that("self-defined functions appear in the Stan code", { # cauchit link scode <- stancode(rating ~ treat, data = inhaler, family = bernoulli("cauchit")) expect_match2(scode, "real inv_cauchit(real y)") # softplus link scode <- stancode(rating ~ treat, data = inhaler, family = brmsfamily("poisson", "softplus")) expect_match2(scode, "vector log_expm1(vector x)") # squareplus link scode <- stancode(rating ~ treat, data = inhaler, family = brmsfamily("poisson", "squareplus")) expect_match2(scode, "real squareplus(real x)") # tan_half link expect_match2(stancode(rating ~ treat, data = inhaler, family = von_mises("tan_half")), "vector inv_tan_half(vector y)") # logm1 link expect_match2(stancode(rating ~ treat, data = inhaler, family = frechet()), "real expp1(real y)") # inverse gaussian models scode <- stancode(time | cens(censored) ~ age, data = kidney, family = inverse.gaussian) expect_match2(scode, "real inv_gaussian_lpdf(real y") expect_match2(scode, "real inv_gaussian_lcdf(real y") expect_match2(scode, "real inv_gaussian_lccdf(real y") expect_match2(scode, "real inv_gaussian_lpdf(vector y") # zero-inflated and hurdle models expect_match2(stancode(count ~ Trt, data = epilepsy, family = "zero_inflated_poisson"), "real zero_inflated_poisson_lpmf(int y") expect_match2(stancode(count ~ Trt, data = epilepsy, family = "zero_inflated_negbinomial"), "real zero_inflated_neg_binomial_lpmf(int y") expect_match2(stancode(count ~ Trt, data = epilepsy, family = "zero_inflated_binomial"), "real zero_inflated_binomial_lpmf(int y") expect_match2(stancode(count ~ Trt, data = epilepsy, family = "zero_inflated_beta_binomial"), "real zero_inflated_beta_binomial_lpmf(int y") expect_match2(stancode(count ~ Trt, data = epilepsy, family = "zero_inflated_beta"), "real zero_inflated_beta_lpdf(real y") expect_match2(stancode(count ~ Trt, data = epilepsy, family = "zero_one_inflated_beta"), "real zero_one_inflated_beta_lpdf(real y") expect_match2(stancode(count ~ Trt, data = epilepsy, family = hurdle_poisson()), "real hurdle_poisson_lpmf(int y") expect_match2(stancode(count ~ Trt, data = epilepsy, family = hurdle_negbinomial), "real hurdle_neg_binomial_lpmf(int y") expect_match2(stancode(count ~ Trt, data = epilepsy, family = hurdle_gamma("log")), "real hurdle_gamma_lpdf(real y") expect_match2(stancode(count ~ Trt, data = epilepsy, family = hurdle_lognormal("identity")), "real hurdle_lognormal_lpdf(real y") # linear models with special covariance structures expect_match2( stancode(rating ~ treat + ar(cov = TRUE), data = inhaler), "real normal_time_hom_lpdf(vector y" ) expect_match2( stancode(time ~ age + ar(cov = TRUE), data = kidney, family = "student"), "real student_t_time_hom_lpdf(vector y" ) # ARMA covariance matrices expect_match2( stancode(rating ~ treat + ar(cov = TRUE), data = inhaler), "matrix cholesky_cor_ar1(real ar" ) expect_match2( stancode(time ~ age + ma(cov = TRUE), data = kidney), "matrix cholesky_cor_ma1(real ma" ) expect_match2( stancode(time ~ age + arma(cov = TRUE), data = kidney), "matrix cholesky_cor_arma1(real ar, real ma" ) }) test_that("invalid combinations of modeling options are detected", { data <- data.frame(y1 = rnorm(10), y2 = rnorm(10), wi = 1:10, ci = sample(-1:1, 10, TRUE)) expect_error( stancode(y1 | cens(ci) ~ y2 + ar(cov = TRUE), data = data), "Invalid addition arguments for this model" ) form <- bf(mvbind(y1, y2) ~ 1 + ar(cov = TRUE)) + set_rescor(TRUE) expect_error( stancode(form, data = data), "Explicit covariance terms cannot be modeled when 'rescor'" ) expect_error( stancode(y1 | resp_se(wi) ~ y2 + ma(), data = data), "Please set cov = TRUE in ARMA structures" ) }) test_that("Stan code for multivariate models is correct", { dat <- data.frame( y1 = rnorm(10), y2 = rnorm(10), x = 1:10, g = rep(1:2, each = 5), censi = sample(0:1, 10, TRUE) ) # models with residual correlations form <- bf(mvbind(y1, y2) ~ x) + set_rescor(TRUE) prior <- prior(horseshoe(2), resp = "y1") + prior(horseshoe(2), resp = "y2") scode <- stancode(form, dat, prior = prior) expect_match2(scode, "target += multi_normal_cholesky_lpdf(Y | Mu, LSigma);") expect_match2(scode, "LSigma = diag_pre_multiply(sigma, Lrescor);") expect_match2(scode, "target += student_t_lpdf(hs_local_y1 | hs_df_y1, 0, 1)") expect_match2(scode, "target += student_t_lpdf(hs_local_y2 | hs_df_y2, 0, 1)") expect_match2(scode, "rescor[choose(k - 1, 2) + j] = Rescor[j, k];") form <- bf(mvbind(y1, y2) ~ x) + set_rescor(TRUE) prior <- prior(R2D2(0.2, 10), resp = "y1") + prior(R2D2(0.5, 10), resp = "y2") scode <- SW(stancode(form, dat, student(), prior = prior)) expect_match2(scode, "target += multi_student_t_lpdf(Y | nu, Mu, Sigma);") expect_match2(scode, "matrix[nresp, nresp] Sigma = multiply_lower") expect_match2(scode, "lprior += gamma_lpdf(nu | 2, 0.1)") expect_match2(scode, "target += dirichlet_lpdf(R2D2_phi_y2 | R2D2_cons_D2_y2);") form <- bf(mvbind(y1, y2) | weights(x) ~ 1) + set_rescor(TRUE) scode <- stancode(form, dat) expect_match2(scode, "target += weights[n] * (multi_normal_cholesky_lpdf(Y[n] | Mu[n], LSigma));" ) # models without residual correlations expect_warning( bform <- bf(y1 | cens(censi) ~ x + y2 + (x|2|g)) + gaussian() + cor_ar() + (bf(x ~ 1) + mixture(poisson, nmix = 2)) + (bf(y2 ~ s(y2) + (1|2|g)) + skew_normal()), "Using 'cor_brms' objects for 'autocor' is deprecated" ) bprior <- prior(normal(0, 5), resp = y1) + prior(normal(0, 10), resp = y2) scode <- stancode(bform, dat, prior = bprior) expect_match2(scode, "r_1_y2_3 = r_1[, 3]") expect_match2(scode, "err_y1[n] = Y_y1[n] - mu_y1[n]") expect_match2(scode, "target += normal_lccdf(Y_y1[Jrcens_y1[1:Nrcens_y1]] | mu_y1[Jrcens_y1[1:Nrcens_y1]], sigma_y1)") expect_match2(scode, "target += skew_normal_lpdf(Y_y2 | mu_y2, omega_y2, alpha_y2)") expect_match2(scode, "ps[1] = log(theta1_x) + poisson_log_lpmf(Y_x[n] | mu1_x[n])") expect_match2(scode, "lprior += normal_lpdf(b_y1 | 0, 5)") expect_match2(scode, "lprior += normal_lpdf(bs_y2 | 0, 10)") # multivariate binomial models bform <- bf(x ~ 1) + bf(g ~ 1) + binomial() scode <- stancode(bform, dat) expect_match2(scode, "binomial_logit_lpmf(Y_x | trials_x, mu_x)") expect_match2(scode, "binomial_logit_lpmf(Y_g | trials_g, mu_g)") # multivariate weibull models bform <- bform + weibull() scode <- stancode(bform, dat) expect_match2(scode, "weibull_lpdf(Y_g | shape_g, mu_g ./ tgamma(1 + 1 ./ shape_g));") }) test_that("Stan code for categorical models is correct", { dat <- data.frame(y = rep(c(1, 2, 3, "a_b"), 2), x = 1:8, .g = 1:8) prior <- prior(normal(0, 5), "b", dpar = muab) + prior(normal(0, 10), "b", dpar = mu2) + prior(cauchy(0, 1), "Intercept", dpar = mu2) + prior(normal(0, 2), "Intercept", dpar = mu3) scode <- stancode(y ~ x + (1 | gr(.g, id = "ID")), data = dat, family = categorical(), prior = prior) expect_match2(scode, "target += categorical_logit_lpmf(Y[n] | mu[n]);") expect_match2(scode, "mu[n] = transpose([0, mu2[n], mu3[n], muab[n]]);") expect_match2(scode, "mu2 += Intercept_mu2 + Xc_mu2 * b_mu2;") expect_match2(scode, "muab[n] += r_1_muab_3[J_1[n]] * Z_1_muab_3[n];") expect_match2(scode, "lprior += normal_lpdf(b_mu2 | 0, 10);") expect_match2(scode, "lprior += normal_lpdf(b_muab | 0, 5);") expect_match2(scode, "lprior += cauchy_lpdf(Intercept_mu2 | 0, 1);") expect_match2(scode, "lprior += normal_lpdf(Intercept_mu3 | 0, 2);") expect_match2(scode, "r_1 = scale_r_cor(z_1, sd_1, L_1);") scode <- stancode(y ~ x + (1 |ID| .g), data = dat, family = categorical(refcat = NA)) expect_match2(scode, "mu[n] = transpose([mu1[n], mu2[n], mu3[n], muab[n]]);") # test use of glm primitive scode <- stancode(y ~ x, data = dat, family = categorical()) expect_match2(scode, "b[, 1] = rep_vector(0, Kc_mu2);") expect_match2(scode, "b[, 3] = b_mu3;") expect_match2(scode, "Intercept = transpose([0, Intercept_mu2, Intercept_mu3, Intercept_muab]);") expect_match2(scode, "target += categorical_logit_glm_lpmf(Y | Xc_mu2, Intercept, b);") scode <- stancode(bf(y ~ x, center = FALSE), data = dat, family = categorical()) expect_match2(scode, "target += categorical_logit_glm_lpmf(Y | X_mu2, rep_vector(0, ncat), b);") }) test_that("Stan code for multinomial models is correct", { N <- 15 dat <- data.frame( y1 = rbinom(N, 10, 0.3), y2 = rbinom(N, 10, 0.5), y3 = rbinom(N, 10, 0.7), x = rnorm(N) ) dat$size <- with(dat, y1 + y2 + y3) dat$y <- with(dat, cbind(y1, y2, y3)) prior <- prior(normal(0, 10), "b", dpar = muy2) + prior(cauchy(0, 1), "Intercept", dpar = muy2) + prior(normal(0, 2), "Intercept", dpar = muy3) scode <- stancode(bf(y | trials(size) ~ 1, muy2 ~ x), data = dat, family = multinomial(), prior = prior) expect_match2(scode, "array[N, ncat] int Y;") expect_match2(scode, "target += multinomial_logit2_lpmf(Y[n] | mu[n]);") expect_match2(scode, "muy2 += Intercept_muy2 + Xc_muy2 * b_muy2;") expect_match2(scode, "lprior += normal_lpdf(b_muy2 | 0, 10);") expect_match2(scode, "lprior += cauchy_lpdf(Intercept_muy2 | 0, 1);") expect_match2(scode, "lprior += normal_lpdf(Intercept_muy3 | 0, 2);") }) test_that("Stan code for dirichlet_multinomial models is correct", { N <- 15 dat <- data.frame( y1 = rbinom(N, 10, 0.3), y2 = rbinom(N, 10, 0.5), y3 = rbinom(N, 10, 0.7), x = rnorm(N) ) dat$size <- with(dat, y1 + y2 + y3) dat$y <- with(dat, cbind(y1, y2, y3)) prior <- prior(normal(0, 10), "b", dpar = muy2) + prior(cauchy(0, 1), "Intercept", dpar = muy2) + prior(normal(0, 2), "Intercept", dpar = muy3) + prior(exponential(10), "phi") scode <- stancode(bf(y | trials(size) ~ 1, muy2 ~ x), data = dat, family = dirichlet_multinomial(), prior = prior) expect_match2(scode, "array[N, ncat] int Y;") expect_match2(scode, "target += dirichlet_multinomial_logit2_lpmf(Y[n] | mu[n], phi);") expect_match2(scode, "muy2 += Intercept_muy2 + Xc_muy2 * b_muy2;") expect_match2(scode, "lprior += normal_lpdf(b_muy2 | 0, 10);") expect_match2(scode, "lprior += cauchy_lpdf(Intercept_muy2 | 0, 1);") expect_match2(scode, "lprior += normal_lpdf(Intercept_muy3 | 0, 2);") expect_match2(scode, "lprior += exponential_lpdf(phi | 10);") }) test_that("Stan code for dirichlet models is correct", { N <- 15 dat <- as.data.frame(rdirichlet(N, c(3, 2, 1))) names(dat) <- c("y1", "y2", "y3") dat$x <- rnorm(N) dat$y <- with(dat, cbind(y1, y2, y3)) # dirichlet in probability-sum(alpha) concentration prior <- prior(normal(0, 5), class = "b", dpar = "muy3") + prior(exponential(10), "phi") scode <- stancode(bf(y ~ 1, muy3 ~ x), data = dat, family = dirichlet(), prior = prior) expect_match2(scode, "array[N] vector[ncat] Y;") expect_match2(scode, "target += dirichlet_logit_lpdf(Y[n] | mu[n], phi);") expect_match2(scode, "muy3 += Intercept_muy3 + Xc_muy3 * b_muy3;") expect_match2(scode, "lprior += normal_lpdf(b_muy3 | 0, 5);") expect_match2(scode, "lprior += exponential_lpdf(phi | 10);") scode <- stancode(bf(y ~ x, phi ~ x), data = dat, family = dirichlet()) expect_match2(scode, "target += dirichlet_logit_lpdf(Y[n] | mu[n], phi[n]);") expect_match2(scode, "phi += Intercept_phi + Xc_phi * b_phi;") expect_match2(scode, "phi = exp(phi);") # dirichlet2 in alpha parameterization prior <- prior(normal(0, 5), class = "b", dpar = "muy3") scode <- stancode(bf(y ~ 1, muy3 ~ x), data = dat, family = brmsfamily("dirichlet2"), prior = prior) expect_match2(scode, "array[N] vector[ncat] Y;") expect_match2(scode, "muy3 = exp(muy3);") expect_match2(scode, "target += dirichlet_lpdf(Y[n] | mu[n]);") expect_match2(scode, "muy3 += Intercept_muy3 + Xc_muy3 * b_muy3;") expect_match2(scode, "mu[n] = transpose([muy1[n], muy2[n], muy3[n]]);") expect_match2(scode, "lprior += normal_lpdf(b_muy3 | 0, 5);") expect_match2(scode, "lprior += student_t_lpdf(Intercept_muy1 | 3, 0, 2.5);") }) test_that("Stan code for logistic_normal models is correct", { N <- 15 dat <- as.data.frame(rdirichlet(N, c(3, 2, 1))) names(dat) <- c("y1", "y2", "y3") dat$x <- rnorm(N) dat$y <- with(dat, cbind(y1, y2, y3)) prior <- prior(normal(0, 5), class = "b", dpar = "muy3") + prior(exponential(10), "sigmay1") + prior(lkj(3), "lncor") scode <- stancode(bf(y ~ x), data = dat, family = logistic_normal(refcat = "y2"), prior = prior) expect_match2(scode, "array[N] vector[ncat] Y;") expect_match2(scode, "mu[n] = transpose([muy1[n], muy3[n]]);") expect_match2(scode, "vector[ncat-1] sigma = transpose([sigmay1, sigmay3]);") expect_match2(scode, "target += logistic_normal_cholesky_cor_lpdf(Y[n] | mu[n], sigma, Llncor, 2);") expect_match2(scode, "muy3 += Intercept_muy3 + Xc_muy3 * b_muy3;") expect_match2(scode, "lprior += normal_lpdf(b_muy3 | 0, 5);") expect_match2(scode, "lprior += exponential_lpdf(sigmay1 | 10);") expect_match2(scode, "lprior += lkj_corr_cholesky_lpdf(Llncor | 3);") prior <- prior(normal(0, 5), class = "b", dpar = "muy3") + prior(normal(0, 3), class = "b", dpar = "sigmay2") scode <- stancode(bf(y ~ 1, muy3 ~ x, sigmay2 ~ x), data = dat, family = logistic_normal(), prior = prior) expect_match2(scode, "array[N] vector[ncat] Y;") expect_match2(scode, "mu[n] = transpose([muy2[n], muy3[n]]);") expect_match2(scode, "sigma[n] = transpose([sigmay2[n], sigmay3]);") expect_match2(scode, "target += logistic_normal_cholesky_cor_lpdf(Y[n] | mu[n], sigma[n], Llncor, 1);") expect_match2(scode, "muy3 += Intercept_muy3 + Xc_muy3 * b_muy3;") expect_match2(scode, "lprior += normal_lpdf(b_muy3 | 0, 5);") expect_match2(scode, "lprior += normal_lpdf(b_sigmay2 | 0, 3);") expect_match2(scode, "lprior += lkj_corr_cholesky_lpdf(Llncor | 1);") }) test_that("Stan code for ARMA models is correct", { dat <- data.frame(y = rep(1:4, 2), x = 1:8, time = 1:8) scode <- stancode(y ~ x + ar(time), dat, student()) expect_match2(scode, "vector[Kar] ar") expect_match2(scode, "err[n] = Y[n] - mu[n];") expect_match2(scode, "mu[n] += Err[n, 1:Kar] * ar;") scode <- stancode(y ~ x + ma(time, q = 2), dat, student()) expect_match2(scode, "mu[n] += Err[n, 1:Kma] * ma;") expect_warning( scode <- stancode(mvbind(y, x) ~ 1, dat, gaussian(), autocor = cor_ar()), "Argument 'autocor' should be specified within the 'formula' argument" ) expect_match2(scode, "err_y[n] = Y_y[n] - mu_y[n];") bform <- bf(y ~ x, sigma ~ x) + acformula(~arma(time, cov = TRUE)) scode <- stancode(bform, dat, family = student) expect_match2(scode, "student_t_time_het_lpdf(Y | nu, mu, sigma, Lcortime") bform <- bf(y ~ exp(eta) - 1, eta ~ x, autocor = ~ar(time), nl = TRUE) scode <- stancode(bform, dat, family = student, prior = prior(normal(0, 1), nlpar = eta)) expect_match2(scode, "mu[n] += Err[n, 1:Kar] * ar;") # correlations of latent residuals scode <- stancode( y ~ x + ar(time, cov = TRUE), dat, family = poisson, prior = prior(cauchy(0, 10), class = sderr) ) expect_match2(scode, "Lcortime = cholesky_cor_ar1(ar[1], max_nobs_tg);") expect_match2(scode, "err = scale_time_err(zerr, sderr, Lcortime, nobs_tg, begin_tg, end_tg);" ) expect_match2(scode, "mu += Intercept + Xc * b + err;") expect_match2(scode, "lprior += cauchy_lpdf(sderr | 0, 10)") scode <- stancode( y ~ x + ar(time), dat, family = poisson, prior = prior(cauchy(0, 10), class = sderr) ) expect_match2(scode, "vector[Kar] ar") expect_match2(scode, "mu[n] += Err[n, 1:Kar] * ar;") expect_match2(scode, "err = sderr * zerr;") expect_match2(scode, "mu += Intercept + Xc * b + err;") expect_match2(scode, "lprior += cauchy_lpdf(sderr | 0, 10)") # apply shrinkage priors on sderr scode <- stancode( y ~ x + ar(time), dat, family = poisson, prior = prior(horseshoe(main = TRUE), class = b) + prior(horseshoe(), class = sderr) ) expect_match2(scode, "sderr = scales[(1+Kc):(Kc+1)][1];") }) test_that("Stan code for compound symmetry models is correct", { dat <- data.frame(y = rep(1:4, 2), x = 1:8, time = 1:8) scode <- stancode( y ~ x + cosy(time), dat, prior = prior(normal(0, 2), cosy) ) expect_match2(scode, "real cosy;") expect_match2(scode, "Lcortime = cholesky_cor_cosy(cosy, max_nobs_tg);") expect_match2(scode, "lprior += normal_lpdf(cosy | 0, 2)") scode <- stancode(bf(y ~ x + cosy(time), sigma ~ x), dat) expect_match2(scode, "normal_time_het_lpdf(Y | mu, sigma, Lcortime") scode <- stancode(y ~ x + cosy(time), dat, family = poisson) expect_match2(scode, "Lcortime = cholesky_cor_cosy(cosy, max_nobs_tg);") }) test_that("Stan code for UNSTR covariance terms is correct", { dat <- data.frame(y = 1:12, x = rnorm(12), tim = c(5:1, 1:5, c(0, 4)), g = c(rep(3:4, 5), rep(2, 2))) scode <- stancode(y ~ x + unstr(tim, g), data = dat) expect_match2(scode, "normal_time_hom_flex_lpdf(Y | mu, sigma, Lcortime, nobs_tg, begin_tg, end_tg, Jtime_tg);") expect_match2(scode, "cortime[choose(k - 1, 2) + j] = Cortime[j, k];") expect_match2(scode, "lprior += lkj_corr_cholesky_lpdf(Lcortime | 1);") scode <- stancode( y ~ x + unstr(tim, g), data = dat, family = student(), prior = prior(lkj(4), cortime) ) expect_match2(scode, "student_t_time_hom_flex_lpdf(Y | nu, mu, sigma, Lcortime, nobs_tg, begin_tg, end_tg, Jtime_tg);") expect_match2(scode, "lprior += lkj_corr_cholesky_lpdf(Lcortime | 4);") # test standard error scode <- stancode( y | se(1, sigma = TRUE) ~ x + unstr(tim, g), data = dat, family = gaussian(), ) expect_match2(scode, "normal_time_hom_se_flex_lpdf(Y | mu, sigma, se2, Lcortime, nobs_tg, begin_tg, end_tg, Jtime_tg);") # test latent representation scode <- stancode( y ~ x + unstr(tim, g), data = dat, family = poisson() ) expect_match2(scode, "err = scale_time_err_flex(zerr, sderr, Lcortime, nobs_tg, begin_tg, end_tg,") expect_match2(scode, "mu += Intercept + Xc * b + err;") # non-linear model scode <- stancode( bf(y ~ a, a ~ x, autocor = ~ unstr(tim, g), nl = TRUE), data = dat, family = student(), prior = prior(normal(0,1), nlpar = a) ) expect_match2(scode, "student_t_time_hom_flex_lpdf(Y | nu, mu, sigma, Lcortime, nobs_tg, begin_tg, end_tg, Jtime_tg);") }) test_that("Stan code for intercept only models is correct", { expect_match2(stancode(rating ~ 1, data = inhaler), "b_Intercept = Intercept;") expect_match2(stancode(rating ~ 1, data = inhaler, family = cratio()), "b_Intercept = Intercept;") expect_match2(stancode(rating ~ 1, data = inhaler, family = categorical()), "b_mu3_Intercept = Intercept_mu3;") }) test_that("Stan code of ordinal models is correct", { dat <- data.frame(y = c(rep(1:4, 2), 1, 1), x1 = rnorm(10), x2 = rnorm(10), g = factor(rep(1:2, 5))) scode <- stancode( y ~ x1, dat, family = cumulative("logit"), prior = prior(normal(0, 2), Intercept, coef = 2) ) expect_match2(scode, "target += ordered_logistic_glm_lpmf(Y | Xc, b, Intercept);") expect_match2(scode, "lprior += student_t_lpdf(Intercept[1] | 3, 0, 2.5);") expect_match2(scode, "lprior += normal_lpdf(Intercept[2] | 0, 2);") scode <- stancode( y ~ x1, dat, cumulative("probit", threshold = "equidistant"), prior = prior(normal(0, 2), Intercept) ) expect_match2(scode, "real cumulative_probit_lpmf(int y") expect_match2(scode, "p = Phi(disc * (thres[1] - mu));") expect_match2(scode, "real delta;") expect_match2(scode, "Intercept[k] = first_Intercept + (k - 1.0) * delta;") expect_match2(scode, "b_Intercept = Intercept + dot_product(means_X, b);") expect_match2(scode, "lprior += normal_lpdf(first_Intercept | 0, 2);") expect_match2(scode, "target += ordered_probit_lpmf(Y[n] | mu[n], Intercept);") scode <- stancode(y ~ x1, dat, family = cratio("probit")) expect_match2(scode, "real cratio_probit_lpmf(int y") expect_match2(scode, "q[k] = std_normal_lcdf(disc * (mu - thres[k]));") scode <- stancode(y ~ x1 + cs(x2) + cs(g), dat, family = sratio()) expect_match2(scode, "real sratio_logit_lpmf(int y") expect_match2(scode, "matrix[N, Kcs] Xcs;") expect_match2(scode, "matrix[Kcs, nthres] bcs;") expect_match2(scode, "mucs = Xcs * bcs;") expect_match2(scode, "target += sratio_logit_lpmf(Y[n] | mu[n], disc, Intercept - transpose(mucs[n]));" ) scode <- stancode(y ~ x1 + cse(x2) + (cse(1)|g), dat, family = acat()) expect_match2(scode, "real acat_logit_lpmf(int y") expect_match2(scode, "mucs[n, 1] = mucs[n, 1] + r_1_1[J_1[n]] * Z_1_1[n];") expect_match2(scode, "b_Intercept = Intercept + dot_product(means_X, b);") scode <- stancode(y ~ x1 + (cse(x2)||g), dat, family = acat("probit_approx")) expect_match2(scode, paste("mucs[n, 3] = mucs[n, 3] + r_1_3[J_1[n]] * Z_1_3[n]", "+ r_1_6[J_1[n]] * Z_1_6[n];")) expect_match2(scode, "target += acat_probit_approx_lpmf(Y[n] | mu[n], disc, Intercept - transpose(mucs[n]));" ) # sum-to-zero thresholds scode <- stancode( y ~ x1, dat, cumulative("cloglog", threshold = "sum_to_zero"), prior = prior(normal(0, 2), Intercept) ) expect_match2(scode, "Intercept_stz = Intercept - mean(Intercept);") expect_match2(scode, "cumulative_cloglog_lpmf(Y[n] | mu[n], disc, Intercept_stz);") expect_match2(scode, "vector[nthres] b_Intercept = Intercept_stz;") # non-linear ordinal models scode <- stancode( bf(y ~ eta, eta ~ x1, nl = TRUE), dat, family = cumulative(), prior = prior(normal(0, 2), nlpar = eta) ) expect_match2(scode, "ordered[nthres] Intercept;") expect_match2(scode, "target += ordered_logistic_lpmf(Y[n] | mu[n], Intercept);" ) # ordinal mixture models with fixed intercepts scode <- stancode( bf(y ~ 1, mu1 ~ x1, mu2 ~ 1), data = dat, family = mixture(cumulative(), nmix = 2, order = "mu") ) expect_match2(scode, "Intercept_mu2 = fixed_Intercept;") expect_match2(scode, "lprior += student_t_lpdf(fixed_Intercept | 3, 0, 2.5);") }) test_that("Stan code for xbeta models is correct", { dat <- data.frame(y = rbeta(10, 1, 1), x = rnorm(10)) scode <- stancode(y ~ x, dat, family = xbeta()) expect_match2(scode, "target += xbeta_lpdf(Y | mu, phi, kappa);") expect_match2(scode, "lprior += gamma_lpdf(kappa | 0.01, 0.01);") }) test_that("ordinal disc parameters appear in the Stan code", { scode <- stancode( bf(rating ~ period + carry + treat, disc ~ period), data = inhaler, family = cumulative(), prior = prior(normal(0,5), dpar = disc) ) expect_match2(scode, "target += cumulative_logit_lpmf(Y[n] | mu[n], disc[n], Intercept)" ) expect_match2(scode, "lprior += normal_lpdf(b_disc | 0, 5)") expect_match2(scode, "disc = exp(disc)") }) test_that("grouped ordinal thresholds appear in the Stan code", { dat <- data.frame( y = sample(1:6, 10, TRUE), y2 = sample(1:6, 10, TRUE), gr = rep(c("a", "b"), each = 5), th = rep(5:6, each = 5), x = rnorm(10) ) prior <- prior(normal(0,1), class = "Intercept", group = "b") scode <- stancode( y | thres(th, gr) ~ x, data = dat, family = sratio(), prior = prior ) expect_match2(scode, "array[ngrthres] int nthres;") expect_match2(scode, "merged_Intercept[Kthres_start[1]:Kthres_end[1]] = Intercept_1;") expect_match2(scode, "target += sratio_logit_merged_lpmf(Y[n]") expect_match2(scode, "lprior += normal_lpdf(Intercept_2 | 0, 1);") # centering needs to be deactivated automatically expect_match2(scode, "vector[nthres[1]] b_Intercept_1 = Intercept_1;") # model with equidistant thresholds scode <- stancode( y | thres(th, gr) ~ x, data = dat, family = cumulative(threshold = "equidistant"), prior = prior ) expect_match2(scode, "target += ordered_logistic_merged_lpmf(Y[n]") expect_match2(scode, "real first_Intercept_1;") expect_match2(scode, "lprior += normal_lpdf(first_Intercept_2 | 0, 1);") expect_match2(scode, "Intercept_2[k] = first_Intercept_2 + (k - 1.0) * delta_2;") # sum-to-zero constraints scode <- stancode( y | thres(gr = gr) ~ x, data = dat, cumulative(threshold = "sum_to_zero"), prior = prior(normal(0, 2), Intercept) ) expect_match2(scode, "merged_Intercept_stz[Kthres_start[2]:Kthres_end[2]] = Intercept_stz_2;") expect_match2(scode, "ordered_logistic_merged_lpmf(Y[n] | mu[n], merged_Intercept_stz, Jthres[n]);") # ordinal mixture model scode <- stancode( y | thres(th, gr) ~ x, data = dat, family = mixture(cratio, acat, order = "mu"), prior = prior ) expect_match2(scode, "ps[1] = log(theta1) + cratio_logit_merged_lpmf(Y[n]") expect_match2(scode, "ps[2] = log(theta2) + acat_logit_merged_lpmf(Y[n]") expect_match2(scode, "vector[nmthres] merged_Intercept_mu1;") expect_match2(scode, "merged_Intercept_mu2[Kthres_start[1]:Kthres_end[1]] = Intercept_mu2_1;") expect_match2(scode, "vector[nthres[1]] b_mu1_Intercept_1 = Intercept_mu1_1;") # multivariate ordinal model bform <- bf(y | thres(th, gr) ~ x, family = sratio) + bf(y2 | thres(th, gr) ~ x, family = cumulative) scode <- stancode(bform, data = dat) expect_match2(scode, "lprior += student_t_lpdf(Intercept_y2_1 | 3, 0, 2.5);") expect_match2(scode, "merged_Intercept_y[Kthres_start_y[2]:Kthres_end_y[2]] = Intercept_y_2;") }) test_that("Stan code of hurdle cumulative model is correct", { dat <- data.frame(y = rep(0:4, 2), x1 = rnorm(10), x2 = rnorm(10), g = factor(rep(1:2, 5))) scode <- stancode( y ~ x1, dat, family = hurdle_cumulative("logit"), prior = prior(normal(0, 2), Intercept, coef = 2) ) expect_match2(scode, "target += hurdle_cumulative_ordered_logistic_lpmf(Y[n] | mu[n], hu, disc, Intercept);" ) scode <- stancode( bf(y ~ x1, hu ~ x2), dat, hurdle_cumulative("probit", threshold = "equidistant"), prior = prior(normal(0, 2), Intercept) ) expect_match2(scode, "real hurdle_cumulative_ordered_probit_lpmf(int y") expect_match2(scode, "p = Phi(disc * (thres[1] - mu)) * (1 - hu);") expect_match2(scode, "Intercept[k] = first_Intercept + (k - 1.0) * delta;") # sum-to-zero thresholds scode <- stancode( bf(y ~ x1, hu ~ x2, disc ~ g), dat, hurdle_cumulative("cloglog", threshold = "sum_to_zero"), prior = prior(normal(0, 2), Intercept) ) expect_match2(scode, "Intercept_stz = Intercept - mean(Intercept);") expect_match2(scode, "hurdle_cumulative_cloglog_lpmf(Y[n] | mu[n], hu[n], disc[n], Intercept_stz);") expect_match2(scode, "vector[nthres] b_Intercept = Intercept_stz;") # non-linear ordinal models scode <- stancode( bf(y ~ eta, eta ~ x1, nl = TRUE), dat, family = hurdle_cumulative(), prior = prior(normal(0, 2), nlpar = eta) ) expect_match2(scode, "target += hurdle_cumulative_ordered_logistic_lpmf(Y[n] | mu[n], hu, disc, Intercept);" ) }) test_that("monotonic effects appear in the Stan code", { dat <- data.frame(y = rpois(120, 10), x1 = rep(1:4, 30), x2 = factor(rep(c("a", "b", "c"), 40), ordered = TRUE), g = rep(1:10, each = 12)) prior <- c(prior(normal(0,1), class = b, coef = mox1), prior(dirichlet(c(1,0.5,2)), simo, coef = mox11), prior(dirichlet(c(1,0.5,2)), simo, coef = mox21)) scode <- stancode(y ~ y*mo(x1)*mo(x2), dat, prior = prior) expect_match2(scode, "array[N] int Xmo_3;") expect_match2(scode, "simplex[Jmo[1]] simo_1;") expect_match2(scode, "(bsp[2]) * mo(simo_2, Xmo_2[n])") expect_match2(scode, "(bsp[6]) * mo(simo_7, Xmo_7[n]) * mo(simo_8, Xmo_8[n]) * Csp_3[n]" ) expect_match2(scode, "lprior += normal_lpdf(bsp[1] | 0, 1)") expect_match2(scode, "lprior += dirichlet_lpdf(simo_1 | con_simo_1);") expect_match2(scode, "lprior += dirichlet_lpdf(simo_8 | con_simo_8);") scode <- stancode(y ~ mo(x1) + (mo(x1) | x2), dat) expect_match2(scode, "(bsp[1] + r_1_2[J_1[n]]) * mo(simo_1, Xmo_1[n])") expect_true(!grepl("Z_1_w", scode)) # test issue reported in discourse post #12978 scode <- stancode(y ~ mo(x1) + (mo(x1) | x2) + (mo(x1) | g), dat) expect_match2(scode, "(bsp[1] + r_1_2[J_1[n]] + r_2_2[J_2[n]]) * mo(simo_1, Xmo_1[n])") # test issue #813 scode <- stancode(y ~ mo(x1):y, dat) expect_match2(scode, "mu[n] += (bsp[1]) * mo(simo_1, Xmo_1[n]) * Csp_1[n];") # test issue #924 (conditional monotonicity) prior <- c(prior(dirichlet(c(1,0.5,2)), simo, coef = "v"), prior(dirichlet(c(1,0.5,2)), simo, coef = "w")) scode <- stancode(y ~ y*mo(x1, id = "v")*mo(x2, id = "w"), dat, prior = prior) expect_match2(scode, "lprior += dirichlet_lpdf(simo_1 | con_simo_1);") expect_match2(scode, "lprior += dirichlet_lpdf(simo_2 | con_simo_2);") expect_match2(scode, "simplex[Jmo[6]] simo_6 = simo_2;") expect_match2(scode, "simplex[Jmo[7]] simo_7 = simo_1;") expect_error( stancode(y ~ mo(x1) + (mo(x2) | x2), dat), "Special group-level terms require" ) prior <- prior(beta(1, 1), simo, coef = mox11) expect_error( stancode(y ~ mo(x1), dat, prior = prior), "'dirichlet' is the only valid prior for simplex parameters" ) }) test_that("Stan code for non-linear models is correct", { flist <- list(a ~ x, b ~ z + (1|g)) data <- data.frame( y = rgamma(9, 1, 1), x = rnorm(9), z = rnorm(9), v = 1L:9L, g = rep(1:3, 3) ) prior <- c(set_prior("normal(0,5)", nlpar = "a"), set_prior("normal(0,1)", nlpar = "b")) # syntactic validity is already checked within stancode scode <- stancode( bf(y ~ a - exp(b^z) * (z <= a) * v, flist = flist, nl = TRUE), data = data, prior = prior ) expect_match2(scode, "mu[n] = (nlp_a[n] - exp(nlp_b[n] ^ C_1[n]) * (C_1[n] <= nlp_a[n]) * C_2[n]);" ) expect_match2(scode, "vector[N] C_1;") expect_match2(scode, "array[N] int C_2;") # non-linear predictor can be computed outside a loop scode <- stancode(bf(y ~ a - exp(b + z), flist = flist, nl = TRUE, loop = FALSE), data = data, prior = prior) expect_match2(scode, "mu = (nlp_a - exp(nlp_b + C_1));") # check if that also works with threading scode <- stancode(bf(y ~ a - exp(b + z), flist = flist, nl = TRUE, loop = FALSE), data = data, prior = prior, threads = threading(2), parse = FALSE) expect_match2(scode, "mu = (nlp_a - exp(nlp_b + C_1[start:end]));") flist <- list(a1 ~ 1, a2 ~ z + (x|g)) prior <- c(set_prior("beta(1,1)", nlpar = "a1", lb = 0, ub = 1), set_prior("normal(0,1)", nlpar = "a2")) scode <- stancode( bf(y ~ a1 * exp(-x/(a2 + z)), flist = flist, nl = TRUE), data = data, family = Gamma("log"), prior = prior ) expect_match2(scode, "mu[n] = exp(nlp_a1[n] * exp( - C_1[n] / (nlp_a2[n] + C_2[n])));") bform <- bf(y ~ x) + nlf(sigma ~ a1 * exp(-x/(a2 + z))) + lf(a1 ~ 1, a2 ~ z + (x|g)) + lf(alpha ~ x) scode <- stancode( bform, data, family = skew_normal(), prior = c( prior(normal(0, 1), nlpar = a1), prior(normal(0, 5), nlpar = a2) ) ) expect_match2(scode, "nlp_a1 += X_a1 * b_a1") expect_match2(scode, "sigma[n] = exp(nlp_a1[n] * exp( - C_sigma_1[n] / (nlp_a2[n] + C_sigma_2[n])))" ) expect_match2(scode, "lprior += normal_lpdf(b_a2 | 0, 5)") }) test_that("Stan code for nested non-linear parameters is correct", { dat <- data.frame(y = rnorm(10), x = rnorm(10), z = 1:5) bform <- bf( y ~ lb + (1 - lb) * inv_logit(b * x), b + a ~ 1 + (1 | z), nlf(lb ~ inv_logit(a / x)), nl = TRUE ) bprior <- prior(normal(0, 1), nlpar = "a") + prior(normal(0, 1), nlpar = "b") scode <- stancode(bform, dat, prior = bprior) expect_match2(scode, "nlp_lb[n] = (inv_logit(nlp_a[n] / C_lb_1[n]));") expect_match2(scode, "mu[n] = (nlp_lb[n] + (1 - nlp_lb[n]) * inv_logit(nlp_b[n] * C_1[n]));" ) }) test_that("stancode is correct for non-linear matrix covariates", { N <- 10 dat <- data.frame(y=rnorm(N)) dat$X <- matrix(rnorm(N*2), N, 2) dat$X2 <- matrix(1L:4L, N, 2) # numeric matrix nlfun_stan <- " real nlfun(real a, real b, real c, row_vector X) { return a + b * X[1] + c * X[2]; } " nlstanvar <- stanvar(scode = nlfun_stan, block = "functions") bform <- bf(y~nlfun(a, b, c, X), a~1, b~1, c~1, nl = TRUE) scode <- stancode(bform, dat, stanvars = nlstanvar) expect_match2(scode, "matrix[N, 2] C_1;") # integer matrix nlfun_stan_int <- " real nlfun(real a, real b, real c, array[] int X) { return a + b * X[1] + c * X[2]; } " nlstanvar <- stanvar(scode = nlfun_stan_int, block = "functions") bform <- bf(y~nlfun(a, b, c, X2), a~1, b~1, c~1, nl = TRUE) scode <- stancode(bform, dat, stanvars = nlstanvar) expect_match2(scode, "array[N, 2] int C_1;") }) test_that("stancode accepts very long non-linear formulas", { data <- data.frame(y = rnorm(10), this_is_a_very_long_predictor = rnorm(10)) expect_silent(stancode(bf(y ~ b0 + this_is_a_very_long_predictor + this_is_a_very_long_predictor + this_is_a_very_long_predictor, b0 ~ 1, nl = TRUE), data = data, prior = prior(normal(0,1), nlpar = "b0"))) }) test_that("no loop in trans-par is defined for simple 'identity' models", { expect_true(!grepl(stancode(time ~ age, data = kidney), "mu[n] = (mu[n]);", fixed = TRUE)) expect_true(!grepl(stancode(time ~ age, data = kidney, family = poisson("identity")), "mu[n] = (mu[n]);", fixed = TRUE)) }) test_that("known standard errors appear in the Stan code", { scode <- stancode(time | se(age) ~ sex, data = kidney) expect_match2(scode, "target += normal_lpdf(Y | mu, se)") scode <- stancode(time | se(age) + weights(age) ~ sex, data = kidney) expect_match2(scode, "target += weights[n] * (normal_lpdf(Y[n] | mu[n], se[n]))") scode <- stancode(time | se(age, sigma = TRUE) ~ sex, data = kidney) expect_match2(scode, "target += normal_lpdf(Y | mu, sqrt(square(sigma) + se2))") scode <- stancode(bf(time | se(age, sigma = TRUE) ~ sex, sigma ~ sex), data = kidney) expect_match2(scode, "target += normal_lpdf(Y | mu, sqrt(square(sigma) + se2))") }) test_that("functions defined in 'stan_funs' appear in the functions block", { test_fun <- paste0(" real test_fun(real a, real b) {\n", " return a + b;\n", " }\n") scode <- SW(stancode(time ~ age, data = kidney, stan_funs = test_fun)) expect_match2(scode, test_fun) }) test_that("FCOR matrices appear in the Stan code", { data <- data.frame(y = 1:5) V <- diag(5) expect_match2(stancode(y ~ fcor(V), data = data, family = gaussian(), data2 = list(V = V)), "target += normal_fcor_hom_lpdf(Y | mu, sigma, Lfcor);") expect_match2(stancode(y ~ fcor(V), data = data, family = student(), data2 = list(V = V)), "target += student_t_fcor_hom_lpdf(Y | nu, mu, sigma, Lfcor);") }) test_that("Stan code for GAMMs is correct", { dat <- data.frame(y = rnorm(10), x = rnorm(10), g = factor(rep(1:2, 5))) scode <- stancode(y ~ s(x) + (1|g), data = dat, prior = set_prior("normal(0,2)", "sds")) expect_match2(scode, "Zs_1_1 * s_1_1") expect_match2(scode, "matrix[N, knots_1[1]] Zs_1_1") expect_match2(scode, "target += std_normal_lpdf(zs_1_1)") expect_match2(scode, "lprior += normal_lpdf(sds_1 | 0,2)") prior <- c(set_prior("normal(0,5)", nlpar = "lp"), set_prior("normal(0,2)", "sds", nlpar = "lp")) scode <- stancode(bf(y ~ lp, lp ~ s(x) + (1|g), nl = TRUE), data = dat, prior = prior) expect_match2(scode, "Zs_lp_1_1 * s_lp_1_1") expect_match2(scode, "matrix[N, knots_lp_1[1]] Zs_lp_1_1") expect_match2(scode, "target += std_normal_lpdf(zs_lp_1_1)") expect_match2(scode, "lprior += normal_lpdf(sds_lp_1 | 0,2)") scode <- stancode( y ~ s(x) + t2(x,y), data = dat, prior = set_prior("normal(0,1)", "sds") + set_prior("normal(0,2)", "sds", coef = "t2(x, y)") ) expect_match2(scode, "Zs_2_2 * s_2_2") expect_match2(scode, "matrix[N, knots_2[2]] Zs_2_2") expect_match2(scode, "target += std_normal_lpdf(zs_2_2)") expect_match2(scode, "lprior += normal_lpdf(sds_1 | 0,1)") expect_match2(scode, "lprior += normal_lpdf(sds_2 | 0,2)") scode <- stancode(y ~ g + s(x, by = g), data = dat) expect_match2(scode, "vector[knots_2[1]] zs_2_1") expect_match2(scode, "s_2_1 = sds_2[1] * zs_2_1") }) test_that("Stan code of response times models is correct", { dat <- epilepsy dat$cens <- sample(-1:1, nrow(dat), TRUE) scode <- stancode(count ~ Trt + (1|patient), data = dat, family = exgaussian("log"), prior = prior(gamma(1,1), class = beta)) expect_match2(scode, "target += exp_mod_normal_lpdf(Y | mu - beta, sigma, inv(beta))" ) expect_match2(scode, "mu = exp(mu)") expect_match2(scode, "lprior += gamma_lpdf(beta | 1, 1)") scode <- stancode(bf(count ~ Trt + (1|patient), sigma ~ Trt, beta ~ Trt), data = dat, family = exgaussian()) expect_match2(scode, "target += exp_mod_normal_lpdf(Y | mu - beta, sigma, inv(beta))" ) expect_match2(scode, "beta = exp(beta)") scode <- stancode(count | cens(cens) ~ Trt + (1|patient), data = dat, family = exgaussian("inverse")) expect_match2(scode, "target += exp_mod_normal_lccdf(Y[Jrcens[1:Nrcens]] | mu[Jrcens[1:Nrcens]] - beta, sigma, inv(beta));" ) scode <- stancode(count ~ Trt, dat, family = shifted_lognormal()) expect_match2(scode, "target += lognormal_lpdf(Y - ndt | mu, sigma)") scode <- stancode(count | cens(cens) ~ Trt, dat, family = shifted_lognormal()) expect_match2(scode, "target += lognormal_lcdf(Y[Jlcens[1:Nlcens]] - ndt | mu[Jlcens[1:Nlcens]], sigma);" ) # test issue #837 scode <- stancode(mvbind(count, zBase) ~ Trt, data = dat, family = shifted_lognormal()) expect_match2(scode, "lprior += uniform_lpdf(ndt_count | 0, min_Y_count)") expect_match2(scode, "lprior += uniform_lpdf(ndt_zBase | 0, min_Y_zBase)") }) test_that("Stan code of wiener diffusion models is correct", { dat <- data.frame(q = 1:10, resp = sample(0:1, 10, TRUE), x = rnorm(10)) scode <- stancode(q | dec(resp) ~ x, data = dat, family = wiener()) expect_match2(scode, "target += wiener_diffusion_lpdf(Y[n] | dec[n], bs, ndt, bias, mu[n])" ) scode <- stancode(bf(q | dec(resp) ~ x, bs ~ x, ndt ~ x, bias ~ x), data = dat, family = wiener()) expect_match2(scode, "target += wiener_diffusion_lpdf(Y[n] | dec[n], bs[n], ndt[n], bias[n], mu[n])" ) expect_match2(scode, "bias = inv_logit(bias);") scode <- stancode(bf(q | dec(resp) ~ x, ndt = 0.5), data = dat, family = wiener()) expect_match2(scode, "real ndt = 0.5;") expect_error(stancode(q ~ x, data = dat, family = wiener()), "Addition argument 'dec' is required for family 'wiener'") }) test_that("Group IDs appear in the Stan code", { form <- bf(count ~ Trt + (1+Trt|3|visit) + (1|patient), shape ~ (1|3|visit) + (Trt||patient)) scode <- stancode(form, data = epilepsy, family = negbinomial()) expect_match2(scode, "r_2_1 = r_2[, 1]") expect_match2(scode, "r_2_shape_3 = r_2[, 3]") form <- bf(count ~ a, sigma ~ (1|3|visit) + (Trt||patient), a ~ Trt + (1+Trt|3|visit) + (1|patient), nl = TRUE) scode <- stancode(form, data = epilepsy, family = student(), prior = set_prior("normal(0,5)", nlpar = "a")) expect_match2(scode, "r_2_a_2 = r_2[, 2];") expect_match2(scode, "r_1_sigma_2 = (sd_1[2] * (z_1[2]));") }) test_that("weighted, censored, and truncated likelihoods are correct", { dat <- data.frame(y = 1:9, x = rep(-1:1, 3), y2 = 10:18) scode <- stancode(y | weights(y2) ~ 1, dat, poisson()) expect_match2(scode, "target += weights[n] * (poisson_log_lpmf(Y[n] | mu[n]));") scode <- stancode(y | trials(y2) + weights(y2) ~ 1, dat, binomial()) expect_match2(scode, "target += weights[n] * (binomial_logit_lpmf(Y[n] | trials[n], mu[n]));" ) scode <- stancode(y | cens(x, y2) ~ 1, dat, family = poisson()) expect_match2(scode, "target += poisson_lpmf(Y[n] | mu[n]);") expect_match2(scode, "poisson_lcdf(rcens[n] | mu[n])") scode <- stancode(y | cens(x) ~ 1, dat, family = asym_laplace()) expect_match2(scode, "target += asym_laplace_lccdf(Y[n] | mu[n], sigma, quantile);") scode <- stancode(bf(y | cens(x) ~ 1, shape ~ 1), dat, family = Gamma()) expect_match2(scode, "target += gamma_lpdf(Y[Jevent[1:Nevent]] | shape[Jevent[1:Nevent]], shape[Jevent[1:Nevent]] ./ mu[Jevent[1:Nevent]]);") dat$x[1] <- 2 scode <- stancode(y | cens(x, y2) ~ 1, dat, family = asym_laplace()) expect_match2(scode, "target += log_diff_exp(\n") expect_match2(scode, "asym_laplace_lcdf(rcens[n] | mu[n], sigma, quantile),") dat$x <- 1 expect_match2(stancode(y | cens(x) + weights(x) ~ 1, dat, exponential()), "target += weights[n] * exponential_lccdf(Y[n] | inv(mu[n]));") scode <- stancode(y | cens(x) + trunc(0.1) ~ 1, dat, exponential()) expect_match2(scode, "target += exponential_lccdf(Y[n] | inv(mu[n])) -") expect_match2(scode, " exponential_lccdf(lb[n] | inv(mu[n]));") scode <- stancode(y | cens(x) + trunc(ub = 30) ~ 1, dat) expect_match2(scode, "target += normal_lccdf(Y[n] | mu[n], sigma) -") expect_match2(scode, " normal_lcdf(ub[n] | mu[n], sigma);") scode <- stancode(y | weights(x) + trunc(0, 30) ~ 1, dat) expect_match2(scode, "target += weights[n] * (normal_lpdf(Y[n] | mu[n], sigma) -") expect_match2(scode, " log_diff_exp(normal_lcdf(ub[n] | mu[n], sigma),") expect_match2( stancode(y | trials(y2) + weights(y2) ~ 1, dat, beta_binomial()), "target += weights[n] * (beta_binomial_lpmf(Y[n] | trials[n], mu[n] .* phi," ) expect_match2( stancode(y | trials(y2) + trunc(0, 30) ~ 1, dat, beta_binomial()), "log_diff_exp(beta_binomial_lcdf(ub[n] | trials[n], mu[n] .* phi," ) expect_match2( stancode(y | trials(y2) + cens(x, y2) ~ 1, dat, beta_binomial()), "beta_binomial_lcdf(rcens[n] | trials[n], mu[n] .* phi," ) }) test_that("noise-free terms appear in the Stan code", { N <- 30 dat <- data.frame( y = rnorm(N), x = rnorm(N), z = rnorm(N), xsd = abs(rnorm(N, 1)), zsd = abs(rnorm(N, 1)), ID = rep(1:5, each = N / 5) ) me_prior <- prior(normal(0,5)) + prior(normal(0, 10), "meanme") + prior(cauchy(0, 5), "sdme", coef = "mez") + prior(lkj(2), "corme") scode <- stancode( y ~ me(x, xsd)*me(z, zsd)*x, data = dat, prior = me_prior, sample_prior = "yes" ) expect_match2(scode, "(bsp[1]) * Xme_1[n] + (bsp[2]) * Xme_2[n] + (bsp[3]) * Xme_1[n] * Xme_2[n]" ) expect_match2(scode, "(bsp[6]) * Xme_1[n] * Xme_2[n] * Csp_3[n]") expect_match2(scode, "target += normal_lpdf(Xn_2 | Xme_2, noise_2)") expect_match2(scode, "lprior += normal_lpdf(bsp | 0, 5)") expect_match2(scode, "target += std_normal_lpdf(to_vector(zme_1))") expect_match2(scode, "lprior += normal_lpdf(meanme_1 | 0, 10)") expect_match2(scode, "lprior += cauchy_lpdf(sdme_1[2] | 0, 5)") expect_match2(scode, "lprior += lkj_corr_cholesky_lpdf(Lme_1 | 2)") expect_match2(scode, "+ transpose(diag_pre_multiply(sdme_1, Lme_1) * zme_1)") expect_match2(scode, "corme_1[choose(k - 1, 2) + j] = Corme_1[j, k];") scode <- stancode( y ~ me(x, xsd)*z + (me(x, xsd)*z | ID), data = dat ) expect_match2(scode, "(bsp[1] + r_1_3[J_1[n]]) * Xme_1[n]") expect_match2(scode, "(bsp[2] + r_1_4[J_1[n]]) * Xme_1[n] * Csp_1[n]") expect_match2(stancode(y ~ I(me(x, xsd)^2), data = dat), "(bsp[1]) * (Xme_1[n]^2)") # test that noise-free variables are unique across model parts scode <- stancode( bf(y ~ me(x, xsd)*me(z, zsd)*x, sigma ~ me(x, xsd)), data = dat, prior = prior(normal(0,5)) ) expect_match2(scode, "mu[n] += (bsp[1]) * Xme_1[n]") expect_match2(scode, "sigma[n] += (bsp_sigma[1]) * Xme_1[n]") scode <- stancode( bf(y ~ a * b, a + b ~ me(x, xsd), nl = TRUE), data = dat, prior = prior(normal(0,5), nlpar = a) + prior(normal(0, 5), nlpar = b) ) expect_match2(scode, "nlp_a[n] += (bsp_a[1]) * Xme_1[n]") expect_match2(scode, "nlp_b[n] += (bsp_b[1]) * Xme_1[n]") bform <- bf(mvbind(y, z) ~ me(x, xsd)) + set_rescor(TRUE) + set_mecor(FALSE) scode <- stancode(bform, dat) expect_match2(scode, "mu_y[n] += (bsp_y[1]) * Xme_1[n]") expect_match2(scode, "mu_z[n] += (bsp_z[1]) * Xme_1[n]") expect_match2(scode, "Xme_1 = meanme_1[1] + sdme_1[1] * zme_1;") # noise-free terms with grouping factors bform <- bf(y ~ me(x, xsd, ID) + me(z, xsd) + (me(x, xsd, ID) | ID)) scode <- stancode(bform, dat) expect_match2(scode, "vector[Nme_1] Xn_1;") expect_match2(scode, "Xme_1 = meanme_1[1] + sdme_1[1] * zme_1;") expect_match2(scode, "Xme_2 = meanme_2[1] + sdme_2[1] * zme_2;") expect_match2(scode, "(bsp[1] + r_1_2[J_1[n]]) * Xme_1[Jme_1[n]]") bform <- bform + set_mecor(FALSE) scode <- stancode(bform, dat) expect_match2(scode, "Xme_1 = meanme_1[1] + sdme_1[1] * zme_1;") }) test_that("Stan code of multi-membership models is correct", { dat <- data.frame(y = rnorm(10), g1 = sample(1:10, 10, TRUE), g2 = sample(1:10, 10, TRUE), w1 = rep(1, 10), w2 = rep(abs(rnorm(10)))) expect_match2(stancode(y ~ (1|mm(g1, g2)), data = dat), paste0(" W_1_1[n] * r_1_1[J_1_1[n]] * Z_1_1_1[n]", " + W_1_2[n] * r_1_1[J_1_2[n]] * Z_1_1_2[n]") ) expect_match2(stancode(y ~ (1+w1|mm(g1,g2)), data = dat), paste0(" W_1_1[n] * r_1_2[J_1_1[n]] * Z_1_2_1[n]", " + W_1_2[n] * r_1_2[J_1_2[n]] * Z_1_2_2[n]") ) expect_match2(stancode(y ~ (1+mmc(w1, w2)|mm(g1,g2)), data = dat), " W_1_2[n] * r_1_2[J_1_2[n]] * Z_1_2_2[n];" ) }) test_that("by variables in grouping terms are handled correctly", { dat <- data.frame( y = rnorm(100), x = rnorm(100), g = rep(1:10, each = 10), z = factor(rep(c(0, 4.5, 3, 2, 5), each = 20)) ) scode <- stancode(y ~ x + (1 | gr(g, by = z)), dat) expect_match2(scode, "r_1_1 = (transpose(sd_1[1, Jby_1]) .* (z_1[1]));") scode <- stancode(y ~ x + (x | gr(g, by = z)), dat) expect_match2(scode, "r_1 = scale_r_cor_by(z_1, sd_1, L_1, Jby_1);") expect_match2(scode, "lprior += student_t_lpdf(to_vector(sd_1) | 3, 0, 2.5)") expect_match2(scode, "lprior += lkj_corr_cholesky_lpdf(L_1[5] | 1);") }) test_that("Group syntax | and || is handled correctly,", { data <- data.frame(y = rnorm(10), x = rnorm(10), g1 = rep(1:5, each = 2), g2 = rep(1:2, 5)) scode <- stancode(y ~ x + (1+x||g1) + (I(x/4)|g2), data) expect_match2(scode, "r_1_2 = (sd_1[2] * (z_1[2]));") expect_match2(scode, "r_2_1 = r_2[, 1];") expect_match2(scode, "r_2 = scale_r_cor(z_2, sd_2, L_2);") }) test_that("predicting zi and hu works correctly", { scode <- stancode(bf(count ~ Trt, zi ~ Trt), epilepsy, family = "zero_inflated_poisson") expect_match2(scode, "target += zero_inflated_poisson_log_logit_lpmf(Y[n] | mu[n], zi[n])" ) expect_true(!grepl("inv_logit\\(", scode)) expect_true(!grepl("exp(mu[n])", scode, fixed = TRUE)) scode <- stancode(bf(count ~ Trt, zi ~ Trt), epilepsy, family = zero_inflated_poisson(identity)) expect_match2(scode, "target += zero_inflated_poisson_logit_lpmf(Y[n] | mu[n], zi[n])" ) scode <- stancode(bf(count ~ Trt, zi ~ Trt), epilepsy, family = "zero_inflated_binomial") expect_match2(scode, "target += zero_inflated_binomial_blogit_logit_lpmf(Y[n] | trials[n], mu[n], zi[n])" ) expect_true(!grepl("inv_logit\\(", scode)) fam <- zero_inflated_binomial("probit", link_zi = "identity") scode <- stancode( bf(count ~ Trt, zi ~ Trt), epilepsy, family = fam, prior = prior("", class = Intercept, dpar = zi, lb = 0, ub = 1) ) expect_match2(scode, "target += zero_inflated_binomial_lpmf(Y[n] | trials[n], mu[n], zi[n])" ) expect_match2(scode, "mu = Phi(mu);") scode <- stancode(bf(count ~ Trt, zi ~ Trt), epilepsy, family = "zero_inflated_beta_binomial") expect_match2(scode, paste("target += zero_inflated_beta_binomial_logit_lpmf(Y[n]", "| trials[n], mu[n], phi, zi[n])")) expect_match2(scode, "mu = inv_logit(mu);") scode <- stancode( bf(count ~ Trt, zi ~ Trt), epilepsy, zero_inflated_beta_binomial("probit", link_zi = "identity"), prior = prior("", class = Intercept, dpar = zi, lb = 0, ub = 1) ) expect_match2(scode, paste("target += zero_inflated_beta_binomial_lpmf(Y[n]", "| trials[n], mu[n], phi, zi[n])")) expect_match2(scode, "mu = Phi(mu);") scode <- stancode( bf(count ~ Trt, zi ~ Trt), epilepsy, family = zero_inflated_beta() ) expect_match2(scode, "target += zero_inflated_beta_logit_lpdf(Y[n] | mu[n], phi, zi[n])" ) scode <- stancode(bf(count ~ Trt, hu ~ Trt), epilepsy, family = "hurdle_negbinomial") expect_match2(scode, "target += hurdle_neg_binomial_log_logit_lpmf(Y[n] | mu[n], shape, hu[n])" ) expect_true(!grepl("inv_logit\\(", scode)) expect_true(!grepl("exp(mu)", scode, fixed = TRUE)) scode <- stancode(bf(count ~ Trt, hu ~ Trt), epilepsy, family = "hurdle_gamma") expect_match2(scode, "hurdle_gamma_logit_lpdf(Y[n] | shape, shape / mu[n], hu[n])" ) expect_true(!grepl("inv_logit\\(", scode)) scode <- stancode( bf(count ~ Trt, hu ~ Trt), epilepsy, family = hurdle_gamma(link_hu = "identity"), prior = prior("", class = Intercept, dpar = hu, lb = 0, ub = 1) ) expect_match2(scode, "hurdle_gamma_lpdf(Y[n] | shape, shape / mu[n], hu[n])") expect_true(!grepl("inv_logit\\(", scode)) }) test_that("fixing auxiliary parameters is possible", { scode <- stancode(bf(y ~ 1, sigma = 0.5), data = list(y = rnorm(10))) expect_match2(scode, "real sigma = 0.5;") }) test_that("Stan code of quantile regression models is correct", { data <- data.frame(y = rnorm(10), x = rnorm(10), c = 1) scode <- stancode(y ~ x, data, family = asym_laplace()) expect_match2(scode, "target += asym_laplace_lpdf(Y[n] | mu[n], sigma, quantile)") scode <- stancode(bf(y ~ x, quantile = 0.75), data, family = asym_laplace()) expect_match2(scode, "real quantile = 0.75;") scode <- stancode(y | cens(c) ~ x, data, family = asym_laplace()) expect_match2(scode, "target += asym_laplace_lccdf(Y[n] | mu[n], sigma, quantile)") scode <- stancode(bf(y ~ x, sigma ~ x), data, family = asym_laplace()) expect_match2(scode, "target += asym_laplace_lpdf(Y[n] | mu[n], sigma[n], quantile)") scode <- stancode(bf(y ~ x, quantile = 0.75), data, family = brmsfamily("zero_inflated_asym_laplace")) expect_match2(scode, "target += zero_inflated_asym_laplace_lpdf(Y[n] | mu[n], sigma, quantile, zi)" ) }) test_that("Stan code of addition term 'rate' is correct", { data <- data.frame(y = rpois(10, 1), x = rnorm(10), time = 1:10) scode <- stancode(y | rate(time) ~ x, data, poisson()) expect_match2(scode, "target += poisson_log_lpmf(Y | mu + log_denom);") scode <- stancode(y | rate(time) ~ x, data, poisson("identity")) expect_match2(scode, "target += poisson_lpmf(Y | mu .* denom);") scode <- stancode(y | rate(time) ~ x, data, negbinomial()) expect_match2(scode, "target += neg_binomial_2_log_lpmf(Y | mu + log_denom, shape .* denom);") bform <- bf(y | rate(time) ~ mi(x), shape ~ mi(x), family = negbinomial()) + bf(x | mi() ~ 1, family = gaussian()) scode <- stancode(bform, data) expect_match2(scode, "target += neg_binomial_2_log_lpmf(Y_y | mu_y + log_denom_y, shape_y .* denom_y);") scode <- stancode(y | rate(time) ~ x, data, brmsfamily("negbinomial2")) expect_match2(scode, "target += neg_binomial_2_log_lpmf(Y | mu + log_denom, inv(sigma) .* denom);") scode <- stancode(y | rate(time) + cens(1) ~ x, data, geometric()) expect_match2(scode, "target += neg_binomial_2_lpmf(Y[Jevent[1:Nevent]] | mu[Jevent[1:Nevent]] .* denom[Jevent[1:Nevent]], 1 .* denom[Jevent[1:Nevent]]);" ) }) test_that("Stan code of GEV models is correct", { data <- data.frame(y = rnorm(10), x = rnorm(10), c = 1) SW(scode <- stancode(y ~ x, data, gen_extreme_value())) expect_match2(scode, "target += gen_extreme_value_lpdf(Y[n] | mu[n], sigma, xi)") expect_match2(scode, "xi = scale_xi(tmp_xi, Y, mu, sigma)") SW(scode <- stancode(bf(y ~ x, sigma ~ x), data, gen_extreme_value())) expect_match2(scode, "xi = scale_xi(tmp_xi, Y, mu, sigma)") SW(scode <- stancode(bf(y ~ x, xi ~ x), data, gen_extreme_value())) expect_match2(scode, "xi = expm1(xi)") SW(scode <- stancode(bf(y ~ x, xi = 0), data, gen_extreme_value())) expect_match2(scode, "real xi = 0; // shape parameter") SW(scode <- stancode(y | cens(c) ~ x, data, gen_extreme_value())) expect_match2(scode, "target += gen_extreme_value_lccdf(Y[n] | mu[n], sigma, xi)") }) test_that("Stan code of Cox models is correct", { data <- data.frame(y = rexp(100), ce = sample(0:1, 100, TRUE), x = rnorm(100), g = sample(1:3, 100, TRUE)) bform <- bf(y | cens(ce) ~ x) scode <- stancode(bform, data, brmsfamily("cox")) expect_match2(scode, "target += cox_log_lpdf(Y[Jevent[1:Nevent]] | mu[Jevent[1:Nevent]], bhaz[Jevent[1:Nevent]], cbhaz[Jevent[1:Nevent]]);" ) expect_match2(scode, "vector[N] cbhaz = Zcbhaz * sbhaz;") expect_match2(scode, "lprior += dirichlet_lpdf(sbhaz | con_sbhaz);") expect_match2(scode, "simplex[Kbhaz] sbhaz;") bform <- bf(y ~ x) scode <- stancode(bform, data, brmsfamily("cox", "identity")) expect_match2(scode, "target += cox_lpdf(Y | mu, bhaz, cbhaz);") bform <- bf(y | bhaz(gr = g) ~ x) scode <- stancode(bform, data, brmsfamily("cox")) expect_match2(scode, "lprior += dirichlet_lpdf(sbhaz[k] | con_sbhaz[k]);") expect_match2(scode, "bhaz[n] = Zbhaz[n] * sbhaz[Jgrbhaz[n]];") }) test_that("offsets appear in the Stan code", { data <- data.frame(y = rnorm(10), x = rnorm(10), c = 1) scode <- stancode(y ~ x + offset(c), data) expect_match2(scode, "+ offsets;") scode <- stancode(bf(y ~ a, a ~ offset(log(c + 1)), nl = TRUE), data, prior = prior(normal(0,1), nlpar = a)) expect_match2(scode, "+ offsets_a;") }) test_that("prior only models are correctly checked", { data <- data.frame(y = rnorm(10), x = rnorm(10), c = 1) prior <- prior(normal(0, 5), b) + prior("", Intercept) expect_error(stancode(y ~ x, data, prior = prior, sample_prior = "only"), "Sampling from priors is not possible") prior <- prior(normal(0, 5), b) + prior(normal(0, 10), Intercept) scode <- stancode(y ~ x, data, prior = prior, sample_prior = "only") expect_match2(scode, "lprior += normal_lpdf(Intercept | 0, 10)") }) test_that("Stan code of mixture model is correct", { data <- data.frame(y = 1:10, x = rnorm(10), c = 1) data$z <- abs(data$y) scode <- stancode( bf(y ~ x, sigma2 ~ x), data, family = mixture(gaussian, gaussian), sample_prior = TRUE ) expect_match2(scode, "ordered[2] ordered_Intercept;") expect_match2(scode, "Intercept_mu2 = ordered_Intercept[2];") expect_match2(scode, "lprior += dirichlet_lpdf(theta | con_theta);") expect_match2(scode, "ps[1] = log(theta1) + normal_lpdf(Y[n] | mu1[n], sigma1);") expect_match2(scode, "ps[2] = log(theta2) + normal_lpdf(Y[n] | mu2[n], sigma2[n]);") expect_match2(scode, "target += log_sum_exp(ps);") expect_match2(scode, "simplex[2] prior_theta = dirichlet_rng(con_theta);") scode <- stancode(bf(z | weights(c) ~ x, shape1 ~ x, theta1 = 1, theta2 = 2), data = data, mixture(Gamma("log"), weibull)) expect_match(scode, "data \\{[^\\}]*real theta1;") expect_match(scode, "data \\{[^\\}]*real theta2;") expect_match2(scode, "ps[1] = log(theta1) + gamma_lpdf(Y[n] | shape1[n], shape1[n] ./ mu1[n]);") expect_match2(scode, "target += weights[n] * log_sum_exp(ps);") scode <- stancode(bf(abs(y) | se(c) ~ x), data = data, mixture(gaussian, student)) expect_match2(scode, "ps[1] = log(theta1) + normal_lpdf(Y[n] | mu1[n], se[n]);") expect_match2(scode, "ps[2] = log(theta2) + student_t_lpdf(Y[n] | nu2, mu2[n], se[n]);") fam <- mixture(gaussian, student, exgaussian) scode <- stancode(bf(y ~ x), data = data, family = fam) expect_match(scode, "parameters \\{[^\\}]*real Intercept_mu3;") expect_match2(scode, "ps[2] = log(theta2) + student_t_lpdf(Y[n] | nu2, mu2[n], sigma2);" ) expect_match2(scode, "ps[3] = log(theta3) + exp_mod_normal_lpdf(Y[n] | mu3[n] - beta3, sigma3, inv(beta3));" ) scode <- stancode(bf(y ~ x, theta1 ~ x, theta3 ~ x), data = data, family = fam) expect_match2(scode, "log_sum_exp_theta = log(exp(theta1[n]) + exp(theta2[n]) + exp(theta3[n]));") expect_match2(scode, "theta2 = rep_vector(0.0, N);") expect_match2(scode, "theta3[n] = theta3[n] - log_sum_exp_theta;") expect_match2(scode, "ps[1] = theta1[n] + normal_lpdf(Y[n] | mu1[n], sigma1);") fam <- mixture(cumulative, sratio) scode <- stancode(y ~ x, data, family = fam) expect_match2(scode, "ordered_logistic_lpmf(Y[n] | mu1[n], Intercept_mu1);") expect_match2(scode, "sratio_logit_lpmf(Y[n] | mu2[n], disc2, Intercept_mu2);") # censored mixture model fam <- mixture(gaussian, gaussian) scode <- stancode(y | cens(2, y2 = 2) ~ x, data, fam) expect_match2(scode, "ps[2] = log(theta2) + normal_lccdf(Y[n] | mu2[n], sigma2);" ) expect_match2(scode, paste0( "ps[2] = log(theta2) + log_diff_exp(\n", " normal_lcdf(rcens[n] | mu2[n], sigma2)," )) # truncated mixture model scode <- stancode(y | trunc(3) ~ x, data, fam) expect_match2(scode, paste0( "ps[1] = log(theta1) + normal_lpdf(Y[n] | mu1[n], sigma1) -\n", " normal_lccdf(lb[n] | mu1[n], sigma1);" )) # non-linear mixture model bform <- bf(y ~ 1) + nlf(mu1 ~ eta^2) + nlf(mu2 ~ log(eta) + a) + lf(eta + a ~ x) + mixture(gaussian, nmix = 2) bprior <- prior(normal(0, 1), nlpar = "eta") + prior(normal(0, 1), nlpar = "a") scode <- stancode(bform, data = data, prior = bprior) expect_match2(scode, "mu1[n] = (nlp_eta[n] ^ 2);") expect_match2(scode, "mu2[n] = (log(nlp_eta[n]) + nlp_a[n]);") }) test_that("sparse matrix multiplication is applied correctly", { data <- data.frame(y = rnorm(10), x = rnorm(10)) # linear model scode <- stancode( bf(y ~ x, sparse = TRUE) + lf(sigma ~ x, sparse = TRUE), data, prior = prior(normal(0, 5), coef = "Intercept") ) expect_match2(scode, "wX = csr_extract_w(X);") expect_match2(scode, "mu += csr_matrix_times_vector(rows(X), cols(X), wX, vX, uX, b);" ) expect_match2(scode, "uX_sigma[size(csr_extract_u(X_sigma))] = csr_extract_u(X_sigma);" ) expect_match2(scode, paste0( "sigma += csr_matrix_times_vector(rows(X_sigma), cols(X_sigma), ", "wX_sigma, vX_sigma, uX_sigma, b_sigma);" ) ) expect_match2(scode, "lprior += normal_lpdf(b[1] | 0, 5);") expect_match2(scode, "target += normal_lpdf(Y | mu, sigma);") # non-linear model scode <- stancode( bf(y ~ a, lf(a ~ x, sparse = TRUE), nl = TRUE), data, prior = prior(normal(0, 1), nlpar = a) ) expect_match2(scode, "vX_a[size(csr_extract_v(X_a))] = csr_extract_v(X_a);" ) expect_match2(scode, "nlp_a += csr_matrix_times_vector(rows(X_a), cols(X_a), wX_a, vX_a, uX_a, b_a);" ) }) test_that("QR decomposition is included in the Stan code", { data <- data.frame(y = rnorm(10), x1 = rnorm(10), x2 = rnorm(10)) bform <- bf(y ~ x1 + x2, decomp = "QR") + lf(sigma ~ 0 + x1 + x2, decomp = "QR") # simple priors scode <- stancode(bform, data, prior = prior(normal(0, 2))) expect_match2(scode, "XQ = qr_thin_Q(Xc) * sqrt(N - 1);") expect_match2(scode, "b = XR_inv * bQ;") expect_match2(scode, "lprior += normal_lpdf(bQ | 0, 2);") expect_match2(scode, "XQ * bQ") expect_match2(scode, "XR_sigma = qr_thin_R(X_sigma) / sqrt(N - 1);") # horseshoe prior scode <- stancode(bform, data, prior = prior(horseshoe(1))) expect_match2(scode, "target += std_normal_lpdf(zb);") expect_match2(scode, "scales = scales_horseshoe(") expect_match2(scode, "sdb = scales[(1):(Kc)];") expect_match2(scode, "bQ = zb .* sdb;") }) test_that("Stan code for Gaussian processes is correct", { set.seed(1234) dat <- data.frame(y = rnorm(40), x1 = rnorm(40), x2 = rnorm(40), z = factor(rep(3:6, each = 10))) prior <- prior(gamma(0.1, 0.1), sdgp) + prior(gamma(4, 2), sdgp, coef = gpx2x1) scode <- stancode(y ~ gp(x1, cov = "matern32") + gp(x2, by = x1, gr = FALSE), dat, prior = prior) expect_match2(scode, "lprior += inv_gamma_lpdf(lscale_1[1]") expect_match2(scode, "lprior += gamma_lpdf(sdgp_1 | 0.1, 0.1)") expect_match2(scode, "lprior += gamma_lpdf(sdgp_2 | 4, 2)") expect_match2(scode, "gp_pred_1 = gp_matern32(Xgp_1, sdgp_1[1], lscale_1[1], zgp_1);") expect_match2(scode, "gp_pred_2 = gp_exp_quad(Xgp_2, sdgp_2[1], lscale_2[1], zgp_2);") expect_match2(scode, "Cgp_2 .* gp_pred_2;") prior <- prior + prior(normal(0, 1), lscale, coef = gpx1) scode <- stancode(y ~ gp(x1, cov = "matern52") + gp(x2, by = x1, cov = "exponential"), data = dat, prior = prior) expect_match2(scode, "lprior += normal_lpdf(lscale_1[1][1] | 0, 1)") expect_match2(scode, "gp_pred_1 = gp_matern52(Xgp_1, sdgp_1[1], lscale_1[1], zgp_1)") expect_match2(scode, "gp_pred_2 = gp_exponential(Xgp_2, sdgp_2[1], lscale_2[1], zgp_2);") expect_match2(scode, "+ Cgp_2 .* gp_pred_2[Jgp_2]") # non-isotropic GP scode <- stancode(y ~ gp(x1, x2, by = z, iso = FALSE), data = dat) expect_match2(scode, "lprior += inv_gamma_lpdf(lscale_1[1][2]") expect_match2(scode, "lprior += inv_gamma_lpdf(lscale_1[4][2]") scode <- stancode(y ~ gp(x1, x2) + gp(x1, by = z, gr = FALSE), data = dat) expect_match2(scode, "gp_exp_quad(Xgp_1, sdgp_1[1], lscale_1[1], zgp_1)") expect_match2(scode, "mu[Igp_2_2] += Cgp_2_2 .* gp_pred_2_2;") # approximate GPS scode <- stancode( y ~ gp(x1, k = 10, c = 5/4) + gp(x2, by = x1, k = 10, c = 5/4, cov = "matern32"), data = dat ) expect_match2(scode, "lprior += inv_gamma_lpdf(lscale_1") expect_match2(scode, "rgp_1 = sqrt(spd_gp_exp_quad(slambda_1, sdgp_1[1], lscale_1[1])) .* zgp_1;" ) expect_match2(scode, "rgp_2 = sqrt(spd_gp_matern32(slambda_2, sdgp_2[1], lscale_2[1])) .* zgp_2;" ) expect_match2(scode, "Cgp_2 .* gp_pred_2[Jgp_2]") prior <- c(prior(normal(0, 10), lscale, coef = gpx1, nlpar = a), prior(gamma(0.1, 0.1), sdgp, nlpar = a), prior(normal(0, 1), b, nlpar = a)) scode <- stancode(bf(y ~ a, a ~ gp(x1), nl = TRUE), data = dat, prior = prior) expect_match2(scode, "lprior += normal_lpdf(lscale_a_1[1][1] | 0, 10)") expect_match2(scode, "lprior += gamma_lpdf(sdgp_a_1 | 0.1, 0.1)") expect_match2(scode, "gp_exp_quad(Xgp_a_1, sdgp_a_1[1], lscale_a_1[1], zgp_a_1)") prior <- prior(gamma(2, 2), lscale, coef = gpx1z5, nlpar = "a") scode <- stancode(bf(y ~ a, a ~ gp(x1, by = z, gr = TRUE), nl = TRUE), data = dat, prior = prior, silent = TRUE) expect_match2(scode, "nlp_a[Igp_a_1_1] += Cgp_a_1_1 .* gp_pred_a_1_1[Jgp_a_1_1];" ) expect_match2(scode, "gp_exp_quad(Xgp_a_1_3, sdgp_a_1[3], lscale_a_1[3], zgp_a_1_3)") expect_match2(scode, "lprior += gamma_lpdf(lscale_a_1[3][1] | 2, 2);") expect_match2(scode, "target += std_normal_lpdf(zgp_a_1_3);") # test warnings and errors prior <- prior(normal(0, 1), lscale) expect_warning( stancode(y ~ gp(x1), data = dat, prior = prior), "The global prior 'normal(0, 1)' of class 'lscale' will not be used", fixed = TRUE ) expect_error(stancode(y ~ gp(x1, cov = "periodic"), data = dat)) }) test_that("Stan code for SAR models is correct", { dat <- data.frame(y = rnorm(10), x = rnorm(10)) W <- matrix(0, nrow = 10, ncol = 10) dat2 <- list(W = W) scode <- stancode( y ~ x + sar(W), data = dat, prior = prior(normal(0.5, 1), lagsar), data2 = dat2 ) expect_match2(scode, "target += normal_lagsar_lpdf(Y | mu, sigma, lagsar, Msar, eigenMsar)" ) expect_match2(scode, "lprior += normal_lpdf(lagsar | 0.5, 1)") scode <- stancode( y ~ x + sar(W, type = "lag"), data = dat, family = student(), data2 = dat2 ) expect_match2(scode, "target += student_t_lagsar_lpdf(Y | nu, mu, sigma, lagsar, Msar, eigenMsar)" ) scode <- stancode(y ~ x + sar(W, type = "error"), data = dat, data2 = dat2) expect_match2(scode, "target += normal_errorsar_lpdf(Y | mu, sigma, errorsar, Msar, eigenMsar)" ) scode <- stancode( y ~ x + sar(W, "error"), data = dat, family = student(), prior = prior(beta(2, 3), errorsar), data2 = dat2 ) expect_match2(scode, "target += student_t_errorsar_lpdf(Y | nu, mu, sigma, errorsar, Msar, eigenMsar)" ) expect_match2(scode, "lprior += beta_lpdf(errorsar | 2, 3)") expect_error( stancode(bf(y ~ sar(W), sigma ~ x), data = dat), "SAR models are not implemented when predicting 'sigma'" ) }) test_that("Stan code for CAR models is correct", { dat <- data.frame(y = rnorm(10), x = rnorm(10)) edges <- cbind(1:10, 10:1) W <- matrix(0, nrow = 10, ncol = 10) for (i in seq_len(nrow(edges))) { W[edges[i, 1], edges[i, 2]] <- 1 } rownames(W) <- seq_len(nrow(W)) dat2 <- list(W = W) scode <- stancode(y ~ x + car(W), dat, data2 = dat2) expect_match2(scode, "real car;") expect_match2(scode, "real sparse_car_lpdf(vector phi") expect_match2(scode, "target += sparse_car_lpdf(") expect_match2(scode, "mu[n] += rcar[Jloc[n]]") scode <- stancode(y ~ x + car(W, type = "esicar"), dat, data2 = dat2) expect_match2(scode, "real sparse_icar_lpdf(vector phi") expect_match2(scode, "target += sparse_icar_lpdf(") expect_match2(scode, "mu[n] += rcar[Jloc[n]]") expect_match2(scode, "rcar[Nloc] = - sum(zcar)") scode <- stancode(y ~ x + car(W, type = "icar"), dat, data2 = dat2) expect_match2(scode, "target += -0.5 * dot_self(zcar[edges1] - zcar[edges2])") expect_match2(scode, "target += normal_lpdf(sum(zcar) | 0, 0.001 * Nloc)") expect_match2(scode, "mu[n] += rcar[Jloc[n]]") expect_match2(scode, "rcar = zcar * sdcar") scode <- stancode(y ~ x + car(W, type = "bym2"), dat, data2 = dat2) expect_match2(scode, "target += -0.5 * dot_self(zcar[edges1] - zcar[edges2])") expect_match2(scode, "target += normal_lpdf(sum(zcar) | 0, 0.001 * Nloc)") expect_match2(scode, "mu[n] += rcar[Jloc[n]]") expect_match2(scode, "lprior += beta_lpdf(rhocar | 1, 1)") expect_match2(scode, paste0( "rcar = (sqrt(1 - rhocar) * nszcar + ", "sqrt(rhocar * inv(car_scale)) * zcar) * sdcar" )) # apply a CAR term on a distributional parameter other than 'mu' scode <- stancode(bf(y ~ x, sigma ~ car(W)), dat, data2 = dat2) expect_match2(scode, "real sparse_car_lpdf(vector phi") expect_match2(scode, "target += sparse_car_lpdf(") expect_match2(scode, "sigma[n] += rcar_sigma[Jloc_sigma[n]]") # apply shrinkage priors on a CAR term scode <- stancode(bf(y ~ x + car(W)), dat, data2 = dat2, prior = prior(horseshoe(main = TRUE), class = b) + prior(horseshoe(), class = sdcar)) expect_match2(scode, "sdcar = scales[(1+Kc):(Kc+1)][1];") }) test_that("Stan code for skew_normal models is correct", { dat = data.frame(y = rnorm(10), x = rnorm(10)) scode <- stancode(y ~ x, dat, skew_normal()) expect_match2(scode, "delta = alpha / sqrt(1 + alpha^2);") expect_match2(scode, "omega = sigma / sqrt(1 - sqrt(2 / pi())^2 * delta^2);") expect_match2(scode, "mu[n] = mu[n] - omega * delta * sqrt(2 / pi());") scode <- stancode(bf(y ~ x, sigma ~ x), dat, skew_normal()) expect_match2(scode, "omega[n] = sigma[n] / sqrt(1 - sqrt(2 / pi())^2 * delta^2);") expect_match2(scode, "mu[n] = mu[n] - omega[n] * delta * sqrt(2 / pi());") scode <- stancode(bf(y | se(x) ~ x, alpha ~ x), dat, skew_normal()) expect_match2(scode, "delta[n] = alpha[n] / sqrt(1 + alpha[n]^2);") expect_match2(scode, "omega[n] = se[n] / sqrt(1 - sqrt(2 / pi())^2 * delta[n]^2);") expect_match2(scode, "mu[n] = mu[n] - omega[n] * delta[n] * sqrt(2 / pi());") scode <- stancode(y ~ x, dat, mixture(skew_normal, nmix = 2)) expect_match2(scode, "omega1 = sigma1 / sqrt(1 - sqrt(2 / pi())^2 * delta1^2);") expect_match2(scode, "mu2[n] = mu2[n] - omega2 * delta2 * sqrt(2 / pi());") }) test_that("Stan code for missing value terms works correctly", { dat = data.frame(y = rnorm(10), x = rnorm(10), g = 1:10, z = 1) dat$x[c(1, 3, 9)] <- NA bform <- bf(y ~ mi(x)*g) + bf(x | mi() ~ g) + set_rescor(FALSE) scode <- stancode(bform, dat) expect_match2(scode, "Yl_x[Jmi_x] = Ymi_x;") expect_match2(scode, "(bsp_y[1]) * Yl_x[n] + (bsp_y[2]) * Yl_x[n] * Csp_y_1[n];") expect_match2(scode, "target += normal_id_glm_lpdf(Yl_x | Xc_x, Intercept_x, b_x, sigma_x);") bform <- bf(y ~ mi(x) + (mi(x) | g)) + bf(x | mi() ~ 1) + set_rescor(FALSE) scode <- stancode(bform, dat) expect_match2(scode, "(bsp_y[1] + r_1_y_2[J_1_y[n]]) * Yl_x[n] + r_1_y_1[J_1_y[n]] * Z_1_y_1[n];" ) bform <- bf(y ~ a, a ~ mi(x), nl = TRUE) + bf(x | mi() ~ 1) + set_rescor(FALSE) bprior <- prior(normal(0, 1), nlpar = "a", resp = "y") scode <- stancode(bform, dat, prior = bprior) expect_match2(scode, "nlp_y_a[n] += (bsp_y_a[1]) * Yl_x[n];") expect_match2(scode, "lprior += normal_lpdf(bsp_y_a | 0, 1);") bform <- bf(y ~ mi(x)*mo(g)) + bf(x | mi() ~ 1) + set_rescor(FALSE) scode <- stancode(bform, dat) expect_match2(scode, "(bsp_y[3]) * Yl_x[n] * mo(simo_y_2, Xmo_y_2[n]);") bform <- bf(y ~ 1, sigma ~ 1) + bf(x | mi() ~ 1) + set_rescor(TRUE) scode <- stancode(bform, dat) expect_match2(scode, "Yl[n][2] = Yl_x[n];") expect_match2(scode, "sigma[n] = transpose([sigma_y[n], sigma_x]);") expect_match2(scode, "LSigma[n] = diag_pre_multiply(sigma[n], Lrescor);") bform <- bf(x | mi() ~ y, family = "lognormal") scode <- stancode(bform, dat) expect_match2(scode, "vector[Nmi] Ymi;") bform <- bf(y ~ I(log(mi(x))) * g) + bf(x | mi() + trunc(lb = 1) ~ y, family = "lognormal") scode <- stancode(bform, dat) expect_match2(scode, "vector[Nmi_x] Ymi_x;") expect_match2(scode, "(bsp_y[1]) * (log(Yl_x[n])) + (bsp_y[2]) * (log(Yl_x[n])) * Csp_y_1[n]" ) bform <- bf(y ~ mi(x)*g) + bf(x | mi() + cens(z) ~ y, family = "beta") scode <- stancode(bform, dat) expect_match2(scode, "vector[Nmi_x] Ymi_x;") expect_match2(scode, "target += beta_lpdf(Y_x[Jevent_x[1:Nevent_x]] | mu_x[Jevent_x[1:Nevent_x]] .* phi_x, (1 - mu_x[Jevent_x[1:Nevent_x]]) .* phi_x);" ) # tests #1608 bform <- bf(y ~ g + mi(x):g + mi(x):mi(z) + mi(z):g) + bf(x | mi() ~ 1) + bf(z | mi() ~ 1) + set_rescor(FALSE) scode <- stancode(bform, dat) expect_match2(scode, "mu_y[n] += (bsp_y[1]) * Yl_x[n] * Csp_y_1[n] + (bsp_y[2]) * Yl_x[n] * Yl_z[n] + (bsp_y[3]) * Yl_z[n] * Csp_y_2[n];" ) bform <- bf(y | mi() ~ mi(x), shape ~ mi(x), family=weibull()) + bf(x| mi() ~ z, family=gaussian()) + set_rescor(FALSE) scode <- stancode(bform, data = dat) expect_match2(scode, "weibull_lpdf(Yl_y | shape_y, mu_y ./ tgamma(1 + 1 ./ shape_y));") expect_match2(scode, "shape_y[n] += (bsp_shape_y[1]) * Yl_x[n];") }) test_that("Stan code for overimputation works correctly", { dat = data.frame(y = rnorm(10), x_x = rnorm(10), g = 1:10, z = 1) dat$x[c(1, 3, 9)] <- NA bform <- bf(y ~ mi(x_x)*g) + bf(x_x | mi(g) ~ 1) + set_rescor(FALSE) scode <- stancode(bform, dat, sample_prior = "yes") expect_match2(scode, "target += normal_lpdf(Yl_xx | mu_xx, sigma_xx)") expect_match2(scode, "target += normal_lpdf(Y_xx[Jme_xx] | Yl_xx[Jme_xx], noise_xx[Jme_xx])" ) expect_match2(scode, "vector[N_xx] Yl_xx;") }) test_that("Missing value terms can be combined with 'subset'", { dat <- data.frame( y = rnorm(10), x = c(rnorm(9), NA), z = rnorm(10), g2 = 10:1, g1 = sample(1:5, 10, TRUE), s = c(FALSE, rep(TRUE, 9)) ) bform <- bf(y ~ mi(x, idx = g1)*mi(z)) + bf(x | mi() + index(g2) + subset(s) ~ 1) + bf(z | mi() ~ s) + set_rescor(FALSE) scode <- stancode(bform, dat) expect_match2(scode, "(bsp_y[1]) * Yl_x[idxl_y_x_1[n]]") expect_match2(scode, "(bsp_y[2]) * Yl_z[n]") expect_match2(scode, "(bsp_y[3]) * Yl_x[idxl_y_x_1[n]] * Yl_z[n]") expect_match2(scode, "array[N_y] int idxl_y_x_1;") }) test_that("Stan code for advanced count data distribution is correct", { scode <- stancode( count ~ zAge + zBase * Trt + (1|patient), data = epilepsy, family = brmsfamily("discrete_weibull") ) expect_match2(scode, "mu = inv_logit(mu);") expect_match2(scode, "target += discrete_weibull_lpmf(Y[n] | mu[n], shape);") scode <- stancode( count ~ zAge + zBase * Trt + (1|patient), data = epilepsy, family = brmsfamily("com_poisson") ) expect_match2(scode, "target += com_poisson_log_lpmf(Y[n] | mu[n], shape);") }) test_that("argument 'stanvars' is handled correctly", { bprior <- prior(normal(mean_intercept, 10), class = "Intercept") mean_intercept <- 5 stanvars <- stanvar(mean_intercept) scode <- stancode(count ~ Trt, data = epilepsy, prior = bprior, stanvars = stanvars) expect_match2(scode, "real mean_intercept;") # define a multi_normal prior with known covariance matrix bprior <- prior(multi_normal(M, V), class = "b") stanvars <- stanvar(rep(0, 2), "M", scode = "vector[K] M;") + stanvar(diag(2), "V", scode = "matrix[K, K] V;") scode <- stancode(count ~ Trt + zBase, epilepsy, prior = bprior, stanvars = stanvars) expect_match2(scode, "vector[K] M;") expect_match2(scode, "matrix[K, K] V;") # define a hierarchical prior on the regression coefficients bprior <- set_prior("normal(0, tau)", class = "b") + set_prior("target += normal_lpdf(tau | 0, 10)", check = FALSE) stanvars <- stanvar(scode = "real tau;", block = "parameters") scode <- stancode(count ~ Trt + zBase, epilepsy, prior = bprior, stanvars = stanvars) expect_match2(scode, "real tau;") expect_match2(scode, "lprior += normal_lpdf(b | 0, tau);") # ensure that variables are passed to the likelihood of a threaded model foo <- 0.5 stanvars <- stanvar(foo) + stanvar(scode = "real tau;", block = "parameters", pll_args = "real tau") scode <- stancode(count ~ 1, data = epilepsy, family = poisson(), stanvars = stanvars, threads = threading(2), parse = FALSE) expect_match2(scode, "partial_log_lik_lpmf(array[] int seq, int start, int end, data array[] int Y, real Intercept, data real foo, real tau)" ) expect_match2(scode, "reduce_sum(partial_log_lik_lpmf, seq, grainsize, Y, Intercept, foo, tau)" ) # specify Stan code in the likelihood part of the model block stanvars <- stanvar(scode = "mu += 1.0;", block = "likelihood", position = "start") scode <- stancode(count ~ Trt + (1|patient), data = epilepsy, stanvars = stanvars) expect_match2(scode, "mu += 1.0;") stanvars <- stanvar(scode = "mu += 1.0;", block = "likelihood", position = "start") scode <- stancode(count ~ Trt + (1|patient), data = epilepsy, stanvars = stanvars, threads = 2, parse = FALSE) expect_match2(scode, "mu += 1.0;") # add transformation at the end of a block stanvars <- stanvar(scode = "r_1_1 = r_1_1 * 2;", block = "tparameters", position = "end") scode <- stancode(count ~ Trt + (1 | patient), epilepsy, stanvars = stanvars) expect_match2(scode, "r_1_1 = r_1_1 * 2;\n}") # use the non-centered parameterization for 'b' # unofficial feature not supported anymore for the time being # bprior <- set_prior("target += normal_lpdf(zb | 0, 1)", check = FALSE) + # set_prior("target += normal_lpdf(tau | 0, 10)", check = FALSE) # stanvars <- stanvar(scode = "vector[Kc] zb;", block = "parameters") + # stanvar(scode = "real tau;", block = "parameters") + # stanvar(scode = "vector[Kc] b = zb * tau;", # block="tparameters", name = "b") # scode <- stancode(count ~ Trt, epilepsy, # prior = bprior, stanvars = stanvars) # expect_match2(scode, "vector[Kc] b = zb * tau;") # stanvars <- stanvar(scode = "vector[Ksp] zbsp;", block = "parameters") + # stanvar(scode = "real tau;", block = "parameters") + # stanvar(scode = "vector[Ksp] bsp = zbsp * tau;", # block = "tparameters", name = "bsp") # scode <- stancode(count ~ mo(Base), epilepsy, stanvars = stanvars) # expect_match2(scode, "vector[Ksp] bsp = zbsp * tau;") }) test_that("custom families are handled correctly", { dat <- data.frame(size = 10, y = sample(0:10, 20, TRUE), x = rnorm(20)) # define a custom beta-binomial family log_lik_beta_binomial2 <- function(i, prep) { mu <- prep$dpars$mu[, i] tau <- prep$dpars$tau trials <- prep$data$vint1[i] y <- prep$data$Y[i] beta_binomial2_lpmf(y, mu, tau, trials) } posterior_predict_beta_binomial2 <- function(i, prep, ...) { mu <- prep$dpars$mu[, i] tau <- prep$dpars$tau trials <- prep$data$vint1[i] beta_binomial2_rng(mu, tau, trials) } posterior_epred_beta_binomial2 <- function(prep) { mu <- prep$dpars$mu trials <- prep$data$vint1 trials <- matrix(trials, nrow = nrow(mu), ncol = ncol(mu), byrow = TRUE) mu * trials } beta_binomial2 <- custom_family( "beta_binomial2", dpars = c("mu", "tau"), links = c("logit", "log"), lb = c(NA, 0), type = "int", vars = c("vint1[n]", "vreal1[n]"), log_lik = log_lik_beta_binomial2, posterior_epred = posterior_epred_beta_binomial2, posterior_predict = posterior_predict_beta_binomial2 ) # define custom stan functions # real R is just to also test the vreal addition argument stan_funs <- " real beta_binomial2_lpmf(int y, real mu, real phi, int N, real R) { return beta_binomial_lpmf(y | N, mu * phi, (1 - mu) * phi); } int beta_binomial2_rng(real mu, real phi, int N, real R) { return beta_binomial_rng(N, mu * phi, (1 - mu) * phi); } " stanvars <- stanvar(scode = stan_funs, block = "functions") scode <- stancode( y | vint(size) + vreal(size) ~ x, data = dat, family = beta_binomial2, prior = prior(gamma(0.1, 0.1), class = "tau"), stanvars = stanvars ) expect_match2(scode, "array[N] int vint1;") expect_match2(scode, "real tau;") expect_match2(scode, "mu = inv_logit(mu);") expect_match2(scode, "lprior += gamma_lpdf(tau | 0.1, 0.1);") expect_match2(scode, "target += beta_binomial2_lpmf(Y[n] | mu[n], tau, vint1[n], vreal1[n]);" ) scode <- stancode( bf(y | vint(size) + vreal(size) ~ x, tau ~ x), data = dat, family = beta_binomial2, stanvars = stanvars ) expect_match2(scode, "tau = exp(tau);") expect_match2(scode, "target += beta_binomial2_lpmf(Y[n] | mu[n], tau[n], vint1[n], vreal1[n]);" ) # check custom families in mixture models scode <- stancode( y | vint(size) + vreal(size) + trials(size) ~ x, data = dat, family = mixture(binomial, beta_binomial2), stanvars = stanvars ) expect_match2(scode, "log(theta2) + beta_binomial2_lpmf(Y[n] | mu2[n], tau2, vint1[n], vreal1[n]);" ) # check custom families in multivariate models bform <- bf( y | vint(size) + vreal(size) + trials(size) ~ x, family = beta_binomial2 ) + bf(x ~ 1, family = gaussian()) scode <- stancode(bform, data = dat, stanvars = stanvars) expect_match2(scode, "target += beta_binomial2_lpmf(Y_y[n] | mu_y[n], tau_y, vint1_y[n], vreal1_y[n]);" ) # check vectorized custom families beta_binomial2_vec <- custom_family( "beta_binomial2_vec", dpars = c("mu", "tau"), links = c("logit", "log"), lb = c(NA, 0), type = "int", vars = c("vint1", "vreal1"), loop = FALSE ) stan_funs_vec <- " real beta_binomial2_vec_lpmf(array[] int y, vector mu, real phi, array[] int N, array[] real R) { return beta_binomial_lpmf(y | N, mu * phi, (1 - mu) * phi); } int beta_binomial2_rng(real mu, real phi, int N, real R) { return beta_binomial_rng(N, mu * phi, (1 - mu) * phi); } " stanvars <- stanvar(scode = stan_funs_vec, block = "functions") scode <- stancode( y | vint(size) + vreal(size) ~ x, data = dat, family = beta_binomial2_vec, prior = prior(gamma(0.1, 0.1), class = "tau"), stanvars = stanvars ) expect_match2(scode, "target += beta_binomial2_vec_lpmf(Y | mu, tau, vint1, vreal1);" ) }) test_that("likelihood of distributional beta models is correct", { # test issue #404 dat <- data.frame(prop = rbeta(100, shape1 = 2, shape2 = 2)) scode <- stancode( bf(prop ~ 1, phi ~ 1), data = dat, family = Beta() ) expect_match2(scode, "target += beta_lpdf(Y | mu .* phi, (1 - mu) .* phi);") }) test_that("student-t group-level effects work without errors", { scode <- stancode(count ~ Trt + (1|gr(patient, dist = "st")), epilepsy) expect_match2(scode, "dfm_1 = sqrt(df_1 * udf_1);") expect_match2(scode, "dfm_1 .* (sd_1[1] * (z_1[1]));") expect_match2(scode, "lprior += gamma_lpdf(df_1 | 2, 0.1)") expect_match2(scode, "target += inv_chi_square_lpdf(udf_1 | df_1);") bprior <- prior(normal(20, 5), class = df, group = patient) scode <- stancode( count ~ Trt + (Trt|gr(patient, dist = "st")), epilepsy, prior = bprior ) expect_match2(scode, "r_1 = rep_matrix(dfm_1, M_1) .* scale_r_cor(z_1, sd_1, L_1);" ) expect_match2(scode, "lprior += normal_lpdf(df_1 | 20, 5)") }) test_that("centering design matrices can be changed correctly", { dat <- data.frame(y = 1:10, x = 1:10) scode <- stancode( bf(y ~ x, center = FALSE), data = dat, family = weibull(), prior = prior(normal(0,1), coef = Intercept) ) expect_match2(scode, "mu += X * b;") expect_match2(scode, "lprior += normal_lpdf(b[1] | 0, 1);") bform <- bf(y ~ eta, nl = TRUE) + lf(eta ~ x, center = TRUE) scode <- stancode(bform, data = dat) expect_match2(scode, "nlp_eta += Intercept_eta + Xc_eta * b_eta;") }) test_that("to_vector() is correctly removed from prior of SD parameters", { # see https://discourse.mc-stan.org/t/prior-for-sd-generate-parsing-text-error/12292/5 dat <- data.frame( y = rnorm(100), ID = 1:10, group = rep(1:2, each = 5) ) bform <- bf( y ~ 1 + (1 | p | gr(ID, by=group)), sigma ~ 1 + (1 | p | gr(ID, by=group)) ) bprior <- c( prior(normal(0, 0.1), class = sd) , prior(normal(0, 0.01), class = sd, dpar = sigma) ) scode <- stancode( bform, data = dat, prior = bprior, sample_prior = TRUE ) expect_match2(scode, "prior_sd_1__1 = normal_rng(0,0.1);") expect_match2(scode, "prior_sd_1__2 = normal_rng(0,0.01);") }) test_that("Dirichlet priors can be flexibly included", { # tests issue #1165 dat <- data.frame(y = rnorm(10), x1 = rnorm(10), x2 = rnorm(10)) bprior <- prior("dirichlet([1,2]')", class = "b") scode <- stancode(y ~ x1 + x2, dat, prior = bprior) expect_match2(scode, "simplex[Kc] b;") }) test_that("threaded Stan code is correct", { # tests require cmdstanr which is not yet on CRAN skip_on_cran() # only run if cmdstan >= 2.29 can be found on the system # otherwise the canonicalized code will cause test failures # TODO: switch to testing with rstan? cmdstan_version <- try(cmdstanr::cmdstan_version(), silent = TRUE) found_cmdstan <- !brms:::is_try_error(cmdstan_version) skip_if_not(found_cmdstan && cmdstan_version >= "2.29.0") options(brms.backend = "cmdstanr") dat <- data.frame( count = rpois(236, lambda = 20), visit = rep(1:4, each = 59), patient = factor(rep(1:59, 4)), Age = rnorm(236), Trt = factor(sample(0:1, 236, TRUE)), AgeSD = abs(rnorm(236, 1)), Exp = sample(1:5, 236, TRUE), volume = rnorm(236), gender = factor(c(rep("m", 30), rep("f", 29))) ) threads <- threading(2, grainsize = 20) bform <- bf( count ~ Trt*Age + mo(Exp) + s(Age) + offset(Age) + (1+Trt|visit), sigma ~ Trt + gp(Age) + gp(volume, by = Trt) ) scode <- stancode(bform, dat, family = student(), threads = threads) expect_match2(scode, "real partial_log_lik_lpmf(array[] int seq, int start,") expect_match2(scode, "mu[n] += (bsp[1]) * mo(simo_1, Xmo_1[nn])") expect_match2(scode, "ptarget += student_t_lpdf(Y[start:end] | nu, mu, sigma);") expect_match2(scode, "+ gp_pred_sigma_1[Jgp_sigma_1[start:end]]") expect_match2(scode, ".* gp_pred_sigma_2_1[Jgp_sigma_2_1[which_gp_sigma_2_1]];") expect_match2(scode, "sigma[start_at_one(Igp_sigma_2_2[which_gp_sigma_2_2], start)] +=") expect_match2(scode, "target += reduce_sum(partial_log_lik_lpmf, seq, grainsize, Y,") scode <- stancode( visit ~ cs(Trt) + Age, dat, family = sratio(), threads = threads, ) expect_match2(scode, "matrix[N, nthres] mucs = Xcs[start:end] * bcs;") expect_match2(scode, "ptarget += sratio_logit_lpmf(Y[nn] | mu[n], disc, Intercept") expect_match2(scode, " - transpose(mucs[n]));") scode <- stancode( bf(visit ~ a * Trt ^ b, a ~ mo(Exp), b ~ s(Age), nl = TRUE), data = dat, family = Gamma("log"), prior = set_prior("normal(0, 1)", nlpar = c("a", "b")), threads = threads ) expect_match2(scode, "mu[n] = exp(nlp_a[n] * C_1[nn] ^ nlp_b[n]);") expect_match2(scode, "ptarget += gamma_lpdf(Y[start:end] | shape, shape ./ mu);") bform <- bf(mvbind(count, Exp) ~ Trt) + set_rescor(TRUE) scode <- stancode(bform, dat, gaussian(), threads = threads) expect_match2(scode, "ptarget += multi_normal_cholesky_lpdf(Y[start:end] | Mu, LSigma);") bform <- bf(brms::mvbind(count, Exp) ~ Trt) + set_rescor(FALSE) scode <- stancode(bform, dat, gaussian(), threads = threads) expect_match2(scode, "target += reduce_sum(partial_log_lik_count_lpmf, seq_count,") expect_match2(scode, "target += reduce_sum(partial_log_lik_Exp_lpmf, seq_Exp,") expect_match2(scode, "ptarget += normal_id_glm_lpdf(Y_Exp[start:end] | Xc_Exp[start:end], Intercept_Exp, b_Exp, sigma_Exp);" ) scode <- stancode( visit ~ Trt, dat, family = mixture(poisson(), nmix = 2), threads = threading(4, grainsize = 10, static = TRUE) ) expect_match2(scode, "ps[1] = log(theta1) + poisson_log_lpmf(Y[nn] | mu1[n]);") expect_match2(scode, "ptarget += log_sum_exp(ps);") expect_match2(scode, "target += reduce_sum_static(partial_log_lik_lpmf,") # test that code related to censoring is correct scode <- stancode( count | cens(Trt) ~ Age, dat, family = lognormal(), threads = threading(4) ) expect_match2(scode, "else if (cens[nn] == 1) {") expect_match2(scode, "Jrcens[Nrcens] = n;") expect_match2(scode, "ptarget += lognormal_lcdf(Y[add_int(Jlcens[1:Nlcens], start - 1)] | mu[Jlcens[1:Nlcens]], sigma);" ) }) test_that("Un-normalized Stan code is correct", { # tests require cmdstanr which is not yet on CRAN skip_on_cran() # only run if cmdstan >= 2.29 can be found on the system # otherwise the canonicalized code will cause test failures cmdstan_version <- try(cmdstanr::cmdstan_version(), silent = TRUE) found_cmdstan <- !brms:::is_try_error(cmdstan_version) skip_if_not(found_cmdstan && cmdstan_version >= "2.29.0") options(brms.backend = "cmdstanr") scode <- stancode( count ~ zAge + zBase * Trt + (1|patient) + (1|obs), data = epilepsy, family = poisson(), prior = prior(student_t(5,0,10), class = b) + prior(cauchy(0,2), class = sd), normalize = FALSE ) expect_match2(scode, "target += poisson_log_glm_lupmf(Y | Xc, mu, b);") expect_match2(scode, "lprior += student_t_lupdf(b | 5, 0, 10);") expect_match2(scode, "lprior += student_t_lupdf(Intercept | 3, 1.4, 2.5);") expect_match2(scode, "lprior += cauchy_lupdf(sd_1 | 0, 2);") expect_match2(scode, "target += std_normal_lupdf(z_1[1]);") scode <- stancode( count ~ zAge + zBase * Trt + (1|patient) + (1|obs), data = epilepsy, family = poisson(), prior = prior(student_t(5,0,10), class = b) + prior(cauchy(0,2), class = sd), normalize = FALSE, threads = threading(2) ) expect_match2(scode, "target += reduce_sum(partial_log_lik_lpmf, seq, grainsize, Y, Xc, b,") expect_match2(scode, "Intercept, J_1, Z_1_1, r_1_1, J_2, Z_2_1, r_2_1);") expect_match2(scode, "ptarget += poisson_log_glm_lupmf(Y[start:end] | Xc[start:end], mu, b);") expect_match2(scode, "lprior += student_t_lupdf(b | 5, 0, 10);") expect_match2(scode, "lprior += student_t_lupdf(Intercept | 3, 1.4, 2.5);") expect_match2(scode, "lprior += cauchy_lupdf(sd_1 | 0, 2);") expect_match2(scode, "target += std_normal_lupdf(z_1[1]);") # Check that brms custom distributions stay normalized scode <- stancode( rating ~ period + carry + cs(treat), data = inhaler, family = sratio("cloglog"), normalize = FALSE ) expect_match2(scode, "target += sratio_cloglog_lpmf(Y[n] | mu[n], disc, Intercept") expect_match2(scode, "- transpose(mucs[n]));") # Check that user-specified custom distributions stay normalized dat <- data.frame(size = 10, y = sample(0:10, 20, TRUE), x = rnorm(20)) beta_binomial2 <- custom_family( "beta_binomial2", dpars = c("mu", "tau"), links = c("logit", "log"), lb = c(NA, 0), type = "int", vars = c("vint1[n]", "vreal1[n]"), ) stan_funs <- " real beta_binomial2_lpmf(int y, real mu, real phi, int N, real R) { return beta_binomial_lpmf(y | N, mu * phi, (1 - mu) * phi); } " stanvars <- stanvar(scode = stan_funs, block = "functions") scode <- stancode( y | vint(size) + vreal(size) ~ x, data = dat, family = beta_binomial2, prior = prior(gamma(0.1, 0.1), class = "tau"), stanvars = stanvars, normalize = FALSE, ) expect_match2(scode, "target += beta_binomial2_lpmf(Y[n] | mu[n], tau, vint1[n], vreal1[n]);") expect_match2(scode, "gamma_lupdf(tau | 0.1, 0.1);") }) # the new array syntax is now used throughout brms # test_that("Canonicalizing Stan code is correct", { # # tests require cmdstanr which is not yet on CRAN # skip_on_cran() # # # only run if cmdstan >= 2.29 can be found on the system # # otherwise the canonicalized code will cause test failures # cmdstan_version <- try(cmdstanr::cmdstan_version(), silent = TRUE) # found_cmdstan <- !is_try_error(cmdstan_version) # skip_if_not(found_cmdstan && cmdstan_version >= "2.29.0") # options(brms.backend = "cmdstanr") # # scode <- stancode( # count ~ zAge + zBase * Trt + (1|patient) + (1|obs), # data = epilepsy, family = poisson(), # prior = prior(student_t(5,0,10), class = b) + # prior(cauchy(0,2), class = sd), # normalize = FALSE # ) # expect_match2(scode, "array[M_1] vector[N_1] z_1;") # expect_match2(scode, "array[M_2] vector[N_2] z_2;") # # model <- " # data { # int a[5]; # real b[5]; # vector[5] c[4]; # } # parameters { # real d[5]; # vector[5] e[4]; # } # " # stan_file <- cmdstanr::write_stan_file(model) # canonicalized_code <- .canonicalize_stan_model(stan_file, overwrite_file = FALSE) # expect_match2(canonicalized_code, "array[5] int a;") # expect_match2(canonicalized_code, "array[5] real b;") # expect_match2(canonicalized_code, "array[4] vector[5] c;") # expect_match2(canonicalized_code, "array[5] real d;") # expect_match2(canonicalized_code, "array[4] vector[5] e;") # }) test_that("Normalizing Stan code works correctly", { normalize_stancode <- brms:::normalize_stancode expect_equal( normalize_stancode("// a\nb;\n b + c = 4; // kde\ndata"), normalize_stancode("// dasflkjldl\n // adsfadsfa\n b;\n\n \n \t\rb + c = 4;\ndata") ) expect_equal( normalize_stancode("data /* adfa */ {\nint a;\n /* asdddede \n asdfas \n asf */}\n"), normalize_stancode("data {\nint a;\n} /* aa \n adfasdf \n asdfadsf ddd */\n") ) expect_equal( normalize_stancode("data \n {\nint a;\n\n } \t\n"), normalize_stancode("data {\nint a;\n} \n") ) expect_equal( normalize_stancode("/* \n\n */\na*/"), normalize_stancode("a*/") ) expect_equal( normalize_stancode("//adsfadf \ra // asdfasdf\r\n"), normalize_stancode("a") ) expect_equal( normalize_stancode("/* * \n * \n * fg / */hhh"), normalize_stancode("hhh") ) expect_equal( normalize_stancode("a //b"), normalize_stancode("a") ) expect_false(normalize_stancode("// a\ndata {\nint a;\n}\n") == normalize_stancode("// a\ndata {\nint b;\n}\n")) # should not remove single whitespace expect_false(normalize_stancode("da ta") == normalize_stancode("data")) # should handle wrong nested comments expect_false(normalize_stancode("/* \n\n */\na*/") == normalize_stancode("b*/")) }) test_that("Grouping prior weights are added to the Stan code", { # Check for a single grouping variable, varying intercept only wtd_epilepsy <- epilepsy patient_weights <- c(1, rep(c(0.9, 1.1), each = 29)) wtd_epilepsy[['patient_samp_wgt']] <- patient_weights[match(epilepsy$patient, levels(epilepsy$patient))] scode <- stancode( count ~ Trt + (1 + Trt | gr(patient, pw = patient_samp_wgt)), data = wtd_epilepsy, family = gaussian() ) expect_match2(scode, "vector[N_1] PW_1; // weights for group contribution to the prior") expect_match2(scode, "target += PW_1[j] * std_normal_lpdf(z_1[, j]);") # Check for multiple grouping variables, varying intercept and slope wtd_epilepsy[['random_group']] <- rep(4:1, times = 59) wtd_epilepsy[['random_group_wgt']] <- rep(c(0.8, 1.2, 0.7, 1.3), times = 59) scode <- stancode( count ~ Trt + (1 + Trt | gr(patient, pw = patient_samp_wgt)) + (1 | gr(random_group, pw = random_group_wgt)), data = wtd_epilepsy, family = gaussian() ) expect_match2(scode, "vector[N_2] PW_2; // weights for group contribution to the prior") expect_match2(scode, "target += PW_1[j] * std_normal_lpdf(z_1[, j]);") expect_match2(scode, "target += PW_2[j] * std_normal_lpdf(z_2[1, j]);") # Check for multivariate model dat <- data.frame( y1 = rnorm(10), y2 = rnorm(10), x = 1:10, g1 = rep(1:2, each = 5), g1wgt = rep(c(0.9, 1.1), each = 5), g2 = c(rep(1:4, each = 2), 1:2), g2wgt = c(rep(9:12, each = 2), 9:10), censi = sample(0:1, 10, TRUE) ) # models with residual correlations form <- bf(mvbind(y1, y2) ~ x + (1 | gr(g1, pw = g1wgt)) + (1 | gr(g2, pw = g2wgt))) + set_rescor(TRUE) prior <- prior(horseshoe(2), resp = "y1") + prior(horseshoe(2), resp = "y2") scode <- stancode(form, dat, prior = prior) expect_match2(scode, "vector[N_4] PW_4; // weights for group contribution to the prior") expect_match2(scode, "target += PW_4[j] * std_normal_lpdf(z_4[1, j]);") # multi-membership model scode <- stancode(y1 ~ x + (x | mm(g1, g2, pw = g2wgt)), data = dat) expect_match2(scode, "vector[N_1] PW_1; // weights for group contribution to the prior") expect_match2(scode, "target += PW_1[j] * std_normal_lpdf(z_1[, j]);") }) brms/tests/testthat/tests.brmsfit-methods.R0000644000176200001440000010557715053254244020635 0ustar liggesuserscontext("Tests for brmsfit methods") # to reduce testing time on CRAN substantially skip_on_cran() expect_range <- function(object, lower = -Inf, upper = Inf, ...) { testthat::expect_true(all(object >= lower & object <= upper), ...) } expect_ggplot <- function(object, ...) { testthat::expect_true(is(object, "ggplot"), ...) } SM <- suppressMessages SW <- suppressWarnings fit1 <- rename_pars(brms:::brmsfit_example1) fit2 <- rename_pars(brms:::brmsfit_example2) fit3 <- rename_pars(brms:::brmsfit_example3) fit4 <- rename_pars(brms:::brmsfit_example4) fit5 <- rename_pars(brms:::brmsfit_example5) fit6 <- rename_pars(brms:::brmsfit_example6) # some high level info about the data sets nobs <- 40 npatients <- 10 nsubjects <- 8 nvisits <- 4 # test S3 methods in alphabetical order test_that("as_draws and friends have resonable outputs", { draws <- as_draws(fit1, variable = "b_Intercept") expect_s3_class(draws, "draws_list") expect_equal(variables(draws), "b_Intercept") expect_equal(ndraws(draws), ndraws(fit1)) draws <- SM(as_draws_matrix(fit1)) expect_s3_class(draws, "draws_matrix") expect_equal(ndraws(draws), ndraws(fit1)) draws <- as_draws_array(fit2) expect_s3_class(draws, "draws_array") expect_equal(niterations(draws), ndraws(fit2)) draws <- as_draws_df(fit2, variable = "^b_", regex = TRUE) expect_s3_class(draws, "draws_df") expect_true(all(grepl("^b_", variables(draws)))) draws <- as_draws_list(fit2) expect_s3_class(draws, "draws_list") expect_equal(nchains(draws), nchains(fit2)) draws <- as_draws_rvars(fit3) expect_s3_class(draws, "draws_rvars") expect_equal(ndraws(draws), ndraws(fit3)) expect_true(length(variables(draws)) > 0) }) test_that("as.data.frame has reasonable ouputs", { draws <- as.data.frame(fit1) expect_true(is(draws, "data.frame")) expect_equal(dim(draws), c(ndraws(fit1), length(variables(fit1)))) # deprecated 'pars' argument still works expect_warning( draws <- as.data.frame(fit1, pars = "^b_"), "'pars' is deprecated" ) expect_s3_class(draws, "data.frame") expect_true(ncol(draws) > 0) # deprecated 'subset' argument still works expect_warning( draws <- as.data.frame(fit1, subset = 10:20), "'subset' is deprecated" ) expect_s3_class(draws, "data.frame") expect_equal(nrow(draws), 11) }) test_that("as.matrix has reasonable ouputs", { draws <- as.matrix(fit1, iteration = 1:10) expect_true(is(draws, "matrix")) expect_equal(dim(draws), c(10, length(variables(fit1)))) }) test_that("as.array has reasonable ouputs", { draws <- as.array(fit1) expect_true(is.array(draws)) chains <- fit1$fit@sim$chains ps_dim <- c(niterations(fit1), chains, length(variables(fit1))) expect_equal(dim(draws), ps_dim) draws <- as.array(fit1, chain = 1) expect_true(is.array(draws)) ps_dim <- c(niterations(fit1), 1, length(variables(fit1))) expect_equal(dim(draws), ps_dim) }) test_that("as.mcmc has reasonable ouputs", { chains <- fit1$fit@sim$chains mc <- SW(as.mcmc(fit1)) expect_equal(length(mc), chains) expect_equal(dim(mc[[1]]), c(ndraws(fit1) / chains, length(variables(fit1)))) mc <- SW(as.mcmc(fit1, combine_chains = TRUE)) expect_equal(dim(mc), c(ndraws(fit1), length(variables(fit1)))) # test assumes thin = 1 expect_equal(dim(SW(as.mcmc(fit1, inc_warmup = TRUE)[[1]])), c(fit1$fit@sim$iter, length(variables(fit1)))) }) test_that("autocor has reasonable ouputs", { expect_true(is.null(SW(autocor(fit1)))) expect_true(is.null(SW(autocor(fit6, resp = "count")))) }) test_that("bayes_R2 has reasonable ouputs", { fit1 <- add_criterion(fit1, "bayes_R2") R2 <- bayes_R2(fit1, summary = FALSE) expect_equal(dim(R2), c(ndraws(fit1), 1)) R2 <- bayes_R2(fit2, newdata = model.frame(fit2)[1:5, ], re_formula = NA) expect_equal(dim(R2), c(1, 4)) R2 <- bayes_R2(fit6) expect_equal(dim(R2), c(2, 4)) }) test_that("bayes_factor has reasonable ouputs", { # don't test for now as it requires calling Stan's C++ code }) test_that("bridge_sampler has reasonable ouputs", { # don't test for now as it requires calling Stan's C++ code }) test_that("coef has reasonable ouputs", { coef1 <- SM(coef(fit1)) expect_equal(dim(coef1$visit), c(4, 4, 9)) coef1 <- SM(coef(fit1, summary = FALSE)) expect_equal(dim(coef1$visit), c(ndraws(fit1), 4, 9)) coef2 <- SM(coef(fit2)) expect_equal(dim(coef2$patient), c(npatients, 4, 4)) coef4 <- SM(coef(fit4)) expect_equal(dim(coef4$subject), c(nsubjects, 4, 8)) }) test_that("combine_models has reasonable ouputs", { expect_equal(ndraws(combine_models(fit1, fit1)), ndraws(fit1) * 2) }) test_that("conditional_effects has reasonable ouputs", { me <- conditional_effects(fit1, resp = "count") expect_equal(nrow(me[[2]]), 100) meplot <- plot(me, points = TRUE, rug = TRUE, ask = FALSE, plot = FALSE) expect_ggplot(meplot[[1]]) me <- conditional_effects(fit1, "Trt", select_points = 0.1) expect_lt(nrow(attr(me[[1]], "points")), nobs(fit1)) me <- conditional_effects(fit1, "volume:Age", surface = TRUE, resolution = 15, too_far = 0.2) meplot <- plot(me, plot = FALSE) expect_ggplot(meplot[[1]]) meplot <- plot(me, stype = "raster", plot = FALSE) expect_ggplot(meplot[[1]]) me <- conditional_effects(fit1, "Age", spaghetti = TRUE, ndraws = 10) expect_equal(nrow(attr(me$Age, "spaghetti")), 1000) meplot <- plot(me, plot = FALSE) expect_ggplot(meplot[[1]]) expect_error( conditional_effects(fit1, "Age", spaghetti = TRUE, surface = TRUE), "Cannot use 'spaghetti' and 'surface' at the same time" ) me <- conditional_effects(fit1, effects = c("Age", "Age:visit"), re_formula = NULL) expect_equal(nrow(me[[1]]), 100) exp_nrow <- 100 * length(unique(fit1$data$visit)) expect_equal(nrow(me[[2]]), exp_nrow) mdata = data.frame( Age = c(-0.3, 0, 0.3), count = c(10, 20, 30), Exp = c(1, 3, 5) ) exp_nrow <- nrow(mdata) * 100 me <- conditional_effects(fit1, effects = "Age", conditions = mdata) expect_equal(nrow(me[[1]]), exp_nrow) mdata$visit <- 1:3 me <- conditional_effects(fit1, re_formula = NULL, conditions = mdata) expect_equal(nrow(me$Age), exp_nrow) me <- conditional_effects( fit1, "Age:Trt", int_conditions = list(Age = rnorm(5)) ) expect_equal(nrow(me[[1]]), 10) me <- conditional_effects( fit1, "Age:Trt", int_conditions = list(Age = quantile) ) expect_equal(nrow(me[[1]]), 10) expect_error(conditional_effects(fit1, effects = "Trtc"), "All specified effects are invalid for this model") expect_warning(conditional_effects(fit1, effects = c("Trtc", "Trt")), "Some specified effects are invalid for this model") expect_error(conditional_effects(fit1, effects = "Trtc:a:b"), "please use the 'conditions' argument") mdata$visit <- NULL mdata$Exp <- NULL mdata$patient <- 1 expect_equal(nrow(conditional_effects(fit2)[[2]]), 100) me <- conditional_effects(fit2, re_formula = NULL, conditions = mdata) expect_equal(nrow(me$Age), exp_nrow) expect_warning( me4 <- conditional_effects(fit4), "Predictions are treated as continuous variables" ) expect_true(is(me4, "brms_conditional_effects")) me4 <- conditional_effects(fit4, "x2", categorical = TRUE) expect_true(is(me4, "brms_conditional_effects")) me5 <- conditional_effects(fit5) expect_true(is(me5, "brms_conditional_effects")) me6 <- conditional_effects(fit6, ndraws = 20) expect_true(is(me6, "brms_conditional_effects")) }) test_that("plot of conditional_effects has reasonable outputs", { SW(ggplot2::theme_set(theme_black())) N <- 90 marg_results <- data.frame( effect1__ = rpois(N, 20), effect2__ = factor(rep(1:3, each = N / 3)), estimate__ = rnorm(N, sd = 5), se__ = rt(N, df = 10), cond__ = rep(1:2, each = N / 2), cats__ = factor(rep(1:3, each = N / 3)) ) marg_results[["lower__"]] <- marg_results$estimate__ - 2 marg_results[["upper__"]] <- marg_results$estimate__ + 2 marg_results <- list(marg_results[order(marg_results$effect1__), ]) class(marg_results) <- "brms_conditional_effects" attr(marg_results[[1]], "response") <- "count" # test with 1 numeric predictor attr(marg_results[[1]], "effects") <- "P1" marg_plot <- plot(marg_results, plot = FALSE) expect_ggplot(marg_plot[[1]]) # test with 1 categorical predictor attr(marg_results[[1]], "effects") <- "P2" marg_plot <- plot(marg_results, plot = FALSE) expect_ggplot(marg_plot[[1]]) # test with 1 numeric and 1 categorical predictor attr(marg_results[[1]], "effects") <- c("P1", "P2") marg_plot <- plot(marg_results, plot = FALSE) expect_ggplot(marg_plot[[1]]) # test ordinal raster plot attr(marg_results[[1]], "effects") <- c("P1", "cats__") attr(marg_results[[1]], "ordinal") <- TRUE marg_plot <- plot(marg_results, plot = FALSE) expect_ggplot(marg_plot[[1]]) }) test_that("conditional_smooths has reasonable ouputs", { ms <- conditional_smooths(fit1) expect_equal(nrow(ms[[1]]), 100) expect_true(is(ms, "brms_conditional_effects")) ms <- conditional_smooths(fit1, spaghetti = TRUE, ndraws = 10) expect_equal(nrow(attr(ms[[1]], "spaghetti")), 1000) expect_error(conditional_smooths(fit1, smooths = "s3"), "No valid smooth terms found in the model") expect_error(conditional_smooths(fit2), "No valid smooth terms found in the model") }) test_that("family has reasonable ouputs", { expect_is(family(fit1), "brmsfamily") expect_is(family(fit6, resp = "count"), "brmsfamily") expect_output(print(family(fit1), links = TRUE), "student.*log.*logm1") expect_output(print(family(fit5)), "Mixture.*gaussian.*exponential") }) test_that("fitted has reasonable outputs", { skip_on_cran() fi <- fitted(fit1) expect_equal(dim(fi), c(nobs(fit1), 4)) expect_equal(colnames(fi), c("Estimate", "Est.Error", "Q2.5", "Q97.5")) newdata <- data.frame( Age = c(0, -0.2), visit = c(1, 4), Trt = c(0, 1), count = c(20, 13), patient = c(1, 42), Exp = c(2, 4), volume = 0 ) fi <- fitted(fit1, newdata = newdata) expect_equal(dim(fi), c(2, 4)) newdata$visit <- c(1, 6) fi <- fitted(fit1, newdata = newdata, allow_new_levels = TRUE) expect_equal(dim(fi), c(2, 4)) # fitted values with new_levels newdata <- data.frame( Age = 0, visit = paste0("a", 1:100), Trt = 0, count = 20, patient = 1, Exp = 2, volume = 0 ) fi <- fitted(fit1, newdata = newdata, allow_new_levels = TRUE, sample_new_levels = "old_levels", ndraws = 10) expect_equal(dim(fi), c(100, 4)) fi <- fitted(fit1, newdata = newdata, allow_new_levels = TRUE, sample_new_levels = "gaussian", ndraws = 1) expect_equal(dim(fi), c(100, 4)) # fitted values of auxiliary parameters newdata <- data.frame( Age = 0, visit = c("a", "b"), Trt = 0, count = 20, patient = 1, Exp = 2, volume = 0 ) fi <- fitted(fit1, dpar = "sigma") expect_equal(dim(fi), c(nobs(fit1), 4)) expect_true(all(fi > 0)) fi_lin <- fitted(fit1, dpar = "sigma", scale = "linear") expect_equal(dim(fi_lin), c(nobs(fit1), 4)) expect_true(!isTRUE(all.equal(fi, fi_lin))) expect_error(fitted(fit1, dpar = "inv"), "Invalid argument 'dpar'") fi <- fitted(fit2) expect_equal(dim(fi), c(nobs(fit2), 4)) fi <- fitted(fit2, newdata = newdata, allow_new_levels = TRUE) expect_equal(dim(fi), c(2, 4)) fi <- fitted(fit2, dpar = "shape") expect_equal(dim(fi), c(nobs(fit2), 4)) expect_equal(fi[1, ], fi[2, ]) fi <- fitted(fit2, nlpar = "a") expect_equal(dim(fi), c(nobs(fit2), 4)) fi <- fitted(fit3, newdata = fit3$data[1:10, ]) expect_equal(dim(fi), c(10, 4)) fi <- fitted(fit4) expect_equal(dim(fi), c(nobs(fit4), 4, 4)) fi <- fitted(fit4, newdata = fit4$data[1, ]) expect_equal(dim(fi), c(1, 4, 4)) fi <- fitted(fit4, newdata = fit4$data[1, ], scale = "linear") expect_equal(dim(fi), c(1, 4, 3)) fi <- fitted(fit5) expect_equal(dim(fi), c(nobs(fit5), 4)) fi <- fitted(fit6) expect_equal(dim(fi), c(nobs(fit6), 4, 2)) expect_equal(dimnames(fi)[[3]], c("volume", "count")) }) test_that("fixef has reasonable ouputs", { fixef1 <- SM(fixef(fit1)) expect_equal(rownames(fixef1), c("Intercept", "sigma_Intercept", "Trt1", "Age", "volume", "Trt1:Age", "sigma_Trt1", "sAge_1", "moExp") ) fixef1 <- SM(fixef(fit1, pars = c("Age", "sAge_1"))) expect_equal(rownames(fixef1), c("Age", "sAge_1")) }) test_that("formula has reasonable ouputs", { expect_true(is.brmsformula(formula(fit1))) }) test_that("inits has reasonable ouputs", { # rstan backend inits1 <- inits(fit1) expect_type(inits1, "list") expect_length(inits1, nchains(fit1)) inits2 <- inits(fit2) expect_type(inits2, "list") expect_length(inits2, nchains(fit2)) }) test_that("hypothesis has reasonable ouputs", { hyp <- hypothesis(fit1, c("Age > Trt1", "Trt1:Age = -1")) expect_equal(dim(hyp$hypothesis), c(2, 8)) expect_output(print(hyp), "(Age)-(Trt1) > 0", fixed = TRUE) expect_ggplot(plot(hyp, plot = FALSE)[[1]]) hyp <- hypothesis(fit1, "Intercept = 0", class = "sd", group = "visit") expect_true(is.numeric(hyp$hypothesis$Evid.Ratio[1])) expect_output(print(hyp), "class sd_visit:", fixed = TRUE) expect_ggplot(plot(hyp, ignore_prior = TRUE, plot = FALSE)[[1]]) hyp <- hypothesis(fit1, "0 > r_visit[4,Intercept]", class = "", alpha = 0.01) expect_equal(dim(hyp$hypothesis), c(1, 8)) expect_output(print(hyp, chars = NULL), "r_visit[4,Intercept]", fixed = TRUE) expect_output(print(hyp), "99%-CI", fixed = TRUE) hyp <- hypothesis( fit1, c("Intercept = 0", "Intercept + exp(Trt1) = 0"), group = "visit", scope = "coef" ) expect_equal(dim(hyp$hypothesis), c(8, 9)) expect_equal(hyp$hypothesis$Group[1], factor(1, levels = 1:4)) expect_error(hypothesis(fit1, "Intercept > x"), fixed = TRUE, "cannot be found in the model: \n'b_x'") expect_error(hypothesis(fit1, 1), "Argument 'hypothesis' must be a character vector") expect_error(hypothesis(fit2, "b_Age = 0", alpha = 2), "Argument 'alpha' must be a single value in [0,1]", fixed = TRUE) expect_error(hypothesis(fit3, "b_Age x 0"), "Every hypothesis must be of the form 'left (= OR < OR >) right'", fixed = TRUE) # test hypothesis.default method hyp <- hypothesis(as.data.frame(fit3), "bsp_meAgeAgeSD > sigma") expect_equal(dim(hyp$hypothesis), c(1, 8)) hyp <- hypothesis(fit3$fit, "bsp_meAgeAgeSD > sigma") expect_equal(dim(hyp$hypothesis), c(1, 8)) }) test_that("launch_shinystan has reasonable ouputs", { # requires running shiny which is not reasonable in automated tests }) test_that("log_lik has reasonable ouputs", { expect_equal(dim(log_lik(fit1)), c(ndraws(fit1), nobs(fit1))) expect_equal(dim(logLik(fit1)), c(ndraws(fit1), nobs(fit1))) expect_equal(dim(log_lik(fit2)), c(ndraws(fit2), nobs(fit2))) }) test_that("loo has reasonable outputs", { skip_on_cran() loo1 <- SW(LOO(fit1, cores = 1)) expect_true(is.numeric(loo1$estimates)) expect_output(print(loo1), "looic") loo_compare1 <- SW(loo(fit1, fit1, cores = 1)) expect_equal(names(loo_compare1$loos), c("fit1", "fit1")) expect_equal(dim(loo_compare1$ic_diffs__), c(1, 2)) expect_output(print(loo_compare1), "'fit1':") expect_is(loo_compare1$diffs, "compare.loo") loo2 <- SW(loo(fit2, cores = 1)) expect_true(is.numeric(loo2$estimates)) loo3 <- SW(loo(fit3, cores = 1)) expect_true(is.numeric(loo3$estimates)) loo3 <- SW(loo(fit3, pointwise = TRUE, cores = 1)) expect_true(is.numeric(loo3$estimates)) loo4 <- SW(loo(fit4, cores = 1)) expect_true(is.numeric(loo4$estimates)) # fails because of too small effective sample size # loo5 <- SW(loo(fit5, cores = 1)) # expect_true(is.numeric(loo5$estimates)) loo6_1 <- SW(loo(fit6, cores = 1)) expect_true(is.numeric(loo6_1$estimates)) loo6_2 <- SW(loo(fit6, cores = 1, newdata = fit6$data)) expect_true(is.numeric(loo6_2$estimates)) loo_compare <- loo_compare(loo6_1, loo6_2) expect_range(loo_compare[2, 1], -1, 1) }) test_that("loo_subsample has reasonable outputs", { skip_on_cran() loo2 <- SW(loo_subsample(fit2, observations = 30)) expect_true(is.numeric(loo2$estimates)) expect_equal(nrow(loo2$pointwise), 30) expect_output(print(loo2), "looic") }) test_that("loo_R2 has reasonable outputs", { skip_on_cran() R2 <- SW(loo_R2(fit1)) expect_equal(dim(R2), c(1, 4)) R2 <- SW(loo_R2(fit2, summary = FALSE)) expect_equal(dim(R2), c(ndraws(fit1), 1)) }) test_that("loo_epred has reasonable outputs", { skip_on_cran() llp <- SW(loo_epred(fit1)) expect_equal(nrow(llp), nobs(fit1)) newdata <- data.frame( Age = 0, visit = c("a", "b"), Trt = 0, count = 20, patient = 1, Exp = 2, volume = 0 ) llp <- SW(loo_epred( fit1, newdata = newdata, type = "quantile", probs = c(0.25, 0.75), allow_new_levels = TRUE )) expect_equal(dim(llp), c(nrow(newdata), 2)) llp <- SW(loo_epred(fit4)) expect_equal(nrow(llp), nobs(fit4)) expect_equal(dim(llp)[3], 4) }) test_that("loo_linpred has reasonable outputs", { skip_on_cran() llp <- SW(loo_linpred(fit1)) expect_equal(nrow(llp), nobs(fit1)) llp <- SW(loo_linpred(fit4)) expect_equal(nrow(llp), nobs(fit4)) expect_equal(dim(llp)[3], 3) llp <- SW(loo_linpred(fit2, scale = "response", type = "var")) expect_equal(nrow(llp), nobs(fit2)) }) test_that("loo_predict has reasonable outputs", { skip_on_cran() llp <- SW(loo_predict(fit1)) expect_equal(nrow(llp), nobs(fit1)) newdata <- data.frame( Age = 0, visit = c("a", "b"), Trt = 0, count = 20, patient = 1, Exp = 2, volume = 0 ) llp <- SW(loo_predict( fit1, newdata = newdata, type = "quantile", probs = c(0.25, 0.75), allow_new_levels = TRUE )) expect_equal(dim(llp), c(nrow(newdata), 2)) llp <- SW(loo_predict(fit4)) expect_equal(nrow(llp), nobs(fit4)) expect_equal(length(dim(llp)), 2) }) test_that("loo_predictive_interval has reasonable outputs", { skip_on_cran() llp <- SW(loo_predictive_interval(fit3)) expect_equal(dim(llp), c(nobs(fit3), 2)) }) test_that("loo_model_weights has reasonable outputs", { skip_on_cran() llw <- SW(loo_model_weights(fit1, fit1)) expect_is(llw[1:2], "numeric") expect_equal(names(llw), c("fit1", "fit1")) }) test_that("model.frame has reasonable ouputs", { expect_equal(model.frame(fit1), fit1$data) }) test_that("model_weights has reasonable ouputs", { mw <- model_weights(fit1, fit1, weights = "waic") expect_equal(names(mw), c("fit1", "fit1")) # fails with MKL on CRAN for unknown reasons # expect_equal(mw, setNames(c(0.5, 0.5), c("fit1", "fit1"))) }) test_that("ndraws and friends have reasonable ouputs", { expect_equal(ndraws(fit1), 25) expect_equal(nchains(fit1), 1) expect_equal(niterations(fit1), 25) }) test_that("ngrps has reasonable ouputs", { expect_equal(ngrps(fit1), list(visit = 4)) expect_equal(ngrps(fit2), list(patient = 10)) }) test_that("nobs has reasonable ouputs", { expect_equal(nobs(fit1), nobs) }) test_that("nsamples has reasonable ouputs", { expect_equal(SW(nsamples(fit1)), 25) expect_equal(SW(nsamples(fit1, subset = 10:1)), 10) expect_equal(SW(nsamples(fit1, incl_warmup = TRUE)), 75) }) test_that("pairs has reasonable outputs", { expect_s3_class(SW(pairs(fit1, variable = variables(fit1)[1:3])), "bayesplot_grid") }) test_that("plot has reasonable outputs", { expect_silent(p <- plot(fit1, plot = FALSE)) expect_silent(p <- plot(fit1, variable = "^b", regex = TRUE, plot = FALSE)) expect_silent(p <- plot(fit1, variable = "^sd", regex = TRUE, plot = FALSE)) expect_error(plot(fit1, variable = "123")) }) test_that("post_prob has reasonable ouputs", { # only test error messages for now expect_error(post_prob(fit1, fit2, model_names = "test1"), "Number of model names is not equal to the number of models") }) test_that("posterior_average has reasonable outputs", { pnames <- c("b_Age", "nu") draws <- posterior_average(fit1, fit1, variable = pnames, weights = c(0.3, 0.7)) expect_equal(dim(draws), c(ndraws(fit1), 2)) expect_equal(names(draws), pnames) weights <- rexp(3) draws <- brms:::SW(posterior_average( fit1, fit2, fit3, variable = "nu", weights = rexp(3), missing = 1, ndraws = 10 )) expect_equal(dim(draws), c(10, 1)) expect_equal(names(draws), "nu") }) test_that("posterior_samples has reasonable outputs", { draws <- SW(posterior_samples(fit1)) expect_equal(dim(draws), c(ndraws(fit1), length(variables(fit1)))) expect_equal(names(draws), variables(fit1)) expect_equal(names(SW(posterior_samples(fit1, pars = "^b_"))), c("b_Intercept", "b_sigma_Intercept", "b_Trt1", "b_Age", "b_volume", "b_Trt1:Age", "b_sigma_Trt1")) # test default method draws <- SW(posterior_samples(fit1$fit, "^b_Intercept$")) expect_equal(dim(draws), c(ndraws(fit1), 1)) }) test_that("posterior_summary has reasonable outputs", { draws <- posterior_summary(fit1, variable = "^b_", regex = TRUE) expect_equal(dim(draws), c(7, 4)) }) test_that("posterior_interval has reasonable outputs", { expect_equal(dim(posterior_interval(fit1)), c(length(variables(fit1)), 2)) }) test_that("posterior_predict has reasonable outputs", { expect_equal(dim(posterior_predict(fit1)), c(ndraws(fit1), nobs(fit1))) }) test_that("posterior_linpred has reasonable outputs", { expect_equal(dim(posterior_linpred(fit1)), c(ndraws(fit1), nobs(fit1))) }) test_that("pp_average has reasonable outputs", { ppa <- pp_average(fit1, fit1, weights = "waic") expect_equal(dim(ppa), c(nobs(fit1), 4)) ppa <- pp_average(fit1, fit1, weights = c(1, 4)) expect_equal(attr(ppa, "weights"), c(fit1 = 0.2, fit1 = 0.8)) ns <- c(fit1 = ndraws(fit1) / 5, fit1 = 4 * ndraws(fit1) / 5) expect_equal(attr(ppa, "ndraws"), ns) }) test_that("pp_check has reasonable outputs", { expect_ggplot(pp_check(fit1)) expect_ggplot(pp_check(fit1, newdata = fit1$data[1:10, ])) expect_ggplot(pp_check(fit1, "stat", ndraws = 5)) expect_ggplot(pp_check(fit1, "error_binned")) pp <- pp_check(fit1, "ribbon_grouped", group = "visit", x = "Age") expect_ggplot(pp) pp <- pp_check(fit1, type = "violin_grouped", group = "visit", newdata = fit1$data[1:10, ]) expect_ggplot(pp) pp <- SW(pp_check(fit1, type = "loo_pit_qq", cores = 1)) expect_ggplot(pp) # ppd plots work expect_ggplot(pp_check(fit1, prefix = "ppd")) # reduce test time on CRAN skip_on_cran() expect_ggplot(pp_check(fit3)) expect_ggplot(pp_check(fit2, "ribbon", x = "Age")) expect_error(pp_check(fit2, "ribbon", x = "x"), "Variable 'x' could not be found in the data") expect_error(pp_check(fit1, "wrong_type")) expect_error(pp_check(fit2, "violin_grouped"), "group") expect_error(pp_check(fit1, "stat_grouped", group = "g"), "Variable 'g' could not be found in the data") expect_ggplot(pp_check(fit4)) expect_ggplot(pp_check(fit5)) expect_error(pp_check(fit4, "error_binned"), "Type 'error_binned' is not available") }) test_that("posterior_epred has reasonable outputs", { expect_equal(dim(posterior_epred(fit1)), c(ndraws(fit1), nobs(fit1))) # test that point_estimate produces identical draws pe <- posterior_epred(fit1, point_estimate = "median", ndraws_point_estimate = 2) expect_equal(nrow(pe), 2) expect_true(all(pe[1, ] == pe[2, ])) }) test_that("pp_mixture has reasonable outputs", { expect_equal(dim(pp_mixture(fit5)), c(nobs(fit5), 4, 2)) expect_error(pp_mixture(fit1), "Method 'pp_mixture' can only be applied to mixture models" ) }) test_that("predict has reasonable outputs", { pred <- predict(fit1) expect_equal(dim(pred), c(nobs(fit1), 4)) expect_equal(colnames(pred), c("Estimate", "Est.Error", "Q2.5", "Q97.5")) pred <- predict(fit1, ndraws = 10, probs = c(0.2, 0.5, 0.8)) expect_equal(dim(pred), c(nobs(fit1), 5)) newdata <- data.frame( Age = c(0, -0.2), visit = c(1, 4), Trt = c(1, 0), count = c(2, 10), patient = c(1, 42), Exp = c(1, 2), volume = 0 ) pred <- predict(fit1, newdata = newdata) expect_equal(dim(pred), c(2, 4)) newdata$visit <- c(1, 6) pred <- predict(fit1, newdata = newdata, allow_new_levels = TRUE) expect_equal(dim(pred), c(2, 4)) # predict NA responses in ARMA models df <- fit1$data[1:10, ] df$count[8:10] <- NA pred <- predict(fit1, newdata = df, ndraws = 1) expect_true(!anyNA(pred[, "Estimate"])) pred <- predict(fit2) expect_equal(dim(pred), c(nobs(fit2), 4)) pred <- predict(fit2, newdata = newdata, allow_new_levels = TRUE) expect_equal(dim(pred), c(2, 4)) # check if grouping factors with a single level are accepted newdata$patient <- factor(2) pred <- predict(fit2, newdata = newdata) expect_equal(dim(pred), c(2, 4)) pred <- predict(fit4) expect_equal(dim(pred), c(nobs(fit4), 4)) expect_equal(colnames(pred), paste0("P(Y = ", 1:4, ")")) pred <- predict(fit4, newdata = fit4$data[1, ]) expect_equal(dim(pred), c(1, 4)) pred <- predict(fit5) expect_equal(dim(pred), c(nobs(fit5), 4)) newdata <- fit5$data[1:5, ] newdata$patient <- "a" pred <- predict(fit5, newdata, allow_new_levels = TRUE, sample_new_levels = "old_levels") expect_equal(dim(pred), c(5, 4)) pred <- predict(fit5, newdata, allow_new_levels = TRUE, sample_new_levels = "gaussian") expect_equal(dim(pred), c(5, 4)) }) test_that("predictive_error has reasonable outputs", { expect_equal(dim(predictive_error(fit1)), c(ndraws(fit1), nobs(fit1))) }) test_that("print has reasonable outputs", { expect_output(SW(print(fit1)), "Multilevel Hyperparameters:") }) test_that("prior_draws has reasonable outputs", { prs1 <- prior_draws(fit1) prior_names <- c( "Intercept", "b", paste0("simo_moExp1[", 1:4, "]"), "bsp", "bs", "sds_sAge", "b_sigma", "Intercept_sigma", "nu", "sd_visit", "cor_visit" ) expect_equal(colnames(prs1), prior_names) prs2 <- prior_draws(fit1, variable = "b_Trt1") expect_equal(dimnames(prs2), list(as.character(1:ndraws(fit1)), "b_Trt1")) expect_equal(sort(prs1$b), sort(prs2$b_Trt)) # test default method prs <- prior_draws(fit1$fit, variable = "^sd_visit", regex = TRUE) expect_equal(names(prs), "prior_sd_visit") }) test_that("prior_summary has reasonable outputs", { expect_true(is(prior_summary(fit1), "brmsprior")) }) test_that("ranef has reasonable outputs", { ranef1 <- SM(ranef(fit1)) expect_equal(dim(ranef1$visit), c(nvisits, 4, 2)) ranef1 <- SM(ranef(fit1, pars = "Trt1")) expect_equal(dimnames(ranef1$visit)[[3]], "Trt1") ranef1 <- SM(ranef(fit1, groups = "a")) expect_equal(length(ranef1), 0L) ranef2 <- SM(ranef(fit2, summary = FALSE)) expect_equal(dim(ranef2$patient), c(ndraws(fit2), npatients, 2)) }) test_that("residuals has reasonable outputs", { res1 <- SW(residuals(fit1, type = "pearson", probs = c(0.65))) expect_equal(dim(res1), c(nobs(fit1), 3)) newdata <- cbind(epilepsy[1:10, ], Exp = rep(1:5, 2), volume = 0) res2 <- residuals(fit1, newdata = newdata) expect_equal(dim(res2), c(10, 4)) newdata$visit <- rep(1:5, 2) res3 <- residuals(fit1, newdata = newdata, allow_new_levels = TRUE) expect_equal(dim(res3), c(10, 4)) res4 <- residuals(fit2) expect_equal(dim(res4), c(nobs(fit2), 4)) expect_error(residuals(fit4), "Predictive errors are not defined") res6 <- residuals(fit6) expect_equal(dim(res6), c(nobs(fit6), 4, 2)) expect_equal(dimnames(res6)[[3]], c("volume", "count")) }) test_that("stancode has reasonable outputs", { scode <- stancode(fit1) expect_true(is.character(stancode(fit1))) expect_match(stancode(fit1), "generated quantities") expect_identical(scode, fit1$model) # test that stancode can be updated scode <- stancode(fit2, threads = threading(1)) expect_match(scode, "reduce_sum(partial_log_lik_lpmf,", fixed = TRUE) }) test_that("standata has reasonable outputs", { expect_equal(sort(names(standata(fit1))), sort(c("N", "Y", "Kar", "Kma", "J_lag", "K", "Kc", "X", "Ksp", "Imo", "Xmo_1", "Jmo", "con_simo_1", "Z_1_1", "Z_1_2", "nb_1", "knots_1", "Zs_1_1", "Ks", "Xs", "offsets", "K_sigma", "Kc_sigma", "X_sigma", "J_1", "N_1", "M_1", "NC_1", "prior_only")) ) expect_equal(sort(names(standata(fit2))), sort(c("N", "Y", "weights", "C_1", "K_a", "X_a", "Z_1_a_1", "K_b", "X_b", "Z_1_b_2", "J_1", "N_1", "M_1", "NC_1", "prior_only")) ) }) test_that("mcmc_plot has reasonable outputs", { expect_ggplot(mcmc_plot(fit1)) expect_ggplot(mcmc_plot(fit1, variable = "^b", regex = TRUE)) expect_ggplot(SM(mcmc_plot(fit1, type = "trace", variable = "^b_", regex = TRUE))) expect_ggplot(mcmc_plot(fit1, type = "hist", variable = "^sd_", regex = TRUE)) expect_ggplot(mcmc_plot(fit1, type = "dens")) expect_ggplot(mcmc_plot(fit1, type = "scatter", variable = variables(fit1)[2:3])) expect_ggplot(SW(mcmc_plot(fit1, type = "rhat", variable = "^b_", regex = TRUE))) expect_ggplot(SW(mcmc_plot(fit1, type = "neff"))) expect_ggplot(mcmc_plot(fit1, type = "acf")) expect_silent(p <- mcmc_plot(fit1, type = "nuts_divergence")) expect_error(mcmc_plot(fit1, type = "density"), "Invalid plot type") expect_error(mcmc_plot(fit1, type = "hex"), "Exactly 2 parameters must be selected") }) test_that("summary has reasonable outputs", { summary1 <- SW(summary(fit1, priors = TRUE)) expect_true(is.data.frame(summary1$fixed)) expect_equal(rownames(summary1$fixed), c("Intercept", "sigma_Intercept", "Trt1", "Age", "volume", "Trt1:Age", "sigma_Trt1", "sAge_1", "moExp")) expect_equal(colnames(summary1$fixed), c("Estimate", "Est.Error", "l-95% CI", "u-95% CI", "Rhat", "Bulk_ESS", "Tail_ESS")) expect_equal(rownames(summary1$random$visit), c("sd(Intercept)", "sd(Trt1)", "cor(Intercept,Trt1)")) expect_output(print(summary1), "Regression Coefficients:") expect_output(print(summary1), "Priors:") summary5 <- SW(summary(fit5, robust = TRUE)) expect_output(print(summary5), "sigma1") expect_output(print(summary5), "theta1") summary6 <- SW(summary(fit6)) expect_output(print(summary6), "sdgp") }) test_that("update has reasonable outputs", { # Do not actually refit the model as is causes CRAN checks to fail. # Some tests are commented out as they fail when updating Stan code # of internal example models because of Stan code mismatches. Refitting # these example models is slow especially when done repeatedly and # leads the git repo to blow up eventually due the size of the models. up <- update(fit1, testmode = TRUE) expect_true(is(up, "brmsfit")) new_data <- data.frame( Age = rnorm(18), visit = rep(c(3, 2, 4), 6), Trt = rep(0:1, 9), count = rep(c(5, 17, 28), 6), patient = rep(1:6, each = 3), Exp = 4, volume = 0 ) up <- update(fit1, newdata = new_data, save_pars = save_pars(group = FALSE), testmode = TRUE) expect_true(is(up, "brmsfit")) expect_equal(attr(up$data, "data_name"), "new_data") # expect_equal(attr(up$ranef, "levels")$visit, c("2", "3", "4")) # expect_true("r_1_1" %in% up$exclude) expect_error(update(fit1, data = new_data), "use argument 'newdata'") up <- update(fit1, formula = ~ . + I(exp(Age)), testmode = TRUE, prior = set_prior("normal(0,10)")) expect_true(is(up, "brmsfit")) up <- update(fit1, ~ . - Age + factor(Age), testmode = TRUE) expect_true(is(up, "brmsfit")) up <- update(fit1, formula = ~ . + I(exp(Age)), newdata = new_data, sample_prior = FALSE, testmode = TRUE) expect_true(is(up, "brmsfit")) expect_error(update(fit1, formula. = ~ . + wrong_var), "New variables found: 'wrong_var'") up <- update(fit1, save_pars = save_pars(group = FALSE), testmode = TRUE) expect_true(is(up, "brmsfit")) # expect_true("r_1_1" %in% up$exclude) up <- update(fit3, save_pars = save_pars(latent = FALSE), testmode = TRUE) expect_true(is(up, "brmsfit")) # expect_true("Xme_1" %in% up$exclude) up <- update(fit2, algorithm = "fullrank", testmode = TRUE) expect_true(is(up, "brmsfit")) # expect_equal(up$algorithm, "fullrank") up <- update(fit2, formula. = bf(. ~ ., a + b ~ 1, nl = TRUE), testmode = TRUE) expect_true(is(up, "brmsfit")) up <- update(fit2, formula. = bf(count ~ a + b, nl = TRUE), testmode = TRUE) expect_true(is(up, "brmsfit")) up <- update(fit3, family = acat(), testmode = TRUE) expect_true(is(up, "brmsfit")) up <- update(fit3, bf(~., family = acat()), testmode = TRUE) expect_true(is(up, "brmsfit")) }) test_that("VarCorr has reasonable outputs", { vc <- VarCorr(fit1) expect_equal(names(vc), c("visit")) Names <- c("Intercept", "Trt1") expect_equal(dimnames(vc$visit$cov)[c(1, 3)], list(Names, Names)) vc <- VarCorr(fit2) expect_equal(names(vc), c("patient")) expect_equal(dim(vc$patient$cor), c(2, 4, 2)) vc <- VarCorr(fit2, summary = FALSE) expect_equal(dim(vc$patient$cor), c(ndraws(fit2), 2, 2)) expect_equal(dim(VarCorr(fit6)$residual__$sd), c(1, 4)) vc <- VarCorr(fit5) expect_equal(dim(vc$patient$sd), c(2, 4)) }) test_that("variables has reasonable ouputs", { expect_true(all( c("b_Intercept", "bsp_moExp", "ar[1]", "cor_visit__Intercept__Trt1", "nu", "simo_moExp1[2]", "r_visit[4,Trt1]", "s_sAge_1[8]", "prior_sd_visit", "prior_cor_visit", "lp__") %in% variables(fit1) )) expect_true(all( c("b_a_Intercept", "b_b_Age", "sd_patient__b_Intercept", "cor_patient__a_Intercept__b_Intercept", "r_patient__a[1,Intercept]", "r_patient__b[4,Intercept]", "prior_b_a") %in% variables(fit2) )) expect_true(all( c("lscale_volume_gpAgeTrt0", "lscale_volume_gpAgeTrt1") %in% variables(fit6) )) expect_equal(variables(fit3), SW(parnames(fit3))) }) test_that("vcov has reasonable outputs", { expect_equal(dim(vcov(fit1)), c(9, 9)) expect_equal(dim(vcov(fit1, cor = TRUE)), c(9, 9)) }) test_that("waic has reasonable outputs", { waic1 <- SW(WAIC(fit1)) expect_true(is.numeric(waic1$estimates)) # fails on MKL for unknown reasons # expect_equal(waic1, SW(waic(fit1))) fit1 <- SW(add_criterion(fit1, "waic")) expect_true(is.numeric(fit1$criteria$waic$estimates)) # fails on MKL for unknown reasons # expect_equal(waic(fit1), fit1$criteria$waic) waic_compare <- SW(waic(fit1, fit1)) expect_equal(length(waic_compare$loos), 2) expect_equal(dim(waic_compare$ic_diffs__), c(1, 2)) waic2 <- SW(waic(fit2)) expect_true(is.numeric(waic2$estimates)) waic_pointwise <- SW(waic(fit2, pointwise = TRUE)) expect_equal(waic2, waic_pointwise) expect_warning(compare_ic(waic1, waic2), "Model comparisons are likely invalid") waic4 <- SW(waic(fit4)) expect_true(is.numeric(waic4$estimates)) }) test_that("diagnostic convenience functions have reasonable outputs", { expect_true(is.data.frame(log_posterior(fit1))) expect_true(is.data.frame(nuts_params(fit1))) expect_true(is.numeric(rhat(fit1))) expect_true(is.numeric(SW(neff_ratio(fit1)))) }) test_that("contrasts of grouping factors are not stored #214", { expect_true(is.null(attr(fit1$data$patient, "contrasts"))) }) brms/tests/testthat/tests.posterior_epred.R0000644000176200001440000002213115053072461020712 0ustar liggesuserscontext("Tests for posterior_epred helper functions") # to reduce testing time on CRAN skip_on_cran() test_that("posterior_epred helper functions run without errors", { # actually run posterior_epred.brmsfit that call the helper functions fit <- brms:::rename_pars(brms:::brmsfit_example1) add_dummy_draws <- brms:::add_dummy_draws fit <- add_dummy_draws(fit, "shape", dist = "exp") fit <- add_dummy_draws(fit, "alpha", dist = "norm") fit <- add_dummy_draws(fit, "hu", dist = "beta", shape1 = 1, shape2 = 1) fit <- add_dummy_draws(fit, "phi", dist = "beta", shape1 = 1, shape2 = 1) fit <- add_dummy_draws(fit, "zi", dist = "beta", shape1 = 1, shape2 = 1) fit <- add_dummy_draws(fit, "quantile", dist = "beta", shape1 = 2, shape2 = 1) fit <- add_dummy_draws(fit, "xi", dist = "unif", min = -1, max = 0.5) fit <- add_dummy_draws(fit, "ndt", dist = "exp") fit$formula$formula <- update(fit$formula$formula, .~. - arma(visit, patient)) prep <- brms:::prepare_predictions(fit) prep$dpars$mu <- brms:::get_dpar(prep, "mu") prep$dpars$sigma <- brms:::get_dpar(prep, "sigma") prep$dpars$nu <- brms:::get_dpar(prep, "nu") ndraws <- ndraws(fit) nobs <- nobs(fit) # test preparation of truncated models prep$data$lb <- 0 prep$data$ub <- 200 mu <- brms:::posterior_epred_trunc(prep) expect_equal(dim(mu), c(ndraws, nobs)) # pseudo log-normal model fit$family <- fit$formula$family <- lognormal() expect_equal(dim(posterior_epred(fit, summary = FALSE)), c(ndraws, nobs)) # pseudo shifted log-normal model fit$family <- fit$formula$family <- shifted_lognormal() expect_equal(dim(posterior_epred(fit, summary = FALSE)), c(ndraws, nobs)) # pseudo skew-normal model fit$family <- fit$formula$family <- skew_normal() expect_equal(dim(posterior_epred(fit, summary = FALSE)), c(ndraws, nobs)) # pseudo asym_laplace model fit$family <- fit$formula$family <- asym_laplace() expect_equal(dim(posterior_epred(fit, summary = FALSE)), c(ndraws, nobs)) # pseudo zero_inflated_asym_laplace model fit$family <- fit$formula$family <- brmsfamily("zero_inflated_asym_laplace") expect_equal(dim(posterior_epred(fit, summary = FALSE)), c(ndraws, nobs)) # pseudo gen_extreme_value model fit$family <- fit$formula$family <- gen_extreme_value() expect_equal(dim(posterior_epred(fit, summary = FALSE)), c(ndraws, nobs)) # pseudo weibull model fit$formula$pforms <- NULL fit$family <- fit$formula$family <- weibull() expect_equal(dim(SW(posterior_epred(fit, summary = FALSE))), c(ndraws, nobs)) # pseudo binomial model old_formula <- fit$formula$formula fit$formula$formula <- update(fit$formula$formula, . | trials(100) ~ .) fit$autocor <- brms:::cor_empty() fit$family <- fit$formula$family <- binomial() expect_equal(dim(SW(posterior_epred(fit, summary = FALSE))), c(ndraws, nobs)) # pseudo beta-binomial model fit$family <- fit$formula$family <- beta_binomial() expect_equal(dim(SW(posterior_epred(fit, summary = FALSE))), c(ndraws, nobs)) # pseudo zero inflated binomial model fit$family <- fit$formula$family <- zero_inflated_binomial() expect_equal(dim(SW(posterior_epred(fit, summary = FALSE))), c(ndraws, nobs)) # pseudo zero inflated beta binomial model fit$family <- fit$formula$family <- zero_inflated_beta_binomial() expect_equal(dim(SW(posterior_epred(fit, summary = FALSE))), c(ndraws, nobs)) # pseudo hurdle poisson model fit$formula$formula <- old_formula fit$family <- fit$formula$family <- hurdle_poisson() fit$formula <- bf(count ~ Trt*Age + mo(Exp) + offset(Age) + (1+Trt|visit), family = family(fit)) expect_equal(dim(posterior_epred(fit, summary = FALSE)), c(ndraws, nobs)) # pseudo zero-inflated poisson model fit$family <- fit$formula$family <- zero_inflated_poisson() expect_equal(dim(posterior_epred(fit, summary = FALSE)), c(ndraws, nobs)) # pseudo custom model posterior_epred_test <- function(prep) { prep$dpars$mu } fit$family <- fit$formula$family <- custom_family( "test", dpars = "mu", links = c("logit"), type = "int", vars = "trials[n]" ) expect_equal(dim(posterior_epred(fit, summary = FALSE)), c(ndraws, nobs)) # truncated continuous models prep$dpars$shape <- c(as.matrix(fit, variable = "shape")) mu <- brms:::posterior_epred_trunc_gaussian(prep, lb = 0, ub = 10) expect_equal(dim(mu), c(ndraws, nobs)) mu <- brms:::posterior_epred_trunc_student(prep, lb = -Inf, ub = 15) expect_equal(dim(mu), c(ndraws, nobs)) mu <- brms:::posterior_epred_trunc_lognormal(prep, lb = 2, ub = 15) expect_equal(dim(mu), c(ndraws, nobs)) prep$dpars$mu <- exp(prep$dpars$mu) mu <- brms:::posterior_epred_trunc_gamma(prep, lb = 1, ub = 7) expect_equal(dim(mu), c(ndraws, nobs)) mu <- brms:::posterior_epred_trunc_exponential(prep, lb = 0, ub = Inf) expect_equal(dim(mu), c(ndraws, nobs)) mu <- SW(brms:::posterior_epred_trunc_weibull(prep, lb = -Inf, ub = Inf)) expect_equal(dim(mu), c(ndraws, nobs)) # truncated discrete models data <- list(Y = sample(100, 10), trials = 1:10, N = 10) lb <- matrix(0, nrow = ndraws, ncol = nobs) ub <- matrix(100, nrow = ndraws, ncol = nobs) mu <- brms:::posterior_epred_trunc_poisson(prep, lb = lb, ub = ub) expect_equal(dim(mu), c(ndraws, nobs)) mu <- brms:::posterior_epred_trunc_negbinomial(prep, lb = lb, ub = ub) expect_equal(dim(mu), c(ndraws, nobs)) mu <- brms:::posterior_epred_trunc_negbinomial2(prep, lb = lb, ub = ub) expect_equal(dim(mu), c(ndraws, nobs)) mu <- brms:::posterior_epred_trunc_geometric(prep, lb = lb, ub = ub) expect_equal(dim(mu), c(ndraws, nobs)) prep$data$trials <- 120 lb <- matrix(-Inf, nrow = ndraws, ncol = nobs) prep$dpars$mu <- brms:::inv_link(prep$dpars$mu, "logit") mu <- brms:::posterior_epred_trunc_binomial(prep, lb = lb, ub = ub) expect_equal(dim(mu), c(ndraws, nobs)) }) test_that("posterior_epred_lagsar runs without errors", { prep <- list( dpars = list(mu = matrix(rnorm(30), nrow = 3)), ac = list( lagsar = matrix(c(0.3, 0.5, 0.7)), Msar = matrix(1:100, 10, 10) ), ndraws = 3, nobs = 10, family = gaussian() ) mu_new <- brms:::posterior_epred_lagsar(prep) expect_equal(dim(mu_new), dim(prep$dpars$mu)) expect_true(!identical(mu_new, prep$dpars$mu)) }) test_that("posterior_epred for advanced count data distributions runs without errors", { ns <- 15 nobs <- 5 ncat <- 3 prep <- structure(list(ndraws = ns, nobs = nobs), class = "brmsprep") prep$dpars <- list( mu = array(rbeta(ns*nobs, 2, 2), dim = c(ns, nobs)), shape = array(rexp(ns*nobs, 3), dim = c(ns, nobs)) ) prep$family <- brmsfamily("discrete_weibull") pred <- suppressWarnings(brms:::posterior_epred_discrete_weibull(prep)) expect_equal(dim(pred), c(ns, nobs)) prep$family <- brmsfamily("com_poisson") pred <- suppressWarnings(brms:::posterior_epred_com_poisson(prep)) expect_equal(dim(pred), c(ns, nobs)) }) test_that("posterior_epred for multinomial, dirichlet_multinomial and dirichlet models runs without errors", { ns <- 15 nobs <- 8 ncat <- 3 prep <- structure(list(ndraws = ns, nobs = nobs), class = "brmsprep") prep$dpars <- list( mu1 = array(rnorm(ns*nobs), dim = c(ns, nobs)), mu2 = array(rnorm(ns*nobs), dim = c(ns, nobs)) ) prep$data <- list(ncat = ncat, trials = sample(1:20, nobs)) prep$refcat <- 1 prep$family <- multinomial() pred <- brms:::posterior_epred_multinomial(prep = prep) expect_equal(dim(pred), c(ns, nobs, ncat)) prep$family <- dirichlet_multinomial() pred <- brms:::posterior_epred_dirichlet_multinomial(prep = prep) expect_equal(dim(pred), c(ns, nobs, ncat)) prep$family <- dirichlet() pred <- brms:::posterior_epred_dirichlet(prep = prep) expect_equal(dim(pred), c(ns, nobs, ncat)) prep$family <- brmsfamily("dirichlet2") prep$dpars$mu1 <- array(rexp(ns*nobs, 1), dim = c(ns, nobs)) prep$dpars$mu2 <- array(rexp(ns*nobs, 1), dim = c(ns, nobs)) prep$dpars$mu3 <- array(rexp(ns*nobs, 1), dim = c(ns, nobs)) pred <- brms:::posterior_epred_dirichlet2(prep = prep) expect_equal(dim(pred), c(ns, nobs, ncat)) }) test_that("posterior_epred_xbeta runs without errors", { ns <- 50 nobs <- 8 prep <- structure(list(ndraws = ns, nobs = nobs), class = "brmsprep") prep$dpars <- list( mu = matrix(rbeta(ns * nobs, 1.2, 2.3), ncol = nobs), phi = rexp(ns, 0.01), kappa = rexp(ns, 2) ) prep$data <- list(Y = rbeta(nobs, 2, 3)) mu_new <- brms:::posterior_epred_xbeta(prep) expect_equal(dim(mu_new), dim(prep$dpars$mu)) expect_true(!identical(mu_new, prep$dpars$mu)) }) test_that("posterior_epred can be reproduced by using d()", { fit4 <- rename_pars(brms:::brmsfit_example4) epred4 <- posterior_epred(fit4) eta4 <- posterior_linpred(fit4) bprep4 <- prepare_predictions(fit4) thres4 <- bprep4$thres$thres disc4 <- bprep4$dpars$disc$fe$b %*% t(bprep4$dpars$disc$fe$X) disc4 <- exp(disc4) epred4_ch <- aperm(sapply(seq_len(dim(eta4)[2]), function(i) { dsratio(seq_len(ncol(thres4) + 1), eta4[, i, ], thres4, disc4[, i]) }, simplify = "array"), perm = c(1, 3, 2)) expect_equivalent(epred4, epred4_ch) }) brms/tests/testthat/tests.standata.R0000644000176200001440000013570415053305627017322 0ustar liggesuserscontext("Tests for standata") test_that(paste("standata returns correct data names ", "for fixed and random effects"), { expect_equal(sort(names(standata(rating ~ treat + period + carry + (1|subject), data = inhaler))), sort(c("N", "Y", "K", "Kc", "X", "Z_1_1", "J_1", "N_1", "M_1", "NC_1", "prior_only"))) expect_equal(sort(names(standata(rating ~ treat + period + carry + (1+treat|id|subject), data = inhaler, family = "categorical"))), sort(c("N", "Y", "ncat", "K_mu2", "Kc_mu2", "X_mu2", "Z_1_mu2_1", "Z_1_mu2_2", "K_mu3", "Kc_mu3", "X_mu3", "Z_1_mu3_3", "Z_1_mu3_4", "K_mu4", "Kc_mu4", "X_mu4", "Z_1_mu4_5", "Z_1_mu4_6", "J_1", "N_1", "M_1", "NC_1", "prior_only"))) expect_equal(sort(names(standata(rating ~ treat + period + carry + (1+treat|subject), data = inhaler))), sort(c("N", "Y", "K", "Kc", "X", "Z_1_1", "Z_1_2", "J_1", "N_1", "M_1", "NC_1", "prior_only"))) dat <- data.frame(y = 1:10, g = 1:10, h = 11:10, x = rep(0,10)) expect_equal(sort(names(standata(y ~ 0 + Intercept + x + (1|g) + (1|h), dat, "poisson"))), sort(c("N", "Y", "K", "X", "Z_1_1", "Z_2_1", "J_1", "J_2", "N_1", "M_1", "NC_1", "N_2", "M_2", "NC_2", "prior_only"))) expect_true(all(c("Z_1_1", "Z_1_2", "Z_2_1", "Z_2_2") %in% names(standata(y ~ x + (1+x|g/h), dat)))) expect_equal(standata(y ~ x + (1+x|g+h), dat), standata(y ~ x + (1+x|g) + (1+x|h), dat)) }) test_that(paste("standata handles variables used as fixed effects", "and grouping factors at the same time"), { data <- data.frame(y = 1:9, x = factor(rep(c("a","b","c"), 3))) standata <- standata(y ~ x + (1|x), data = data) expect_equal(colnames(standata$X), c("Intercept", "xb", "xc")) expect_equal(standata$J_1, as.array(rep(1:3, 3))) standata2 <- standata(y ~ x + (1|x), data = data, control = list(not4stan = TRUE)) expect_equal(colnames(standata2$X), c("Intercept", "xb", "xc")) }) test_that("standata returns correct data names for addition terms", { dat <- data.frame(y = 1:10, w = 1:10, t = 1:10, x = rep(0,10), c = sample(-1:1,10,TRUE)) expect_equal(names(standata(y | se(w) ~ x, dat, gaussian())), c("N", "Y", "se", "K", "Kc", "X", "sigma", "prior_only")) expect_equal(names(standata(y | weights(w) ~ x, dat, "gaussian")), c("N", "Y", "weights", "K", "Kc", "X", "prior_only")) expect_equal(names(standata(y | cens(c) ~ x, dat, "student")), c("N", "Y", "cens", "K", "Kc", "X", "prior_only")) expect_equal(names(standata(y | trials(t) ~ x, dat, "binomial")), c("N", "Y", "trials", "K", "Kc", "X", "prior_only")) expect_equal(names(standata(y | trials(10) ~ x, dat, "binomial")), c("N", "Y", "trials", "K", "Kc", "X", "prior_only")) expect_equal(names(standata(y | thres(11) ~ x, dat, "acat")), c("N", "Y", "nthres", "K", "Kc", "X", "disc", "prior_only")) expect_equal(names(standata(y | thres(10) ~ x, dat, cumulative())), c("N", "Y", "nthres", "K", "Kc", "X", "disc", "prior_only")) sdata <- standata(y | trunc(0,20) ~ x, dat, "gaussian") expect_true(all(sdata$lb == 0) && all(sdata$ub == 20)) sdata <- standata(y | trunc(ub = 21:30) ~ x, dat) expect_true(all(all(sdata$ub == 21:30))) }) test_that(paste("standata accepts correct response variables", "depending on the family"), { expect_equal(standata(y ~ 1, data = data.frame(y = seq(-9.9,0,0.1)), family = "student")$Y, as.array(seq(-9.9,0,0.1))) expect_equal(standata(y | trials(10) ~ 1, data = data.frame(y = 1:10), family = "binomial")$Y, as.array(1:10)) expect_equal(standata(y ~ 1, data = data.frame(y = 10:20), family = "poisson")$Y, as.array(10:20)) expect_equal(standata(y ~ 1, data = data.frame(y = rep(-c(1:2),5)), family = "bernoulli")$Y, as.array(rep(1:0,5))) expect_equal(standata(y ~ 1, data = data.frame(y = rep(c(TRUE, FALSE),5)), family = "bernoulli")$Y, as.array(rep(1:0,5))) expect_equal(standata(y ~ 1, data = data.frame(y = rep(1,5)), family = "bernoulli")$Y, as.array(rep(1, 5))) expect_equal(standata(y ~ 1, data = data.frame(y = rep(0,5)), family = "bernoulli")$Y, as.array(rep(0, 5))) expect_equal(standata(y ~ 1, data = data.frame(y = rep(1:10,5)), family = "categorical")$Y, as.array(rep(1:10,5))) expect_equal(standata(y ~ 1, data = data.frame(y = rep(11:20,5)), family = "categorical")$Y, as.array(rep(1:10,5))) expect_equal(standata(y ~ 1, data = data.frame(y = factor(rep(11:20,5))), family = "categorical")$Y, as.array(rep(1:10,5))) expect_equal(standata(y ~ 1, data = data.frame(y = rep(1:10,5)), family = "cumulative")$Y, as.array(rep(1:10,5))) dat <- data.frame(y = factor(rep(-4:5,5), order = TRUE)) expect_equal(standata(y ~ 1, data = dat, family = "acat")$Y, as.array(rep(1:10,5))) expect_equal(standata(y ~ 1, data = data.frame(y = seq(1,10,0.1)), family = "exponential")$Y, as.array(seq(1,10,0.1))) dat <- data.frame(y1 = 1:10, y2 = 11:20, x = rep(0,10)) form <- bf(mvbind(y1, y2) ~ x) + set_rescor(TRUE) sdata <- standata(form, data = dat) expect_equal(sdata$Y_y1, as.array(1:10)) expect_equal(sdata$Y_y2, as.array(11:20)) }) test_that(paste("standata rejects incorrect response variables", "depending on the family"), { expect_error(standata(y ~ 1, data = data.frame(y = factor(1:10)), family = "student"), "Family 'student' requires numeric responses") expect_error(standata(y ~ 1, data = data.frame(y = -5:5), family = "geometric"), "Family 'geometric' requires response greater than or equal to 0") expect_error(standata(y ~ 1, data = data.frame(y = -1:1), family = "bernoulli"), "contain only two different values") expect_error(standata(y ~ 1, data = data.frame(y = factor(-1:1)), family = "cratio"), "Family 'cratio' requires either positive integers or ordered factors") expect_error(standata(y ~ 1, data = data.frame(y = rep(0.5:7.5), 2), family = "sratio"), "Family 'sratio' requires either positive integers or ordered factors") expect_error(standata(y ~ 1, data = data.frame(y = rep(-7.5:7.5), 2), family = "gamma"), "Family 'gamma' requires response greater than 0") expect_error(standata(y ~ 1, data = data.frame(y = c(0.1, 0.5, 1)), family = Beta()), "Family 'beta' requires response smaller than 1") expect_error(standata(y ~ 1, data = data.frame(y = c(0, 0.5, 4)), family = von_mises()), "Family 'von_mises' requires response smaller than or equal to 3.14") expect_error(standata(y ~ 1, data = data.frame(y = c(-1, 2, 5)), family = hurdle_gamma()), "Family 'hurdle_gamma' requires response greater than or equal to 0") }) test_that("standata suggests using family bernoulli if appropriate", { expect_message(standata(y | trials(1) ~ 1, data = list(y = rep(0:1,5)), family = "binomial"), "family 'bernoulli' might be a more efficient choice.") expect_message(standata(y ~ 1, data = data.frame(y = rep(1:2, 5)), family = "acat"), "family 'bernoulli' might be a more efficient choice.") expect_message(standata(y ~ 1, data = data.frame(y = rep(0:1,5)), family = "categorical"), "family 'bernoulli' might be a more efficient choice.") }) test_that("standata returns correct values for addition terms", { dat <- data.frame(y = rnorm(9), s = 1:9, w = 1:9, c1 = rep(-1:1, 3), c2 = rep(c("left","none","right"), 3), c3 = c(rep(c(TRUE, FALSE), 4), FALSE), c4 = c(sample(-1:1, 5, TRUE), rep(2, 4)), t = 11:19) expect_equivalent(standata(y | se(s) ~ 1, data = dat)$se, as.array(1:9)) expect_equal(standata(y | weights(w) ~ 1, data = dat)$weights, as.array(1:9)) expect_equal(standata(y | cens(c1) ~ 1, data = dat)$cens, as.array(rep(-1:1, 3))) expect_equal(standata(y | cens(c2) ~ 1, data = dat)$cens, as.array(rep(-1:1, 3))) expect_equal(standata(y | cens(c3) ~ 1, data = dat)$cens, as.array(c(rep(1:0, 4), 0))) expect_equal(standata(y | cens(c4, y + 2) ~ 1, data = dat)$rcens, as.array(c(rep(0, 5), dat$y[6:9] + 2))) expect_equal(standata(s | trials(10) ~ 1, dat, family = "binomial")$trials, as.array(rep(10, 9))) expect_equal(standata(s | trials(t) ~ 1, data = dat, family = "binomial")$trials, as.array(11:19)) expect_equal(SW(standata(s | cat(19) ~ 1, data = dat, family = "cumulative"))$nthres, 18) }) test_that("standata rejects incorrect addition terms", { dat <- data.frame(y = rnorm(9), s = -(1:9), w = -(1:9), c = rep(-2:0, 3), t = 9:1, z = 1:9) expect_error(standata(y | se(s) ~ 1, data = dat), "Standard errors must be non-negative") expect_error(standata(y | weights(w) ~ 1, data = dat), "Weights must be non-negative") expect_error(standata(y | cens(c) ~ 1, data = dat)) expect_error(standata(z | trials(t) ~ 1, data = dat, family = "binomial"), "Number of trials is smaller than the number of events") }) test_that("standata handles multivariate models", { dat <- data.frame( y1 = 1:10, y2 = 11:20, x = rep(0, 10), g = rep(1:2, 5), censi = sample(0:1, 10, TRUE), tim = 10:1, w = 1:10 ) form <- bf(mvbind(y1, y2) | weights(w) ~ x) + set_rescor(TRUE) sdata <- standata(form, data = dat) expect_equal(sdata$Y_y1, as.array(dat$y1)) expect_equal(sdata$Y_y2, as.array(dat$y2)) expect_equal(sdata$weights_y1, as.array(1:10)) expect_error(standata(bf(mvbind(y1, y2, y2) ~ x) + set_resor(FALSE), data = dat), "Cannot use the same response variable twice") form <- bf(mvbind(y1 / y2, y2, y1 * 3) ~ x) + set_rescor(FALSE) sdata <- standata(form, data = dat) expect_equal(sdata$Y_y1y2, as.array(dat$y1 / dat$y2)) sdata <- suppressWarnings( standata(mvbind(y1, y2) ~ x, dat, autocor = cor_ar(~ tim | g)) ) target1 <- c(seq(9, 1, -2), seq(10, 2, -2)) expect_equal(sdata$Y_y1, as.array(target1)) target2 <- c(seq(19, 11, -2), seq(20, 12, -2)) expect_equal(sdata$Y_y2, as.array(target2)) # models without residual correlations expect_warning( bform <- bf(y1 | cens(censi) ~ x + y2 + (x|2|g)) + gaussian() + cor_ar() + (bf(x ~ 1) + mixture(poisson, nmix = 2)) + (bf(y2 ~ s(y2) + (1|2|g)) + skew_normal()), "Using 'cor_brms' objects for 'autocor' is deprecated" ) bprior <- prior(normal(0, 5), resp = y1) + prior(normal(0, 10), resp = y2) + prior(dirichlet(2, 1), theta, resp = x) sdata <- standata(bform, dat, prior = bprior) sdata_names <- c( "N", "J_1_y1", "cens_y1", "Kma_y1", "Z_1_y2_3", "Zs_y2_1_1", "Y_y2", "con_theta_x", "X_mu2_x" ) expect_true(all(sdata_names %in% names(sdata))) expect_equal(sdata$con_theta_x, as.array(c(2, 1))) }) test_that("standata removes NAs correctly", { dat <- data.frame(y = c(rnorm(9), NA)) sdata <- suppressWarnings(standata(y ~ 1, dat)) expect_equal(as.numeric(sdata$Y), dat$y[1:9]) }) test_that("standata handles the 'subset' addition argument correctly", { dat1 <- data.frame( y1 = rnorm(15), y2 = NA, x1 = rnorm(15), x2 = NA, x3 = rnorm(15), sub1 = 1, sub2 = 0 ) dat2 <- data.frame( y1 = NA, y2 = rnorm(10), x1 = NA, x2 = rnorm(10), x3 = NA, sub1 = 0, sub2 = 1 ) dat <- rbind(dat1, dat2) bform <- bf(y1 | subset(sub1) ~ x1*x3 + sin(x1), family = gaussian()) + bf(y2 | subset(sub2) ~ x2, family = gaussian()) + set_rescor(FALSE) sdata <- standata(bform, dat) nsub1 <- sum(dat$sub1) nsub2 <- sum(dat$sub2) expect_equal(sdata$N_y1, nsub1) expect_equal(sdata$N_y2, nsub2) expect_equal(length(sdata$Y_y1), nsub1) expect_equal(nrow(sdata$X_y2), nsub2) }) test_that("standata returns correct data for ARMA terms", { dat <- data.frame(y = 1:10, x = rep(0, 10), tim = 10:1, g = rep(3:4, 5)) sdata <- standata(y ~ x + ma(tim, g), data = dat) expect_equal(sdata$J_lag, as.array(c(1, 1, 1, 1, 0, 1, 1, 1, 1, 0))) sdata <- standata(y ~ x + ar(tim, g, p = 2), data = dat) expect_equal(sdata$J_lag, as.array(c(1, 2, 2, 2, 0, 1, 2, 2, 2, 0))) sdata <- standata(y ~ x + ar(tim, g, cov = TRUE), data = dat) expect_equal(sdata$begin_tg, as.array(c(1, 6))) expect_equal(sdata$nobs_tg, as.array(c(5, 5))) sdata <- standata(y ~ x + ar(tim), data = dat, family = poisson(), prior = prior(horseshoe(), class = sderr)) expect_equal(sdata$Kscales, 1) bform <- bf(y ~ exp(b * x), b ~ 1, nl = TRUE, autocor = ~arma()) sdata <- standata(bform, dat) }) test_that("standata returns correct data for UNSTR covariance terms", { dat <- data.frame(y = 1:12, x = rnorm(12), tim = c(5:1, 1:5, c(0, 4)), g = c(rep(3:4, 5), rep(2, 2))) sdata <- standata(y ~ x + unstr(tim, g), data = dat) expect_equal(sdata$n_unique_t, 6) expect_equal(sdata$n_unique_cortime, 15) Jtime <- rbind(c(1, 5, 0, 0, 0), 2:6, 2:6) expect_equal(sdata$Jtime_tg, Jtime) }) test_that("standata allows to retrieve the initial data order", { dat <- data.frame(y1 = rnorm(100), y2 = rnorm(100), id = sample(1:10, 100, TRUE), time = sample(1:100, 100)) # univariate model sdata1 <- standata(y1 ~ ar(time, id), data = dat, internal = TRUE) expect_equal(dat$y1, as.numeric(sdata1$Y[attr(sdata1, "old_order")])) # multivariate model form <- bf(mvbind(y1, y2) ~ ma(time, id)) + set_rescor(FALSE) sdata2 <- standata(form, data = dat, internal = TRUE) expect_equal(sdata2$Y_y1[attr(sdata2, "old_order")], as.array(dat$y1)) expect_equal(sdata2$Y_y2[attr(sdata2, "old_order")], as.array(dat$y2)) }) test_that("standata handles covariance matrices correctly", { A <- structure(diag(1, 4), dimnames = list(1:4, NULL)) sdata <- standata(count ~ Trt + (1|gr(visit, cov = A)), data = epilepsy, data2 = list(A = A)) expect_equivalent(sdata$Lcov_1, t(chol(A))) B <- structure(diag(1:5), dimnames = list(c(1,5,2,4,3), NULL)) sdata <- standata(count ~ Trt + (1|gr(visit, cov = B)), data = epilepsy, data2 = list(B = B)) expect_equivalent(sdata$Lcov_1, t(chol(B[c(1,3,5,4), c(1,3,5,4)]))) B <- diag(1, 4) expect_error(standata(count ~ Trt + (1|gr(visit, cov = B)), data = epilepsy, data2 = list(B = B)), "Row or column names are required") B <- structure(diag(1, 4), dimnames = list(2:5, NULL)) expect_error(standata(count ~ Trt + (1|gr(visit, cov = B)), data = epilepsy, data2 = list(B = B)), "Levels of .* do not match") B <- A B[1,2] <- 0.5 expect_error(standata(count ~ Trt + (1|gr(visit, cov = B)), data = epilepsy, data2 = list(B = B)), "must be symmetric") expect_warning( sdata <- standata(count ~ Trt + (1|visit), data = epilepsy, cov_ranef = list(visit = A)), "Argument 'cov_ranef' is deprecated" ) expect_equivalent(sdata$Lcov_1, t(chol(A))) }) test_that("standata correctly prepares data for non-linear models", { flist <- list(a ~ x + (1|1|g), b ~ mo(z) + (1|1|g)) dat <- data.frame( y = rnorm(9), x = rnorm(9), z = sample(1:9, 9), g = rep(1:3, 3) ) bform <- bf(y ~ a - b^z, flist = flist, nl = TRUE) sdata <- standata(bform, data = dat) expect_equal(names(sdata), c("N", "Y", "C_1", "K_a", "X_a", "Z_1_a_1", "K_b", "X_b", "Ksp_b", "Imo_b", "Xmo_b_1", "Jmo_b", "con_simo_b_1", "Z_1_b_2", "J_1", "N_1", "M_1", "NC_1", "prior_only") ) expect_equal(colnames(sdata$X_a), c("Intercept", "x")) expect_equal(sdata$J_1, as.array(dat$g)) bform <- bf(y ~ x) + nlf(sigma ~ a1 * exp(-x/(a2 + z))) + lf(a1 ~ 1, a2 ~ z + (x|g)) + lf(alpha ~ x) sdata <- standata(bform, dat, family = skew_normal()) sdata_names <- c("C_sigma_1", "X_a2", "Z_1_a2_1") expect_true(all(sdata_names %in% names(sdata))) }) test_that("standata correctly prepares data for monotonic effects", { data <- data.frame( y = rpois(120, 10), x1 = rep(1:4, 30), z = rnorm(10), x2 = factor(rep(c("a", "b", "c"), 40), ordered = TRUE) ) sdata <- standata(y ~ mo(x1)*mo(x2)*y, data = data) sdata_names <- c("Xmo_1", "Imo", "Jmo", "con_simo_8", "con_simo_5") expect_true(all(sdata_names %in% names(sdata))) expect_equivalent(sdata$Xmo_1, as.array(data$x1 - 1)) expect_equivalent(sdata$Xmo_2, as.array(as.numeric(data$x2) - 1)) expect_equal( as.vector(unname(sdata$Jmo)), rep(c(max(data$x1) - 1, length(unique(data$x2)) - 1), 4) ) expect_equal(sdata$con_simo_1, as.array(rep(1, 3))) prior <- set_prior("dirichlet(1:3)", coef = "mox11", class = "simo", dpar = "sigma") sdata <- standata(bf(y ~ 1, sigma ~ mo(x1)), data = data, prior = prior) expect_equal(sdata$con_simo_sigma_1, as.array(1:3)) prior <- c( set_prior("normal(0,1)", class = "b", coef = "mox1"), set_prior("dirichlet(c(1, 0.5, 2))", class = "simo", coef = "mox11"), prior_(~dirichlet(c(1, 0.5, 2)), class = "simo", coef = "mox1:mox21") ) sdata <- standata(y ~ mo(x1)*mo(x2), data = data, prior = prior) expect_equal(sdata$con_simo_1, as.array(c(1, 0.5, 2))) expect_equal(sdata$con_simo_3, as.array(c(1, 0.5, 2))) # test issue #924 (conditional monotonicity) prior <- c(prior(dirichlet(c(1, 0.5, 2)), simo, coef = "v"), prior(dirichlet(c(1,3)), simo, coef = "w")) sdata <- standata(y ~ y*mo(x1, id = "v")*mo(x2, id = "w"), data, prior = prior) expect_equal(sdata$con_simo_1, as.array(c(1, 0.5, 2))) expect_equal(sdata$con_simo_2, as.array(c(1, 3))) expect_true(!"sdata$con_simo_3" %in% names(sdata)) expect_error( standata(y ~ mo(z), data = data), "Monotonic predictors must be integers or ordered factors" ) prior <- c(set_prior("dirichlet(c(1,0.5,2))", class = "simo", coef = "mox21")) expect_error( standata(y ~ mo(x2), data = data, prior = prior), "Invalid Dirichlet prior" ) }) test_that("standata returns FCOR covariance matrices", { data <- data.frame(y = 1:5) data2 <- list(V = diag(5)) expect_equal(standata(y ~ fcor(V), data, data2 = data2)$Mfcor, data2$V, check.attributes = FALSE) expect_warning( expect_error( standata(y~1, data, autocor = cor_fixed(diag(2))), "Dimensions of 'M' for FCOR terms must be equal" ), "Using 'cor_brms' objects for 'autocor' is deprecated" ) }) test_that("standata returns data for GAMMs", { dat <- data.frame(y = rnorm(10), x1 = rnorm(10), x2 = rnorm(10), x3 = rnorm(10), z = rnorm(10), g = factor(rep(1:2, 5))) sdata <- standata(y ~ s(x1) + z + s(x2, by = x3), data = dat) expect_equal(sdata$nb_1, 1) expect_equal(as.vector(sdata$knots_2), 8) expect_equal(dim(sdata$Zs_1_1), c(10, 8)) expect_equal(dim(sdata$Zs_2_1), c(10, 8)) bform <- bf(y ~ lp, lp ~ s(x1) + z + s(x2, by = x3), nl = TRUE) sdata <- standata(bform, dat) expect_equal(sdata$nb_lp_1, 1) expect_equal(as.vector(sdata$knots_lp_2), 8) expect_equal(dim(sdata$Zs_lp_1_1), c(10, 8)) expect_equal(dim(sdata$Zs_lp_2_1), c(10, 8)) sdata <- standata(y ~ g + s(x2, by = g), data = dat) expect_true(all(c("knots_1", "knots_2") %in% names(sdata))) # test issue #562 dat$g <- as.character(dat$g) sdata <- standata(y ~ g + s(x2, by = g), data = dat) expect_true(all(c("knots_1", "knots_2") %in% names(sdata))) sdata <- standata(y ~ t2(x1, x2), data = dat) expect_equal(sdata$nb_1, 3) expect_equal(as.vector(sdata$knots_1), c(9, 6, 6)) expect_equal(dim(sdata$Zs_1_1), c(10, 9)) expect_equal(dim(sdata$Zs_1_3), c(10, 6)) expect_error(standata(y ~ te(x1, x2), data = dat), "smooths 'te' and 'ti' are not yet implemented") }) test_that("standata returns correct group ID data", { form <- bf(count ~ Trt + (1+Trt|3|visit) + (1|patient), shape ~ (1|3|visit) + (Trt||patient)) sdata <- standata(form, data = epilepsy, family = negbinomial()) expect_true(all(c("Z_1_1", "Z_2_2", "Z_3_shape_1", "Z_2_shape_3") %in% names(sdata))) form <- bf(count ~ a, sigma ~ (1|3|visit) + (Trt||patient), a ~ Trt + (1+Trt|3|visit) + (1|patient), nl = TRUE) sdata <- standata(form, data = epilepsy, family = student()) expect_true(all(c("Z_1_sigma_1", "Z_2_a_3", "Z_2_sigma_1", "Z_3_a_1") %in% names(sdata))) }) test_that("standata handles population-level intercepts", { dat <- data.frame(y = 10:1, x = 1:10) sdata <- standata(y ~ 0 + x, data = dat) expect_equal(unname(sdata$X[, 1]), dat$x) sdata <- standata(y ~ x, dat, cumulative(), control = list(not4stan = TRUE)) expect_equal(unname(sdata$X[, 1]), dat$x) sdata <- standata(y ~ 0 + Intercept + x, data = dat) expect_equal(unname(sdata$X), cbind(1, dat$x)) }) test_that("standata handles category specific effects", { sdata <- standata(rating ~ period + carry + cse(treat), data = inhaler, family = sratio()) expect_equivalent(sdata$Xcs, matrix(inhaler$treat)) sdata <- standata(rating ~ period + carry + cs(treat) + (cs(1)|subject), data = inhaler, family = acat()) expect_equivalent(sdata$Z_1_3, as.array(rep(1, nrow(inhaler)))) sdata <- standata(rating ~ period + carry + (cs(treat)|subject), data = inhaler, family = cratio()) expect_equivalent(sdata$Z_1_4, as.array(inhaler$treat)) expect_warning( standata(rating ~ 1 + cs(treat), data = inhaler, family = "cumulative"), "Category specific effects for this family should be considered experimental" ) expect_error(standata(rating ~ 1 + (treat + cs(1)|subject), data = inhaler, family = "cratio"), "category specific effects in separate group-level terms") }) test_that("standata handles wiener diffusion models", { dat <- data.frame(q = 1:10, resp = sample(0:1, 10, TRUE), x = rnorm(10)) dat$dec <- ifelse(dat$resp == 0, "lower", "upper") dat$test <- "a" sdata <- standata(q | dec(resp) ~ x, data = dat, family = wiener()) expect_equal(sdata$dec, as.array(dat$resp)) sdata <- standata(q | dec(dec) ~ x, data = dat, family = wiener()) expect_equal(sdata$dec, as.array(dat$resp)) expect_error(standata(q | dec(test) ~ x, data = dat, family = wiener()), "Decisions should be 'lower' or 'upper'") }) test_that("standata handles noise-free terms", { N <- 30 dat <- data.frame( y = rnorm(N), x = rnorm(N), z = rnorm(N), xsd = abs(rnorm(N, 1)), zsd = abs(rnorm(N, 1)), ID = rep(1:5, each = N / 5) ) sdata <- standata( bf(y ~ me(x, xsd)*me(z, zsd)*x, sigma ~ me(x, xsd)), data = dat ) expect_equal(sdata$Xn_1, as.array(dat$x)) expect_equal(sdata$noise_2, as.array(dat$zsd)) expect_equal(unname(sdata$Csp_3), as.array(dat$x)) expect_equal(sdata$Ksp, 6) expect_equal(sdata$NCme_1, 1) }) test_that("standata handles noise-free terms with grouping factors", { dat <- data.frame( y = rnorm(10), x1 = rep(1:5, each = 2), sdx = rep(1:5, each = 2), g = rep(c("b", "c", "a", "d", 1), each = 2) ) sdata <- standata(y ~ me(x1, sdx, gr = g), dat) expect_equal(unname(sdata$Xn_1), as.array(c(5, 3, 1, 2, 4))) expect_equal(unname(sdata$noise_1), as.array(c(5, 3, 1, 2, 4))) dat$sdx[2] <- 10 expect_error( standata(y ~ me(x1, sdx, gr = g), dat), "Measured values and measurement error should be unique" ) }) test_that("standata handles missing value terms", { dat = data.frame(y = rnorm(10), x = rnorm(10), g = 1:10) miss <- c(1, 3, 9) dat$x[miss] <- NA bform <- bf(y ~ mi(x)*g) + bf(x | mi() ~ g) + set_rescor(FALSE) sdata <- standata(bform, dat) expect_equal(sdata$Jmi_x, as.array(miss)) expect_true(all(is.infinite(sdata$Y_x[miss]))) # dots in variable names are correctly handled #452 dat$x.2 <- dat$x bform <- bf(y ~ mi(x.2)*g) + bf(x.2 | mi() ~ g) + set_rescor(FALSE) sdata <- standata(bform, dat) expect_equal(sdata$Jmi_x, as.array(miss)) dat$z <- rbeta(10, 1, 1) dat$z[miss] <- NA bform <- bf(exp(y) ~ mi(z)*g) + bf(z | mi() ~ g, family = Beta()) + set_rescor(FALSE) sdata <- standata(bform, dat) expect_equal(sdata$Jmi_z, as.array(miss)) }) test_that("standata handles overimputation", { dat = data.frame(y = rnorm(10), x = rnorm(10), g = 1:10, sdy = 1) miss <- c(1, 3, 9) dat$x[miss] <- dat$sdy[miss] <- NA bform <- bf(y ~ mi(x)*g) + bf(x | mi(sdy) ~ g) + set_rescor(FALSE) sdata <- standata(bform, dat) expect_equal(sdata$Jme_x, as.array(setdiff(1:10, miss))) expect_true(all(is.infinite(sdata$Y_x[miss]))) expect_true(all(is.infinite(sdata$noise_x[miss]))) }) test_that("standata handles 'mi' terms with 'subset'", { dat <- data.frame( y = rnorm(10), x = c(rnorm(9), NA), z = rnorm(10), g1 = sample(1:5, 10, TRUE), g2 = 10:1, g3 = 1:10, s = c(FALSE, rep(TRUE, 9)) ) bform <- bf(y ~ mi(x, idx = g1)) + bf(x | mi() + index(g2) + subset(s) ~ 1) + set_rescor(FALSE) sdata <- standata(bform, dat) expect_true(all(sdata$idxl_y_x_1 %in% 9:5)) # test a bunch of errors # fails on CRAN for some reason # bform <- bf(y ~ mi(x, idx = g1)) + # bf(x | mi() + index(g3) + subset(s) ~ 1) + # set_rescor(FALSE) # expect_error(standata(bform, dat), # "Could not match all indices in response 'x'" # ) bform <- bf(y ~ mi(x, idx = g1)) + bf(x | mi() + subset(s) ~ 1) + set_rescor(FALSE) expect_error(standata(bform, dat), "Response 'x' needs to have an 'index' addition term" ) bform <- bf(y ~ mi(x)) + bf(x | mi() + subset(s) + index(g2) ~ 1) + set_rescor(FALSE) expect_error(standata(bform, dat), "mi() terms of subsetted variables require the 'idx' argument", fixed = TRUE ) bform <- bf(y | mi() ~ mi(x, idx = g1)) + bf(x | mi() + subset(s) + index(g2) ~ mi(y)) + set_rescor(FALSE) expect_error(standata(bform, dat), "mi() terms in subsetted formulas require the 'idx' argument", fixed = TRUE ) }) test_that("standata handles multi-membership models", { dat <- data.frame(y = rnorm(10), g1 = c(7:2, rep(10, 4)), g2 = 1:10, w1 = rep(1, 10), w2 = rep(abs(rnorm(10)))) sdata <- standata(y ~ (1|mm(g1,g2,g1,g2)), data = dat) expect_true(all(paste0(c("W_1_", "J_1_"), 1:4) %in% names(sdata))) expect_equal(sdata$W_1_4, as.array(rep(0.25, 10))) expect_equal(unname(sdata$Z_1_1_1), as.array(rep(1, 10))) expect_equal(unname(sdata$Z_1_1_2), as.array(rep(1, 10))) # this checks whether combintation of factor levels works as intended expect_equal(sdata$J_1_1, as.array(c(6, 5, 4, 3, 2, 1, 7, 7, 7, 7))) expect_equal(sdata$J_1_2, as.array(c(8, 1, 2, 3, 4, 5, 6, 9, 10, 7))) sdata <- standata(y ~ (1|mm(g1,g2, weights = cbind(w1, w2))), dat) expect_equal(sdata$W_1_1, as.array(dat$w1 / (dat$w1 + dat$w2))) # tests mmc terms sdata <- standata(y ~ (1+mmc(w1, w2)|mm(g1,g2)), data = dat) expect_equal(unname(sdata$Z_1_2_1), as.array(dat$w1)) expect_equal(unname(sdata$Z_1_2_2), as.array(dat$w2)) expect_error( standata(y ~ (mmc(w1, w2, y)|mm(g1,g2)), data = dat), "Invalid term 'mmc(w1, w2, y)':", fixed = TRUE ) expect_error( standata(y ~ (mmc(w1, w2)*y|mm(g1,g2)), data = dat), "The term 'mmc(w1, w2):y' is invalid", fixed = TRUE ) # tests if ":" works in multi-membership models sdata <- standata(y ~ (1|mm(w1:g1,w1:g2)), dat) expect_true(all(c("J_1_1", "J_1_2") %in% names(sdata))) }) test_that("by variables in grouping terms are handled correctly", { gvar <- c("1A", "1B", "2A", "2B", "3A", "3B", "10", "100", "2", "3") gvar <- rep(gvar, each = 10) g_order <- order(gvar) byvar <- c(0, 4.5, 3, 2, "x 1") byvar <- factor(rep(byvar, each = 20)) dat <- data.frame( y = rnorm(100), x = rnorm(100), g = gvar, g2 = gvar[g_order], z = byvar, z2 = byvar[g_order], z3 = factor(1:2) ) sdata <- standata(y ~ x + (x | gr(g, by = z)), dat) expect_equal(sdata$Nby_1, 5) expect_equal(sdata$Jby_1, as.array(c(2, 2, 1, 1, 5, 4, 4, 5, 3, 3))) sdata <- standata(y ~ x + (x | mm(g, g2, by = cbind(z, z2))), dat) expect_equal(sdata$Nby_1, 5) expect_equal(sdata$Jby_1, as.array(c(2, 2, 1, 1, 5, 4, 4, 5, 3, 3))) expect_error(standata(y ~ x + (1|gr(g, by = z3)), dat), "Some levels of 'g' correspond to multiple levels of 'z3'") }) test_that("standata handles calls to the 'poly' function", { dat <- data.frame(y = rnorm(10), x = rnorm(10)) expect_equal(colnames(standata(y ~ 1 + poly(x, 3), dat)$X), c("Intercept", "polyx31", "polyx32", "polyx33")) }) test_that("standata allows fixed distributional parameters", { dat <- list(y = 1:10) expect_equal(standata(bf(y ~ 1, nu = 3), dat, student())$nu, 3) expect_equal(standata(y ~ 1, dat, acat())$disc, 1) expect_error(standata(bf(y ~ 1, bias = 0.5), dat), "Invalid fixed parameters: 'bias'") }) test_that("Cell-mean coding can be disabled", { df <- data.frame(y = 1:10, g = rep(c("a", "b"), 5)) bform <- bf(y ~ g) + lf(disc ~ 0 + g + (0 + g | y), cmc = FALSE) + cumulative() sdata <- standata(bform, df) target <- matrix(rep(0:1, 5), dimnames = list(1:10, "gb")) expect_equal(sdata$X_disc, target) expect_equal(unname(sdata$Z_1_disc_1), as.array(rep(0:1, 5))) expect_true(!"Z_1_disc_2" %in% names(sdata)) bform <- bf(y ~ 0 + g + (1 | y), cmc = FALSE) sdata <- standata(bform, df) expect_equal(sdata$X, target) expect_equal(unname(sdata$Z_1_1), as.array(rep(1, 10))) }) test_that("standata correctly includes offsets", { data <- data.frame(y = rnorm(10), x = rnorm(10), c = 1) sdata <- standata(bf(y ~ x + offset(c), sigma ~ offset(c + 1)), data) expect_equal(sdata$offsets, as.array(data$c)) expect_equal(sdata$offsets_sigma, as.array(data$c + 1)) sdata <- standata(y ~ x + offset(c) + offset(x), data) expect_equal(sdata$offsets, as.array(data$c + data$x)) }) test_that("standata includes data for mixture models", { data <- data.frame(y = rnorm(10), x = rnorm(10), c = 1) form <- bf(y ~ x, mu1 ~ 1, family = mixture(gaussian, gaussian)) sdata <- standata(form, data) expect_equal(sdata$con_theta, as.array(c(1, 1))) expect_equal(dim(sdata$X_mu1), c(10, 1)) expect_equal(dim(sdata$X_mu2), c(10, 2)) form <- bf(y ~ x, family = mixture(gaussian, gaussian)) sdata <- standata(form, data, prior = prior(dirichlet(10, 2), theta)) expect_equal(sdata$con_theta, as.array(c(10, 2))) form <- bf(y ~ x, theta1 = 1, theta2 = 3, family = mixture(gaussian, gaussian)) sdata <- standata(form, data) expect_equal(sdata$theta1, 1/4) expect_equal(sdata$theta2, 3/4) }) test_that("standata includes data for Gaussian processes", { dat <- data.frame(y = rnorm(10), x1 = rnorm(10), z = factor(c(2, 2, 2, 3, 4, rep(5, 5)))) sdata <- standata(y ~ gp(x1), dat) expect_equal(max(sdata$Xgp_1) - min(sdata$Xgp_1), 1) sdata <- standata(y ~ gp(x1, scale = FALSE), dat) expect_equal(max(sdata$Xgp_1) - min(sdata$Xgp_1), max(dat$x1) - min(dat$x1)) sdata <- SW(standata(y ~ gp(x1, by = z, gr = TRUE, scale = FALSE), dat)) expect_equal(sdata$Igp_1_2, as.array(4)) expect_equal(sdata$Jgp_1_4, as.array(1:5)) expect_equal(sdata$Igp_1_4, as.array(6:10)) sdata <- SW(standata(y ~ gp(x1, by = y, gr = TRUE), dat)) expect_equal(sdata$Cgp_1, as.array(dat$y)) }) test_that("standata includes data for approximate Gaussian processes", { dat <- data.frame(y = rnorm(10), x1 = sample(1:10, 10), z = factor(c(2, 2, 2, 3, 4, rep(5, 5)))) sdata <- standata(y ~ gp(x1, k = 5, c = 5/4), dat) expect_equal(sdata$NBgp_1, 5) expect_equal(dim(sdata$Xgp_1), c(10, 5)) expect_equal(dim(sdata$slambda_1), c(5, 1)) sdata <- SW(standata(y ~ gp(x1, by = z, k = 5, c = 5/4, scale = FALSE), dat)) expect_equal(sdata$Igp_1_2, as.array(4)) expect_equal(sdata$Cgp_1_2, as.array(1)) expect_equal(sdata$Igp_1_4, as.array(6:10)) }) test_that("standata includes data for SAR models", { dat <- data.frame(y = rnorm(10), x = rnorm(10)) W <- matrix(0, nrow = 10, ncol = 10) dat2 <- list(W = W) sdata <- standata(y ~ x + sar(W), data = dat, data2 = dat2) expect_equal(dim(sdata$M), rep(nrow(W), 2)) dat2 <- list(W = matrix(0, 2, 2)) expect_error( standata(y ~ x + sar(W), data = dat, data2 = dat2), "Dimensions of 'M' for SAR terms must be equal" ) }) test_that("standata includes data for CAR models", { dat = data.frame(y = rnorm(10), x = rnorm(10), obs = 1:10) edges <- cbind(1:10, 10:1) W <- matrix(0, nrow = 10, ncol = 10) for (i in seq_len(nrow(edges))) { W[edges[i, 1], edges[i, 2]] <- 1 } rownames(W) <- 1:nrow(W) dat2 <- list(W = W) sdata <- standata(y ~ x + car(W, gr = obs), dat, data2 = dat2) expect_equal(sdata$Nloc, 10) expect_equal(unname(sdata$Nneigh), rep(1, 10)) expect_equal(unname(sdata$edges1), as.array(10:6)) expect_equal(unname(sdata$edges2), as.array(1:5)) sdata_old <- SW(standata(y ~ x, dat, autocor = cor_car(W))) expect_equal(sdata, sdata_old) rownames(dat2$W) <- c("a", 2:9, "b") dat$group <- rep(c("a", "b"), each = 5) sdata <- standata(y ~ x + car(W, gr = group), dat, data2 = dat2, prior = prior(horseshoe(), class = sdcar)) expect_equal(sdata$Nloc, 2) expect_equal(sdata$edges1, as.array(2)) expect_equal(sdata$edges2, as.array(1)) expect_equal(sdata$Kscales, 1) sdata <- standata(y ~ x + car(W, group, type = "bym2"), data = dat, data2 = dat2) expect_equal(length(sdata$car_scale), 1L) dat2$W[1, 10] <- 4 dat2$W[10, 1] <- 4 expect_message(standata(y ~ car(W, gr = group), dat, data2 = dat2), "Converting all non-zero values in 'M' to 1") # test error messages rownames(dat2$W) <- c(1:9, "a") expect_error(standata(y ~ car(W, gr = group), dat, data2 = dat2), "Row names of 'M' for CAR terms do not match") rownames(dat2$W) <- NULL expect_error(standata(y ~ car(W, gr = group), dat, data2 = dat2), "Row names are required for 'M'") dat2$W[1, 10] <- 0 expect_error(standata(y ~ car(W), dat, data2 = dat2), "'M' for CAR terms must be symmetric") dat2$W[10, 1] <- 0 expect_error(SW(standata(y ~ x + car(W), dat, data2 = dat2)), "all locations should have at least one neighbor") }) test_that("standata includes data of special priors", { dat <- data.frame(y = 1:10, x1 = rnorm(10), x2 = rnorm(10), g = rep(1:2, each = 5), x3 = sample(1:5, 10, TRUE)) # horseshoe prior hs <- horseshoe(7, scale_global = 2, df_global = 3, df_slab = 6, scale_slab = 3) sdata <- standata(y ~ x1*x2, data = dat, prior = set_prior(hs)) expect_equal(sdata$hs_df, 7) expect_equal(sdata$hs_df_global, 3) expect_equal(sdata$hs_df_slab, 6) expect_equal(sdata$hs_scale_global, 2) expect_equal(sdata$hs_scale_slab, 3) hs <- horseshoe(par_ratio = 0.1) sdata <- standata(y ~ x1*x2, data = dat, prior = set_prior(hs)) expect_equal(sdata$hs_scale_global, 0.1 / sqrt(nrow(dat))) # R2D2 prior sdata <- standata(y ~ x1*x2, data = dat, prior = prior(R2D2(0.5, 10))) expect_equal(sdata$R2D2_mean_R2, 0.5) expect_equal(sdata$R2D2_prec_R2, 10) expect_equal(sdata$R2D2_cons_D2, as.array(rep(0.5, 3))) # horseshoe and R2D2 prior applied in a non-linear model hs_a1 <- horseshoe(7, scale_global = 2, df_global = 3) R2D2_a2 <- R2D2(0.5, 10) sdata <- standata( bf(y ~ a1 + a2, a1 ~ x1, a2 ~ 0 + x2, nl = TRUE), data = dat, sample_prior = TRUE, prior = c(set_prior(hs_a1, nlpar = "a1"), set_prior(R2D2_a2, nlpar = "a2")) ) expect_equal(sdata$hs_df_a1, 7) expect_equal(sdata$R2D2_mean_R2_a2, 0.5) bform <- bf(y ~ x1*mo(x3) + (1|g) + gp(x3) + s(x2) + arma(p = 2, q = 2, gr = g)) bprior <- prior(R2D2(cons_D2 = 11:1, main = TRUE), class = b) + prior(R2D2(), class = sd) + prior(R2D2(), class = sds) + prior(R2D2(), class = sdgp) + prior(R2D2(), class = ar) + prior(R2D2(), class = ma) sdata <- standata(bform, data = dat, prior = bprior) expect_equal(sdata$Kscales, 11) expect_equal(sdata$R2D2_cons_D2, as.array(11:1)) }) test_that("dots in formula are correctly expanded", { dat <- data.frame(y = 1:10, x1 = 1:10, x2 = 1:10) sdata <- standata(y ~ ., dat) expect_equal(colnames(sdata$X), c("Intercept", "x1", "x2")) }) test_that("argument 'stanvars' is handled correctly", { bprior <- prior(normal(mean_intercept, 10), class = "Intercept") mean_intercept <- 5 stanvars <- stanvar(mean_intercept) sdata <- standata(count ~ Trt, data = epilepsy, prior = bprior, stanvars = stanvars) expect_equal(sdata$mean_intercept, 5) # define a multi_normal prior with known covariance matrix bprior <- prior(multi_normal(M, V), class = "b") stanvars <- stanvar(rep(0, 2), "M", scode = " vector[K] M;") + stanvar(diag(2), "V", scode = " matrix[K, K] V;") sdata <- standata(count ~ Trt + zBase, epilepsy, prior = bprior, stanvars = stanvars) expect_equal(sdata$M, rep(0, 2)) expect_equal(sdata$V, diag(2)) }) test_that("addition arguments 'vint' and 'vreal' work correctly", { dat <- data.frame(size = 10, y = sample(0:10, 20, TRUE), x = rnorm(20)) beta_binomial2 <- custom_family( "beta_binomial2", dpars = c("mu", "tau"), links = c("logit", "log"), lb = c(NA, 0), type = "int", vars = c("vint1[n]", "vreal1[n]") ) sdata <- standata( y | vint(size) + vreal(x, size) ~ 1, data = dat, family = beta_binomial2, ) expect_equal(sdata$vint1, as.array(rep(10, 20))) expect_equal(sdata$vreal1, as.array(dat$x)) expect_equal(sdata$vreal2, as.array(rep(10, 20))) }) test_that("reserved variables 'Intercept' is handled correctly", { dat <- data.frame(y = 1:10) expect_warning( sdata <- standata(y ~ 0 + intercept, dat), "Reserved variable name 'intercept' is deprecated." ) expect_true(all(sdata$X[, "intercept"] == 1)) sdata <- standata(y ~ 0 + Intercept, dat) expect_true(all(sdata$X[, "Intercept"] == 1)) }) test_that("data for multinomial, dirichlet_multinomial and dirichlet models is correct", { N <- 15 dat <- as.data.frame(rdirichlet(N, c(3, 2, 1))) names(dat) <- c("y1", "y2", "y3") dat$t1 <- round(dat$y1 * rpois(N, 10)) dat$t2 <- round(dat$y2 * rpois(N, 10)) dat$t3 <- round(dat$y3 * rpois(N, 10)) dat$x <- rnorm(N) dat$y <- with(dat, cbind(y1, y2, y3)) dat$t <- with(dat, cbind(t1, t2, t3)) dat$size <- rowSums(dat$t) sdata <- standata(t | trials(size) ~ x, dat, multinomial()) expect_equal(sdata$trials, as.array(dat$size)) expect_equal(sdata$ncat, 3) expect_equal(sdata$Y, unname(dat$t)) sdata <- standata(t | trials(size) ~ x, dat, dirichlet_multinomial()) expect_equal(sdata$trials, as.array(dat$size)) expect_equal(sdata$ncat, 3) expect_equal(sdata$Y, unname(dat$t)) sdata <- standata(y ~ x, data = dat, family = dirichlet()) expect_equal(sdata$ncat, 3) expect_equal(sdata$Y, unname(dat$y)) expect_error( standata(t | trials(10) ~ x, data = dat, family = multinomial()), "Number of trials does not match the number of events" ) expect_error( standata(t | trials(10) ~ x, data = dat, family = dirichlet_multinomial()), "Number of trials does not match the number of events" ) expect_error(standata(t ~ x, data = dat, family = dirichlet()), "Response values in simplex models must sum to 1") }) test_that("standata handles cox models correctly", { skip_if_not_installed("splines2") data <- data.frame(y = rexp(100), x = rnorm(100), g = sample(1:3, 100, TRUE)) bform <- bf(y ~ x) bprior <- prior(dirichlet(3), sbhaz) sdata <- standata(bform, data, brmsfamily("cox"), prior = bprior) expect_equal(dim(sdata$Zbhaz), c(100, 5)) expect_equal(dim(sdata$Zcbhaz), c(100, 5)) expect_equal(sdata$con_sbhaz, as.array(rep(3, 5))) bform <- bf(y | bhaz(df = 6) ~ x) sdata <- standata(bform, data, brmsfamily("cox")) expect_equal(dim(sdata$Zbhaz), c(100, 6)) expect_equal(dim(sdata$Zcbhaz), c(100, 6)) bform <- bf(y | bhaz(gr = g) ~ x) bprior <- prior(dirichlet(3), "sbhaz", group = 2) sdata <- standata(bform, data, family = brmsfamily("cox"), prior = bprior) expect_equal(sdata$ngrbhaz, 3) expect_equivalent(sdata$Jgrbhaz, data$g) con_mat <- rbind(rep(1, 5), rep(3, 5), rep(1, 5)) expect_equivalent(sdata$con_sbhaz, con_mat) }) test_that("standata handles addition term 'rate' is correctly", { data <- data.frame(y = rpois(10, 1), x = rnorm(10), time = 1:10) sdata <- standata(y | rate(time) ~ x, data, poisson()) expect_equal(sdata$denom, as.array(data$time)) }) test_that("standata handles grouped ordinal thresholds correctly", { dat <- data.frame( y = c(1:5, 1:4, 4), gr = rep(c("a", "b"), each = 5), th = rep(5:6, each = 5), x = rnorm(10) ) # thresholds without a grouping factor sdata <- standata(y ~ x, dat, cumulative()) expect_equal(sdata$nthres, 4) sdata <- standata(y | thres(5) ~ x, dat, cumulative()) expect_equal(sdata$nthres, 5) expect_error( standata(y | thres(th) ~ x, dat, cumulative()), "Number of thresholds needs to be a single value" ) # thresholds with a grouping factor sdata <- standata(y | thres(th, gr) ~ x, dat, cumulative()) expect_equal(sdata$nthres, as.array(c(5, 6))) expect_equal(sdata$ngrthres, 2) expect_equal(unname(sdata$Jthres[1, ]), c(1, 5)) expect_equal(unname(sdata$Jthres[10, ]), c(6, 11)) sdata <- standata(y | thres(gr = gr) ~ x, dat, cumulative()) expect_equal(sdata$nthres, as.array(c(4, 3))) expect_equal(sdata$ngrthres, 2) sdata <- standata(y | thres(6, gr = gr) ~ x, dat, cumulative()) expect_equal(sdata$nthres, as.array(c(6, 6))) expect_equal(sdata$ngrthres, 2) }) test_that("information for threading is handled correctly", { dat <- data.frame(y = 1:10) sdata <- standata(y ~ 1, dat, threads = threading(2, grainsize = 3)) expect_equal(sdata$grainsize, 3) }) test_that("variables in data2 can be used in population-level effects", { dat <- data.frame(y = 1:10, x1 = rnorm(10), x2 = rnorm(10), x3 = rnorm(10)) foo <- function(..., idx = NULL) { out <- cbind(...) if (!is.null(idx)) { out <- out[, idx, drop = FALSE] } out } sdata <- standata(y ~ foo(x1, x2, x3, idx = id), data = dat, data2 = list(id = c(3, 1))) target <- c("Intercept", "foox1x2x3idxEQidx3", "foox1x2x3idxEQidx1") expect_equal(colnames(sdata$X), target) expect_equivalent(sdata$X[, 2], dat$x3) expect_equivalent(sdata$X[, 3], dat$x1) }) test_that("NAs are allowed in unused interval censoring variables", { dat <- data.frame(y = rnorm(10), ce = c(1, rep(2, 9))) dat$y2 <- dat$y + 2 dat$y2[1] <- NA sdata <- standata(y | cens(ce, y2 = y2) ~ 1, data = dat) expect_equal(sdata$N, 10L) expect_equal(sdata$rcens[1], 0) dat$ce[1] <- 2 expect_error( standata(y | cens(ce, y2 = y2) ~ 1, data = dat), "'y2' should not be NA for interval censored observations" ) }) test_that("drop_unused_factor levels works correctly", { dat <- data.frame(y = rnorm(10), x = factor(c("a", "b"), levels = c("a", "b", "c"))) # should drop level "c" sdata <- standata(y ~ x, data = dat) expect_equal(colnames(sdata$X), c("Intercept", "xb")) # should not drop level "c" sdata <- standata(y ~ x, data = dat, drop_unused_levels = FALSE) expect_equal(colnames(sdata$X), c("Intercept", "xb", "xc")) }) test_that("Group prior weights are correctly created", { # For example with a single grouping variable wtd_epilepsy <- epilepsy patient_weights <- c(1, rep(c(0.9, 1.1), each = 29)) wtd_epilepsy[['patient_samp_wgt']] <- patient_weights[match(epilepsy$patient, levels(epilepsy$patient))] sdata <- standata( count ~ Trt + (1 + Trt | gr(patient, pw = patient_samp_wgt)), data = wtd_epilepsy, family = gaussian() ) expect_equal(as.vector(sdata[['PW_1']]), patient_weights) # Multiple grouping variables # with one variable whose factor level order differs from order of appearance wtd_epilepsy[['random_group']] <- rep(c('d', 'b', 'a', 'c'), times = 59) wtd_epilepsy[['random_group_wgt']] <- rep(c(0.8, 1.2, 0.7, 1.3), times = 59) sdata <- standata( count ~ Trt + (1 + Trt | gr(patient, pw = patient_samp_wgt)) + (1 | gr(random_group, pw = random_group_wgt)), data = wtd_epilepsy, family = gaussian() ) expect_equal(as.vector(sdata[['PW_2']]), c(0.7, 1.2, 1.3, 0.8)) # Model with multiple outcomes dat <- data.frame( y1 = rnorm(10), y2 = rnorm(10), x = 1:10, g1 = c(2, 2, rep(2:4, each = 2), 1:2), g1wgt = c(1.1, 1.1, 1.1, 1.1, 1.0, 1.0, 1.2, 1.2, 0.9, 1.1), g2 = rep(1:2, each = 5), g2wgt = rep(c(0.9, 1.1), each = 5), censi = sample(0:1, 10, TRUE) ) form <- bf(mvbind(y1, y2) ~ x + (1 | gr(g1, pw = g1wgt)) + (1 | gr(g2, pw = g2wgt))) + set_rescor(TRUE) prior <- prior(horseshoe(2), resp = "y1") + prior(horseshoe(2), resp = "y2") sdata <- standata(form, dat, prior = prior) expect_in(c("PW_1", "PW_4"), names(sdata)) # multi-membership model # (note some levels only appear in g1 or g2, not both) sdata <- SW(standata(y1 ~ x + (x | mm(g1, g2, pw = cbind(g1wgt, g2wgt))), data = dat)) expect_equal(as.vector(sdata$PW_1), c(0.9, 1.1, 1.0, 1.2)) # test informative error and warning messages expect_error( standata( count ~ Trt + (1 | gr(patient, pw = bad_group_wgt)), data = wtd_epilepsy |> transform(bad_group_wgt = runif(n = nrow(wtd_epilepsy))), family = gaussian() ), "Prior weights cannot vary within a group" ) # Informative error or warning for bad weight variables wtd_epilepsy[['bad_random_group_wgt']] <- rep(c(0.8, 1.2, 'a', 1.3), times = 59) expect_error( standata( count ~ Trt + (1 | gr(random_group, pw = bad_random_group_wgt)), data = wtd_epilepsy, family = gaussian() ), "must be numeric" ) wtd_epilepsy[['bad_random_group_wgt']] <- rep(c(0.8, 1.2, -1, 1.3), times = 59) expect_warning( standata( count ~ Trt + (1 | gr(random_group, pw = bad_random_group_wgt)), data = wtd_epilepsy, family = gaussian() ), "Negative prior weights detected" ) }) brms/tests/testthat/tests.data-helpers.R0000644000176200001440000000215314424476034020065 0ustar liggesuserscontext("Tests for data helper functions") test_that("validate_newdata handles factors correctly", { fit <- brms:::rename_pars(brms:::brmsfit_example1) fit$data$fac <- factor(sample(1:3, nrow(fit$data), TRUE)) newdata <- fit$data[1:5, ] expect_silent(brms:::validate_newdata(newdata, fit)) newdata$visit <- 1:5 expect_error(brms:::validate_newdata(newdata, fit), "Levels '5' of grouping factor 'visit' cannot") newdata$fac <- 1:5 expect_error(brms:::validate_newdata(newdata, fit), "New factor levels are not allowed") }) test_that("validate_data returns correct model.frames", { dat <- data.frame(y = 1:5, x = 1:5, z = 6:10, g = 5:1) bterms <- brmsterms(y ~ as.numeric(x) + (as.factor(z) | g), family = gaussian()) mf <- brms:::validate_data(dat, bterms = bterms) expect_true(all(c("x", "z") %in% names(mf))) bterms <- brmsterms(y ~ 1 + (1|g/x/z), family = gaussian()) mf <- brms:::validate_data(dat, bterms = bterms) expect_equal(mf[["g:x"]], paste0(dat$g, "_", dat$x)) expect_equal(mf[["g:x:z"]], paste0(dat$g, "_", dat$x, "_", dat$z)) }) brms/tests/testthat/tests.posterior_predict.R0000644000176200001440000003511415053072461021252 0ustar liggesuserscontext("Tests for posterior_predict helper functions") test_that("posterior_predict for location shift models runs without errors", { ns <- 30 nobs <- 10 prep <- structure(list(ndraws = ns), class = "brmsprep") prep$dpars <- list( mu = matrix(rnorm(ns * nobs), ncol = nobs), sigma = rchisq(ns, 3), nu = rgamma(ns, 4) ) i <- sample(nobs, 1) pred <- brms:::posterior_predict_gaussian(i, prep = prep) expect_equal(length(pred), ns) pred <- brms:::posterior_predict_student(i, prep = prep) expect_equal(length(pred), ns) }) test_that("posterior_predict for various skewed models runs without errors", { ns <- 50 nobs <- 2 prep <- structure(list(ndraws = ns), class = "brmsprep") prep$dpars <- list( sigma = rchisq(ns, 3), beta = rchisq(ns, 3), mu = matrix(rnorm(ns * nobs), ncol = nobs), alpha = rnorm(ns), ndt = 1 ) pred <- brms:::posterior_predict_lognormal(1, prep = prep) expect_equal(length(pred), ns) pred <- brms:::posterior_predict_shifted_lognormal(1, prep = prep) expect_equal(length(pred), ns) pred <- brms:::posterior_predict_exgaussian(1, prep = prep) expect_equal(length(pred), ns) pred <- brms:::posterior_predict_skew_normal(1, prep = prep) expect_equal(length(pred), ns) }) test_that("posterior_predict for aysm_laplace models runs without errors", { ns <- 50 prep <- structure(list(ndraws = ns), class = "brmsprep") prep$dpars <- list( sigma = rchisq(ns, 3), quantile = rbeta(ns, 2, 1), mu = matrix(rnorm(ns*2), ncol = 2), zi = rbeta(ns, 10, 10) ) pred <- brms:::posterior_predict_asym_laplace(1, prep = prep) expect_equal(length(pred), ns) pred <- brms:::posterior_predict_zero_inflated_asym_laplace(1, prep = prep) expect_equal(length(pred), ns) }) test_that("posterior_predict for multivariate linear models runs without errors", { ns <- 10 nvars <- 3 ncols <- 4 nobs <- nvars * ncols Sigma = array(cov(matrix(rnorm(300), ncol = 3)), dim = c(3, 3, 10)) prep <- structure(list(ndraws = ns), class = "mvbrmsprep") prep$mvpars <- list( Mu = array(rnorm(ns*nobs*nvars), dim = c(ns, nobs, nvars)), Sigma = aperm(Sigma, c(3, 1, 2)) ) prep$dpars <- list(nu = rgamma(ns, 5)) prep$data <- list(N = nobs, N_trait = ncols) pred <- brms:::posterior_predict_gaussian_mv(1, prep = prep) expect_equal(dim(pred), c(ns, nvars)) pred <- brms:::posterior_predict_student_mv(2, prep = prep) expect_equal(dim(pred), c(ns, nvars)) }) test_that("posterior_predict for ARMA covariance models runs without errors", { ns <- 20 nobs <- 15 prep <- structure(list(ndraws = ns), class = "brmsprep") prep$dpars <- list( mu = matrix(rnorm(ns*nobs), ncol = nobs), sigma = rchisq(ns, 3), nu = rgamma(ns, 5) ) prep$ac <- list( ar = matrix(rbeta(ns, 0.5, 0.5), ncol = 1), ma = matrix(rnorm(ns, 0.2, 1), ncol = 1), begin_tg = c(1, 5, 12), end_tg = c(4, 11, 15) ) prep$data <- list(se = rgamma(ns, 10)) prep$family$fun <- "gaussian_time" pred <- brms:::posterior_predict_gaussian_time(1, prep = prep) expect_equal(length(pred), ns * 4) prep$family$fun <- "student_time" pred <- brms:::posterior_predict_student_time(2, prep = prep) expect_equal(length(pred), ns * 7) }) test_that("loglik for SAR models runs without errors", { ns = 3 prep <- structure(list(ndraws = ns, nobs = 10), class = "brmsprep") prep$dpars <- list( mu = matrix(rnorm(30), nrow = ns), nu = rep(2, ns), sigma = rep(10, ns) ) prep$ac <- list(lagsar = matrix(c(0.3, 0.5, 0.7)), Msar = diag(10)) pred <- brms:::posterior_predict_gaussian_lagsar(1, prep = prep) expect_equal(dim(pred), c(3, 10)) pred <- brms:::posterior_predict_student_lagsar(1, prep = prep) expect_equal(dim(pred), c(3, 10)) prep$ac$errorsar <- prep$ac$lagsar prep$ac$lagsar <- NULL pred <- brms:::posterior_predict_gaussian_errorsar(1, prep = prep) expect_equal(dim(pred), c(3, 10)) pred <- brms:::posterior_predict_student_errorsar(1, prep = prep) expect_equal(dim(pred), c(3, 10)) }) test_that("posterior_predict for FCOR models runs without errors", { ns <- 3 nobs <- 10 prep <- structure(list(ndraws = ns, nobs = nobs), class = "brmsprep") prep$dpars <- list( mu = matrix(rnorm(nobs * ns), nrow = ns), sigma = rep(1, ns), nu = rep(2, ns) ) prep$ac <- list(Mfcor = diag(nobs)) pred <- brms:::posterior_predict_gaussian_fcor(1, prep = prep) expect_equal(dim(pred), c(ns, nobs)) pred <- brms:::posterior_predict_student_fcor(1, prep = prep) expect_equal(dim(pred), c(ns, nobs)) }) test_that("posterior_predict for count and survival models runs without errors", { ns <- 25 nobs <- 10 trials <- sample(10:30, nobs, replace = TRUE) prep <- structure(list(ndraws = ns, nobs = nobs), class = "brmsprep") prep$dpars <- list( eta = matrix(rnorm(ns * nobs), ncol = nobs), shape = rgamma(ns, 4), xi = 0, phi = rgamma(ns, 1) ) prep$dpars$nu <- prep$dpars$sigma <- prep$dpars$shape + 1 prep$data <- list(trials = trials) i <- sample(nobs, 1) prep$dpars$mu <- brms:::inv_cloglog(prep$dpars$eta) pred <- brms:::posterior_predict_binomial(i, prep = prep) expect_equal(length(pred), ns) pred <- brms:::posterior_predict_beta_binomial(i, prep = prep) expect_equal(length(pred), ns) pred <- brms:::posterior_predict_discrete_weibull(i, prep = prep) expect_equal(length(pred), ns) prep$dpars$mu <- exp(prep$dpars$eta) pred <- brms:::posterior_predict_poisson(i, prep = prep) expect_equal(length(pred), ns) pred <- brms:::posterior_predict_negbinomial(i, prep = prep) expect_equal(length(pred), ns) pred <- brms:::posterior_predict_negbinomial2(i, prep = prep) expect_equal(length(pred), ns) pred <- brms:::posterior_predict_geometric(i, prep = prep) expect_equal(length(pred), ns) pred <- brms:::posterior_predict_com_poisson(i, prep = prep) expect_equal(length(pred), ns) pred <- brms:::posterior_predict_exponential(i, prep = prep) expect_equal(length(pred), ns) pred <- brms:::posterior_predict_gamma(i, prep = prep) expect_equal(length(pred), ns) pred <- brms:::posterior_predict_frechet(i, prep = prep) expect_equal(length(pred), ns) pred <- brms:::posterior_predict_inverse.gaussian(i, prep = prep) expect_equal(length(pred), ns) pred <- brms:::posterior_predict_gen_extreme_value(i, prep = prep) expect_equal(length(pred), ns) prep$family$link <- "log" pred <- brms:::posterior_predict_weibull(i, prep = prep) expect_equal(length(pred), ns) }) test_that("posterior_predict for bernoulli and beta models works correctly", { ns <- 17 nobs <- 10 prep <- structure(list(ndraws = ns, nobs = nobs), class = "brmsprep") prep$dpars <- list( mu = brms:::inv_logit(matrix(rnorm(ns * nobs * 2), ncol = 2 * nobs)), phi = rgamma(ns, 4) ) i <- sample(1:nobs, 1) pred <- brms:::posterior_predict_bernoulli(i, prep = prep) expect_equal(length(pred), ns) pred <- brms:::posterior_predict_beta(i, prep = prep) expect_equal(length(pred), ns) }) test_that("posterior_predict for xbeta models works correctly", { skip_if_not_installed("betareg") ns <- 17 nobs <- 10 prep <- structure(list(ndraws = ns, nobs = nobs), class = "brmsprep") prep$dpars <- list( mu = brms:::inv_logit(matrix(rnorm(ns * nobs * 2), ncol = 2 * nobs)), phi = rgamma(ns, 4), kappa = rexp(ns, 5) ) i <- sample(1:nobs, 1) pred <- brms:::posterior_predict_xbeta(i, prep = prep) expect_equal(length(pred), ns) pred <- brms:::posterior_predict_xbeta(i, prep = prep) expect_equal(length(pred), ns) }) test_that("posterior_predict for circular models runs without errors", { ns <- 15 nobs <- 10 prep <- structure(list(ndraws = ns, nobs = nobs), class = "brmsprep") prep$dpars <- list( mu = 2 * atan(matrix(rnorm(ns * nobs * 2), ncol = nobs * 2)), kappa = rgamma(ns, 4) ) i <- sample(seq_len(nobs), 1) pred <- brms:::posterior_predict_von_mises(i, prep = prep) expect_equal(length(pred), ns) }) test_that("posterior_predict for zero-inflated and hurdle models runs without erros", { ns <- 50 nobs <- 8 trials <- sample(10:30, nobs, replace = TRUE) prep <- structure(list(ndraws = ns, nobs = nobs), class = "brmsprep") prep$dpars <- list( eta = matrix(rnorm(ns * nobs * 2), ncol = nobs * 2), shape = rgamma(ns, 4), phi = rgamma(ns, 1), zi = rbeta(ns, 1, 1), coi = rbeta(ns, 5, 7) ) prep$dpars$hu <- prep$dpars$zoi <- prep$dpars$zi prep$data <- list(trials = trials) prep$dpars$mu <- exp(prep$dpars$eta) pred <- brms:::posterior_predict_hurdle_poisson(1, prep = prep) expect_equal(length(pred), ns) pred <- brms:::posterior_predict_hurdle_negbinomial(2, prep = prep) expect_equal(length(pred), ns) pred <- brms:::posterior_predict_hurdle_gamma(5, prep = prep) expect_equal(length(pred), ns) pred <- brms:::posterior_predict_zero_inflated_poisson(3, prep = prep) expect_equal(length(pred), ns) pred <- brms:::posterior_predict_zero_inflated_negbinomial(6, prep = prep) expect_equal(length(pred), ns) prep$dpars$mu <- brms:::inv_logit(prep$dpars$eta) pred <- brms:::posterior_predict_zero_inflated_binomial(4, prep = prep) expect_equal(length(pred), ns) pred <- brms:::posterior_predict_zero_inflated_beta_binomial(6, prep = prep) expect_equal(length(pred), ns) pred <- brms:::posterior_predict_zero_inflated_beta(8, prep = prep) expect_equal(length(pred), ns) pred <- brms:::posterior_predict_zero_one_inflated_beta(7, prep = prep) expect_equal(length(pred), ns) }) test_that("posterior_predict for ordinal models runs without errors", { ns <- 50 nobs <- 8 nthres <- 3 ncat <- nthres + 1 prep <- structure(list(ndraws = ns, nobs = nobs), class = "brmsprep") prep$dpars <- list( mu = array(rnorm(ns * nobs), dim = c(ns, nobs)), disc = rexp(ns), hu = rbeta(ns, 1, 1) ) prep$thres$thres <- array(0, dim = c(ns, nthres)) prep$data <- list(Y = rep(1:ncat, 2), ncat = ncat) prep$family$link <- "logit" prep$family$family <- "cumulative" pred <- sapply(1:nobs, brms:::posterior_predict_cumulative, prep = prep) expect_equal(dim(pred), c(ns, nobs)) prep$family$family <- "sratio" pred <- sapply(1:nobs, brms:::posterior_predict_sratio, prep = prep) expect_equal(dim(pred), c(ns, nobs)) prep$family$family <- "cratio" pred <- sapply(1:nobs, brms:::posterior_predict_cratio, prep = prep) expect_equal(dim(pred), c(ns, nobs)) prep$family$family <- "acat" pred <- sapply(1:nobs, brms:::posterior_predict_acat, prep = prep) expect_equal(dim(pred), c(ns, nobs)) prep$family$link <- "probit" pred <- sapply(1:nobs, brms:::posterior_predict_acat, prep = prep) expect_equal(dim(pred), c(ns, nobs)) prep$family$family <- "hurdle_cumulative" pred <- sapply(1:nobs, brms:::posterior_predict_hurdle_cumulative, prep = prep) expect_equal(dim(pred), c(ns, nobs)) }) test_that("posterior_predict for categorical and related models runs without erros", { set.seed(1234) ns <- 50 nobs <- 8 ncat <- 3 prep <- structure(list(ndraws = ns, nobs = nobs), class = "brmsprep") prep$dpars <- list( mu1 = array(rnorm(ns*nobs, 0, 0.1), dim = c(ns, nobs)), mu2 = array(rnorm(ns*nobs, 0, 0.1), dim = c(ns, nobs)) ) prep$data <- list(Y = rep(1:ncat, 2), ncat = ncat) prep$family <- categorical() prep$refcat <- 1 pred <- sapply(1:nobs, brms:::posterior_predict_categorical, prep = prep) expect_equal(dim(pred), c(ns, nobs)) prep$data$trials <- sample(1:20, nobs) prep$family <- multinomial() pred <- brms:::posterior_predict_multinomial(i = sample(1:nobs, 1), prep = prep) expect_equal(dim(pred), c(ns, ncat)) prep$data$trials <- sample(1:20, nobs) prep$dpars$phi <- rexp(ns, 1) prep$family <- dirichlet_multinomial() pred <- brms:::posterior_predict_dirichlet_multinomial(i = sample(1:nobs, 1), prep = prep) expect_equal(dim(pred), c(ns, ncat)) prep$dpars$phi <- rexp(ns, 1) prep$family <- dirichlet() pred <- brms:::posterior_predict_dirichlet(i = sample(1:nobs, 1), prep = prep) expect_equal(dim(pred), c(ns, ncat)) expect_equal(rowSums(pred), rep(1, nrow(pred))) prep$family <- brmsfamily("dirichlet2") prep$dpars$mu1 <- rexp(ns, 10) prep$dpars$mu2 <- rexp(ns, 10) prep$dpars$mu3 <- rexp(ns, 10) pred <- brms:::posterior_predict_dirichlet2(i = sample(1:nobs, 1), prep = prep) expect_equal(dim(pred), c(ns, ncat)) expect_equal(rowSums(pred), rep(1, nrow(pred))) prep$family <- brmsfamily("logistic_normal") prep$dpars <- list( mu2 = rnorm(ns), mu3 = rnorm(ns), sigma2 = rexp(ns, 10), sigma3 = rexp(ns, 10) ) prep$lncor <- rbeta(ns, 2, 1) pred <- brms:::posterior_predict_logistic_normal(i = sample(1:nobs, 1), prep = prep) expect_equal(dim(pred), c(ns, ncat)) expect_equal(rowSums(pred), rep(1, nrow(pred))) }) test_that("truncated posterior_predict run without errors", { ns <- 30 nobs <- 15 prep <- structure(list(ndraws = ns, nobs = nobs), class = "brmsprep") prep$dpars <- list( mu = matrix(rnorm(ns * nobs), ncol = nobs), sigma = rchisq(ns, 3) ) prep$refcat <- 1 prep$data <- list(lb = sample(-(4:7), nobs, TRUE)) pred <- sapply(1:nobs, brms:::posterior_predict_gaussian, prep = prep) expect_equal(dim(pred), c(ns, nobs)) prep$dpars$mu <- exp(prep$dpars$mu) prep$data <- list(ub = sample(70:80, nobs, TRUE)) pred <- sapply(1:nobs, brms:::posterior_predict_poisson, prep = prep) expect_equal(dim(pred), c(ns, nobs)) prep$data <- list(lb = rep(0, nobs), ub = sample(70:75, nobs, TRUE)) pred <- sapply(1:nobs, brms:::posterior_predict_poisson, prep = prep) expect_equal(dim(pred), c(ns, nobs)) }) test_that("posterior_predict for the wiener diffusion model runs without errors", { skip("skip as long as RWiener fails on R-devel for 3.6.0") ns <- 5 nobs <- 3 prep <- structure(list(ndraws = ns, nobs = nobs), class = "brmsprep") prep$dpars <- list( mu = matrix(rnorm(ns * nobs), ncol = nobs), bs = rchisq(ns, 3), ndt = rep(0.5, ns), bias = rbeta(ns, 1, 1) ) prep$data <- list(Y = abs(rnorm(ns)) + 0.5, dec = c(1, 0, 1)) i <- sample(1:nobs, 1) expect_equal(nrow(brms:::posterior_predict_wiener(i, prep)), ns) }) test_that("posterior_predict_custom runs without errors", { ns <- 15 nobs <- 10 prep <- structure(list(ndraws = ns, nobs = nobs), class = "brmsprep") prep$dpars <- list( mu = matrix(rbeta(ns * nobs * 2, 1, 1), ncol = nobs * 2) ) prep$data <- list(trials = rep(1, nobs)) prep$family <- custom_family( "beta_binomial2", dpars = c("mu", "tau"), links = c("logit", "log"), lb = c(NA, 0), type = "int", vars = "trials[n]" ) posterior_predict_beta_binomial2 <- function(i, prep) { mu <- prep$dpars$mu[, i] rbinom(prep$ndraws, size = prep$data$trials[i], prob = mu) } expect_equal(length(brms:::posterior_predict_custom(sample(1:nobs, 1), prep)), ns) }) brms/tests/testthat/tests.rename_pars.R0000644000176200001440000000070414213413565020004 0ustar liggesuserscontext("Tests for renaming helper functions") test_that("make_index_names returns correct 1 and 2 dimensional indices", { expect_equal(make_index_names(rownames = 1:2), c("[1]", "[2]")) expect_equal(make_index_names(rownames = 1:2, colnames = 1:3, dim = 1), c("[1]", "[2]")) expect_equal(make_index_names(rownames = c("a","b"), colnames = 1:3, dim = 2), c("[a,1]", "[b,1]", "[a,2]", "[b,2]", "[a,3]", "[b,3]")) }) brms/tests/testthat/tests.log_lik.R0000644000176200001440000004473215056555177017155 0ustar liggesuserscontext("Tests for log_lik helper functions") test_that("log_lik for location shift models works as expected", { ns <- 25 prep <- structure(list(), class = "brmsprep") prep$dpars <- list( mu = matrix(rnorm(ns * 2), ncol = 2), sigma = rchisq(ns, 3), nu = rgamma(ns, 4) ) prep$family <- gaussian() prep$family$fun <- "gaussian" prep$data <- list(Y = rnorm(ns)) ll_gaussian <- dnorm( x = prep$data$Y[1], mean = prep$dpars$mu[, 1], sd = prep$dpars$sigma, log = TRUE ) ll <- brms:::log_lik_gaussian(1, prep = prep) expect_equal(ll, ll_gaussian) ll_student <- dstudent_t( x = prep$data$Y[2], df = prep$dpars$nu, mu = prep$dpars$mu[, 2], sigma = prep$dpars$sigma, log = TRUE ) ll <- brms:::log_lik_student(2, prep = prep) expect_equal(ll, ll_student) # also test weighting prep$data$weights <- sample(1:10, ns, replace = TRUE) ll <- brms:::log_lik_gaussian(1, prep = prep) expect_equal(ll, ll_gaussian * prep$data$weights[1]) }) test_that("log_lik for various skewed normal models works as expected", { ns <- 50 prep <- structure(list(), class = "brmsprep") prep$dpars <- list( sigma = rchisq(ns, 3), beta = rchisq(ns, 3), mu = matrix(rnorm(ns*2), ncol = 2), alpha = rnorm(ns), ndt = 1 ) prep$data <- list(Y = rlnorm(ns)) ll_lognormal <- dlnorm( x = prep$data$Y[1], mean = prep$dpars$mu[, 1], sd = prep$dpars$sigma, log = TRUE ) ll <- brms:::log_lik_lognormal(1, prep = prep) expect_equal(ll, ll_lognormal) ll_shifted_lognormal <- dshifted_lnorm( x = prep$data$Y[1], mean = prep$dpars$mu[, 1], sd = prep$dpars$sigma, shift = prep$dpars$ndt, log = TRUE ) ll <- brms:::log_lik_shifted_lognormal(1, prep = prep) expect_equal(ll, ll_shifted_lognormal) ll_exgaussian <- dexgaussian( x = prep$data$Y[1], mu = prep$dpars$mu[, 1], sigma = prep$dpars$sigma, beta = prep$dpars$beta, log = TRUE ) ll <- brms:::log_lik_exgaussian(1, prep = prep) expect_equal(ll, ll_exgaussian) ll_skew_normal <- dskew_normal( x = prep$data$Y[1], mu = prep$dpars$mu[, 1], sigma = prep$dpars$sigma, alpha = prep$dpars$alpha, log = TRUE ) ll <- as.numeric(brms:::log_lik_skew_normal(1, prep = prep)) expect_equal(ll, ll_skew_normal) }) test_that("log_lik of aysm_laplace models runs without errors", { ns <- 50 prep <- structure(list(), class = "brmsprep") prep$dpars <- list( sigma = rchisq(ns, 3), quantile = rbeta(ns, 2, 1), mu = matrix(rnorm(ns*2), ncol = 2), zi = rbeta(ns, 10, 10) ) prep$data <- list(Y = brms:::rasym_laplace(ns)) ll <- brms:::log_lik_asym_laplace(1, prep = prep) expect_equal(length(ll), ns) ll <- brms:::log_lik_zero_inflated_asym_laplace(1, prep = prep) expect_equal(length(ll), ns) }) test_that("log_lik for multivariate linear models runs without errors", { ns <- 10 nvars <- 3 ncols <- 4 nobs <- nvars * ncols prep <- structure(list(), class = "mvbrmsprep") Sigma = array(cov(matrix(rnorm(300), ncol = 3)), dim = c(3, 3, 10)) prep$mvpars <- list( Mu = array(rnorm(ns*nobs*nvars), dim = c(ns, nobs, nvars)), Sigma = aperm(Sigma, c(3, 1, 2)) ) prep$dpars <- list(nu = rgamma(ns, 5)) prep$ndraws <- ns prep$data <- list(Y = matrix(rnorm(nobs), ncol = nvars)) ll <- brms:::log_lik_gaussian_mv(1, prep = prep) expect_equal(length(ll), ns) ll <- brms:::log_lik_student_mv(2, prep = prep) expect_equal(length(ll), ns) }) test_that("log_lik for ARMA models runs without errors", { ns <- 20 nobs <- 15 prep <- structure(list(ndraws = ns), class = "brmsprep") prep$dpars <- list( mu = matrix(rnorm(ns*nobs), ncol = nobs), sigma = rchisq(ns, 3), nu = rgamma(ns, 5) + 15 ) prep$ac <- list( ar = matrix(rbeta(ns, 0.5, 0.5), ncol = 1), ma = matrix(rbeta(ns, 0.2, 1), ncol = 1), begin_tg = 2, end_tg = 5 ) prep$data <- list(Y = rnorm(nobs), se = rgamma(ns, 10)) prep$family$fun <- "gaussian_time" ll <- brms:::log_lik_gaussian_time(1, prep = prep) expect_equal(dim(ll), c(ns, 4)) prep$family$fun <- "student_time" ll <- brms:::log_lik_student_time(1, prep = prep) expect_equal(dim(ll), c(ns, 4)) }) test_that("log_lik for SAR models runs without errors", { prep <- structure(list(ndraws = 3, nobs = 10), class = "brmsprep") prep$dpars <- list( mu = matrix(rnorm(30), nrow = 3), nu = rep(10, 3), sigma = rep(10, 3) ) prep$ac <- list( lagsar = matrix(c(0.3, 0.5, 0.7)), Msar = diag(10) ) prep$data <- list(Y = rnorm(10)) ll <- brms:::log_lik_gaussian_lagsar(1, prep = prep) expect_equal(dim(ll), c(3, 10)) ll <- brms:::log_lik_student_lagsar(1, prep = prep) expect_equal(dim(ll), c(3, 10)) prep$ac$errorsar <- prep$ac$lagsar prep$ac$lagsar <- NULL ll <- brms:::log_lik_gaussian_errorsar(1, prep = prep) expect_equal(dim(ll), c(3, 10)) ll <- brms:::log_lik_student_errorsar(1, prep = prep) expect_equal(dim(ll), c(3, 10)) }) test_that("log_lik for FCOR models runs without errors", { ns <- 3 nobs <- 10 prep <- structure(list(ndraws = ns, nobs = nobs), class = "brmsprep") prep$dpars <- list( mu = matrix(rnorm(nobs * ns), nrow = ns), sigma = rep(1, ns), nu = rep(10, ns) ) prep$ac <- list(Mfcor = diag(nobs)) prep$data$Y <- rnorm(nobs) ll <- brms:::log_lik_gaussian_fcor(1, prep = prep) expect_equal(dim(ll), c(ns, nobs)) ll <- brms:::log_lik_student_fcor(1, prep = prep) expect_equal(dim(ll), c(ns, nobs)) }) test_that("log_lik for FCOR student-t models works as expected", { ns <- 3 nobs <- 4 prep <- structure(list(ndraws = ns, nobs = nobs), class = "brmsprep") prep$data$Y <- rnorm(nobs) prep$dpars <- list( mu = matrix(rnorm(nobs * ns), nrow = ns), sigma = rgamma(ns, 2), nu = rgamma(ns, 5) ) # Set up acframe for fcor A <- matrix(rnorm(nobs^2), nobs, nobs) M <- t(A) %*% A + diag(nobs) * 0.1 s_diag <- sqrt(diag(M)) Mfcor <- M / (s_diag %*% t(s_diag)) acframe <- data.frame(class = "fcor", cov = TRUE, stringsAsFactors = FALSE) class(acframe) <- c("acframe", "data.frame") prep$ac <- list(Mfcor = Mfcor, acframe = acframe) ll <- brms:::log_lik_student_fcor(1, prep = prep) # Naively compute log-likelihoods using # https://en.wikipedia.org/wiki/Multivariate_t-distribution#Conditional_Distribution ll_student <- matrix(0, ns, nobs) for (s in 1:ns) { df <- prep$dpars$nu[s] mu <- prep$dpars$mu[s, ] sigma <- prep$dpars$sigma[s] Sigma <- sigma^2 * prep$ac$Mfcor dfloo <- df + nobs - 1 for (i in 1:nobs) { e_ic <- (prep$data$Y[-i] - mu[-i]) Sigma_ic <- Sigma[-i, -i] Sigma_i_ic <- Sigma[i, -i] inv_Sigma_ic_e <- solve(Sigma_ic, e_ic) d_ic <- t(e_ic) %*% inv_Sigma_ic_e sigma_scale <- (df + d_ic) / dfloo schur <- Sigma[i, i] - Sigma_i_ic %*% solve(Sigma_ic, Sigma_i_ic) mu_cond_i <- mu[i] + Sigma_i_ic %*% inv_Sigma_ic_e sigma_cond_i <- sqrt(sigma_scale * schur) y_i <- prep$data$Y[i] ll_student[s, i] <- dstudent_t(y_i, dfloo, mu_cond_i, sigma_cond_i, log = TRUE) } } expect_equal(ll, ll_student) }) test_that("log_lik for count and survival models works correctly", { skip_if_not_installed("extraDistr") ns <- 25 nobs <- 10 trials <- sample(10:30, nobs, replace = TRUE) prep <- structure(list(ndraws = ns, nobs = nobs), class = "brmsprep") prep$dpars <- list( eta = matrix(rnorm(ns*nobs), ncol = nobs), shape = rgamma(ns, 4), xi = runif(ns, -1, 0.5), phi = rgamma(ns, 1) ) prep$dpars$sigma <- 1 / prep$dpars$shape prep$dpars$nu <- prep$dpars$shape + 1 prep$data <- list( Y = rbinom(nobs, size = trials, prob = rbeta(nobs, 1, 1)), trials = trials ) i <- sample(nobs, 1) prep$dpars$mu <- brms:::inv_logit(prep$dpars$eta) ll_binom <- dbinom( x = prep$data$Y[i], prob = prep$dpars$mu[, i], size = prep$data$trials[i], log = TRUE ) ll <- brms:::log_lik_binomial(i, prep = prep) expect_equal(ll, ll_binom) ll_beta_binom <- dbeta_binomial( x = prep$data$Y[i], size = prep$data$trials[i], mu = prep$dpars$mu[, i], phi = prep$dpars$phi, log = TRUE ) ll <- brms:::log_lik_beta_binomial(i, prep = prep) expect_equal(ll, ll_beta_binom) # don't test the actual values as they will be -Inf for this data ll <- brms:::log_lik_discrete_weibull(i, prep = prep) expect_equal(length(ll), ns) prep$dpars$mu <- exp(prep$dpars$eta) ll_pois <- dpois( x = prep$data$Y[i], lambda = prep$dpars$mu[, i], log = TRUE ) ll <- brms:::log_lik_poisson(i, prep = prep) expect_equal(ll, ll_pois) ll_nbinom <- dnbinom( x = prep$data$Y[i], mu = prep$dpars$mu[, i], size = prep$dpars$shape, log = TRUE ) ll <- brms:::log_lik_negbinomial(i, prep = prep) expect_equal(ll, ll_nbinom) ll <- brms:::log_lik_negbinomial2(i, prep = prep) expect_equal(ll, ll_nbinom) ll_geo <- dnbinom( x = prep$data$Y[i], mu = prep$dpars$mu[, i], size = 1, log = TRUE ) ll <- brms:::log_lik_geometric(i, prep = prep) expect_equal(ll, ll_geo) ll_com_pois <- brms:::dcom_poisson( x = prep$data$Y[i], mu = prep$dpars$mu[, i], shape = prep$dpars$shape, log = TRUE ) ll <- brms:::log_lik_com_poisson(i, prep = prep) expect_equal(ll, ll_com_pois) ll_exp <- dexp( x = prep$data$Y[i], rate = 1 / prep$dpars$mu[, i], log = TRUE ) ll <- brms:::log_lik_exponential(i, prep = prep) expect_equal(ll, ll_exp) ll_gamma <- dgamma( x = prep$data$Y[i], shape = prep$dpars$shape, scale = prep$dpars$mu[, i] / prep$dpars$shape, log = TRUE ) ll <- brms:::log_lik_gamma(i, prep = prep) expect_equal(ll, ll_gamma) scale <- prep$dpars$mu[, i] / gamma(1 - 1 / prep$dpars$nu) ll_frechet <- dfrechet( x = prep$data$Y[i], shape = prep$dpars$nu, scale = scale, log = TRUE ) ll <- brms:::log_lik_frechet(i, prep = prep) expect_equal(ll, ll_frechet) ll_invgauss <- dinv_gaussian( x = prep$data$Y[i], shape = prep$dpars$shape, mu = prep$dpars$mu[, i], log = TRUE ) ll <- brms:::log_lik_inverse.gaussian(i, prep = prep) expect_equal(ll, ll_invgauss) ll_weibull <- dweibull( x = prep$data$Y[i], shape = prep$dpars$shape, scale = prep$dpars$mu[, i] / gamma(1 + 1 / prep$dpars$shape), log = TRUE ) ll <- brms:::log_lik_weibull(i, prep = prep) expect_equal(ll, c(ll_weibull)) # keep test at the end prep$family$link <- "identity" prep$data$Y[i] <- 0 ll_gen_extreme_value <- SW(dgen_extreme_value( x = prep$data$Y[i], mu = prep$dpars$mu[, i], sigma = prep$dpars$sigma, xi = prep$dpars$xi, log = TRUE )) ll <- SW(brms:::log_lik_gen_extreme_value(i, prep = prep)) expect_equal(ll, ll_gen_extreme_value) }) test_that("log_lik for bernoulli and beta models works correctly", { ns <- 15 nobs <- 10 prep <- structure(list(ndraws = ns, nobs = nobs), class = "brmsprep") prep$dpars <- list( mu = brms:::inv_logit(matrix(rnorm(ns * nobs * 2), ncol = nobs * 2)), phi = rgamma(ns, 4) ) prep$data <- list(Y = sample(0:1, nobs, replace = TRUE)) i <- sample(1:nobs, 1) ll_bern <- dbinom( x = prep$data$Y[i], prob = prep$dpars$mu[, i], size = 1, log = TRUE ) ll <- brms:::log_lik_bernoulli(i, prep = prep) expect_equal(ll, ll_bern) prep$data <- list(Y = rbeta(nobs, 1, 1)) ll_beta <- dbeta( x = prep$data$Y[i], shape1 = prep$dpars$mu[, i] * prep$dpars$phi, shape2 = (1 - prep$dpars$mu[, i]) * prep$dpars$phi, log = TRUE ) ll <- brms:::log_lik_beta(i, prep = prep) expect_equal(ll, ll_beta) }) test_that("log_lik for circular models runs without errors", { ns <- 15 nobs <- 10 prep <- structure(list(ndraws = ns, nobs = nobs), class = "brmsprep") prep$dpars <- list( mu = 2 * atan(matrix(rnorm(ns * nobs * 2), ncol = nobs * 2)), kappa = rgamma(ns, 4) ) prep$data <- list(Y = runif(nobs, -pi, pi)) i <- sample(seq_len(nobs), 1) ll <- brms:::log_lik_von_mises(i, prep = prep) expect_equal(length(ll), ns) prep$data$cens <- sample(-1:1, nobs, TRUE) ll <- brms:::log_lik_von_mises(i, prep = prep) expect_equal(length(ll), ns) }) test_that("log_lik for zero-inflated and hurdle models runs without erros", { skip_if_not_installed("extraDistr") ns <- 50 nobs <- 8 trials <- sample(10:30, nobs, replace = TRUE) resp <- rbinom(nobs, size = trials, prob = rbeta(nobs, 1, 1)) prep <- structure(list(ndraws = ns, nobs = nobs), class = "brmsprep") prep$dpars <- list( eta = matrix(rnorm(ns*nobs), ncol = nobs), shape = rgamma(ns, 4), phi = rgamma(ns, 1), zi = rbeta(ns, 1, 1), coi = rbeta(ns, 5, 7) ) prep$dpars$hu <- prep$dpars$zoi <- prep$dpars$zi prep$data <- list(Y = c(resp, rep(0, 4)), trials = trials) prep$dpars$mu <- exp(prep$dpars$eta) ll <- brms:::log_lik_hurdle_poisson(1, prep = prep) expect_equal(length(ll), ns) ll <- brms:::log_lik_hurdle_negbinomial(5, prep = prep) expect_equal(length(ll), ns) ll <- brms:::log_lik_hurdle_gamma(2, prep = prep) expect_equal(length(ll), ns) ll <- brms:::log_lik_hurdle_gamma(8, prep = prep) expect_equal(length(ll), ns) ll <- brms:::log_lik_zero_inflated_poisson(3, prep = prep) expect_equal(length(ll), ns) ll <- brms:::log_lik_zero_inflated_negbinomial(6, prep = prep) expect_equal(length(ll), ns) prep$dpars$mu <- brms:::inv_logit(prep$dpars$eta) ll <- brms:::log_lik_zero_inflated_binomial(4, prep = prep) expect_equal(length(ll), ns) ll <- brms:::log_lik_zero_inflated_beta_binomial(7, prep = prep) expect_equal(length(ll), ns) prep$data$Y[1:nobs] <- rbeta(nobs / 2, 0.5, 4) ll <- brms:::log_lik_zero_inflated_beta(6, prep = prep) expect_equal(length(ll), ns) ll <- brms:::log_lik_zero_one_inflated_beta(7, prep = prep) expect_equal(length(ll), ns) }) test_that("log_lik for ordinal models runs without erros", { ns <- 50 nobs <- 8 nthres <- 3 ncat <- nthres + 1 prep <- structure(list(ndraws = ns, nobs = nobs), class = "brmsprep") prep$dpars <- list( mu = array(rnorm(ns * nobs), dim = c(ns, nobs)), disc = rexp(ns), hu = rbeta(ns, 1, 1) ) prep$thres$thres <- array(0, dim = c(ns, nthres)) prep$data <- list(Y = rep(1:ncat, 2), ncat = ncat) prep$family$link <- "logit" ll <- sapply(1:nobs, brms:::log_lik_cumulative, prep = prep) expect_equal(dim(ll), c(ns, nobs)) ll <- sapply(1:nobs, brms:::log_lik_sratio, prep = prep) expect_equal(dim(ll), c(ns, nobs)) ll <- sapply(1:nobs, brms:::log_lik_cratio, prep = prep) expect_equal(dim(ll), c(ns, nobs)) ll <- sapply(1:nobs, brms:::log_lik_acat, prep = prep) expect_equal(dim(ll), c(ns, nobs)) prep$family$link <- "probit" ll <- sapply(1:nobs, brms:::log_lik_acat, prep = prep) expect_equal(dim(ll), c(ns, nobs)) ll <- brms:::log_lik_hurdle_cumulative(3, prep = prep) expect_equal(length(ll), ns) }) test_that("log_lik for categorical and related models runs without erros", { skip_if_not_installed("extraDistr") ns <- 50 nobs <- 8 ncat <- 3 prep <- structure(list(ndraws = ns, nobs = nobs), class = "brmsprep") prep$dpars <- list( mu1 = array(rnorm(ns*nobs), dim = c(ns, nobs)), mu2 = array(rnorm(ns*nobs), dim = c(ns, nobs)) ) prep$data <- list(Y = rep(1:ncat, 2), ncat = ncat) prep$family <- categorical() prep$refcat <- 1 ll <- sapply(1:nobs, brms:::log_lik_categorical, prep = prep) expect_equal(dim(ll), c(ns, nobs)) prep$data$Y <- matrix( sample(1:20, nobs * ncat, TRUE), nrow = nobs, ncol = ncat ) prep$data$trials <- sample(1:20, nobs) prep$family <- multinomial() ll <- sapply(1:nobs, brms:::log_lik_multinomial, prep = prep) expect_equal(dim(ll), c(ns, nobs)) prep$data$trials <- sample(1:20, nobs) prep$dpars$phi <- rexp(ns, 10) prep$family <- dirichlet_multinomial() ll <- sapply(1:nobs, brms:::log_lik_dirichlet_multinomial, prep = prep) expect_equal(dim(ll), c(ns, nobs)) prep$data$Y <- prep$data$Y / rowSums(prep$data$Y) prep$dpars$phi <- rexp(ns, 10) prep$family <- dirichlet() ll <- sapply(1:nobs, brms:::log_lik_dirichlet, prep = prep) expect_equal(dim(ll), c(ns, nobs)) prep$family <- brmsfamily("dirichlet2") prep$dpars$mu1 <- rexp(ns, 10) prep$dpars$mu2 <- rexp(ns, 10) prep$dpars$mu3 <- rexp(ns, 10) ll <- sapply(1:nobs, brms:::log_lik_dirichlet2, prep = prep) expect_equal(dim(ll), c(ns, nobs)) prep$family <- brmsfamily("logistic_normal") prep$dpars <- list( mu2 = rnorm(ns), mu3 = rnorm(ns), sigma2 = rexp(ns, 10), sigma3 = rexp(ns, 10) ) prep$lncor <- rbeta(ns, 2, 1) ll <- sapply(1:nobs, brms:::log_lik_logistic_normal, prep = prep) expect_equal(dim(ll), c(ns, nobs)) }) test_that("censored and truncated log_lik run without errors", { ns <- 30 nobs <- 3 prep <- structure(list(ndraws = ns, nobs = nobs), class = "brmsprep") prep$dpars <- list( mu = matrix(rnorm(ns * nobs), ncol = nobs), sigma = rchisq(ns, 3) ) prep$data <- list(Y = rnorm(ns), cens = c(-1,0,1)) ll <- sapply(1:nobs, brms:::log_lik_gaussian, prep = prep) expect_equal(dim(ll), c(ns, nobs)) prep$data <- list(Y = sample(-3:3, nobs), lb = -4, ub = 5) ll <- sapply(1:nobs, brms:::log_lik_gaussian, prep = prep) expect_equal(dim(ll), c(ns, nobs)) }) test_that("log_lik for the wiener diffusion model runs without errors", { skip_if_not_installed("RWiener") ns <- 5 nobs <- 3 prep <- structure(list(ndraws = ns, nobs = nobs), class = "brmsprep") prep$dpars <- list( mu = matrix(rnorm(ns * nobs), ncol = nobs), bs = rchisq(ns, 3), ndt = rep(0.5, ns), bias = rbeta(ns, 1, 1) ) prep$data <- list(Y = abs(rnorm(ns)) + 0.5, dec = c(1, 0, 1)) i <- sample(1:nobs, 1) expect_equal(length(brms:::log_lik_wiener(i, prep)), ns) }) test_that("log_lik for the xbeta model runs without errors", { skip_if_not_installed("betareg") ns <- 50 nobs <- 8 prep <- structure(list(ndraws = ns, nobs = nobs), class = "brmsprep") prep$dpars <- list( mu = matrix(rbeta(ns * nobs, 1.2, 2.3), ncol = nobs), phi = rexp(ns, 0.01), kappa = rexp(ns, 2) ) prep$data <- list(Y = rbeta(nobs, 2, 3)) ll <- brms:::log_lik_xbeta(3, prep = prep) expect_equal(length(ll), ns) }) test_that("log_lik_custom runs without errors", { ns <- 15 nobs <- 10 prep <- structure(list(ndraws = ns, nobs = nobs), class = "brmsprep") prep$dpars <- list( mu = matrix(rbeta(ns * nobs * 2, 1, 1), ncol = nobs * 2) ) prep$data <- list( Y = sample(0:1, nobs, replace = TRUE), trials = rep(1, nobs) ) prep$family <- custom_family( "beta_binomial2", dpars = c("mu", "tau"), links = c("logit", "log"), lb = c(NA, 0), type = "int", vars = "trials[n]" ) log_lik_beta_binomial2 <- function(i, prep) { mu <- prep$dpars$mu[, i] dbinom(prep$data$Y[i], size = prep$data$trials[i], prob = mu) } expect_equal(length(brms:::log_lik_custom(sample(1:nobs, 1), prep)), ns) }) brms/tests/testthat/tests.read_csv_as_stanfit.R0000644000176200001440000000740315053072461021513 0ustar liggesuserscontext("Tests for read_csv_as_stanfit") skip("not run by default") library(cmdstanr) # fit model model_code <- " parameters { vector[2] x; } model { x ~ std_normal(); } " stan_file <- cmdstanr::write_stan_file(code = model_code) mod <- cmdstan_model(stan_file) fit <- mod$sample(parallel_chains = 2, iter_warmup = 200, iter_sampling=200) fit_warmup <- mod$sample(parallel_chains = 2, iter_warmup = 200, iter_sampling=200, save_warmup = TRUE) fit_dense_warmup <- mod$sample(parallel_chains = 4, iter_warmup = 200, iter_sampling=200, metric = "dense_e", save_warmup = TRUE) fit_nosampling <- mod$sample(parallel_chains = 4, iter_warmup = 200, iter_sampling = 0, save_warmup = TRUE) fit_thinned <- mod$sample(parallel_chains = 4, iter_warmup = 200, iter_sampling = 200, thin = 5) fit_variational <- mod$variational() test_set <- list( single_chain = fit$output_files()[[1]], multi_chain = fit$output_files(), with_warmup = fit_warmup$output_files(), dense_warmup = fit_dense_warmup$output_files(), no_samples = fit_nosampling$output_files(), thinned = fit_thinned$output_files(), VI = fit_variational$output_files() ) compare_functions <- function(filename, check_pars = TRUE) { rstan_read <- suppressWarnings(rstan::read_stan_csv(filename)) csv_as_stanfit <- brms:::read_csv_as_stanfit(filename) # should only have permutation different so set to NULL rstan_read@sim$permutation <- NULL csv_as_stanfit@sim$permutation <- NULL if (check_pars) { # currently fails for VI because of different preprocessing expect_identical(rstan_read@model_pars, csv_as_stanfit@model_pars) expect_equal(rstan_read@par_dims, csv_as_stanfit@par_dims) expect_equal(rstan_read@sim, csv_as_stanfit@sim) } expect_identical(rstan_read@model_name, csv_as_stanfit@model_name) expect_identical(rstan_read@mode, csv_as_stanfit@mode) expect_equal(rstan_read@inits, csv_as_stanfit@inits) # should have 4 missing bits of info: metric_file, file, diagnostic_file, stancflags # expect_equal(length(all.equal(rstan_read@stan_args[[1]], csv_as_stanfit@stan_args[[1]])) == 4, expect_equal(rstan_read@stanmodel, csv_as_stanfit@stanmodel) expect_equal(rstan_read@date, csv_as_stanfit@date) return(invisible(NULL)) } # tests test_that("read methods identical: single chain with samples", { compare_functions(test_set$single_chain) }) test_that("read methods identical: multiple chains with samples", { compare_functions(test_set$multi_chain) }) test_that("read methods identical: warmup", { compare_functions(test_set$with_warmup) }) test_that("read methods identical: dense warmup", { compare_functions(test_set$dense_warmup) }) test_that("read methods identical: no samples", { compare_functions(test_set$no_samples) }) test_that("read methods identical: thinned samples", { compare_functions(test_set$thinned) }) test_that("read methods identical: variational inference", { # comparison of parameters and their draws may fail because # of CSV preprocessing done differently by rstan and cmdstanr compare_functions(test_set$VI, check_pars = FALSE) }) test_that("rstan can locate max_treedepth", { fit_treedepth <- mod$sample( parallel_chains = 2, iter_warmup = 200, iter_sampling = 200, max_treedepth = 2, adapt_delta = .1 ) fit <- read_csv_as_stanfit(fit_treedepth$output_files()) expect_message(rstan::check_treedepth(fit), "depth of 2") }) brms/tests/testthat/tests.stop2.R0000644000176200001440000000242215053072461016555 0ustar liggesuserstest_that("stop2() throws a brms_error with simple message", { expect_error(stop2("Something went wrong"), class = "brms_error") }) test_that("stop2() throws a brms_error with simple message", { value <- 42 expect_error(stop2("Unexpected value {value}"), class = "brms_error") }) test_that("stop2() supports custom subclasses", { err <- expect_error( stop2("Some issue", .subclass = "brms_custom"), class = "brms_custom" ) expect_true(inherits(err, "brms_error")) expect_true(inherits(err, "brms_custom")) }) test_that("stop2() supports custom subclasses", { algorithm = "SomeAlgorithm" err <- expect_error( stop2("Algorithm '", algorithm, "' is not supported." ,.subclass = "brms_algorithm" ), class = "brms_algorithm" ) expect_true(inherits(err, "brms_algorithm")) }) test_that("stop2() respects an explicit call argument", { err <- expect_error( stop2("Cannot remove the intercept in an ordinal model." , .subclass = "brms_ordinal_model"), class = "brms_ordinal_model" ) expect_true(inherits(err, "brms_ordinal_model")) }) test_that("stop2() respects an explicit call argument", { fake_call <- quote(fake_func("a", 123)) err <- expect_error(stop2("error occurred", call = fake_call)) expect_equal(conditionCall(err), fake_call) }) brms/tests/testthat/tests.brm.R0000644000176200001440000001306615053072461016274 0ustar liggesusers# calling context() avoids a strange bug in testthat 2.0.0 # cannot actually run brms models in tests as it takes way too long context("Tests for brms error messages") test_that("brm works fully with mock backend", { skip_on_cran() dat <- data.frame(y = rnorm(10), x = rnorm(10), g = rep(1:5, 2)) # Positive control - forced error gets thrown and propagated expect_error(brm(y ~ x + (1|g), dat, backend = "mock", stan_model_args = list(compile_error = "Test error")), "Test error") # Positive control - bad Stan code from stanvars gets an error # test passes but prints output that is somehow impossible to suppress # expect_error(suppressMessages( # brm(y ~ x + (1|g), dat, backend = "mock", # stanvars = stanvar(scode = "invalid;", block = "model")) # )) # Testing some models mock_fit <- brm(y ~ x + (1|g), dat, mock_fit = 1, backend = "mock", rename = FALSE) expect_equal(mock_fit$fit, 1) }) test_that("brm(file = xx) works fully with mock backend", { skip_on_cran() dat <- data.frame(y = rnorm(10), x = rnorm(10), g = rep(1:5, 2)) file <- tempfile(fileext = ".rds") mock_fit1 <- brm(y ~ x + (1|g), dat, mock_fit = "stored", backend = "mock", rename = FALSE, file = file) expect_true(file.exists(file)) mock_fit2 <- brm(y ~ x + (1|g), dat, mock_fit = "new", backend = "mock", rename = FALSE, file = file) expect_equal(mock_fit2$fit, "stored") # In default settings, even using different data/model should result in the # model being loaded from file changed_data <- dat[1:8, ] mock_fit2 <- brm(y ~ x + 0, changed_data, mock_fit = "new", backend = "mock", rename = FALSE, file = file) expect_equal(mock_fit2$fit, "stored") # Now test using file_refit = "on_change" which should be more clever # No change mock_fit2 <- brm(y ~ x + (1|g), dat, mock_fit = "new", backend = "mock", rename = FALSE, file = file) expect_equal(mock_fit2$fit, "stored") # Change data, but not code mock_fit2 <- brm(y ~ x + (1|g), changed_data, mock_fit = "new", backend = "mock", rename = FALSE, file = file, file_refit = "on_change") expect_equal(mock_fit2$fit, "new") # Change code but not data mock_fit2 <- brm(y ~ x + (1|g), dat, mock_fit = "new", backend = "mock", rename = FALSE, file = file, file_refit = "on_change", prior = prior(normal(0,2), class = sd)) expect_equal(mock_fit2$fit, "new") # Change both mock_fit2 <- brm(y ~ x + 0, changed_data, mock_fit = "new", backend = "mock", rename = FALSE, file = file, file_refit = "on_change") expect_equal(mock_fit2$fit, "new") }) test_that("brm produces expected errors", { dat <- data.frame(y = rnorm(10), x = rnorm(10), g = rep(1:5, 2)) # formula parsing expect_error(brm(~ x + (1|g), dat, file = "test"), "Response variable is missing") expect_error(brm(bf(y ~ a, nl = TRUE)), "No non-linear parameters specified") expect_error(brm(bf(y | se(sei) ~ x, sigma ~ x), dat), "Cannot predict or fix 'sigma' in this model") expect_error(brm(y | se(sei) ~ x, dat, family = weibull()), "Argument 'se' is not supported for family") expect_error(brm(y | se(sei) + se(sei2) ~ x, dat, family = gaussian()), "Each addition argument may only be defined once") expect_error(brm(y | abc(sei) ~ x, family = gaussian()), "The following addition terms are invalid:\n'abc(sei)'", fixed = TRUE) expect_error(brm(y | disp(sei) ~ x, dat, family = gaussian()), "The following addition terms are invalid:") expect_error(brm(bf(y ~ x, shape ~ x), family = gaussian()), "The parameter 'shape' is not a valid distributional") expect_error(brm(y ~ x + (1|abc|g/x), dat), "Can only combine group-level terms") expect_error(brm(y ~ x + (1|g) + (x|g), dat), "Duplicated group-level effects are not allowed") expect_error(brm(y~mo(g)*t2(x), dat), fixed = TRUE, "The term 'mo(g):t2(x)' is invalid") expect_error(brm(y~x*cs(g), dat), fixed = TRUE, "The term 'x:cs(g)' is invalid") expect_error(brm(y~me(x, 2 * g)*me(x, g), dat), "Variable 'x' is used in different calls to 'me'") expect_error(brm(y ~ 1 + set_rescor(TRUE), data = dat), "Function 'set_rescor' should not be part") # autocorrelation expect_error(brm(y ~ ar(x+y, g), dat), "Cannot coerce 'x \\+ y' to a single variable name") expect_error(brm(y ~ ar(gr = g1/g2), dat), "Illegal grouping term 'g1/g2'") expect_error(brm(y ~ ma(x), dat, poisson()), "Please set cov = TRUE") expect_error(brm(bf(y ~ 1) + arma(x), dat), "Autocorrelation terms can only be specified") # ordinal models expect_error(brm(rating ~ treat + (cs(period)|subject), data = inhaler, family = categorical()), "Category specific effects are not supported") # families and links expect_error(brm(y ~ x, dat, family = poisson("inverse")), "'inverse' is not a supported link for family 'poisson'") expect_error(brm(y ~ x, dat, family = c("weibull", "sqrt")), "'sqrt' is not a supported link for family 'weibull'") expect_error(brm(y ~ x, dat, family = c("categorical", "probit")), "'probit' is not a supported link for family 'categorical'") expect_error(brm(y ~ x, dat, family = "ordinal"), "ordinal is not a supported family") }) brms/tests/testthat/tests.restructure.R0000644000176200001440000001574215053072461020106 0ustar liggesuserscontext("Tests for restructuring of old brmsfit objects") test_that("restructure can be run without error", { # This test does not check if old models can really be restructured # since restructure is called with an already up-to-date model. fit2 <- brms:::rename_pars(brms:::brmsfit_example2) fit2$version <- NULL fit2$exclude <- c("L_1", "zs_1") expect_warning( fit2_up <- restructure(fit2), "Models fitted with brms < 1.0 are no longer offically supported" ) expect_is(fit2_up, "brmsfit") }) test_that("restructure_formula_v1 works correctly", { form <- structure( y ~ x + z, sigma = sigma ~ x, class = c("brmsformula", "formula") ) form <- brms:::restructure_formula_v1(form) expect_equal(form$formula, y ~ x + z) expect_equal(form$pforms, list(sigma = sigma ~ x)) expect_true(!attr(form$formula, "nl")) form <- structure( y ~ a * exp(-b * x), nonlinear = list(a = a ~ x, b = b ~ 1), class = c("brmsformula", "formula") ) form <- brms:::restructure_formula_v1(form) expect_equal(form$formula, y ~ a * exp(-b * x)) expect_equal(form$pforms, list(a = a ~ x, b = b ~ 1)) expect_true(attr(form$formula, "nl")) }) test_that("rename_prior returns expected lists", { pars <- c("b", "b_1", "bp", "bp_1", "prior_b", "prior_b__1", "prior_b__3", "sd_x[1]", "prior_bp__1") expect_equivalent( brms:::rename_prior( class = "b", pars = pars, names = c("x1", "x3", "x2") ), list(list(pos = 6, fnames = "prior_b_x1"), list(pos = 7, fnames = "prior_b_x2")) ) expect_equivalent( brms:::rename_prior( class = "bp", pars = pars, names = c("x1", "x2"), new_class = "b" ), list(list(pos = 9, fnames = "prior_b_x1"))) }) test_that("rename_old_re and rename_old_re2 return expected lists", { data <- data.frame(y = rnorm(10), x = rnorm(10), g = 1:10) bterms <- brmsterms(bf(y ~ a, a ~ x + (1+x|g), family = gaussian(), nl = TRUE)) ranef <- brms:::frame_re(bterms, data = data) target <- list( list(pos = c(rep(FALSE, 2), TRUE, rep(FALSE, 22)), oldname = "sd_a_g_Intercept", pnames = "sd_g_a_Intercept", fnames = "sd_g_a_Intercept", dims = numeric(0)), list(pos = c(rep(FALSE, 3), TRUE, rep(FALSE, 21)), oldname = "sd_a_g_x", pnames = "sd_g_a_x", fnames = "sd_g_a_x", dims = numeric(0)), list(pos = c(rep(FALSE, 4), TRUE, rep(FALSE, 20)), oldname = "cor_a_g_Intercept_x", pnames = "cor_g_a_Intercept_a_x", fnames = "cor_g_a_Intercept_a_x", dims = numeric(0)), list(pos = c(rep(FALSE, 5), rep(TRUE, 20)), oldname = "r_a_g", pnames = "r_g_a", fnames = c(paste0("r_g_a[", 1:10, ",Intercept]"), paste0("r_g_a[", 1:10, ",x]")), dims = c(10, 2))) pars <- c("b_a_Intercept", "b_a_x", "sd_a_g_Intercept", "sd_a_g_x", "cor_a_g_Intercept_x", paste0("r_a_g[", 1:10, ",Intercept]"), paste0("r_a_g[", 1:10, ",x]")) dims <- list("sd_a_g_Intercept" = numeric(0), "sd_a_g_x" = numeric(0), "cor_a_g_Intercept_x" = numeric(0), "r_a_g" = c(10, 2)) expect_equivalent(brms:::rename_old_re(ranef, pars = pars, dims = dims), target) target <- list( list(pos = c(rep(FALSE, 2), TRUE, rep(FALSE, 22)), oldname = "sd_g_a_Intercept", pnames = "sd_g__a_Intercept", fnames = "sd_g__a_Intercept", dims = numeric(0)), list(pos = c(rep(FALSE, 3), TRUE, rep(FALSE, 21)), oldname = "sd_g_a_x", pnames = "sd_g__a_x", fnames = "sd_g__a_x", dims = numeric(0)), list(pos = c(rep(FALSE, 4), TRUE, rep(FALSE, 20)), oldname = "cor_g_a_Intercept_a_x", pnames = "cor_g__a_Intercept__a_x", fnames = "cor_g__a_Intercept__a_x", dims = numeric(0)), list(pos = c(rep(FALSE, 5), rep(TRUE, 20)), oldname = "r_g_a", pnames = "r_g__a", fnames = c(paste0("r_g__a[", 1:10, ",Intercept]"), paste0("r_g__a[", 1:10, ",x]")), dims = c(10, 2))) pars <- c("b_a_Intercept", "b_a_x", "sd_g_a_Intercept", "sd_g_a_x", "cor_g_a_Intercept_a_x", paste0("r_g_a[", 1:10, ",Intercept]"), paste0("r_g_a[", 1:10, ",x]")) dims <- list("sd_g_a_Intercept" = numeric(0), "sd_g_a_x" = numeric(0), "cor_g_a_Intercept_a_x" = numeric(0), "r_g_a" = c(10, 2)) expect_equivalent(brms:::rename_old_re2(ranef, pars = pars, dims = dims), target) }) test_that("rename_old_sm return expected lists", { target <- list( list(pos = c(FALSE, TRUE, rep(FALSE, 15)), oldname = "sds_sx1kEQ9", pnames = "sds_sx1_1", fnames = "sds_sx1_1", dims = numeric(0)), list(pos = c(rep(FALSE, 8), rep(TRUE, 9)), oldname = "s_sx1kEQ9", pnames = "s_sx1_1", fnames = paste0("s_sx1_1[", 1:9, "]"), dims = 9), list(pos = c(TRUE, rep(FALSE, 16)), oldname = "sds_sigma_t2x0", pnames = "sds_sigma_t2x0_1", fnames = "sds_sigma_t2x0_1", dims = numeric(0)), list(pos = c(FALSE, FALSE, rep(TRUE, 6), rep(FALSE, 9)), oldname = "s_sigma_t2x0", pnames = "s_sigma_t2x0_1", fnames = paste0("s_sigma_t2x0_1[", 1:6, "]"), dims = 6) ) pars <- c("sds_sigma_t2x0", "sds_sx1kEQ9", paste0("s_sigma_t2x0[", 1:6, "]"), paste0("s_sx1kEQ9[", 1:9, "]")) dims <- list(sds_sigma_t2x0 = numeric(0), sds_sx1kEQ9 = numeric(0), s_sigma_t2x0 = 6, s_sx1kEQ9 = 9) bterms <- brmsterms(bf(y ~ s(x1, k = 9), sigma ~ t2(x0)), family = gaussian()) dat <- data.frame(y = rnorm(100), x1 = rnorm(100), x0 = rnorm(100)) expect_equivalent(brms:::rename_old_sm(bterms, dat, pars, dims), target) }) test_that("rename_old_mo returns expected lists", { bterms <- brmsterms(bf(y ~ mo(x), sigma ~ mo(x)), family = gaussian()) data <- data.frame(y = rnorm(10), x = rep(1:5, 2)) pars <- c( "bmo_x", "bmo_sigma_x", paste0("simplex_x[", 1:5, "]"), paste0("simplex_sigma_x[", 1:5, "]") ) target <- list( list( pos = c(TRUE, rep(FALSE, 11)), fnames = "bmo_mox" ), list( pos = c(FALSE, FALSE, rep(TRUE, 5), rep(FALSE, 5)), fnames = paste0("simo_mox1[", 1:5, "]") ), list( pos = c(FALSE, TRUE, rep(FALSE, 10)), fnames = "bmo_sigma_mox" ), list( pos = c(rep(FALSE, 7), rep(TRUE, 5)), fnames = paste0("simo_sigma_mox1[", 1:5, "]") ) ) expect_equivalent(brms:::rename_old_mo(bterms, data, pars), target) }) test_that("rename_old_categorical works correctly", { dat <- data.frame( y = rep(c("cat1", "cat2", "cat3"), 3), x = rnorm(9) ) fam <- categorical() fam$dpars <- c("mucat2", "mucat3") bterms <- brmsterms(bf(y ~ x) + fam) pars <- c("b_cat2_Intercept", "b_cat3_Intercept", "b_cat2_x", "b_cat3_x") res <- brms:::rename_old_categorical(bterms, dat, pars) target <- list( list( pos = rep(TRUE, 4), fnames = c( "b_mucat2_Intercept", "b_mucat3_Intercept", "b_mucat2_x", "b_mucat3_x" ) ) ) expect_equivalent(res, target) }) brms/tests/testthat/tests.stan_functions.R0000644000176200001440000002267714213413565020562 0ustar liggesuserscontext("Tests for self-defined Stan functions") test_that("self-defined Stan functions work correctly", { # for some reason expose_stan_functions doesn't work within R CMD CHECK skip_if_not(exists("new_stan_functions", asNamespace("brms"))) rstan::expose_stan_functions(brms:::new_stan_functions) # ARMA matrix generating functions cov_ar1_R <- get_cov_matrix_ar1(ar = matrix(0.5), sigma = 2, se2 = 0, nrows = 3)[1, , ] expect_equal(cov_matrix_ar1(0.5, 2, 3), cov_ar1_R) cov_ma1_R <- matrix(get_cov_matrix_ma1(ma = matrix(-0.3), sigma = 3, se2 = 0, nrows = 1)[1, , ]) expect_equal(cov_matrix_ma1(-0.3, 3, 1), cov_ma1_R) cov_arma1_R <- get_cov_matrix_arma1(ar = matrix(-0.5), ma = matrix(0.7), sigma = 4, se2 = 0, nrows = 5)[1, , ] expect_equal(cov_matrix_arma1(-0.5, 0.7, 4, 5), cov_arma1_R) # log-likelihood functions for covariance models y <- rnorm(9) eta <- rnorm(9) ll_stan <- normal_cov_lpdf(y, eta = eta, se2 = 1:9, I = 2, begin = c(1, 5), end = c(4, 9), nobs = c(4, 5), res_cov_matrix = cov_arma1_R) ll_R <- c(dmulti_normal(y[1:4], eta[1:4], cov_arma1_R[1:4, 1:4] + diag(1:4)), dmulti_normal(y[5:9], eta[5:9], cov_arma1_R[1:5, 1:5] + diag(5:9))) expect_equal(ll_stan, sum(ll_R)) ll_stan <- student_t_cov_lpdf(y, nu = 10, eta = eta, se2 = 1:9, I = 2, begin = c(1, 5), end = c(4, 9), nobs = c(4, 5), res_cov_matrix = cov_arma1_R) ll_R <- c(dmulti_student(y[1:4], df = 10, mu = eta[1:4], Sigma = cov_arma1_R[1:4, 1:4] + diag(1:4)), dmulti_student(y[5:9], df = 10, mu = eta[5:9], Sigma = cov_arma1_R[1:5, 1:5] + diag(5:9))) expect_equal(ll_stan, sum(ll_R)) # inverse gaussian functions shape <- rgamma(1, 20, 1) mu <- 20 y <- statmod::rinvgauss(1, mean = mu, shape = shape) expect_equal(inv_gaussian_lpdf(y, mu, shape, log(y), sqrt(y)), dinvgauss(y, mean = mu, shape = shape, log = TRUE)) expect_equal(inv_gaussian_lcdf(y, mu, shape, log(y), sqrt(y)), pinvgauss(y, mean = mu, shape = shape, log = TRUE)) expect_equal(inv_gaussian_lccdf(y, mu, shape, log(y), sqrt(y)), log(1 - pinvgauss(y, mean = mu, shape = shape))) mu <- 18:22 y <- statmod::rinvgauss(5, mean = mu, shape = shape) expect_equal(inv_gaussian_vector_lpdf(y, mu, shape, sum(log(y)), sqrt(y)), sum(dinvgauss(y, mean = mu, shape = shape, log = TRUE))) # exgaussian functions beta <- rgamma(1, 1, 0.1) sigma <- rgamma(1, 10, 0.1) mu <- 10 y <- rexgaussian(1, mu = mu, sigma = sigma, beta = beta) expect_equal(exgaussian_lpdf(y, mu, sigma, beta), dexgaussian(y, mu, sigma, beta, log = TRUE)) expect_equal(exgaussian_lcdf(y, mu, sigma, beta), pexgaussian(y, mu, sigma, beta, log = TRUE)) expect_equal(exgaussian_lccdf(y, mu, sigma, beta), pexgaussian(y, mu, sigma, beta, lower.tail = FALSE, log = TRUE)) # asym_laplace functions mu <- 10 quantile <- rbeta(1, 2, 1) sigma <- rgamma(1, 10, 0.1) y <- rasym_laplace(1, mu = mu, sigma = sigma, quantile = quantile) expect_equal(asym_laplace_lpdf(y, mu, sigma, quantile), dasym_laplace(y, mu, sigma, quantile, log = TRUE)) expect_equal(asym_laplace_lcdf(y, mu, sigma, quantile), pasym_laplace(y, mu, sigma, quantile, log = TRUE)) expect_equal(asym_laplace_lccdf(y, mu, sigma, quantile), pasym_laplace(y, mu, sigma, quantile, lower.tail = FALSE, log = TRUE)) # wiener diffusion model functions alpha = 2 tau = 0.5 beta = 0.5 delta = 0.5 y <- rWiener(1, alpha, tau, beta, delta) y$resp <- ifelse(y$resp == "lower", 0, 1) expect_equal(wiener_diffusion_lpdf(y$q, y$resp, alpha, tau, beta, delta), dWiener(y$q, alpha, tau, beta, delta, resp = y$resp, log = TRUE)) # zero-inflated and hurdle log-densities draws <- draws2 <- list(eta = matrix(rnorm(4), ncol = 4), shape = 2, phi = 2, sigma = 2) draws$data <- list(Y = c(0, 10), N_trait = 2, max_obs = 15) draws2$data <- list(Y = c(0, 0.5), N_trait = 2) for (i in seq_along(draws$data$Y)) { eta_zi_args <- list(y = draws$data$Y[i], eta = draws$eta[i], eta_zi = draws$eta[i+2]) zi_args <- list(y = draws$data$Y[i], eta = draws$eta[i], zi = inv_logit(eta_zi_args$eta_zi)) eta_hu_args <- list(y = draws$data$Y[i], eta = draws$eta[i], eta_hu = draws$eta[i+2]) hu_args <- list(y = draws$data$Y[i], eta = draws$eta[i], hu = inv_logit(eta_hu_args$eta_hu)) draws$f$link <- "log" expect_equal(do.call(zero_inflated_poisson_lpmf, zi_args), loglik_zero_inflated_poisson(i, draws)) expect_equal(do.call(zero_inflated_poisson_logit_lpmf, eta_zi_args), loglik_zero_inflated_poisson(i, draws)) expect_equal(do.call(zero_inflated_neg_binomial_lpmf, c(zi_args, shape = draws$shape)), loglik_zero_inflated_negbinomial(i, draws)) expect_equal(do.call(zero_inflated_neg_binomial_logit_lpmf, c(eta_zi_args, shape = draws$shape)), loglik_zero_inflated_negbinomial(i, draws)) expect_equal(do.call(hurdle_poisson_lpmf, hu_args), loglik_hurdle_poisson(i, draws)) expect_equal(do.call(hurdle_poisson_logit_lpmf, eta_hu_args), loglik_hurdle_poisson(i, draws)) expect_equal(do.call(hurdle_neg_binomial_lpmf, c(hu_args, shape = draws$shape)), loglik_hurdle_negbinomial(i, draws)) expect_equal(do.call(hurdle_neg_binomial_logit_lpmf, c(eta_hu_args, shape = draws$shape)), loglik_hurdle_negbinomial(i, draws)) expect_equal(do.call(hurdle_gamma_lpdf, c(hu_args, shape = draws$shape)), loglik_hurdle_gamma(i, draws)) expect_equal(do.call(hurdle_gamma_logit_lpdf, c(eta_hu_args, shape = draws$shape)), loglik_hurdle_gamma(i, draws)) draws$f$link <- "identity" expect_equal(do.call(hurdle_lognormal_lpdf, c(hu_args, sigma = draws$sigma)), loglik_hurdle_lognormal(i, draws)) expect_equal(do.call(hurdle_lognormal_logit_lpdf, c(eta_hu_args, sigma = draws$sigma)), loglik_hurdle_lognormal(i, draws)) draws$f$link <- "logit" expect_equal(do.call(zero_inflated_binomial_lpmf, c(zi_args, trials = draws$data$max_obs)), loglik_zero_inflated_binomial(i, draws)) expect_equal(do.call(zero_inflated_binomial_logit_lpmf, c(eta_zi_args, trials = draws$data$max_obs)), loglik_zero_inflated_binomial(i, draws)) # zero_inflated_beta requires Y to be in (0,1) draws2$f$link <- "logit" eta_zi_args <- list(y = draws2$data$Y[i], eta = draws$eta[i], eta_zi = draws$eta[i+2]) zi_args <- list(y = draws2$data$Y[i], eta = draws$eta[i], zi = inv_logit(eta_zi_args$eta_zi)) expect_equal(do.call(zero_inflated_beta_lpdf, c(zi_args, phi = draws$phi)), loglik_zero_inflated_beta(i, draws2)) expect_equal(do.call(zero_inflated_beta_logit_lpdf, c(eta_zi_args, phi = draws$phi)), loglik_zero_inflated_beta(i, draws2)) } # ordinal log-densities eta <- rnorm(1) etap <- array(rnorm(6), dim = c(2, 1, 3)) thres <- sort(rnorm(3)) # cumulative and sratio require thres - eta draws <- list(eta = rep(thres, each = 2) - array(eta, dim = c(2, 1, 3))) draws$data <- list(Y = 2, max_obs = 4) draws$f$link <- "probit" expect_equal(cumulative_lpmf(draws$data$Y, eta, thres), loglik_cumulative(1, draws)[1]) draws$f$link <- "logit" expect_equal(sratio_lpmf(draws$data$Y, eta, thres), loglik_sratio(1, draws)[1]) # acat and cratio require eta - thres # also category specific effects are included here draws$eta <- eta + etap - rep(thres, each = 2) draws$f$link <- "cloglog" expect_equal(cratio_lpmf(draws$data$Y, eta, etap[1, , ], thres), loglik_cratio(1, draws)[1]) draws$f$link <- "cauchit" expect_equal(acat_lpmf(draws$data$Y, eta, etap[1, , ], thres), loglik_acat(1, draws)[1]) # kronecker product A <- matrix(c(3, 2, 1, 2, 4, 1, 1, 1, 5), nrow = 3) B <- matrix(c(3, 2, 2, 4), nrow = 2) sd <- c(2, 7) expect_equal(t(chol(base::kronecker(A, diag(sd) %*% B %*% diag(sd)))), kronecker(t(chol(A)), diag(sd) %*% t(chol(B)))) # as_matrix expect_equal(as_matrix(1:28, 4, 7), rbind(1:7, 8:14, 15:21, 22:28)) expect_equal(as_matrix(1:28, 3, 4), rbind(1:4, 5:8, 9:12)) # cauchit and cloglog link expect_equal(inv_cauchit(1.5), pcauchy(1.5)) expect_equal(cauchit(0.7), qcauchy(0.7)) expect_equal(cloglog(0.2), link(0.2, "cloglog")) # monotonic # slightly arkward way to call this function to make sure # is doesn't conflict with the brms R function of the same name monotonic_temp <- get("monotonic", globalenv()) expect_equal(monotonic_temp(1:10, 4), sum(1:4)) expect_equal(monotonic_temp(rnorm(5), 0), 0) }) brms/tests/testthat/helpers/0000755000176200001440000000000014111751667015672 5ustar liggesusersbrms/tests/testthat/helpers/insert_refcat_ch.R0000644000176200001440000000262714160105076021315 0ustar liggesusers# Very similar to insert_refcat(), but iterates over the observations (if # necessary): insert_refcat_ch <- function(eta, family) { ndim <- length(dim(eta)) if (ndim == 2) { return(insert_refcat_ch_i(eta, family = family)) } else if (ndim == 3) { out <- abind::abind(lapply(seq_cols(eta), function(i) { insert_refcat_ch_i(slice_col(eta, i), family = family) }), along = 3) return(aperm(out, perm = c(1, 3, 2))) } else { stop2("eta has wrong dimensions.") } } environment(insert_refcat_ch) <- as.environment(asNamespace("brms")) # A matrix-only variant of insert_refcat() (used to be insert_refcat() before it # was extended to arrays): insert_refcat_ch_i <- function(eta, family) { stopifnot(is.matrix(eta), is.brmsfamily(family)) if (!conv_cats_dpars(family) || isNA(family$refcat)) { return(eta) } # need to add zeros for the reference category zeros <- as.matrix(rep(0, nrow(eta))) if (is.null(family$refcat) || is.null(family$cats)) { # no information on the categories provided: # use the first category as the reference return(cbind(zeros, eta)) } colnames(zeros) <- paste0("mu", family$refcat) iref <- match(family$refcat, family$cats) before <- seq_len(iref - 1) after <- setdiff(seq_cols(eta), before) cbind(eta[, before, drop = FALSE], zeros, eta[, after, drop = FALSE]) } environment(insert_refcat_ch_i) <- as.environment(asNamespace("brms")) brms/tests/testthat/helpers/inv_link_ordinal_ch.R0000644000176200001440000000557714213413565022021 0ustar liggesusersinv_link_cumulative_ch <- function(x, link) { x <- inv_link(x, link) ndim <- length(dim(x)) ncat <- dim(x)[ndim] + 1 out <- vector("list", ncat) out[[1]] <- slice(x, ndim, 1) if (ncat > 2) { .diff <- function(k) { slice(x, ndim, k) - slice(x, ndim, k - 1) } mid_cats <- 2:(ncat - 1) out[mid_cats] <- lapply(mid_cats, .diff) } out[[ncat]] <- 1 - slice(x, ndim, ncat - 1) abind::abind(out, along = ndim) } environment(inv_link_cumulative_ch) <- as.environment(asNamespace("brms")) inv_link_sratio_ch <- function(x, link) { x <- inv_link(x, link) ndim <- length(dim(x)) ncat <- dim(x)[ndim] + 1 marg_noncat <- seq_along(dim(x))[-ndim] out <- vector("list", ncat) out[[1]] <- slice(x, ndim, 1) if (ncat > 2) { .condprod <- function(k) { slice(x, ndim, k) * apply(1 - slice(x, ndim, 1:(k - 1), drop = FALSE), marg_noncat, prod) } mid_cats <- 2:(ncat - 1) out[mid_cats] <- lapply(mid_cats, .condprod) } out[[ncat]] <- apply(1 - x, marg_noncat, prod) abind::abind(out, along = ndim) } environment(inv_link_sratio_ch) <- as.environment(asNamespace("brms")) inv_link_cratio_ch <- function(x, link) { x <- inv_link(x, link) ndim <- length(dim(x)) ncat <- dim(x)[ndim] + 1 marg_noncat <- seq_along(dim(x))[-ndim] out <- vector("list", ncat) out[[1]] <- 1 - slice(x, ndim, 1) if (ncat > 2) { .condprod <- function(k) { (1 - slice(x, ndim, k)) * apply(slice(x, ndim, 1:(k - 1), drop = FALSE), marg_noncat, prod) } mid_cats <- 2:(ncat - 1) out[mid_cats] <- lapply(mid_cats, .condprod) } out[[ncat]] <- apply(x, marg_noncat, prod) abind::abind(out, along = ndim) } environment(inv_link_cratio_ch) <- as.environment(asNamespace("brms")) inv_link_acat_ch <- function(x, link) { ndim <- length(dim(x)) ncat <- dim(x)[ndim] + 1 marg_noncat <- seq_along(dim(x))[-ndim] out <- vector("list", ncat) if (link == "logit") { # faster evaluation in this case out[[1]] <- array(1, dim = dim(x)[-ndim]) out[[2]] <- exp(slice(x, ndim, 1)) if (ncat > 2) { .catsum <- function(k) { exp(apply(slice(x, ndim, 1:(k - 1), drop = FALSE), marg_noncat, sum)) } remaincats <- 3:ncat out[remaincats] <- lapply(remaincats, .catsum) } } else { x <- inv_link(x, link) out[[1]] <- apply(1 - x, marg_noncat, prod) if (ncat > 2) { .othercatprod <- function(k) { apply(slice(x, ndim, 1:(k - 1), drop = FALSE), marg_noncat, prod) * apply(slice(1 - x, ndim, k:(ncat - 1), drop = FALSE), marg_noncat, prod) } mid_cats <- 2:(ncat - 1) out[mid_cats] <- lapply(mid_cats, .othercatprod) } out[[ncat]] <- apply(x, marg_noncat, prod) } out <- abind::abind(out, along = ndim) catsum <- apply(out, marg_noncat, sum) sweep(out, marg_noncat, catsum, "/") } environment(inv_link_acat_ch) <- as.environment(asNamespace("brms")) brms/tests/testthat/helpers/simopts_catlike_oneobs.R0000644000176200001440000000015214160105076022541 0ustar liggesusers# This test corresponds to a single observation. set.seed(1234) ndraws_vec <- c(1, 5) ncat_vec <- c(2, 3) brms/tests/testthat/helpers/simopts_catlike.R0000644000176200001440000000011614160105076021174 0ustar liggesusersset.seed(1234) ndraws_vec <- c(1, 5) nobsv_vec <- c(1, 4) ncat_vec <- c(2, 3) brms/tests/testthat/helpers/link_ordinal_ch.R0000644000176200001440000000465314160105076021133 0ustar liggesuserslink_ch <- function(x, link) { # switch() would be more straightforward, but for testing purposes, use if () # here: if (link == "logit") { return(qlogis(x)) } else if (link == "probit") { return(qnorm(x)) } else if (link == "cauchit") { return(qcauchy(x)) } else if (link == "cloglog") { return(log(-log(1 - x))) } else { stop("Unknown link.") } } # Very similar to link_cumulative(), but iterates over the observations: link_cumulative_ch <- function(x, link) { # For testing purposes, only allow 3-dimensional arrays here: stopifnot(length(dim(x)) == 3) ndraws <- dim(x)[1] nobsv <- dim(x)[2] ncat <- dim(x)[3] x_cumsum <- aperm( array( sapply(seq_len(nobsv), function(i) { apply(x[, i, -ncat, drop = FALSE], 1, cumsum) }, simplify = "array"), dim = c(ncat - 1, ndraws, nobsv) ), perm = c(2, 3, 1) ) link_ch(x_cumsum, link = link) } # The same as link_sratio(), but dropping margins: link_sratio_ch <- function(x, link) { ndim <- length(dim(x)) .F_k <- function(k) { if (k == 1) { prev_res <- list(F_k = NULL, S_km1_prod = 1) } else { prev_res <- .F_k(k - 1) } F_k <- slice(x, ndim, k) / prev_res$S_km1_prod return(list(F_k = abind::abind(prev_res$F_k, F_k, along = ndim), S_km1_prod = prev_res$S_km1_prod * (1 - F_k))) } x <- .F_k(dim(x)[ndim] - 1)$F_k link_ch(x, link) } environment(link_sratio_ch) <- as.environment(asNamespace("brms")) # The same as link_cratio(), but dropping margins: link_cratio_ch <- function(x, link) { ndim <- length(dim(x)) .F_k <- function(k) { if (k == 1) { prev_res <- list(F_k = NULL, F_km1_prod = 1) } else { prev_res <- .F_k(k - 1) } F_k <- 1 - slice(x, ndim, k) / prev_res$F_km1_prod return(list(F_k = abind::abind(prev_res$F_k, F_k, along = ndim), F_km1_prod = prev_res$F_km1_prod * F_k)) } x <- .F_k(dim(x)[ndim] - 1)$F_k link_ch(x, link) } environment(link_cratio_ch) <- as.environment(asNamespace("brms")) # The same as link_acat(), but possibly dropping margins and not treating the # logit link as a special case: link_acat_ch <- function(x, link) { ndim <- length(dim(x)) ncat <- dim(x)[ndim] dim_noncat <- dim(x)[-ndim] x <- slice(x, ndim, -1) / slice(x, ndim, -ncat) x <- inv_odds(x) array(link_ch(x, link), dim = c(dim_noncat, ncat - 1)) } environment(link_acat_ch) <- as.environment(asNamespace("brms")) brms/tests/testthat/helpers/inv_link_categorical_ch.R0000644000176200001440000000257314361545260022641 0ustar liggesusers# Very similar to inv_link_categorical(), but iterates over the observations and # always assumes the first category to be the reference category: inv_link_categorical_ch <- function(x, log = FALSE, refcat_ins = TRUE) { if (refcat_ins) { zeros_arr <- array(0, dim = c(head(dim(x), -1), 1)) x <- abind::abind(zeros_arr, x) } ndim <- length(dim(x)) # For testing purposes, only allow 3-dimensional arrays here: if (ndim <= 1) { x <- array(x, dim = c(1, 1, length(x))) ndim <- length(dim(x)) need_drop <- TRUE } else if (ndim == 2) { x <- array(x, dim = c(dim(x)[1], 1, dim(x)[2])) ndim <- length(dim(x)) need_drop <- TRUE } else if (ndim > 3) { stop("At most 3 dimensions are allowed here.") } else { need_drop <- FALSE } ndraws <- dim(x)[1] nobsv <- dim(x)[2] ncat <- dim(x)[3] out <- aperm( array( sapply(seq_len(nobsv), function(i) { out_i <- log_softmax(slice(x, 2, i)) if (!log) { out_i <- exp(out_i) } out_i }, simplify = "array"), dim = c(ndraws, ncat, nobsv) ), perm = c(1, 3, 2) ) # Quick-and-dirty solution to drop the margin for a single observation (but # only if the input object was not a 3-dimensional array): if (need_drop) { return(slice(out, 2, 1)) } out } environment(inv_link_categorical_ch) <- as.environment(asNamespace("brms")) brms/tests/testthat/helpers/link_categorical_ch.R0000644000176200001440000000132514176602337021762 0ustar liggesusers# Very similar to link_categorical(), but iterates over the observations: link_categorical_ch <- function(x, refcat = 1, return_refcat = FALSE) { # For testing purposes, only allow 3-dimensional arrays here: stopifnot(length(dim(x)) == 3) x_tosweep <- if (return_refcat) { x } else { slice(x, 3, -refcat, drop = FALSE) } ndraws <- dim(x)[1] nobsv <- dim(x)[2] ncat <- dim(x)[3] log(aperm( array( sapply(seq_len(nobsv), function(i) { slice(x_tosweep, 2, i) / slice(slice(x, 2, i), 2, refcat) }, simplify = "array"), dim = c(ndraws, ncat - !return_refcat, nobsv) ), perm = c(1, 3, 2) )) } environment(link_categorical_ch) <- as.environment(asNamespace("brms")) brms/tests/testthat/tests.priorsense.R0000644000176200001440000000162515053072461017703 0ustar liggesuserscontext("Tests for priorsense support") skip_if_not_installed("priorsense") skip_on_cran() SW <- suppressWarnings require(priorsense) fit1 <- rename_pars(brms:::brmsfit_example1) test_that("create_priorsense_data returns expected output structure", { psd1 <- create_priorsense_data(fit1) expect_s3_class(psd1$draws, "draws") expect_s3_class(psd1$fit, "brmsfit") expect_s3_class(psd1$log_lik, "draws") expect_s3_class(psd1$log_prior, "draws") expect_true(is.function(psd1$log_lik_fn)) expect_true(is.function(psd1$log_prior_fn)) expect_true(is.function(psd1$log_ratio_fn)) }) test_that("powerscale returns without error", { expect_no_error(SW(powerscale(fit1, component = "prior", alpha = 0.8))) expect_no_error(SW(powerscale(fit1, component = "likelihood", alpha = 1.1))) }) test_that("powerscale_sensitivity returns without error", { expect_no_error(SW(powerscale_sensitivity(fit1))) }) brms/tests/testthat.R0000644000176200001440000000006414160105076014342 0ustar liggesuserslibrary(testthat) library(brms) test_check("brms") brms/MD50000644000176200001440000006122515060003132011521 0ustar liggesusers0c7d8d0fd7d9d459622f71f395d315aa *DESCRIPTION 9325e7190645bcfe4018b0ab2185bc1b *NAMESPACE 4cd0bddb41901d0d326ac157f9c430f8 *NEWS.md 88f29a1dbd23319f9a594e8733193117 *R/autocor.R 93eea4aff462a9e374bf14731beecff1 *R/backends.R 8007f42c5b7cfd8ef6f36596012c9082 *R/bayes_R2.R aaca4a01a779f6299bfa90f846009ff4 *R/bridgesampling.R f94e1a5c3d35e9986d34c6381641f133 *R/brm.R acf456296d1b731307ff14aa1e4e0eaa *R/brm_multiple.R 1928da2390e83afaf6e2f7898bae30f0 *R/brms-package.R af4cd41a34fdd4445b2fb8f0093f5ea5 *R/brmsfit-class.R 8c6b2f7d33e4eaae3939600fdeed931a *R/brmsfit-helpers.R bc19a34639e200fd390335c5d25456d1 *R/brmsfit-methods.R 470fd71c9103d00daa40fe3934d89b76 *R/brmsformula.R 6002c2d32e1698788042e9a0c15da878 *R/brmsframe.R 3d08da09f9efdd443e8bce226a97ee0c *R/brmsterms.R 96138ebd1ad3837e6f9340d41d1bec42 *R/conditional_effects.R 07aab7b4552045fd594ffcfeb9ea0e15 *R/conditional_smooths.R 4d32e79c77e7cbe0fc6e6431f0e3a7cc *R/data-helpers.R 7502d1c9e2518de57ca6e455b439b65a *R/data-predictor.R 577379b7ee97983eed04b5f8d10406bc *R/data-response.R d79f47e77c3b11477953f636c7605647 *R/datasets.R 0c817919353979d3a2789e40fb78311b *R/diagnostics.R 334c0067d7aae697fcfd0223516a4e59 *R/distributions.R 805784342a291b9a55d808694e76380e *R/emmeans.R 0139b6e1738ff5eb1a127153e14ed55e *R/exclude_pars.R a8ef78dc95fc0a1275a3086c59dbe18a *R/exclude_terms.R 463e3cc3225407864a1eec42f70ff738 *R/families.R 25fe87cf4563a7505579a0124fb2b3bf *R/family-lists.R 84643ded1091f3c266d4376b367bbe19 *R/formula-ac.R 52374805a2c6b6a051f54c684df5592a *R/formula-ad.R b9d10079aad0858ab9e5271763b22eac *R/formula-cs.R cf1e705f21f27baf1cbdcb61cb6b80d8 *R/formula-gp.R 206622cbb2fee9df0703f6f6132d639b *R/formula-re.R 36becb8c57e627f6384376c3f7bc4b78 *R/formula-sm.R ef6e894b94873c58c784c61d8d7e2e2e *R/formula-sp.R aefb99178ab21e8064b69728118f3ae8 *R/ggplot-themes.R b338c1ddc0e37d68eb922c8305f03fe0 *R/hypothesis.R 10e7e212f8c4a4b2e758aa56846179fa *R/kfold.R 00edb93a843b4932a75ddc39d239a792 *R/launch_shinystan.R 2d09b9c85d432badde361f4f670c6f70 *R/log_lik.R 85e3eccdda1981fc9ce21a7bd721904e *R/loo.R bb2c33c41f12795cbb633cb76a88ccca *R/loo_moment_match.R 620ef92fc48b28a4e2c278903befb4b7 *R/loo_predict.R 24a2aef03aa8af0815e352d452fe3228 *R/loo_subsample.R 71c9036f3d4dc02049eef21acc00e4f7 *R/lsp.R df6788cb050612b9e8f8143535f35b4a *R/misc.R 26d480d11dff1b689e9c467a8e9bed76 *R/model_weights.R 3374a15a46c7f2fc69b367b142ba2068 *R/numeric-helpers.R 662643bad4ee5b317e5897cea5466c4a *R/plot.R 534f5c69d10e153980f5f01ec06ca981 *R/posterior.R d89c5db104c5b319b65c5bbe3ebaa0cb *R/posterior_epred.R 0ce59a5c814bd0c0ac7c5b564c58d472 *R/posterior_predict.R dbde0c94d63711d483e417010b764e9d *R/posterior_samples.R 382652e7c40717ffb82c2de31161fddb *R/posterior_smooths.R 3257258ce49b157ea35e1610a2b3cada *R/pp_check.R 23b6d7d5a82eba6cb48eb40b13e51f4b *R/pp_mixture.R bd404eda215fefa87f3145c524a25c82 *R/predictive_error.R f3ca927300a09f1e8e3c93485aa8a13b *R/predictor.R 31f2371083ea50dc14f53896f975aabc *R/prepare_predictions.R 5aa300349b0a542bce1aff6d55f9929c *R/prior_draws.R b9abc244039da0c7da0302ffaddd7c09 *R/priors.R 648f2a070cf6f48c570365737496a087 *R/priorsense.R 292e73c74a84e88b08c4bd12c46738c5 *R/projpred.R 32e1da8d85afb0a74b9494c759359a05 *R/reloo.R 7581c907abdd3a59413611ae09943540 *R/rename_pars.R cd5296524b292c9b0863f942b6d03c11 *R/restructure.R 3bdbbff2939deda4641dea4e8ae3ea63 *R/stan-helpers.R 434d62d314e2303c906a78dc3a907e3a *R/stan-likelihood.R 9640e1529f4adf49c9fc4f797c0bf502 *R/stan-predictor.R 829e9b4e41d212bb0ed3822593b02350 *R/stan-prior.R d72e42ffca610df999c47e723cf61e38 *R/stan-response.R aef57e5736aac6d87688631fa07408bc *R/stancode.R 3490f1192c80a5df1df5149efc3148e6 *R/standata.R 3a5b3514ea1205e4872cd820222b3146 *R/stanvars.R c10bfb55f8741f5c861de5ba3917dfc8 *R/summary.R eba20db2bf9ca01ad141fee9d19f74ef *R/sysdata.rda aa5d13282e04f0d6c1599f8875767a87 *R/update.R ebbc3cbcb7cc97f18fd3a267b8347935 *R/zzz.R 66e9013887c41a99fa5b413eaad08d83 *README.md 1bf18d9c216b8d95033f0bd2fe2906b2 *build/partial.rdb 8a1458274940afba1ab1e6299a1d6468 *build/vignette.rds 29545093bb6edb0416e8ca2725949829 *data/epilepsy.rda d3e1729f040540ec7d640ce9d9e1c7c4 *data/inhaler.rda b491f9e27065b6a30dfaa06835d4058f *data/kidney.rda 1012588a05c5b7e59dfb16bc57adcf85 *data/loss.rda 2024133c73ebe6ad6887ac0f58235b4d *inst/CITATION e980d638ba46bad234988bd7e2dc77e5 *inst/chunks/fun_add_int.stan ea378d56df10b3d9272d2dca8262e8fb *inst/chunks/fun_asym_laplace.stan ba31fda913a325f23a5376eaae4cd603 *inst/chunks/fun_cauchit.stan fd90371e171982b87e128fcf8113266e *inst/chunks/fun_cholesky_cor_ar1.stan b8cdce7d7bdad258e873ab5cc8cc24d4 *inst/chunks/fun_cholesky_cor_arma1.stan 356998171806c24364357c7fa83bc4f3 *inst/chunks/fun_cholesky_cor_cosy.stan 1a86c51d5048b4cb4f280f041e28c7c6 *inst/chunks/fun_cholesky_cor_ma1.stan 37c2489f62fd1e768bd5099783e2cda8 *inst/chunks/fun_cloglog.stan cc90a446425ce70272883dbad7a6ae43 *inst/chunks/fun_com_poisson.stan 7e32812c1fbc8e61d9c2c96f59248fe4 *inst/chunks/fun_cox.stan d7f5ae53cc6aac2bcd8747f56692daae *inst/chunks/fun_dirichlet_logit.stan 855eb57cbd3f124749825c7e05fbba50 *inst/chunks/fun_dirichlet_multinomial_logit.stan 77bad66bf658c6d78b16f3b74284a9c7 *inst/chunks/fun_discrete_weibull.stan 90bf3da8c32ea57699d7bd87ed025da8 *inst/chunks/fun_gen_extreme_value.stan ae8f230cdc8aed34ddd47ee0ab4aff5c *inst/chunks/fun_gp_exp_quad.stan 122862e122986afa44933b3be4e40ad1 *inst/chunks/fun_gp_exponential.stan 9964d7bcd6927fc6ae9e95247bdcee44 *inst/chunks/fun_gp_matern32.stan c42b3815f3931af84600cd1e05cba11d *inst/chunks/fun_gp_matern52.stan ce292cbc3e1d372d58c21a0626bed6da *inst/chunks/fun_horseshoe.stan 6f382f8dd397b8a4a0aae8085753ffbc *inst/chunks/fun_hurdle_gamma.stan 32a82f3e36792d38d9f3b6aa58b14dbd *inst/chunks/fun_hurdle_lognormal.stan 22cb3b99c9a7aa3b39756cd2575635fb *inst/chunks/fun_hurdle_negbinomial.stan a753bb5e1ed481d31dfb5a72a27c937d *inst/chunks/fun_hurdle_poisson.stan 66ddad88d800f8e56b13ba36859b8ba4 *inst/chunks/fun_inv_gaussian.stan 8925c0b6f0387345f7e9c2a0d71d8ac2 *inst/chunks/fun_is_equal.stan 00aa1a161641dc9210d78322c8d900ef *inst/chunks/fun_logistic_normal.stan 2a96ce5d07454055d299ecd884e427f1 *inst/chunks/fun_logm1.stan 2f8ebeeae1b8524a0f336c7bd7951fdd *inst/chunks/fun_monotonic.stan 2761471d620cb112fafb222b662f6eb6 *inst/chunks/fun_multinomial_logit.stan 6a4e61936b11e2d17d4c2b1a1fcd3502 *inst/chunks/fun_normal_errorsar.stan 7da89af6f64975a537de8f5c77d307e2 *inst/chunks/fun_normal_fcor.stan abd3602bbdca2185ec2f338d4c284ae0 *inst/chunks/fun_normal_lagsar.stan ec4a6899636df1669eb49e764a3ac776 *inst/chunks/fun_normal_time.stan 09de2df29f089db12516f6c17d778376 *inst/chunks/fun_normal_time_se.stan f4429d472004f71c4a71cba4f1c631bb *inst/chunks/fun_r2d2.stan 0bc8ab0d7b8523aa844e1afbb8e9259f *inst/chunks/fun_scale_r_cor.stan 760f7db9ff09fab3e391071a76c6da83 *inst/chunks/fun_scale_r_cor_by.stan b9d1d68364d8c53a0c7eb5d77db29435 *inst/chunks/fun_scale_r_cor_by_cov.stan 73c259890366f5d8ae4268c41114a80a *inst/chunks/fun_scale_r_cor_cov.stan bd76e7df1f9ac3d13119e74e5ddb2d22 *inst/chunks/fun_scale_time_err.stan 37908320d8c68d285c9a02b7c195aadd *inst/chunks/fun_scale_time_err_flex.stan 8553ab777b080404c58390d306e3b4f6 *inst/chunks/fun_scale_xi.stan 5857b52f4b285492e8e31895058c635c *inst/chunks/fun_sequence.stan 2a774be1f69fe0a69cbd61e467c351c3 *inst/chunks/fun_softit.stan c7bf419a946c8bfbd262edd4a33f0e39 *inst/chunks/fun_softplus.stan 14830325d521752f8d04a28f28090176 *inst/chunks/fun_sparse_car_lpdf.stan c2cc9badf997c673b6ae4f1495c5ce3e *inst/chunks/fun_sparse_icar_lpdf.stan a648b7f6a103a14a7ea7101354c703f2 *inst/chunks/fun_spd_gp_exp_quad.stan 9ebeac85fe0d0537a1897bbeb20c428c *inst/chunks/fun_spd_gp_exponential.stan b5611f1ac4b8b4818a37a9c2e663dbc6 *inst/chunks/fun_spd_gp_matern32.stan 6015caf4eba5deb7d6fe130be9a230bf *inst/chunks/fun_spd_gp_matern52.stan aa5d3dd4ddb150c347178728970b9b29 *inst/chunks/fun_squareplus.stan e3410a563832744bc19f81672c4ce38d *inst/chunks/fun_stack_vectors.stan 21f75d7dcbc7ec643344bde03b071057 *inst/chunks/fun_student_t_errorsar.stan 7ecdcc3ef15aac75059696c3092159b9 *inst/chunks/fun_student_t_fcor.stan 17be1585e0d2a3da3db0f5b186dd0e57 *inst/chunks/fun_student_t_lagsar.stan 2a65b404dd030916a9b4ad018784b990 *inst/chunks/fun_student_t_time.stan 45888d7fc56c9dab5f3624a167a4c00d *inst/chunks/fun_student_t_time_se.stan ead13b17a6ee30bc1234cbbd5a9e5478 *inst/chunks/fun_tan_half.stan 827562865ebd163a9824e26b276cb9be *inst/chunks/fun_which_range.stan 6e5b83378b4701b2c6fb3efd326f95ee *inst/chunks/fun_wiener_diffusion.stan 23bc75592a47dd5026912a03dab8dd15 *inst/chunks/fun_xbeta.stan 6a85f96ae29a539743865b155c8393ea *inst/chunks/fun_zero_inflated_asym_laplace.stan e76db5963e8b6358822005b7b3ffe57e *inst/chunks/fun_zero_inflated_beta.stan 701b8376108cde636fd66906f9ce6f17 *inst/chunks/fun_zero_inflated_beta_binomial.stan 007ca9d21e1e8ace60ac061af77ed100 *inst/chunks/fun_zero_inflated_binomial.stan 6f99414a24b70e038b595f3affc7584f *inst/chunks/fun_zero_inflated_negbinomial.stan 078cb83d3122b01e310aa6c7272e1db3 *inst/chunks/fun_zero_inflated_poisson.stan c2055bf9157eb32470ead3264ba79d91 *inst/chunks/fun_zero_one_inflated_beta.stan e88a33d15e2de9139a5ce17cf9f34adc *inst/doc/brms_customfamilies.R eb083883ddb374d533b9248f3f5adc32 *inst/doc/brms_customfamilies.Rmd 1d9d6749430f746179a9693518cf290b *inst/doc/brms_customfamilies.html a0830ccbed0d5d5522f8aebdd5e3703a *inst/doc/brms_distreg.R a339d9434b63d7cce22a07343804868d *inst/doc/brms_distreg.Rmd 75f96d15cf6e2e049f2c39212ec89c89 *inst/doc/brms_distreg.html 8fc9924120fd5301b479e2eebb8c2897 *inst/doc/brms_families.Rmd 410b8d4c80cd6f45b5c76be170008b65 *inst/doc/brms_families.html 94562b0d609f4d99ed74ae1078d3ab6d *inst/doc/brms_missings.R 9d396aa20aa08324a61a03a8456beefe *inst/doc/brms_missings.Rmd 4e9a867bd51799872bbe69c93fe50603 *inst/doc/brms_missings.html 5aa518341f5ab0553ea554fdd608f13b *inst/doc/brms_monotonic.R 0fb59e282dd7005878e97b6751e0b89b *inst/doc/brms_monotonic.Rmd d458e08ab4181b7f45832259c24b1c70 *inst/doc/brms_monotonic.html f7cece21fca8fbaaa53a106038349d0c *inst/doc/brms_multilevel.ltx eaa17caca4f8c0d562744fb6af64c320 *inst/doc/brms_multilevel.pdf 83b1659d4853ec07771f642a70fa9cc0 *inst/doc/brms_multivariate.R aaa035cc896695c250ad14ce006875e6 *inst/doc/brms_multivariate.Rmd 6b2133d16a36260a33ea4ade42356392 *inst/doc/brms_multivariate.html 32fc4c5cce8e76207d0234bdb3087f2a *inst/doc/brms_nonlinear.R 2d0deb9a7d46b1041ad1c4c50b1c7ef3 *inst/doc/brms_nonlinear.Rmd 7cc4a16d4a56471de466dc842be12245 *inst/doc/brms_nonlinear.html a1cedf005c2069da46818011b03829f3 *inst/doc/brms_overview.ltx 3d440f7f3446a5f74e625228357d3c02 *inst/doc/brms_overview.pdf d7a96feb0680fd5719e6263eb3003145 *inst/doc/brms_phylogenetics.R 418d18efa1eef1cb0e4c95b894788847 *inst/doc/brms_phylogenetics.Rmd 645e736272efea79d9ac7e86e6b13366 *inst/doc/brms_phylogenetics.html 0417c4f412dc2375901491f7d0497c8b *inst/doc/brms_threading.R 210bfd3cd4855538f135438f6c477120 *inst/doc/brms_threading.Rmd 61d0efc2c63af0b2535f359f4378590d *inst/doc/brms_threading.html f819a4d09188807bbb5fdda05405e6e1 *man/AsymLaplace.Rd 5213ddb4c75aedec7603e2fdea1af660 *man/BetaBinomial.Rd 14c9f1fc298dcbd26f807f24e07550db *man/Dirichlet.Rd 97e447e090056a382da7393a794dc68d *man/ExGaussian.Rd 348c7a3e4b2acf7822be61a7b9ace214 *man/Frechet.Rd 7b52f19a8bb07059496ab6b2b3aab6ef *man/GenExtremeValue.Rd 35c9075a7ca69042980395bfd9e02bc5 *man/Hurdle.Rd 7b4a4ebd29218e15291e36d3f5c46f9b *man/InvGaussian.Rd 3e30acb0a73351ea6c1b985e94028f42 *man/LogisticNormal.Rd 753d1ca334e597308c7d29c4fd0a4c58 *man/MultiNormal.Rd 177329b0857f2572b3ea7195f81f99b7 *man/MultiStudentT.Rd 5edf98fb45e8e7771074884bf5ac7266 *man/R2D2.Rd 8bf7659c384cabee6cdd45e0616995db *man/Shifted_Lognormal.Rd 8ae449627b649dddccafb402636dd9d6 *man/SkewNormal.Rd 70ba47e2aa88bf4f6138afe10afc6ede *man/StudentT.Rd 6685626d29ded45092d866eab6dbc9c7 *man/VarCorr.brmsfit.Rd f13b2768f3ae0bc9a4146f74bbaf65b3 *man/VonMises.Rd 930e9213115e835e1ecb1321258c4308 *man/Wiener.Rd 2f1fdd6851666b81b68f2896f15c3c0b *man/ZeroInflated.Rd 31a44156c8e576ea06883c5f0b6f05f8 *man/add_criterion.Rd e4dcad442f8cf21705c604480ca9bf6b *man/add_ic.Rd 8ead7876a361cce15b28222a5dc69629 *man/add_rstan_model.Rd 02f35be9b025d61a0b1326b84b7288ab *man/addition-terms.Rd d1694011ffb4be502a30de3bfa1d5709 *man/ar.Rd e48c1cebb35608b8aa990d9aaedcefab *man/arma.Rd 82b55dbf7026b27fe7b97bf7ce022b5a *man/as.brmsprior.Rd 1a5ec35ec370b88d90d312f2ee2894b9 *man/as.data.frame.brmsfit.Rd f87d2ce6d9abe54edca4b01390511c26 *man/as.mcmc.brmsfit.Rd a8a13c885a4f26bb5badf8b43daf36c0 *man/autocor-terms.Rd 8b6e6789c093ecd1badcf2b7db00459a *man/autocor.brmsfit.Rd f0f74832fe6fe23bb89dc2378cab7bc3 *man/bayes_R2.brmsfit.Rd c3e6672f4201e9b6b20308c48225c31d *man/bayes_factor.brmsfit.Rd c4a446cf8e2dffd057691878aa56d500 *man/bridge_sampler.brmsfit.Rd ebcd9ea9583dc0e2dd23d17afb6f3e3b *man/brm.Rd d5c243badbd9eae1710fe72d0aec3582 *man/brm_multiple.Rd a238ee19fdacfdc0ee4795f3b35c7f97 *man/brms-package.Rd 0e13e8595d683c22d29ee1b01ae2eeb8 *man/brmsfamily.Rd b8bbded408efe8198b9dfdfa9805d1f9 *man/brmsfit-class.Rd b74cf28ce5d087c9b17c7d53041d64f7 *man/brmsfit_needs_refit.Rd 1036924e7dc17991d0a52a31458486e4 *man/brmsformula-helpers.Rd 12691f9c9ac249fa210279be6a934883 *man/brmsformula.Rd fb4ca1dcb71e15eaeef0e4e240eb7c48 *man/brmshypothesis.Rd c2b51e956debe84df87304a1d8ddccaa *man/brmsterms.Rd eea27eaf3a81c29d313ae18177be35bc *man/car.Rd ebcaf612c03c7e8e49795504239101b6 *man/coef.brmsfit.Rd 585718ec6123ceb262c5a46f5c2033b3 *man/combine_models.Rd 2d4529ffb04ae9b7b2cf32688d65667a *man/compare_ic.Rd b2e0a65b580bf96fec2a7a6e03aa044e *man/conditional_effects.brmsfit.Rd 55f52c3f271f5f84463e9f95826551e5 *man/conditional_smooths.brmsfit.Rd a038c4a51081b9be6fd08b508d243f34 *man/constant.Rd 75d9f30b935f0e99a41d01e4bf0f9b4e *man/control_params.Rd 4aa53d8353dffc501c9bf55b85e0432f *man/cor_ar.Rd cecad3804f335aea8259e3dc4303647b *man/cor_arma.Rd 7f439f409b1aa8e77f01687959e46393 *man/cor_arr.Rd 8f8b4ff277782a5cce802a93a0099784 *man/cor_brms.Rd 46dc58cfcc1ebebd9bc1b972cfeb4352 *man/cor_bsts.Rd ab427b3414aefcf08e9ab1bb23e9092c *man/cor_car.Rd c0de434e09365e73bc60be48b9020269 *man/cor_cosy.Rd 0c8390364d274f1240881f8db6bf4efe *man/cor_fixed.Rd b830c26475a2c54fbdeaa1db9e14b98b *man/cor_ma.Rd 713028020db23317a00dcbd763eeef6c *man/cor_sar.Rd 9d3a1304f56bd940335c3a2ff440f684 *man/cosy.Rd 53fe23e3c679d38277aa076def69c4ff *man/create_priorsense_data.brmsfit.Rd 285a185d228d276351aa993c5d518dee *man/cs.Rd 937e3f14559f1b1eaa2749a381659d1b *man/custom_family.Rd 7d03bee9e6784550dd14c86517f88048 *man/data_predictor.Rd ce7eda06e9eefc17ea320ef7f1448c2a *man/data_response.Rd b6db324f9a5b64f0941576165e21a631 *man/default_prior.Rd a59323d526a0d9fae260685358a6b943 *man/default_prior.default.Rd 04b4aae9b081455668a9ecbe6ff7b8a1 *man/density_ratio.Rd 1fa223725ad6bf8d81b68686cacc2198 *man/diagnostic-quantities.Rd e589de81ddbec620fa58e1501bc887c0 *man/do_call.Rd 0acbb82e6f9b540146069d2cf844713a *man/draws-brms.Rd 675ee1a3277bd1a7367047e66a21846c *man/draws-index-brms.Rd 14f1e9a3ae3e4c32c254a446847b1ab8 *man/emmeans-brms-helpers.Rd 640e1713fbc56c4761a3fc9ed1a40d57 *man/epilepsy.Rd 0474edf753d3dc04367b0fce35b851e5 *man/expose_functions.brmsfit.Rd ef2c51106154f8ec1eed261051f21a63 *man/expp1.Rd ebbceb3446d178098f9cb6d582ae65b5 *man/family.brmsfit.Rd e80efced805aedd25858d661a85b4959 *man/fcor.Rd 0ea39d7ff5499c25ff4647d789dcbced *man/figures/README-conditional_effects-1.png 418e9fd1e3790e96d75924b70215d7e7 *man/figures/README-plot-1.png b92756dfff9f51be038ca8acc5e2a8e9 *man/figures/brms.png 5fad10a5cc62c59ea429a5ce90191e2e *man/figures/stanlogo.png cb2fc04e2b2be0df5c7bd684eac81cb2 *man/fitted.brmsfit.Rd 655490ff4efde340116660f0781d9350 *man/fixef.brmsfit.Rd cbb1a56c5f50bc677ef49e3b4efca504 *man/get_dpar.Rd 514c482b13b8f794443d89c7e927a7fd *man/get_refmodel.brmsfit.Rd d76887acafebd4415eb1afb776d84224 *man/get_y.Rd 13f2225e9c68f1af5ff4ec662eb2816a *man/gp.Rd 9807df309f9514769c80c643ea651440 *man/gr.Rd 8e87e7266324e0b3b22e78a07fac2995 *man/horseshoe.Rd 5826145f362a2cebf42411081d589d52 *man/hypothesis.brmsfit.Rd b35515077061d0109567561d704fe0e0 *man/inhaler.Rd 8d438d50996df9dbab0425a0e4241c47 *man/inits.brmsfit.Rd 91bc090feda4bd1d3905237cb210afc0 *man/inv_logit_scaled.Rd d3887f794ca279d6e91f78d359488413 *man/is.brmsfit.Rd 4bfcffa8ee62d0ba281e00ac75c44c62 *man/is.brmsfit_multiple.Rd d345caf2b9ad7295e3c8b3c7550099b9 *man/is.brmsformula.Rd 2495abf33e51dd1c7b777be17639e83b *man/is.brmsprior.Rd b4e9ae0fe2f7e053481f5baec6c169f8 *man/is.brmsterms.Rd 719230daa3fa48becfd07b2abd132270 *man/is.cor_brms.Rd a8d15115fddf4462460bee22230c7aa1 *man/is.mvbrmsformula.Rd 9a9129afc0fa575f47184739243bb79d *man/is.mvbrmsterms.Rd 69d1963bc4a501570e1379ddb564b4b7 *man/kfold.brmsfit.Rd 334dfdc995adef09e0f64a0bf3ca9238 *man/kfold_predict.Rd 3da1d29a87963c216a1c6e7a03062f41 *man/kidney.Rd 7f439a55f6cf09c82c5ee2384d971814 *man/lasso.Rd cbd0f56d622011c84a68843f92b97822 *man/launch_shinystan.brmsfit.Rd ee868e61448465ff7e6f80d8f7814172 *man/log_lik.brmsfit.Rd 900ea73d5b892e4fb1436ca014dfcb16 *man/logit_scaled.Rd 1e4ddd51ad3a4561cb500f85ad5f2e0a *man/logm1.Rd 034aaec24cbc993334590800dff505e6 *man/loo.brmsfit.Rd 4c1a2848314db535bfe6875f69fd5a17 *man/loo_R2.brmsfit.Rd 57a07a3eaada9ab2c256a44d27ffec5d *man/loo_compare.brmsfit.Rd f29597640d7d655a681115ab42f02789 *man/loo_model_weights.brmsfit.Rd e37323840deaac3dc944ce41b0b53d55 *man/loo_moment_match.brmsfit.Rd d7e2c7b643685a5f1b338d576abff6f5 *man/loo_predict.brmsfit.Rd e0d53fb404be8407bf1a5ec23410af8d *man/loo_subsample.brmsfit.Rd 7fa05a35f23a32ff377f16d4376fee7a *man/loss.Rd 9ae67551d15eb035058fe01f8fd551f4 *man/ma.Rd 67442f213bfd5a21dc2d7ef560ff618e *man/make_conditions.Rd 699f7d9796dc61fcb6ba5a7fcfe8f03b *man/mcmc_plot.brmsfit.Rd 8a4b6431285accd9445532bc466b216f *man/me.Rd 059d1149efd9185938a5da4f54af27c9 *man/mi.Rd 0d80e006693488c64b0628226d100982 *man/mixture.Rd 3dd10b265565dc6344101a829024e8c3 *man/mm.Rd c8f23b1448b4d3fddc30f12c3c6747af *man/mmc.Rd 67fdada3b82bf0de3502920ff501f251 *man/mo.Rd 9888d2ba125fea25753c8e07bafb4bd8 *man/model_weights.brmsfit.Rd 41d271b33d265ac55dce75c385d429ca *man/mvbind.Rd d9faea0f79c1ed4b2107cedef3c2aea5 *man/mvbrmsformula.Rd c12860b45008dfc4a57a27111003d8f5 *man/ngrps.brmsfit.Rd f736c567c641266af3de81ac00769748 *man/nsamples.brmsfit.Rd 5eadb0ff319ed12d02d1d8af4d2ad78e *man/opencl.Rd ab92f50152366dab3e9dfd8f9f65e2a4 *man/pairs.brmsfit.Rd 3c30943f7c3617d6b30253272079cecf *man/parnames.Rd 365896a4ebacf8032a7ee3c9ad6c78b2 *man/plot.brmsfit.Rd fdf888004fff752c2772e53d818a7d3d *man/post_prob.brmsfit.Rd 38ed4581e02f5dc08768937020a81ba7 *man/posterior_average.brmsfit.Rd 2ce8b18b590387834fe54eef353f63d1 *man/posterior_epred.brmsfit.Rd 19a86630a8ccb9f149f796922bb4fb84 *man/posterior_interval.brmsfit.Rd 5ab7a2646559f20667c5d8c7ef5036b9 *man/posterior_linpred.brmsfit.Rd 7781ea8e6884bcb386474276a5c17d64 *man/posterior_predict.brmsfit.Rd 1a2ada66c95792eb04d29443968a4d00 *man/posterior_samples.brmsfit.Rd cde301543987b3569dce77d3691b128c *man/posterior_smooths.brmsfit.Rd 8b15c4487188671d4819d06f1acdc827 *man/posterior_summary.Rd 95c2007d202944bdb2946fef3b64f14f *man/posterior_table.Rd 69ab8a8a8eb61612f88502adc64ddb16 *man/pp_average.brmsfit.Rd 45f90a4ad993dbb51ade0e90dce69255 *man/pp_check.brmsfit.Rd 1f558f4688129f40ae626c9cf7afaaf7 *man/pp_mixture.brmsfit.Rd bf856ac831da5c17ba70270e95751e38 *man/predict.brmsfit.Rd a5b1914dff505477a38484a70dea4ed4 *man/predictive_error.brmsfit.Rd 9fb4d1382e914f9ff5a306f783091c4b *man/predictive_interval.brmsfit.Rd 13d1cfbc82565d87fd96e363b07c99fb *man/prepare_predictions.Rd d8544d0c388347519595fac378f962cc *man/print.brmsfit.Rd e8009c6186fb93c8d89682c4dd34c1cb *man/print.brmsprior.Rd 924af1c1af0be14eaf84860a048b3a8c *man/prior_draws.brmsfit.Rd fe6e0546b8a6f37da691b634db85a2c6 *man/prior_summary.brmsfit.Rd 98b653ad2bf52c09bd657f1129f93371 *man/psis.brmsfit.Rd f24e2e8f9ac0bac9fb6e51bd2dd66a55 *man/ranef.brmsfit.Rd cfa182543f17df2ce94f4ac13418aa0e *man/read_csv_as_stanfit.Rd 2d049bf19ee1db3b1e00b044c41f3e3d *man/recompile_model.Rd c5cf08cff2220f277b332c27ff2eef3d *man/reloo.brmsfit.Rd ef360aa01a646f3c4a86b8b30d661ecf *man/rename_pars.Rd 6b033a833f8e65dbc9c9220d7dd83aa6 *man/residuals.brmsfit.Rd c94e5799c99fca179dcf339aa26fb156 *man/restructure.Rd b9d0946f5abe7501a39cdba647f2af1c *man/restructure.brmsfit.Rd 4f7f207825b3f9a5f951f9cc02d9bc65 *man/rows2labels.Rd 952bcce8ddb9faa6516e7c2b70e22c29 *man/s.Rd 36766e1568e020be0eedcd04c795f0c9 *man/sar.Rd 93c434f2f48ec1a9397139fff5444473 *man/save_pars.Rd a2c7209c95ccd01d483b2ebe3ccd207f *man/set_prior.Rd 2ab602932234d4fe3cb47112c777c73a *man/stancode.Rd 35583894169f72219b4167048371836a *man/stancode.brmsfit.Rd 62a3d4b0a80e3618f89004da7d170880 *man/stancode.default.Rd aa9ad19d5adcd2b1093d5926729ff3b0 *man/standata.Rd 8b91312957f57098acfb2b12a5a08e26 *man/standata.brmsfit.Rd 4a3ccabed374ff8238c61533fac552fb *man/standata.default.Rd cf0730c154bdbdf99f3eaa2b7efc3639 *man/stanvar.Rd 609139f5fa9d220f297ec9aac9675a05 *man/summary.brmsfit.Rd 6ef704004a7c7719b0806d1cd47f3736 *man/theme_black.Rd 6f15836eefa722613d11ae2a26d498b2 *man/theme_default.Rd 0e7f77b08849f4a8ac1ada1095177316 *man/threading.Rd 7093aec94cb5402d9bdcbd0aa84b8496 *man/unstr.Rd 7a73dcfd9ad17ab4aa446ed5930e5640 *man/update.brmsfit.Rd 80d760ba06ba1f53418ed5fe7aef832f *man/update.brmsfit_multiple.Rd d4329014c6586f1d939c80df9105286d *man/update_adterms.Rd d06bd6cea941992c7efe7978a20f25e9 *man/validate_newdata.Rd 8fe24ef2e8063ec81bb6d74e3c570f25 *man/validate_prior.Rd 1174c012f645c3dc8f70ef58fe542671 *man/vcov.brmsfit.Rd dee69387c0a4ef07a8953e4980649c80 *man/waic.brmsfit.Rd eb94c0cef2e4c20ce9610bd1cc3661b6 *tests/testthat.R 7d17ab2ab674f8c2c73fe7183a2a47e4 *tests/testthat/helpers/insert_refcat_ch.R 5ec846c86afc79b242210452eb4e1b00 *tests/testthat/helpers/inv_link_categorical_ch.R 919d639446d3c2ab168cbdcf3bb4336d *tests/testthat/helpers/inv_link_ordinal_ch.R 771dcf586afefa69ae5c82a1c867e845 *tests/testthat/helpers/link_categorical_ch.R 55eff9dc736befdf5b7569a5b0bdf9f1 *tests/testthat/helpers/link_ordinal_ch.R 34a79884fed445b69b7fcd9e4166e531 *tests/testthat/helpers/simopts_catlike.R 83cf80ac0b464e6217fabba119a182c5 *tests/testthat/helpers/simopts_catlike_oneobs.R 45add0fc02498a6d1bcb890b9c7149f7 *tests/testthat/tests.brm.R 1893699606b1b556bc63fa82e21b1671 *tests/testthat/tests.brmsfit-helpers.R b646d9794d4c04615e885b69294434a1 *tests/testthat/tests.brmsfit-methods.R 218087f1991e81f0f9696364227e3dd6 *tests/testthat/tests.brmsformula.R 147d519778a7cd17bdbe0d365c9ea20a *tests/testthat/tests.brmsterms.R 0701b29bcf35b3dc573c0e48e87762fe *tests/testthat/tests.data-helpers.R f897096ce661f2c08e5c2eb1c4f16a84 *tests/testthat/tests.distributions.R d01d0b94f62f06f1a988178208f1077c *tests/testthat/tests.emmeans.R 65451b49b0aeda03d07d49ebba424295 *tests/testthat/tests.exclude_pars.R 2ea085388d40117d07ef283a4c8df53e *tests/testthat/tests.families.R 6af665159138b24a041791e3974027d2 *tests/testthat/tests.log_lik.R f7948ad671bd0c8a78709cfb244dc9b5 *tests/testthat/tests.misc.R 9e20a39df046c65085c3d1ed716b65a9 *tests/testthat/tests.posterior_epred.R 9e0ffe617df3fc8c20caed5420d48c8b *tests/testthat/tests.posterior_predict.R aca3239d89b8d005de1461331d5e381e *tests/testthat/tests.priors.R f7db211f8cbac5f935fa13b3a617842c *tests/testthat/tests.priorsense.R da12c6a17a5ccf2dd7e49c4975ff1610 *tests/testthat/tests.read_csv_as_stanfit.R 217e1ec6d85a8964e69621bcac0369c8 *tests/testthat/tests.rename_pars.R 38aaf21cc9c3f7f7da617f32352efd6c *tests/testthat/tests.restructure.R 65f6180b5a6026b675b6ac1065e49713 *tests/testthat/tests.stan_functions.R c228ef763e8f515b1c26e8a5768fa3f4 *tests/testthat/tests.stancode.R d4bc03bc7ea4205ae5211025914bdf30 *tests/testthat/tests.standata.R 7a2b007569ddfe6b33568f46fef6e045 *tests/testthat/tests.stop2.R eb083883ddb374d533b9248f3f5adc32 *vignettes/brms_customfamilies.Rmd a339d9434b63d7cce22a07343804868d *vignettes/brms_distreg.Rmd 8fc9924120fd5301b479e2eebb8c2897 *vignettes/brms_families.Rmd 9d396aa20aa08324a61a03a8456beefe *vignettes/brms_missings.Rmd 0fb59e282dd7005878e97b6751e0b89b *vignettes/brms_monotonic.Rmd f7cece21fca8fbaaa53a106038349d0c *vignettes/brms_multilevel.ltx aaa035cc896695c250ad14ce006875e6 *vignettes/brms_multivariate.Rmd 2d0deb9a7d46b1041ad1c4c50b1c7ef3 *vignettes/brms_nonlinear.Rmd a1cedf005c2069da46818011b03829f3 *vignettes/brms_overview.ltx 418d18efa1eef1cb0e4c95b894788847 *vignettes/brms_phylogenetics.Rmd 210bfd3cd4855538f135438f6c477120 *vignettes/brms_threading.Rmd 8e122a174183d81956fefd5f7d9a2b9b *vignettes/citations_multilevel.bib 6ba1d5ec8ecc1031d8845d82dcef11da *vignettes/citations_overview.bib 1e02697a37e36908b7d8954bfaea2e92 *vignettes/flowchart.pdf 598082534ce6cb51d34c01a69dda5088 *vignettes/inhaler_plot.pdf d7d237f55a6850eba15ad5ceeaf821f6 *vignettes/kidney_conditional_effects.pdf 7632f1034a93aa91cd5d27f3430419f7 *vignettes/kidney_plot.pdf 130d165d8715c0e39e51dac5a843d50a *vignettes/me_loss1.pdf 2c51e8bc0ba3986d8e445b445943473c *vignettes/me_loss1_year.pdf 70c11e0b4eb944016ef306a402fce2c4 *vignettes/me_rent1.pdf beff1ce999b4bd7244ecbe2b6e887c9a *vignettes/me_rent2.pdf 8d6a4a639492d0ac1e71bbf25b93fa03 *vignettes/me_rent3.pdf 5b56487f6dc0b92bfe7894ba09264971 *vignettes/me_zinb1.pdf 1fe96ffc00b75a46155b60f534625f43 *vignettes/ppc_mm1.pdf brms/R/0000755000176200001440000000000015057532452011426 5ustar liggesusersbrms/R/formula-sp.R0000644000176200001440000005015715057505416013646 0ustar liggesusers# This file contains functions dealing with the extended # formula syntax to specify special effects terms #' Predictors with Measurement Error in \pkg{brms} Models #' #' (Soft deprecated) Specify predictors with measurement error. The function #' does not evaluate its arguments -- it exists purely to help set up a model. #' #' @param x The variable measured with error. #' @param sdx Known measurement error of \code{x} #' treated as standard deviation. #' @param gr Optional grouping factor to specify which #' values of \code{x} correspond to the same value of the #' latent variable. If \code{NULL} (the default) each #' observation will have its own value of the latent variable. #' #' @details #' For detailed documentation see \code{help(brmsformula)}. #' \code{me} terms are soft deprecated in favor of the more #' general and consistent \code{\link{mi}} terms. #' By default, latent noise-free variables are assumed #' to be correlated. To change that, add \code{set_mecor(FALSE)} #' to your model formula object (see examples). #' #' @seealso #' \code{\link{brmsformula}}, \code{\link{brmsformula-helpers}} #' #' @examples #' \dontrun{ #' # sample some data #' N <- 100 #' dat <- data.frame( #' y = rnorm(N), x1 = rnorm(N), #' x2 = rnorm(N), sdx = abs(rnorm(N, 1)) #' ) #' # fit a simple error-in-variables model #' fit1 <- brm(y ~ me(x1, sdx) + me(x2, sdx), data = dat, #' save_pars = save_pars(latent = TRUE)) #' summary(fit1) #' #' # turn off modeling of correlations #' bform <- bf(y ~ me(x1, sdx) + me(x2, sdx)) + set_mecor(FALSE) #' fit2 <- brm(bform, data = dat, save_pars = save_pars(latent = TRUE)) #' summary(fit2) #' } #' #' @export me <- function(x, sdx, gr = NULL) { # use 'term' for consistency with other special terms term <- deparse0(substitute(x)) sdx <- deparse0(substitute(sdx)) gr <- substitute(gr) if (!is.null(gr)) { gr <- deparse0(gr) stopif_illegal_group(gr) } else { gr <- "" } label <- deparse0(match.call()) out <- nlist(term, sdx, gr, label) class(out) <- c("me_term", "sp_term") out } #' Predictors with Missing Values in \pkg{brms} Models #' #' Specify predictor term with missing values in \pkg{brms}. The function does #' not evaluate its arguments -- it exists purely to help set up a model. #' For documentation on how to specify missing values in response variables, #' see \code{\link{resp_mi}}. #' #' @param x The variable containing missing values. #' @param idx An optional variable containing indices of observations in `x` #' that are to be used in the model. This is mostly relevant in partially #' subsetted models (via \code{resp_subset}) but may also have other #' applications that I haven't thought of. #' #' @details For detailed documentation see \code{help(brmsformula)}. #' #' @seealso \code{\link{brmsformula}} #' #' @examples #' \dontrun{ #' data("nhanes", package = "mice") #' N <- nrow(nhanes) #' #' # simple model with missing data #' bform1 <- bf(bmi | mi() ~ age * mi(chl)) + #' bf(chl | mi() ~ age) + #' set_rescor(FALSE) #' #' fit1 <- brm(bform1, data = nhanes) #' #' summary(fit1) #' plot(conditional_effects(fit1, resp = "bmi"), ask = FALSE) #' loo(fit1, newdata = na.omit(fit1$data)) #' #' # simulate some measurement noise #' nhanes$se <- rexp(N, 2) #' #' # measurement noise can be handled within 'mi' terms #' # with or without the presence of missing values #' bform2 <- bf(bmi | mi() ~ age * mi(chl)) + #' bf(chl | mi(se) ~ age) + #' set_rescor(FALSE) #' #' fit2 <- brm(bform2, data = nhanes) #' #' summary(fit2) #' plot(conditional_effects(fit2, resp = "bmi"), ask = FALSE) #' #' # 'mi' terms can also be used when some responses are subsetted #' nhanes$sub <- TRUE #' nhanes$sub[1:2] <- FALSE #' nhanes$id <- 1:N #' nhanes$idx <- sample(3:N, N, TRUE) #' #' # this requires the addition term 'index' being specified #' # in the subsetted part of the model #' bform3 <- bf(bmi | mi() ~ age * mi(chl, idx)) + #' bf(chl | mi(se) + subset(sub) + index(id) ~ age) + #' set_rescor(FALSE) #' #' fit3 <- brm(bform3, data = nhanes) #' #' summary(fit3) #' plot(conditional_effects(fit3, resp = "bmi"), ask = FALSE) #' } #' #' @export mi <- function(x, idx = NA) { # use 'term' for consistency with other special terms term <- deparse0(substitute(x)) term_vars <- all_vars(term) if (!is_equal(term, term_vars)) { stop2("'mi' only accepts single untransformed variables.") } idx <- deparse0(substitute(idx)) if (idx != "NA") { idx_vars <- all_vars(idx) if (!is_equal(idx, idx_vars)) { stop2("'mi' only accepts single untransformed variables.") } } label <- deparse0(match.call()) out <- nlist(term, idx, label) class(out) <- c("mi_term", "sp_term") out } #' Monotonic Predictors in \pkg{brms} Models #' #' Specify a monotonic predictor term in \pkg{brms}. The function does not #' evaluate its arguments -- it exists purely to help set up a model. #' #' @param x An integer variable or an ordered factor to be modeled as monotonic. #' @param id Optional character string. All monotonic terms #' with the same \code{id} within one formula will be modeled as #' having the same simplex (shape) parameter vector. If all monotonic terms #' of the same predictor have the same \code{id}, the resulting #' predictions will be conditionally monotonic for all values of #' interacting covariates (Bürkner & Charpentier, 2020). #' #' @details See Bürkner and Charpentier (2020) for the underlying theory. For #' detailed documentation of the formula syntax used for monotonic terms, #' see \code{help(brmsformula)} as well as \code{vignette("brms_monotonic")}. #' #' @seealso \code{\link{brmsformula}} #' #' @references #' Bürkner P. C. & Charpentier E. (2020). Modeling Monotonic Effects of Ordinal #' Predictors in Regression Models. British Journal of Mathematical and #' Statistical Psychology. doi:10.1111/bmsp.12195 #' #' @examples #' \dontrun{ #' # generate some data #' income_options <- c("below_20", "20_to_40", "40_to_100", "greater_100") #' income <- factor(sample(income_options, 100, TRUE), #' levels = income_options, ordered = TRUE) #' mean_ls <- c(30, 60, 70, 75) #' ls <- mean_ls[income] + rnorm(100, sd = 7) #' dat <- data.frame(income, ls) #' #' # fit a simple monotonic model #' fit1 <- brm(ls ~ mo(income), data = dat) #' summary(fit1) #' plot(fit1, N = 6) #' plot(conditional_effects(fit1), points = TRUE) #' #' # model interaction with other variables #' dat$x <- sample(c("a", "b", "c"), 100, TRUE) #' fit2 <- brm(ls ~ mo(income)*x, data = dat) #' summary(fit2) #' plot(conditional_effects(fit2), points = TRUE) #' #' # ensure conditional monotonicity #' fit3 <- brm(ls ~ mo(income, id = "i")*x, data = dat) #' summary(fit3) #' plot(conditional_effects(fit3), points = TRUE) #' } #' #' @export mo <- function(x, id = NA) { # use 'term' for consistency with other special terms term <- deparse0(substitute(x)) id <- as_one_character(id, allow_na = TRUE) label <- deparse0(match.call()) out <- nlist(term, id, label) class(out) <- c("mo_term", "sp_term") out } # find variable names for which to keep NAs vars_keep_na <- function(x, ...) { UseMethod("vars_keep_na") } #' @export vars_keep_na.mvbrmsterms <- function(x, ...) { resps <- get_element(x, "respform") resps <- ulapply(resps, terms_resp, check_names = FALSE) out <- lapply(x$terms, vars_keep_na, responses = resps, ...) vars_mi <- unique(ulapply(out, attr, "vars_mi")) out <- unique(unlist(out)) miss_mi <- setdiff(vars_mi, out) if (length(miss_mi)) { stop2( "Response models of variables in 'mi' terms require " , "specification of the addition argument 'mi'. See ?mi. ", "Error occurred for ", collapse_comma(miss_mi), "." ) } out } #' @export vars_keep_na.brmsterms <- function(x, responses = NULL, ...) { out <- character(0) if (is.formula(x$adforms$mi)) { mi_respcall <- terms_resp(x$respform, check_names = FALSE) mi_respvars <- all_vars(mi_respcall) mi_advars <- all_vars(x$adforms$mi) c(out) <- unique(c(mi_respcall, mi_respvars, mi_advars)) } if (is.formula(x$adforms$cens)) { y2_expr <- get_ad_expr(x, "cens", "y2", type = "vars") c(out) <- all_vars(y2_expr) } uni_mi <- ulapply(get_effect(x, "sp"), attr, "uni_mi") if (length(uni_mi)) { vars_mi <- ulapply(uni_mi, function(term) eval2(term)$term) miss_mi <- setdiff(vars_mi, responses) if (length(miss_mi)) { stop2( "Variables in 'mi' terms should also be specified " , "as response variables in the model. See ?mi. ", "Error occurred for ", collapse_comma(miss_mi), "." ) } attr(out, "vars_mi") <- vars_mi } out } # extract unique names of noise-free terms get_uni_me <- function(x) { uni_me <- ulapply(get_effect(x, "sp"), attr, "uni_me") if (!length(uni_me)) { return(NULL) } xname <- ulapply(uni_me, function(term) eval2(term)$term) df <- data.frame(xname, uni_me) df <- df[!duplicated(df), ] xdupl <- df$xname[duplicated(df$xname)] if (length(xdupl)) { calls <- df$uni_me[df$xname == xdupl[1]] stop2( "Variable '", xdupl[1], "' is used in different calls to 'me'.\n", "Associated calls are: ", collapse_comma(calls) ) } unique(uni_me) } # save all me-terms within a tidy data.frame frame_me <- function(x, data, old_levels = NULL) { uni_me <- get_uni_me(x) if (!length(uni_me)) { return(empty_meframe()) } if (has_subset(x)) { # 'Xme' variables need to be the same across univariate models stop2("Argument 'subset' is not supported when using 'me' terms.") } out <- data.frame( term = uni_me, xname = "", grname = "", stringsAsFactors = FALSE ) levels <- list() for (i in seq_rows(out)) { tmp <- eval2(out$term[i]) out$xname[i] <- tmp$term if (isTRUE(nzchar(tmp$gr))) { out$grname[i] <- tmp$gr if (is.null(levels[[tmp$gr]])) { levels[[tmp$gr]] <- extract_levels(get(tmp$gr, data)) } } } out$coef <- rename(paste0("me", out$xname)) out$cor <- isTRUE(x$mecor) if (!is.null(old_levels)) { # for newdata numeration has to depend on the original levels set_levels(out) <- old_levels set_levels(out, "used") <- levels } else { set_levels(out) <- levels } class(out) <- meframe_class() out } empty_meframe <- function() { out <- data.frame( term = character(0), xname = character(0), grname = character(0), cor = logical(0), stringsAsFactors = FALSE ) class(out) <- meframe_class() out } meframe_class <- function() { c("meframe", "data.frame") } is.meframe <- function(x) { inherits(x, "meframe") } # handle default of correlations between 'me' terms default_mecor <- function(mecor = NULL) { if (is.null(mecor)) TRUE else as_one_logical(mecor) } # find names of all variables used in a special effects type get_sp_vars <- function(x, type) { sp_terms <- ulapply(get_effect(x, "sp"), all_terms) all_vars(str2formula(get_matches_expr(regex_sp(type), sp_terms))) } # gather information of special effects terms # @param x either a formula or a list containing an element "sp" # @param data data frame containing the monotonic variables # @return a data.frame with one row per special term # TODO: refactor to store in long format to avoid several list columns? frame_sp <- function(x, data) { if (is.formula(x)) { x <- brmsterms(x, check_response = FALSE)$dpars$mu } form <- x[["sp"]] if (!is.formula(form)) { return(empty_data_frame()) } mm <- sp_model_matrix(form, data, rename = FALSE) out <- data.frame(term = colnames(mm), stringsAsFactors = FALSE) # fixes issue #1754 try_parse <- try(parse(text = out$term)) if (is_try_error(try_parse)) { stop2("Cannot parse special effects terms (see above error message). ", "Likely this is because of factor levels with special symbols ", "such as '$' or '@'.") } out$coef <- rename(out$term) calls_cols <- c(paste0("calls_", all_sp_types()), "joint_call") list_cols <- c("vars_mi", "idx_mi", "idx2_mi", "ids_mo", "Imo") for (col in c(calls_cols, list_cols)) { out[[col]] <- vector("list", nrow(out)) } kmo <- 0 terms_split <- strsplit(out$term, ":") for (i in seq_rows(out)) { # prepare mo terms take_mo <- grepl_expr(regex_sp("mo"), terms_split[[i]]) if (sum(take_mo)) { out$calls_mo[[i]] <- terms_split[[i]][take_mo] nmo <- length(out$calls_mo[[i]]) out$Imo[[i]] <- (kmo + 1):(kmo + nmo) out$ids_mo[[i]] <- rep(NA, nmo) kmo <- kmo + nmo for (j in seq_along(out$calls_mo[[i]])) { mo_term <- out$calls_mo[[i]][[j]] mo_match <- get_matches_expr(regex_sp("mo"), mo_term) if (length(mo_match) > 1L || nchar(mo_match) < nchar(mo_term)) { stop2("The monotonic term '", mo_term, "' is invalid.") } out$ids_mo[[i]][j] <- eval2(mo_term)$id } } # prepare me terms take_me <- grepl_expr(regex_sp("me"), terms_split[[i]]) if (sum(take_me)) { out$calls_me[[i]] <- terms_split[[i]][take_me] # remove 'I' (identity) function calls that # were used solely to separate formula terms out$calls_me[[i]] <- gsub("^I\\(", "(", out$calls_me[[i]]) } # prepare mi terms take_mi <- grepl_expr(regex_sp("mi"), terms_split[[i]]) if (sum(take_mi)) { mi_parts <- terms_split[[i]][take_mi] out$calls_mi[[i]] <- get_matches_expr(regex_sp("mi"), mi_parts) out$vars_mi[[i]] <- out$idx_mi[[i]] <- rep(NA, length(out$calls_mi[[i]])) for (j in seq_along(out$calls_mi[[i]])) { mi_term <- eval2(out$calls_mi[[i]][[j]]) out$vars_mi[[i]][j] <- mi_term$term if (mi_term$idx != "NA") { out$idx_mi[[i]][j] <- mi_term$idx } } # do it like terms_resp to ensure correct matching out$vars_mi[[i]] <- gsub("\\.|_", "", make.names(out$vars_mi[[i]])) } has_sp_calls <- grepl_expr(regex_sp(all_sp_types()), terms_split[[i]]) sp_calls <- sub("^I\\(", "(", terms_split[[i]][has_sp_calls]) out$joint_call[[i]] <- paste0(sp_calls, collapse = " * ") } # extract data frame to track all required index variables uni_mi <- unique(data.frame( var = unlist(out$vars_mi), idx = unlist(out$idx_mi), stringsAsFactors = FALSE )) uni_mi$idx2 <- rep(NA, nrow(uni_mi)) for (i in seq_rows(uni_mi)) { uni_mi_sub <- subset2(uni_mi, var = uni_mi$var[i]) uni_mi$idx2[i] <- match(uni_mi$idx[i], na.omit(uni_mi_sub$idx)) } attr(out, "uni_mi") <- uni_mi for (i in seq_rows(out)) { for (j in seq_along(out$idx_mi[[i]])) { sub <- subset2( uni_mi, var = out$vars_mi[[i]][j], idx = out$idx_mi[[i]][j] ) out$idx2_mi[[i]][j] <- sub$idx2 } } # extract information on covariates # only non-zero covariates are relevant to consider has_covars <- attr(mm, "covars") cumsum_covars <- cumsum(has_covars) out$Ic <- ifelse(has_covars, cumsum_covars, 0) class(out) <- spframe_class() out } spframe_class <- function() { c("spframe", "data.frame") } is.spframe <- function(x) { inherits(x, "spframe") } # extract names of monotonic simplex parameters # @param spframe output of frame_sp # @param use_id use the 'id' argument to construct simo labels? # @return a character vector of length nrow(spframe) get_simo_labels <- function(spframe, use_id = FALSE) { out <- named_list(spframe$term) I <- which(lengths(spframe$Imo) > 0) for (i in I) { # use the ID as label if specified out[[i]] <- ifelse( use_id & !is.na(spframe$ids_mo[[i]]), spframe$ids_mo[[i]], paste0(spframe$coef[i], seq_along(spframe$Imo[[i]])) ) } unlist(out) } # standard errors of variables with missing values get_sdy <- function(x, data = NULL) { stopifnot(is.brmsterms(x)) miform <- x$adforms[["mi"]] sdy <- NULL if (is.formula(miform)) { mi <- eval_rhs(miform) if (mi$vars$sdy != "NA") { sdy <- eval2(mi$vars$sdy, data) if (!is.null(sdy) && !is.numeric(sdy)) { stop2("Measurement error should be numeric.") } if (isTRUE(any(sdy <= 0))) { stop2("Measurement error should be positive.") } } } sdy } # get names of grouping variables from me terms get_me_group_vars <- function(x) { uni_me <- get_uni_me(x) out <- lapply(uni_me, eval2) out <- ufrom_list(out, "gr") out[nzchar(out)] } # get the design matrix of special effects terms # @param formula a formula containing special effects terms # @param data data.frame passed by the user # @param types types of special terms to consider # @param ... passed to get_model_matrix # @details special terms will be evaluated to 1 so that columns # containing not only ones are those with covariates # @return design matrix of special effects terms and their covariates sp_model_matrix <- function(formula, data, types = all_sp_types(), ...) { attributes(data)$terms <- NULL terms_split <- strsplit(all_terms(formula), split = ":") terms_unique <- unique(unlist(terms_split)) regex <- regex_sp(types) terms_replace <- terms_unique[grepl_expr(regex, terms_unique)] dummies <- paste0("dummy", seq_along(terms_replace), "__") data[dummies] <- list(1) terms_comb <- covars <- rep(NA, length(terms_split)) # loop over terms and add dummy variables for (i in seq_along(terms_split)) { replace_i <- grepl_expr(regex, terms_split[[i]]) terms_i_replace <- terms_split[[i]][replace_i] dummies_i <- dummies[match(terms_i_replace, terms_replace)] terms_split[[i]][replace_i] <- dummies_i terms_comb[i] <- paste0(terms_split[[i]], collapse = ":") # non-special covariates are part of the term covars[i] <- !all(replace_i) } new_formula <- str2formula(terms_comb) attributes(new_formula) <- attributes(formula) out <- get_model_matrix(new_formula, data, ...) # fixes issue #1504 colnames(out) <- rm_wsp(colnames(out)) # recover original column names colnames(out) <- rename(colnames(out), dummies, terms_replace) attr(out, "covars") <- covars out } # formula of variables used in special effects terms sp_fake_formula <- function(...) { dots <- c(...) out <- vector("list", length(dots)) for (i in seq_along(dots)) { tmp <- eval2(dots[[i]]) out[[i]] <- all_vars(c(tmp$term, tmp$sdx, tmp$gr)) } str2formula(unique(unlist(out))) } # extract an me variable get_me_values <- function(term, data) { term <- get_sp_term(term) stopifnot(is.me_term(term)) x <- as.vector(eval2(term$term, data)) if (!is.numeric(x)) { stop2("Noisy variables should be numeric.") } as.array(x) } # extract the measurement error of an me term get_me_noise <- function(term, data) { term <- get_sp_term(term) stopifnot(is.me_term(term)) sdx <- as.vector(eval2(term$sdx, data)) if (length(sdx) == 0L) { stop2("Argument 'sdx' is missing in function 'me'.") } else if (length(sdx) == 1L) { sdx <- rep(sdx, nrow(data)) } if (!is.numeric(sdx)) { stop2("Measurement error should be numeric.") } if (isTRUE(any(sdx <= 0))) { stop2("Measurement error should be positive.") } as.array(sdx) } # extract the grouping variable of an me term get_me_group <- function(term, data) { term <- get_sp_term(term) stopifnot(is.me_term(term)) as.array(eval2(term$gr, data)) } # extract mo variables get_mo_values <- function(term, data) { term <- get_sp_term(term) stopifnot(is.mo_term(term)) x <- eval2(term$term, data) if (is.ordered(x)) { # counting starts at zero max_value <- length(levels(x)) - 1 x <- as.numeric(x) - 1 } else if (all(is_wholenumber(x))) { min_value <- attr(x, "min") if (is.null(min_value)) { min_value <- min(x) } x <- x - min_value max_value <- max(x) } else { stop2( "Monotonic predictors must be integers or ordered ", "factors. Error occurred for variable '", term$term, "'." ) } x <- as.array(x) attr(x, "max") <- max_value x } # prepare 'sp_term' objects get_sp_term <- function(term) { if (!is.sp_term(term)) { term <- eval2(as_one_character(term)) } term } # all effects which fall under the 'sp' category of brms all_sp_types <- function() { c("mo", "me", "mi") } # classes used to set up special effects terms is.sp_term <- function(x) { inherits(x, "sp_term") } is.mo_term <- function(x) { inherits(x, "mo_term") } is.me_term <- function(x) { inherits(x, "me_term") } is.mi_term <- function(x) { inherits(x, "mi_term") } brms/R/stancode.R0000644000176200001440000004405015053072461013347 0ustar liggesusers#' @title Stan Code for Bayesian models #' #' @description \code{stancode} is a generic function that can be used to #' generate Stan code for Bayesian models. Its original use is #' within the \pkg{brms} package, but new methods for use #' with objects from other packages can be registered to the same generic. #' #' @param object An object whose class will determine which method to apply. #' Usually, it will be some kind of symbolic description of the model #' form which Stan code should be generated. #' @param formula Synonym of \code{object} for use in \code{make_stancode}. #' @param ... Further arguments passed to the specific method. #' #' @return Usually, a character string containing the generated Stan code. #' For pretty printing, we recommend the returned object to be of class #' \code{c("character", "brmsmodel")}. #' #' @details #' See \code{\link[brms:stancode.default]{stancode.default}} for the default #' method applied for \pkg{brms} models. #' You can view the available methods by typing: \code{methods(stancode)} #' The \code{make_stancode} function is an alias of \code{stancode}. #' #' @seealso #' \code{\link{stancode.default}}, \code{\link{stancode.brmsfit}} #' #' @examples #' stancode(rating ~ treat + period + carry + (1|subject), #' data = inhaler, family = "cumulative") #' #' @export stancode <- function(object, ...) { UseMethod("stancode") } #' @rdname stancode #' @export make_stancode <- function(formula, ...) { # became an alias of 'stancode' in 2.20.14 stancode(formula, ...) } #' Stan Code for \pkg{brms} Models #' #' Generate Stan code for \pkg{brms} models #' #' @inheritParams brm #' @param object An object of class \code{\link[stats:formula]{formula}}, #' \code{\link{brmsformula}}, or \code{\link{mvbrmsformula}} (or one that can #' be coerced to that classes): A symbolic description of the model to be #' fitted. The details of model specification are explained in #' \code{\link{brmsformula}}. #' @param ... Other arguments for internal usage only. #' #' @return A character string containing the fully commented \pkg{Stan} code #' to fit a \pkg{brms} model. It is of class \code{c("character", "brmsmodel")} #' to facilitate pretty printing. #' #' @examples #' stancode(rating ~ treat + period + carry + (1|subject), #' data = inhaler, family = "cumulative") #' #' stancode(count ~ zAge + zBase * Trt + (1|patient), #' data = epilepsy, family = "poisson") #' #' @export stancode.default <- function(object, data, family = gaussian(), prior = NULL, autocor = NULL, data2 = NULL, cov_ranef = NULL, sparse = NULL, sample_prior = "no", stanvars = NULL, stan_funs = NULL, knots = NULL, drop_unused_levels = TRUE, threads = getOption("brms.threads", NULL), normalize = getOption("brms.normalize", TRUE), save_model = NULL, ...) { object <- validate_formula( object, data = data, family = family, autocor = autocor, sparse = sparse, cov_ranef = cov_ranef ) bterms <- brmsterms(object) data2 <- validate_data2( data2, bterms = bterms, get_data2_autocor(object), get_data2_cov_ranef(object) ) data <- validate_data( data, bterms = bterms, data2 = data2, knots = knots, drop_unused_levels = drop_unused_levels ) bframe <- brmsframe(bterms, data) prior <- .validate_prior( prior, bframe = bframe, sample_prior = sample_prior ) stanvars <- validate_stanvars(stanvars, stan_funs = stan_funs) threads <- validate_threads(threads) .stancode( bframe, prior = prior, stanvars = stanvars, threads = threads, normalize = normalize, save_model = save_model, ... ) } # internal work function of 'stancode.default' # @param parse parse the Stan model for automatic syntax checking # @param backend name of the backend used for parsing # @param silent silence parsing messages .stancode <- function(bterms, prior, stanvars, threads = threading(), normalize = getOption("brms.normalize", TRUE), parse = getOption("brms.parse_stancode", FALSE), backend = getOption("brms.backend", "rstan"), silent = TRUE, save_model = NULL, ...) { normalize <- as_one_logical(normalize) parse <- as_one_logical(parse) backend <- match.arg(backend, backend_choices()) silent <- as_one_logical(silent) scode_predictor <- stan_predictor( bterms, prior = prior, normalize = normalize, stanvars = stanvars, threads = threads ) scode_re <- stan_re( bterms, prior = prior, threads = threads, normalize = normalize ) scode_Xme <- stan_Xme( bterms, prior = prior, threads = threads, normalize = normalize ) # extend Stan's likelihood part if (use_threading(threads)) { # threading is activated for (i in seq_along(scode_predictor)) { resp <- usc(names(scode_predictor)[i]) pll_args <- stan_clean_pll_args( scode_predictor[[i]][["pll_args"]], scode_re[["pll_args"]], scode_Xme[["pll_args"]], collapse_stanvars_pll_args(stanvars) ) partial_log_lik <- paste0( scode_predictor[[i]][["pll_def"]], scode_predictor[[i]][["model_def"]], collapse_stanvars(stanvars, "likelihood", "start"), scode_predictor[[i]][["model_comp_basic"]], scode_predictor[[i]][["model_comp_eta_basic"]], scode_predictor[[i]][["model_comp_eta_loop"]], scode_predictor[[i]][["model_comp_dpar_link"]], scode_predictor[[i]][["model_comp_dpar_trans"]], scode_predictor[[i]][["model_comp_mix"]], scode_predictor[[i]][["model_comp_arma"]], scode_predictor[[i]][["model_comp_catjoin"]], scode_predictor[[i]][["model_comp_mvjoin"]], scode_predictor[[i]][["model_log_lik"]], collapse_stanvars(stanvars, "likelihood", "end") ) partial_log_lik <- gsub(" target \\+=", " ptarget +=", partial_log_lik) partial_log_lik <- paste0( "// compute partial sums of the log-likelihood\n", "real partial_log_lik", resp, "_lpmf(array[] int seq", resp, ", int start, int end", pll_args$typed, ") {\n", " real ptarget = 0;\n", " int N = end - start + 1;\n", partial_log_lik, " return ptarget;\n", "}\n" ) partial_log_lik <- wsp_per_line(partial_log_lik, 2) scode_predictor[[i]][["partial_log_lik"]] <- partial_log_lik static <- str_if(threads$static, "_static") scode_predictor[[i]][["model_lik"]] <- paste0( " target += reduce_sum", static, "(partial_log_lik", resp, "_lpmf", ", seq", resp, ", grainsize", pll_args$plain, ");\n" ) str_add(scode_predictor[[i]][["tdata_def"]]) <- glue( " array[N{resp}] int seq{resp} = sequence(1, N{resp});\n" ) } scode_predictor <- collapse_lists(ls = scode_predictor) scode_predictor[["model_lik"]] <- paste0( scode_predictor[["model_no_pll_def"]], scode_predictor[["model_no_pll_comp_basic"]], scode_predictor[["model_no_pll_comp_mvjoin"]], scode_predictor[["model_lik"]] ) str_add(scode_predictor[["fun"]]) <- " #include 'fun_sequence.stan'\n" str_add(scode_predictor[["data"]]) <- " int grainsize; // grainsize for threading\n" } else { # threading is not activated scode_predictor <- collapse_lists(ls = scode_predictor) scode_predictor[["model_lik"]] <- paste0( scode_predictor[["model_no_pll_def"]], scode_predictor[["model_def"]], collapse_stanvars(stanvars, "likelihood", "start"), scode_predictor[["model_no_pll_comp_basic"]], scode_predictor[["model_comp_basic"]], scode_predictor[["model_comp_eta_basic"]], scode_predictor[["model_comp_eta_loop"]], scode_predictor[["model_comp_dpar_link"]], scode_predictor[["model_comp_dpar_trans"]], scode_predictor[["model_comp_mix"]], scode_predictor[["model_comp_arma"]], scode_predictor[["model_comp_catjoin"]], scode_predictor[["model_no_pll_comp_mvjoin"]], scode_predictor[["model_comp_mvjoin"]], scode_predictor[["model_log_lik"]], collapse_stanvars(stanvars, "likelihood", "end") ) } scode_predictor[["model_lik"]] <- wsp_per_line(scode_predictor[["model_lik"]], 2) # get all priors added to 'lprior' scode_tpar_prior <- paste0( scode_predictor[["tpar_prior"]], scode_re[["tpar_prior"]], scode_Xme[["tpar_prior"]] ) # generate functions block scode_functions <- paste0( "// generated with brms ", utils::packageVersion("brms"), "\n", "functions {\n", scode_predictor[["fun"]], scode_re[["fun"]], collapse_stanvars(stanvars, "functions"), scode_predictor[["partial_log_lik"]], "}\n" ) # generate data block scode_data <- paste0( "data {\n", " int N; // total number of observations\n", scode_predictor[["data"]], scode_re[["data"]], scode_Xme[["data"]], " int prior_only; // should the likelihood be ignored?\n", collapse_stanvars(stanvars, "data"), "}\n" ) # generate transformed parameters block scode_transformed_data <- paste0( "transformed data {\n", scode_predictor[["tdata_def"]], collapse_stanvars(stanvars, "tdata", "start"), scode_predictor[["tdata_comp"]], collapse_stanvars(stanvars, "tdata", "end"), "}\n" ) # generate parameters block scode_parameters <- paste0( scode_predictor[["par"]], scode_re[["par"]], scode_Xme[["par"]] ) # prepare additional sampling from priors scode_rngprior <- stan_rngprior( tpar_prior = scode_tpar_prior, par_declars = scode_parameters, gen_quantities = scode_predictor[["gen_def"]], special_prior = attr(prior, "special"), sample_prior = get_sample_prior(prior) ) scode_parameters <- paste0( "parameters {\n", scode_parameters, scode_rngprior[["par"]], collapse_stanvars(stanvars, "parameters"), "}\n" ) # prepare lprior tags scode_lprior_def <- paste0( " // prior contributions to the log posterior\n", " real lprior = 0;\n" ) scode_lprior_assign <- "" lprior_tags <- unique(prior$tag[nzchar(prior$tag)]) if (length(lprior_tags)) { str_add(scode_lprior_def) <- collapse(" real lprior_", lprior_tags, " = 0;\n") scode_lprior_assign <- collapse(" lprior += lprior_", lprior_tags, ";\n") } # generate transformed parameters block scode_transformed_parameters <- paste0( "transformed parameters {\n", scode_predictor[["tpar_def"]], scode_re[["tpar_def"]], scode_Xme[["tpar_def"]], str_if(normalize, scode_lprior_def), collapse_stanvars(stanvars, "tparameters", "start"), scode_predictor[["tpar_prior_const"]], scode_re[["tpar_prior_const"]], scode_Xme[["tpar_prior_const"]], scode_predictor[["tpar_comp"]], scode_predictor[["tpar_special_prior"]], scode_re[["tpar_comp"]], scode_Xme[["tpar_comp"]], # lprior cannot contain _lupdf functions in transformed parameters # as discussed on github.com/stan-dev/stan/issues/3094 str_if(normalize, scode_tpar_prior), str_if(normalize, scode_lprior_assign), collapse_stanvars(stanvars, "tparameters", "end"), "}\n" ) # combine likelihood with prior part not_const <- str_if(!normalize, " not") scode_model <- paste0( "model {\n", str_if(!normalize, scode_lprior_def), collapse_stanvars(stanvars, "model", "start"), " // likelihood", not_const, " including constants\n", " if (!prior_only) {\n", scode_predictor[["model_lik"]], " }\n", " // priors", not_const, " including constants\n", str_if(!normalize, scode_tpar_prior), str_if(!normalize, scode_lprior_assign), " target += lprior;\n", scode_predictor[["model_prior"]], scode_re[["model_prior"]], scode_Xme[["model_prior"]], stan_unchecked_prior(prior), collapse_stanvars(stanvars, "model", "end"), "}\n" ) # generate generated quantities block scode_generated_quantities <- paste0( "generated quantities {\n", scode_predictor[["gen_def"]], scode_re[["gen_def"]], scode_Xme[["gen_def"]], scode_rngprior[["gen_def"]], collapse_stanvars(stanvars, "genquant", "start"), scode_predictor[["gen_comp"]], scode_re[["gen_comp"]], scode_rngprior[["gen_comp"]], scode_Xme[["gen_comp"]], collapse_stanvars(stanvars, "genquant", "end"), "}\n" ) # combine all elements into a complete Stan model scode <- paste0( scode_functions, scode_data, scode_transformed_data, scode_parameters, scode_transformed_parameters, scode_model, scode_generated_quantities ) scode <- expand_include_statements(scode) if (parse) { scode <- parse_model(scode, backend, silent = silent) } if (is.character(save_model)) { cat(scode, file = save_model) } class(scode) <- c("character", "brmsmodel") scode } #' @export print.brmsmodel <- function(x, ...) { cat(x) invisible(x) } #' Extract Stan code from \code{brmsfit} objects #' #' Extract Stan code from a fitted \pkg{brms} model. #' #' @param object An object of class \code{brmsfit}. #' @param version Logical; indicates if the first line containing the \pkg{brms} #' version number should be included. Defaults to \code{TRUE}. #' @param regenerate Logical; indicates if the Stan code should be regenerated #' with the current \pkg{brms} version. By default, \code{regenerate} will be #' \code{FALSE} unless required to be \code{TRUE} by other arguments. #' @param threads Controls whether the Stan code should be threaded. See #' \code{\link{threading}} for details. #' @param backend Controls the Stan backend. See \code{\link{brm}} for details. #' @param ... Further arguments passed to #' \code{\link[brms:stancode.default]{stancode}} if the Stan code is #' regenerated. #' #' @return Stan code for further processing. #' #' @export stancode.brmsfit <- function(object, version = TRUE, regenerate = NULL, threads = NULL, backend = NULL, ...) { if (is.null(regenerate)) { # determine whether regenerating the Stan code is required regenerate <- FALSE cl <- match.call() if ("threads" %in% names(cl)) { threads <- validate_threads(threads) if (use_threading(threads) && !use_threading(object$threads) || !use_threading(threads) && use_threading(object$threads)) { # threading changed; regenerated Stan code regenerate <- TRUE } object$threads <- threads } if ("backend" %in% names(cl)) { backend <- match.arg(backend, backend_choices()) # older Stan versions do not support array syntax if (require_old_stan_syntax(object, backend, "2.29.0")) { regenerate <- TRUE } object$backend <- backend } } regenerate <- as_one_logical(regenerate) if (regenerate) { object <- restructure(object) out <- make_stancode( formula = object$formula, data = object$data, prior = object$prior, data2 = object$data2, stanvars = object$stanvars, sample_prior = get_sample_prior(object$prior), threads = object$threads, backend = object$backend, ... ) } else { # extract Stan code unaltered out <- object$model } if (!version) { out <- sub("^[^\n]+[[:digit:]]\\.[^\n]+\n", "", out) } out } # expand '#include' and '#includeR' statements # For '#include' this could also be done automatically by Stan at compilation time # but would result in Stan code that is not self-contained until compilation # @param model Stan code that may contain '#include' and '#includeR' statements # @return Stan code with '#include' and '#includeR' statements expanded expand_include_statements <- function(model) { # '#include' statements will be replaced by the content of a file path <- system.file("chunks", package = "brms") includes <- unique(get_matches("#include '[^']+'", model)) files <- gsub("(#include )|(')", "", includes) for (i in seq_along(includes)) { code <- readLines(paste0(path, "/", files[i])) code <- paste0(code, collapse = "\n") pattern <- paste0(" *", escape_all(includes[i])) model <- sub(pattern, code, model) # remove all duplicated include statements model <- gsub(pattern, "", model) } # '#includeR' statements will be replaced by the call to an R function includes <- unique(get_matches("#includeR `[^`]+`", model)) calls <- gsub("(#includeR )|(`)", "", includes) for (i in seq_along(includes)) { code <- eval2(calls[i]) pattern <- paste0(" *", escape_all(includes[i])) model <- sub(pattern, code, model) # remove all duplicated include statements model <- gsub(pattern, "", model) } model } # check if Stan code includes normalization constants is_normalized <- function(stancode) { !grepl("_lup(d|m)f\\(", stancode) } # Normalizes Stan code to avoid triggering refit after whitespace and # comment changes in the generated code. # In some distant future, StanC3 may provide its own normalizing functions, # until then this is a set of regex hacks. # @param x a string containing the Stan code normalize_stancode <- function(x) { x <- as_one_character(x) # Remove single-line comments x <- gsub("//[^\n\r]*[\n\r]", " ", x) x <- gsub("//[^\n\r]*$", " ", x) # Remove multi-line comments x <- gsub("/\\*([^*]*(\\*[^/])?)*\\*/", " ", x) # Standardize whitespace (including newlines) x <- gsub("[[:space:]]+"," ", x) trimws(x) } # check if the currently installed Stan version requires older syntax # than the Stan version with which the model was initially fitted require_old_stan_syntax <- function(object, backend, version) { stopifnot(is.brmsfit(object)) isTRUE( (object$backend == "rstan" && object$version$rstan >= version || object$backend == "cmdstanr" && object$version$cmdstan >= version) && (backend == "rstan" && utils::packageVersion("rstan") < version || backend == "cmdstanr" && cmdstanr::cmdstan_version() < version) ) } brms/R/plot.R0000644000176200001440000002426714540344647012545 0ustar liggesusers#' Trace and Density Plots for MCMC Draws #' #' @param x An object of class \code{brmsfit}. #' @param pars Deprecated alias of \code{variable}. #' Names of the parameters to plot, as given by a #' character vector or a regular expression. #' @param variable Names of the variables (parameters) to plot, as given by a #' character vector or a regular expression (if \code{regex = TRUE}). By #' default, a hopefully not too large selection of variables is plotted. #' @param combo A character vector with at least two elements. #' Each element of \code{combo} corresponds to a column in the resulting #' graphic and should be the name of one of the available #' \code{\link[bayesplot:MCMC-overview]{MCMC}} functions #' (omitting the \code{mcmc_} prefix). #' @param nvariables The number of variables (parameters) plotted per page. #' @param N Deprecated alias of \code{nvariables}. #' @param theme A \code{\link[ggplot2:theme]{theme}} object #' modifying the appearance of the plots. #' For some basic themes see \code{\link[ggplot2:ggtheme]{ggtheme}} #' and \code{\link[bayesplot:theme_default]{theme_default}}. #' @param regex Logical; Indicates whether \code{variable} should #' be treated as regular expressions. Defaults to \code{FALSE}. #' @param fixed (Deprecated) Indicates whether parameter names #' should be matched exactly (\code{TRUE}) or treated as #' regular expressions (\code{FALSE}). Default is \code{FALSE} #' and only works with argument \code{pars}. #' @param bins Number of bins used for posterior histograms (defaults to 30). #' @param plot Logical; indicates if plots should be #' plotted directly in the active graphic device. #' Defaults to \code{TRUE}. #' @param ask Logical; indicates if the user is prompted #' before a new page is plotted. #' Only used if \code{plot} is \code{TRUE}. #' @param newpage Logical; indicates if the first set of plots #' should be plotted to a new page. #' Only used if \code{plot} is \code{TRUE}. #' @param ... Further arguments passed to #' \code{\link[bayesplot:MCMC-combos]{mcmc_combo}}. #' #' @return An invisible list of #' \code{\link[gtable:gtable]{gtable}} objects. #' #' @examples #' \dontrun{ #' fit <- brm(count ~ zAge + zBase * Trt #' + (1|patient) + (1|visit), #' data = epilepsy, family = "poisson") #' plot(fit) #' ## plot population-level effects only #' plot(fit, variable = "^b_", regex = TRUE) #' } #' #' @method plot brmsfit #' @import ggplot2 #' @importFrom graphics plot #' @importFrom grDevices devAskNewPage #' @export plot.brmsfit <- function(x, pars = NA, combo = c("hist", "trace"), nvariables = 5, N = NULL, variable = NULL, regex = FALSE, fixed = FALSE, bins = 30, theme = NULL, plot = TRUE, ask = TRUE, newpage = TRUE, ...) { contains_draws(x) nvariables <- use_alias(nvariables, N) if (!is_wholenumber(nvariables) || nvariables < 1) { stop2("Argument 'nvariables' must be a positive integer.") } variable <- use_variable_alias(variable, x, pars, fixed = fixed) if (is.null(variable)) { variable <- default_plot_variables(x) regex <- TRUE } draws <- as.array(x, variable = variable, regex = regex) variables <- dimnames(draws)[[3]] if (!length(variables)) { stop2("No valid variables selected.") } if (plot) { default_ask <- devAskNewPage() on.exit(devAskNewPage(default_ask)) devAskNewPage(ask = FALSE) } n_plots <- ceiling(length(variables) / nvariables) plots <- vector(mode = "list", length = n_plots) for (i in seq_len(n_plots)) { sub <- ((i - 1) * nvariables + 1):min(i * nvariables, length(variables)) sub_vars <- variables[sub] sub_draws <- draws[, , sub_vars, drop = FALSE] plots[[i]] <- bayesplot::mcmc_combo( sub_draws, combo = combo, bins = bins, gg_theme = theme, ... ) if (plot) { plot(plots[[i]], newpage = newpage || i > 1) if (i == 1) { devAskNewPage(ask = ask) } } } invisible(plots) } # list all parameter classes to be included in plots by default default_plot_variables <- function(family) { c(fixef_pars(), "^sd_", "^cor_", "^sigma_", "^rescor_", paste0("^", valid_dpars(family), "$"), "^delta$", "^theta", "^ar", "^ma", "^arr", "^sderr", "^lagsar", "^errorsar", "^car", "^sdcar", "^sdb_", "^sdbsp_", "^sdbs_", "^sds_", "^sdgp_", "^lscale_") } #' MCMC Plots Implemented in \pkg{bayesplot} #' #' Convenient way to call MCMC plotting functions #' implemented in the \pkg{bayesplot} package. #' #' @aliases stanplot stanplot.brmsfit #' #' @inheritParams plot.brmsfit #' @param object An \R object typically of class \code{brmsfit} #' @param type The type of the plot. #' Supported types are (as names) \code{hist}, \code{dens}, #' \code{hist_by_chain}, \code{dens_overlay}, #' \code{violin}, \code{intervals}, \code{areas}, \code{acf}, #' \code{acf_bar},\code{trace}, \code{trace_highlight}, \code{scatter}, #' \code{rhat}, \code{rhat_hist}, \code{neff}, \code{neff_hist} #' \code{nuts_acceptance}, \code{nuts_divergence}, #' \code{nuts_stepsize}, \code{nuts_treedepth}, and \code{nuts_energy}. #' For an overview on the various plot types see #' \code{\link[bayesplot:MCMC-overview]{MCMC-overview}}. #' @param ... Additional arguments passed to the plotting functions. #' See \code{\link[bayesplot:MCMC-overview]{MCMC-overview}} for #' more details. #' #' @return A \code{\link[ggplot2:ggplot]{ggplot}} object #' that can be further customized using the \pkg{ggplot2} package. #' #' @details #' Also consider using the \pkg{shinystan} package available via #' method \code{\link{launch_shinystan}} in \pkg{brms} for flexible #' and interactive visual analysis. #' #' @examples #' \dontrun{ #' model <- brm(count ~ zAge + zBase * Trt + (1|patient), #' data = epilepsy, family = "poisson") #' #' # plot posterior intervals #' mcmc_plot(model) #' #' # only show population-level effects in the plots #' mcmc_plot(model, variable = "^b_", regex = TRUE) #' #' # show histograms of the posterior distributions #' mcmc_plot(model, type = "hist") #' #' # plot some diagnostics of the sampler #' mcmc_plot(model, type = "neff") #' mcmc_plot(model, type = "rhat") #' #' # plot some diagnostics specific to the NUTS sampler #' mcmc_plot(model, type = "nuts_acceptance") #' mcmc_plot(model, type = "nuts_divergence") #' } #' #' @export mcmc_plot.brmsfit <- function(object, pars = NA, type = "intervals", variable = NULL, regex = FALSE, fixed = FALSE, ...) { contains_draws(object) object <- restructure(object) type <- as_one_character(type) variable <- use_variable_alias(variable, object, pars, fixed = fixed) if (is.null(variable)) { variable <- default_plot_variables(object) regex <- TRUE } valid_types <- as.character(bayesplot::available_mcmc("")) valid_types <- sub("^mcmc_", "", valid_types) if (!type %in% valid_types) { stop2("Invalid plot type. Valid plot types are: \n", collapse_comma(valid_types)) } mcmc_fun <- get(paste0("mcmc_", type), asNamespace("bayesplot")) mcmc_arg_names <- names(formals(mcmc_fun)) mcmc_args <- list(...) if ("x" %in% mcmc_arg_names) { if (grepl("^nuts_", type)) { # x refers to a molten data.frame of NUTS parameters mcmc_args$x <- nuts_params(object) } else { # x refers to a data.frame of draws draws <- as.array(object, variable = variable, regex = regex) if (!length(draws)) { stop2("No valid parameters selected.") } sel_variables <- dimnames(draws)[[3]] if (type %in% c("scatter", "hex") && length(sel_variables) != 2L) { stop2("Exactly 2 parameters must be selected for this type.", "\nParameters selected: ", collapse_comma(sel_variables)) } mcmc_args$x <- draws } } if ("lp" %in% mcmc_arg_names) { mcmc_args$lp <- log_posterior(object) } use_nuts <- isTRUE(object$algorithm == "sampling") if ("np" %in% mcmc_arg_names && use_nuts) { mcmc_args$np <- nuts_params(object) } interval_type <- type %in% c("intervals", "areas") if ("rhat" %in% mcmc_arg_names && !interval_type) { mcmc_args$rhat <- rhat(object) } if ("ratio" %in% mcmc_arg_names) { mcmc_args$ratio <- neff_ratio(object) } do_call(mcmc_fun, mcmc_args) } #' @rdname mcmc_plot.brmsfit #' @export mcmc_plot <- function(object, ...) { UseMethod("mcmc_plot") } # 'stanplot' has been deprecated in brms 2.10.6; remove in brms 3.0 #' @export stanplot <- function(object, ...) { UseMethod("stanplot") } #' @export stanplot.brmsfit <- function(object, ...) { warning2("Method 'stanplot' is deprecated. Please use 'mcmc_plot' instead.") mcmc_plot.brmsfit(object, ...) } #' Create a matrix of output plots from a \code{brmsfit} object #' #' A \code{\link[graphics:pairs]{pairs}} #' method that is customized for MCMC output. #' #' @param x An object of class \code{brmsfit} #' @inheritParams plot.brmsfit #' @param ... Further arguments to be passed to #' \code{\link[bayesplot:MCMC-scatterplots]{mcmc_pairs}}. #' #' @details For a detailed description see #' \code{\link[bayesplot:MCMC-scatterplots]{mcmc_pairs}}. #' #' @examples #' \dontrun{ #' fit <- brm(count ~ zAge + zBase * Trt #' + (1|patient) + (1|visit), #' data = epilepsy, family = "poisson") #' pairs(fit, variable = variables(fit)[1:3]) #' pairs(fit, variable = "^sd_", regex = TRUE) #' } #' #' @export pairs.brmsfit <- function(x, pars = NA, variable = NULL, regex = FALSE, fixed = FALSE, ...) { variable <- use_variable_alias(variable, x, pars, fixed = fixed) if (is.null(variable)) { variable <- default_plot_variables(x) regex <- TRUE } draws <- as.array(x, variable = variable, regex = regex) bayesplot::mcmc_pairs(draws, ...) } #' Default \pkg{bayesplot} Theme for \pkg{ggplot2} Graphics #' #' This theme is imported from the \pkg{bayesplot} package. #' See \code{\link[bayesplot:theme_default]{theme_default}} #' for a complete documentation. #' #' @name theme_default #' #' @param base_size base font size #' @param base_family base font family #' #' @return A \code{theme} object used in \pkg{ggplot2} graphics. #' #' @importFrom bayesplot theme_default #' @export theme_default NULL brms/R/formula-re.R0000644000176200001440000007355215053305627013634 0ustar liggesusers# This file contains functions dealing with the extended # lme4-like formula syntax to specify group-level terms #' Set up basic grouping terms in \pkg{brms} #' #' Function used to set up a basic grouping term in \pkg{brms}. #' The function does not evaluate its arguments -- #' it exists purely to help set up a model with grouping terms. #' \code{gr} is called implicitly inside the package #' and there is usually no need to call it directly. #' #' @param ... One or more terms containing grouping factors. #' @param by An optional factor variable, specifying sub-populations of the #' groups. For each level of the \code{by} variable, a separate #' variance-covariance matrix will be fitted. Levels of the grouping factor #' must be nested in levels of the \code{by} variable. #' @param cor Logical. If \code{TRUE} (the default), group-level terms will be #' modelled as correlated. #' @param id Optional character string. All group-level terms across the model #' with the same \code{id} will be modeled as correlated (if \code{cor} is #' \code{TRUE}). See \code{\link{brmsformula}} for more details. #' @param pw Optional numeric variable specifying prior weights. They weight the #' contribution of each group to the log-prior of the group-level #' coefficients. Should have one distinct value for each level of the #' grouping variable. #' @param cov An optional matrix which is proportional to the within-group #' covariance matrix of the group-level effects. All levels of the grouping #' factor should appear as rownames of the corresponding matrix. This argument #' can be used, among others, to model pedigrees and phylogenetic effects. See #' \code{vignette("brms_phylogenetics")} for more details. By default, levels #' of the same grouping factor are modeled as independent of each other. #' @param dist Name of the distribution of the group-level effects. #' Currently \code{"gaussian"} is the only option. #' #' @seealso \code{\link{brmsformula}} #' #' @examples #' \dontrun{ #' # model using basic lme4-style formula #' fit1 <- brm(count ~ Trt + (1|patient), data = epilepsy) #' summary(fit1) #' #' # equivalent model using 'gr' which is called anyway internally #' fit2 <- brm(count ~ Trt + (1|gr(patient)), data = epilepsy) #' summary(fit2) #' #' # include Trt as a by variable #' fit3 <- brm(count ~ Trt + (1|gr(patient, by = Trt)), data = epilepsy) #' summary(fit3) #' #' # include a group-level weight variable #' epilepsy[['patient_samp_wgt']] <- c(1, rep(c(0.9, 1.1), each = 29)) #' fit4 <- brm(count ~ Trt + (1|gr(patient, pw = patient_samp_wgt)), #' data = epilepsy) #' summary(fit4) #' } #' #' @export gr <- function(..., by = NULL, cor = TRUE, id = NA, pw = NULL, cov = NULL, dist = "gaussian") { label <- deparse0(match.call()) groups <- as.character(as.list(substitute(list(...)))[-1]) if (length(groups) > 1L) { stop2("Grouping structure 'gr' expects only a single grouping term") } stopif_illegal_group(groups[1]) cor <- as_one_logical(cor) id <- as_one_character(id, allow_na = TRUE) by <- substitute(by) if (!is.null(by)) { by <- deparse0(by) } else { by <- "" } pw <- substitute(pw) if (!is.null(pw)) { pw <- deparse0(pw) } else { pw <- "" } cov <- substitute(cov) if (!is.null(cov)) { cov <- all.vars(cov) if (length(cov) != 1L) { stop2("Argument 'cov' must contain exactly one variable.") } } else { cov <- "" } dist <- match.arg(dist, c("gaussian", "student")) byvars <- all_vars(by) pwvars <- all_vars(pw) allvars <- str2formula(c(groups, byvars, pwvars)) nlist(groups, allvars, label, by, cor, id, pw, cov, dist, type = "") } #' Set up multi-membership grouping terms in \pkg{brms} #' #' Function to set up a multi-membership grouping term in \pkg{brms}. #' The function does not evaluate its arguments -- #' it exists purely to help set up a model with grouping terms. #' #' @inheritParams gr #' @param weights A matrix specifying the membership weights of each member. #' It should have as many columns as grouping terms specified in \code{...}. #' If \code{NULL} (the default), equally weights are used. #' @param by An optional factor matrix, specifying sub-populations of the #' groups. It should have as many columns as grouping terms specified in #' \code{...}. For each level of the \code{by} variable, a separate #' variance-covariance matrix will be fitted. Levels of the grouping factor #' must be nested in levels of the \code{by} variable matrix. #' @param pw Optional numeric matrix specifying prior weights. They weight the #' contribution of each group to the log-prior of the group-level #' coefficients. Should have as many columns as grouping terms specified in #' \code{...} and one distinct value for each group level. #' @param scale Logical; if \code{TRUE} (the default), #' membership weights are standardized in order to sum to one per row. #' If negative weights are specified, \code{scale} needs #' to be set to \code{FALSE}. #' @seealso \code{\link{brmsformula}}, \code{\link{mmc}} #' #' @examples #' \dontrun{ #' # simulate some data #' dat <- data.frame( #' y = rnorm(100), x1 = rnorm(100), x2 = rnorm(100), #' g1 = sample(1:10, 100, TRUE), g2 = sample(1:10, 100, TRUE) #' ) #' #' # multi-membership model with two members per group and equal weights #' fit1 <- brm(y ~ x1 + (1|mm(g1, g2)), data = dat) #' summary(fit1) #' #' # weight the first member two times for than the second member #' dat$w1 <- rep(2, 100) #' dat$w2 <- rep(1, 100) #' fit2 <- brm(y ~ x1 + (1|mm(g1, g2, weights = cbind(w1, w2))), data = dat) #' summary(fit2) #' #' # multi-membership model with level specific covariate values #' dat$xc <- (dat$x1 + dat$x2) / 2 #' fit3 <- brm(y ~ xc + (1 + mmc(x1, x2) | mm(g1, g2)), data = dat) #' summary(fit3) #' } #' #' @export mm <- function(..., weights = NULL, scale = TRUE, by = NULL, cor = TRUE, id = NA, pw = NULL, cov = NULL, dist = "gaussian") { label <- deparse0(match.call()) groups <- as.character(as.list(substitute(list(...)))[-1]) if (length(groups) < 2) { stop2("Multi-membership terms require at least two grouping variables.") } for (i in seq_along(groups)) { stopif_illegal_group(groups[i]) } cor <- as_one_logical(cor) id <- as_one_character(id, allow_na = TRUE) by <- substitute(by) if (!is.null(by)) { by <- deparse0(by) } else { by <- "" } pw <- substitute(pw) if (!is.null(pw)) { pw <- deparse0(pw) } else { pw <- "" } cov <- substitute(cov) if (!is.null(cov)) { cov <- all.vars(cov) if (length(cov) != 1L) { stop2("Argument 'cov' must contain exactly one variable.") } } else { cov <- "" } dist <- match.arg(dist, c("gaussian", "student")) scale <- as_one_logical(scale) weights <- substitute(weights) weightvars <- all_vars(weights) pwvars <- all_vars(pw) byvars <- all_vars(by) allvars <- str2formula(c(groups, weightvars, pwvars, byvars)) if (!is.null(weights)) { weights <- str2formula(deparse_no_string(weights)) attr(weights, "scale") <- scale weightvars <- str2formula(weightvars) } nlist( groups, weights, weightvars, allvars, label, by, cor, id, pw, cov, dist, type = "mm" ) } #' Multi-Membership Covariates #' #' Specify covariates that vary over different levels #' of multi-membership grouping factors thus requiring #' special treatment. This function is almost solely useful, #' when called in combination with \code{\link{mm}}. #' Outside of multi-membership terms it will behave #' very much like \code{\link{cbind}}. #' #' @param ... One or more terms containing covariates #' corresponding to the grouping levels specified in \code{\link{mm}}. #' #' @return A matrix with covariates as columns. #' #' @seealso \code{\link{mm}} #' #' @examples #' \dontrun{ #' # simulate some data #' dat <- data.frame( #' y = rnorm(100), x1 = rnorm(100), x2 = rnorm(100), #' g1 = sample(1:10, 100, TRUE), g2 = sample(1:10, 100, TRUE) #' ) #' #' # multi-membership model with level specific covariate values #' dat$xc <- (dat$x1 + dat$x2) / 2 #' fit <- brm(y ~ xc + (1 + mmc(x1, x2) | mm(g1, g2)), data = dat) #' summary(fit) #' } #' #' @export mmc <- function(...) { dots <- list(...) if (any(ulapply(dots, is_like_factor))) { stop2("'mmc' requires numeric variables.") } out <- cbind(...) colnames(out) <- paste0("?", colnames(out)) out } # check if the group part of a group-level term is invalid # @param group the group part of a group-level term illegal_group_expr <- function(group) { group <- as_one_character(group) valid_expr <- ":|([^([:digit:]|[:punct:])]|\\.)[[:alnum:]_\\.]*" rsv_signs <- c("+", "-", "*", "/", "|", "::") nzchar(gsub(valid_expr, "", group)) || any(ulapply(rsv_signs, grepl, x = group, fixed = TRUE)) } stopif_illegal_group <- function(group) { if (illegal_group_expr(group)) { stop2( "Illegal grouping term '", group, "'. It may contain ", "only variable names combined by the symbol ':'" ) } invisible(NULL) } re_lhs <- function(re_terms) { get_matches("^[^\\|]*", re_terms) } re_mid <- function(re_terms) { get_matches("\\|([^\\|]*\\||)", re_terms) } re_rhs <- function(re_terms) { sub("^\\|", "", get_matches("\\|[^\\|]*$", re_terms)) } # extract the three parts of group-level terms # @param re_terms character vector of RE terms in lme4 syntax # @return a data.frame with one row per group-level term re_parts <- function(re_terms) { lhs <- re_lhs(re_terms) mid <- re_mid(re_terms) rhs <- re_rhs(re_terms) out <- nlist(lhs, mid, rhs) if (any(lengths(out) != length(re_terms))) { stop2("Invalid syntax used in group-level terms.") } as.data.frame(out, stringsAsFactors = FALSE) } # split nested group-level terms and check for special effects terms # @param re_terms character vector of RE terms in extended lme4 syntax split_re_terms <- function(re_terms) { if (!length(re_terms)) { return(re_terms) } stopifnot(is.character(re_terms)) # split after grouping factor terms re_parts <- re_parts(re_terms) new_re_terms <- vector("list", length(re_terms)) for (i in seq_along(re_terms)) { new_re_rhs <- terms(formula(paste0("~", re_parts$rhs[i]))) new_re_rhs <- attr(new_re_rhs, "term.labels") new_re_rhs <- ifelse( !grepl("^(gr|mm)\\(", new_re_rhs), paste0("gr(", new_re_rhs, ")"), new_re_rhs ) new_re_terms[[i]] <- paste0( re_parts$lhs[i], re_parts$mid[i], new_re_rhs ) } re_terms <- unlist(new_re_terms) # split after coefficient types re_parts <- re_parts(re_terms) new_re_terms <- type <- vector("list", length(re_terms)) for (i in seq_along(re_terms)) { lhs_form <- formula(paste("~", re_parts$lhs[i])) lhs_all_terms <- all_terms(lhs_form) # otherwise varying intercepts cannot be handled reliably is_cs_term <- grepl_expr(regex_sp("cs"), lhs_all_terms) if (any(is_cs_term) && !all(is_cs_term)) { stop2("Please specify category specific effects ", "in separate group-level terms.") } new_lhs <- NULL # prepare effects of special terms valid_types <- c("sp", "cs", "mmc") invalid_types <- c("sm", "gp") for (t in c(valid_types, invalid_types)) { lhs_tform <- do_call(paste0("terms_", t), list(lhs_form)) if (is.formula(lhs_tform)) { if (t %in% invalid_types) { stop2("Cannot handle splines or GPs in group-level terms.") } new_lhs <- c(new_lhs, formula2str(lhs_tform, rm = 1)) type[[i]] <- c(type[[i]], t) } } # prepare effects of basic terms lhs_terms <- terms(lhs_form) fe_form <- terms_fe(lhs_terms) fe_terms <- all_terms(fe_form) # the intercept lives within not outside of 'cs' terms has_intercept <- has_intercept(lhs_terms) && !"cs" %in% type[[i]] if (length(fe_terms) || has_intercept) { new_lhs <- c(new_lhs, formula2str(fe_form, rm = 1)) type[[i]] <- c(type[[i]], "") } # extract information from the mid section of the terms rhs_call <- str2lang(re_parts$rhs[i]) if (re_parts$mid[i] == "||") { # ||-syntax overwrites the 'cor' argument rhs_call$cor <- FALSE } gcall <- eval(rhs_call) if (gcall$cor) { id <- gsub("\\|", "", re_parts$mid[i]) if (nzchar(id)) { # ID-syntax overwrites the 'id' argument rhs_call$id <- id } else { id <- gcall$id } if (length(new_lhs) > 1 && isNA(id)) { # ID is required to model coefficients as correlated # if multiple types are provided within the same term rhs_call$id <- collapse(sample(0:9, 10, TRUE)) } } re_parts$mid[i] <- "|" re_parts$rhs[i] <- deparse0(rhs_call) new_re_terms[[i]] <- paste0(new_lhs, re_parts$mid[i], re_parts$rhs[i]) new_re_terms[[i]] <- new_re_terms[[i]][order(type[[i]])] type[[i]] <- sort(type[[i]]) } re_terms <- unlist(new_re_terms) structure(re_terms, type = unlist(type)) } # extract group-level terms from a formula of character vector # @param x formula or character vector # @param formula return a formula rather than a character string? # @param brackets include group-level terms in brackets? get_re_terms <- function(x, formula = FALSE, brackets = TRUE) { if (is.formula(x)) { x <- all_terms(x) } re_pos <- grepl("\\|", x) out <- x[re_pos] if (brackets && length(out)) { out <- paste0("(", out, ")") } if (formula) { out <- str2formula(out) } out } # validate the re_formula argument # @inheritParams extract_draws.brmsfit # @param formula: formula to match re_formula with # @return updated re_formula containing only terms existent in formula check_re_formula <- function(re_formula, formula) { old_re_formula <- get_re_terms(formula, formula = TRUE) if (is.null(re_formula)) { re_formula <- old_re_formula } else if (SW(anyNA(re_formula))) { re_formula <- ~1 } else { re_formula <- get_re_terms(as.formula(re_formula), formula = TRUE) new <- brmsterms(re_formula, check_response = FALSE)$dpars$mu[["re"]] old <- brmsterms(old_re_formula, check_response = FALSE)$dpars$mu[["re"]] if (NROW(new) && NROW(old)) { # compare old and new ranefs new_terms <- lapply(new$form, terms) found <- rep(FALSE, NROW(new)) for (i in seq_rows(new)) { group <- new$group[[i]] old_terms <- lapply(old$form[old$group == group], terms) j <- 1 while (!found[i] && j <= length(old_terms)) { new_term_labels <- attr(new_terms[[i]], "term.labels") old_term_labels <- attr(old_terms[[j]], "term.labels") new_intercept <- attr(new_terms[[i]], "intercept") old_intercept <- attr(old_terms[[j]], "intercept") found[i] <- isTRUE( all(new_term_labels %in% old_term_labels) && new_intercept <= old_intercept ) if (found[i]) { # terms have to maintain the original order so that Z_* data # and r_* parameters match in 'extract_draws' (fixes issue #844) term_matches <- match(new_term_labels, old_term_labels) if (is.unsorted(term_matches)) { stop2("Order of terms in 're_formula' should match the original order.") } } j <- j + 1 } } new <- new[found, ] if (NROW(new)) { forms <- ulapply(new$form, formula2str, rm = 1) groups <- ufrom_list(new$gcall, "label") re_terms <- paste("(", forms, "|", groups, ")") re_formula <- formula(paste("~", paste(re_terms, collapse = "+"))) } else { re_formula <- ~1 } } else { re_formula <- ~1 } } re_formula } # remove existing group-level terms in formula and # add valid group-level terms of re_formula update_re_terms <- function(formula, re_formula) { UseMethod("update_re_terms") } #' @export update_re_terms.mvbrmsformula <- function(formula, re_formula) { formula$forms <- lapply(formula$forms, update_re_terms, re_formula) formula } #' @export update_re_terms.brmsformula <- function(formula, re_formula) { formula$formula <- update_re_terms(formula$formula, re_formula) formula$pforms <- lapply(formula$pforms, update_re_terms, re_formula) formula } #' @export update_re_terms.formula <- function(formula, re_formula = NULL) { if (is.null(re_formula) || get_nl(formula)) { return(formula) } re_formula <- check_re_formula(re_formula, formula) new_formula <- formula2str(formula) old_re_terms <- get_re_terms(formula, brackets = FALSE) if (length(old_re_terms)) { # remove old group-level terms rm_terms <- c( paste0("+ (", old_re_terms, ")"), paste0("(", old_re_terms, ")"), old_re_terms ) new_formula <- rename(new_formula, rm_terms, "") if (grepl("~( *\\+*)*$", new_formula)) { # lhs only formulas are syntactically invalid # also check for trailing '+' signs (#769) new_formula <- paste(new_formula, "1") } } # add new group-level terms new_re_terms <- get_re_terms(re_formula) new_formula <- paste(c(new_formula, new_re_terms), collapse = "+") new_formula <- formula(new_formula) attributes(new_formula) <- attributes(formula) new_formula } # extract group-level terms get_re <- function(x, ...) { UseMethod("get_re") } #' @export get_re.default <- function(x, ...) { NULL } # get group-level information in a data.frame # @param bterms object of class 'brmsterms' # @param all logical; include ranefs of additional parameters? #' @export get_re.brmsterms <- function(x, ...) { re <- named_list(c(names(x$dpars), names(x$nlpars))) for (dp in names(x$dpars)) { re[[dp]] <- get_re(x$dpars[[dp]]) } for (nlp in names(x$nlpars)) { re[[nlp]] <- get_re(x$nlpars[[nlp]]) } do_call(rbind, re) } #' @export get_re.mvbrmsterms <- function(x, ...) { do_call(rbind, lapply(x$terms, get_re, ...)) } #' @export get_re.btl <- function(x, ...) { px <- check_prefix(x) re <- x[["re"]] if (is.null(re)) { re <- empty_re() } re$resp <- rep(px$resp, nrow(re)) re$dpar <- rep(px$dpar, nrow(re)) re$nlpar <- rep(px$nlpar, nrow(re)) re } # gather information on group-level effects # @param bterms object of class brmsterms # @param data data.frame containing all model variables # @param old_levels optional original levels of the grouping factors # @return a tidy data.frame with the following columns: # id: ID of the group-level effect # group: name of the grouping factor # gn: number of the grouping term within the respective formula # coef: name of the group-level effect # cn: number of the effect within the ID # resp: name of the response variable # dpar: name of the distributional parameter # nlpar: name of the non-linear parameter # cor: are correlations modeled for this effect? # ggn: global number of the grouping factor # type: special effects type; can be 'sp' or 'cs' # gcall: output of functions 'gr' or 'mm' # form: formula used to compute the effects frame_re <- function(bterms, data, old_levels = NULL) { data <- combine_groups(data, get_group_vars(bterms)) re <- get_re(bterms) out <- vector("list", nrow(re)) used_ids <- new_ids <- NULL id_groups <- list() j <- 1 for (i in seq_rows(re)) { if (!nzchar(re$type[i])) { coef <- colnames(get_model_matrix(re$form[[i]], data)) } else if (re$type[i] == "sp") { # TODO: try to avoid having to call frame_sp here coef <- frame_sp(re$form[[i]], data)$coef } else if (re$type[i] == "mmc") { coef <- rename(all_terms(re$form[[i]])) } else if (re$type[i] == "cs") { resp <- re$resp[i] if (nzchar(resp)) { stopifnot(is.mvbrmsterms(bterms)) nthres <- max(get_thres(bterms$terms[[resp]])) } else { stopifnot(is.brmsterms(bterms)) nthres <- max(get_thres(bterms)) } indices <- paste0("[", seq_len(nthres), "]") coef <- colnames(get_model_matrix(re$form[[i]], data = data)) coef <- as.vector(t(outer(coef, indices, paste0))) } avoid_dpars(coef, bterms) rdat <- data.frame( id = re$id[[i]], group = re$group[[i]], gn = re$gn[[i]], gtype = re$gtype[[i]], coef = coef, cn = NA, resp = re$resp[[i]], dpar = re$dpar[[i]], nlpar = re$nlpar[[i]], ggn = NA, cor = re$cor[[i]], type = re$type[[i]], by = re$gcall[[i]]$by, cov = re$gcall[[i]]$cov, dist = re$gcall[[i]]$dist, stringsAsFactors = FALSE ) bylevels <- NULL if (nzchar(rdat$by[1])) { bylevels <- eval2(rdat$by[1], data) bylevels <- rm_wsp(extract_levels(bylevels)) } rdat$bylevels <- repl(bylevels, nrow(rdat)) rdat$form <- repl(re$form[[i]], nrow(rdat)) rdat$gcall <- repl(re$gcall[[i]], nrow(rdat)) # prepare group-level IDs id <- re$id[[i]] if (is.na(id)) { rdat$id <- j j <- j + 1 } else { if (id %in% used_ids) { k <- match(id, used_ids) rdat$id <- new_ids[k] new_id_groups <- c(re$group[[i]], re$gcall[[i]]$groups) if (!identical(new_id_groups, id_groups[[k]])) { stop2("Can only combine group-level terms of the ", "same grouping factors.") } } else { used_ids <- c(used_ids, id) k <- length(used_ids) rdat$id <- new_ids[k] <- j id_groups[[k]] <- c(re$group[[i]], re$gcall[[i]]$groups) j <- j + 1 } } out[[i]] <- rdat } out <- do_call(rbind, c(list(empty_reframe()), out)) # check for overlap between different group types rsv_groups <- out[nzchar(out$gtype), "group"] other_groups <- out[!nzchar(out$gtype), "group"] inv_groups <- intersect(rsv_groups, other_groups) if (length(inv_groups)) { inv_groups <- paste0("'", inv_groups, "'", collapse = ", ") stop2("Grouping factor names ", inv_groups, " are resevered.") } # check for duplicated and thus not identified effects dup <- duplicated(out[, c("group", "coef", vars_prefix())]) if (any(dup)) { dr <- out[which(dup)[1], ] stop2( "Duplicated group-level effects are not allowed.\n", "Occured for effect '", dr$coef, "' of group '", dr$group, "'." ) } if (has_rows(out)) { for (id in unique(out$id)) { out$cn[out$id == id] <- seq_len(sum(out$id == id)) } out$ggn <- match(out$group, unique(out$group)) # compute random effects levels rsub <- out[!duplicated(out$group), ] levels <- named_list(rsub$group) for (i in seq_along(levels)) { # combine levels of all grouping factors within one grouping term levels[[i]] <- unique(ulapply( rsub$gcall[[i]]$groups, function(g) extract_levels(get(g, data)) )) # fixes issue #1353 bysel <- out$group == names(levels)[i] & nzchar(out$by) & !duplicated(out$by) bysel <- which(bysel) if (length(bysel) > 1L) { stop2("Each grouping factor can only be associated with one 'by' variable.") } # ensure that a non-NULL by-variable is found if present if (length(bysel) == 1L) { rsub[i, ] <- out[bysel, ] } # store information of corresponding by-levels if (nzchar(rsub$by[i])) { stopifnot(rsub$type[i] %in% c("", "mmc")) by <- rsub$by[i] bylevels <- rsub$bylevels[[i]] byvar <- rm_wsp(eval2(by, data)) groups <- rsub$gcall[[i]]$groups if (rsub$gtype[i] == "mm") { byvar <- as.matrix(byvar) if (!identical(dim(byvar), c(nrow(data), length(groups)))) { stop2( "Grouping structure 'mm' expects 'by' to be ", "a matrix with as many columns as grouping factors." ) } df <- J <- named_list(groups) for (k in seq_along(groups)) { J[[k]] <- match(get(groups[k], data), levels[[i]]) df[[k]] <- data.frame(J = J[[k]], by = byvar[, k]) } J <- unlist(J) df <- do_call(rbind, df) } else { J <- match(get(groups, data), levels[[i]]) df <- data.frame(J = J, by = byvar) } df <- unique(df) if (nrow(df) > length(unique(J))) { stop2("Some levels of ", collapse_comma(groups), " correspond to multiple levels of '", by, "'.") } df <- df[order(df$J), ] by_per_level <- bylevels[match(df$by, bylevels)] attr(levels[[i]], "by") <- by_per_level } } if (!is.null(old_levels)) { # for newdata numeration has to depend on the original levels set_levels(out) <- old_levels set_levels(out, "used") <- levels } else { set_levels(out) <- levels } # incorporate deprecated 'cov_ranef' argument out <- update_ranef_cov(out, bterms) } # ordering after IDs matches the order of the posterior draws # if multiple IDs are used for the same grouping factor (#835) out <- out[order(out$id), , drop = FALSE] class(out) <- reframe_class() out } # like frame_re but only returns its levels attribute # this avoids issue #1221 and likely some other edge cases frame_re_levels_only <- function(bterms, data) { out <- empty_reframe() data <- combine_groups(data, get_group_vars(bterms)) re <- get_re(bterms) re <- re[!duplicated(re$group), ] levels <- named_list(re$group) for (i in seq_along(levels)) { # combine levels of all grouping factors within one grouping term levels[[i]] <- unique(ulapply( re$gcall[[i]]$groups, function(g) extract_levels(get(g, data)) )) } set_levels(out) <- levels out } empty_reframe <- function() { out <- data.frame( id = numeric(0), group = character(0), gn = numeric(0), coef = character(0), cn = numeric(0), resp = character(0), dpar = character(0), nlpar = character(0), ggn = numeric(0), cor = logical(0), type = character(0), form = character(0), stringsAsFactors = FALSE ) class(out) <- reframe_class() out } empty_re <- function() { data.frame( group = character(0), gtype = character(0), gn = numeric(0), id = numeric(0), type = character(0), cor = logical(0), form = character(0) ) } reframe_class <- function() { c("reframe", "data.frame") } is.reframe <- function(x) { inherits(x, "reframe") } # extract names of all grouping variables get_group_vars <- function(x, ...) { UseMethod("get_group_vars") } #' @export get_group_vars.brmsfit <- function(x, ...) { get_group_vars(x$formula, ...) } #' @export get_group_vars.default <- function(x, ...) { get_group_vars(brmsterms(x), ...) } #' @export get_group_vars.brmsterms <- function(x, ...) { .get_group_vars(x, ...) } #' @export get_group_vars.mvbrmsterms <- function(x, ...) { .get_group_vars(x, ...) } .get_group_vars <- function(x, ...) { out <- c(get_re_group_vars(x), get_me_group_vars(x), get_ac_group_vars(x)) out <- out[nzchar(out)] if (length(out)) { c(out) <- unlist(strsplit(out, ":")) out <- sort(unique(out)) } out } # get names of grouping variables from re terms get_re_group_vars <- function(x, ...) { ufrom_list(get_re(x)$gcall, "groups") } # extract information about groups with a certain distribution from an reframe subset_reframe_dist <- function(reframe, dist) { stopifnot(is.reframe(reframe)) out <- subset2(reframe, dist = dist) out[!duplicated(out$group), c("group", "ggn", "id")] } # extract names of group-level effects # @param reframe output of frame_re() # @param group optional name of a grouping factor for # which to extract effect names # @param bylevels optional names of 'by' levels for # which to extract effect names # @return a vector of character strings get_rnames <- function(reframe, group = NULL, bylevels = NULL) { stopifnot(is.data.frame(reframe)) if (!is.null(group)) { group <- as_one_character(group) reframe <- subset2(reframe, group = group) } stopifnot(length(unique(reframe$group)) == 1L) out <- paste0(usc(combine_prefix(reframe), "suffix"), reframe$coef) if (isTRUE(nzchar(reframe$by[1]))) { if (!is.null(bylevels)) { stopifnot(all(bylevels %in% reframe$bylevels[[1]])) } else { bylevels <- reframe$bylevels[[1]] } bylabels <- paste0(reframe$by[1], bylevels) out <- outer(out, bylabels, paste, sep = ":") } out } # validate within-group covariance matrices # @param M a matrix to be validated validate_recov_matrix <- function(M) { M <- as.matrix(M) if (!isSymmetric(unname(M))) { stop2("Within-group covariance matrices must be symmetric.") } found_levels <- rownames(M) if (is.null(found_levels)) { found_levels <- colnames(M) } if (is.null(found_levels)) { stop2("Row or column names are required for within-group covariance matrices.") } rownames(M) <- colnames(M) <- found_levels evs <- eigen(M, symmetric = TRUE, only.values = TRUE)$values if (min(evs) <= 0) { stop2("Within-group covariance matrices must be positive definite.") } M } # check validity of the 'cov_ranef' argument # argument 'cov_ranef' is deprecated as of version 2.12.5 validate_cov_ranef <- function(cov_ranef) { if (is.null(cov_ranef)) { return(cov_ranef) } warning2( "Argument 'cov_ranef' is deprecated and will be removed in the future. ", "Please use argument 'cov' in function 'gr' instead." ) cr_names <- names(cov_ranef) cr_is_named <- length(cr_names) && all(nzchar(cr_names)) if (!is.list(cov_ranef) || !cr_is_named) { stop2("'cov_ranef' must be a named list.") } if (any(duplicated(cr_names))) { stop2("Names of 'cov_ranef' must be unique.") } cov_ranef } # update 'reframe' according to information in 'cov_ranef' # argument 'cov_ranef' is deprecated as of version 2.12.5 update_ranef_cov <- function(reframe, bterms) { cr_names <- names(bterms$cov_ranef) if (!length(cr_names)) { return(reframe) } unused_names <- setdiff(cr_names, reframe$group) if (length(unused_names)) { stop2("The following elements of 'cov_ranef' are unused: ", collapse_comma(unused_names)) } has_cov <- reframe$group %in% cr_names reframe$cov[has_cov] <- reframe$group[has_cov] reframe } # extract 'cov_ranef' for storage in 'data2' # @param x a list-like object get_data2_cov_ranef <- function(x) { x[["cov_ranef"]] } brms/R/pp_check.R0000644000176200001440000002026515053072461013325 0ustar liggesusers#' Posterior Predictive Checks for \code{brmsfit} Objects #' #' Perform posterior predictive checks with the help #' of the \pkg{bayesplot} package. #' #' @aliases pp_check #' #' @param object An object of class \code{brmsfit}. #' @param type Type of the ppc plot as given by a character string. #' See \code{\link[bayesplot:PPC-overview]{PPC}} for an overview #' of currently supported types. You may also use an invalid #' type (e.g. \code{type = "xyz"}) to get a list of supported #' types in the resulting error message. #' @param ndraws Positive integer indicating how many #' posterior draws should be used. #' If \code{NULL} all draws are used. If not specified, #' the number of posterior draws is chosen automatically. #' Ignored if \code{draw_ids} is not \code{NULL}. #' @param prefix The prefix of the \pkg{bayesplot} function to be applied. #' Either `"ppc"` (posterior predictive check; the default) #' or `"ppd"` (posterior predictive distribution), the latter being the same #' as the former except that the observed data is not shown for `"ppd"`. #' @param group Optional name of a factor variable in the model #' by which to stratify the ppc plot. This argument is required for #' ppc \code{*_grouped} types and ignored otherwise. #' @param x Optional name of a variable in the model. #' Only used for ppc types having an \code{x} argument #' and ignored otherwise. #' @param ... Further arguments passed to \code{\link{predict.brmsfit}} #' as well as to the PPC function specified in \code{type}. #' @inheritParams prepare_predictions.brmsfit #' #' @return A ggplot object that can be further #' customized using the \pkg{ggplot2} package. #' #' @details For a detailed explanation of each of the ppc functions, #' see the \code{\link[bayesplot:PPC-overview]{PPC}} #' documentation of the \pkg{\link[bayesplot:bayesplot-package]{bayesplot}} #' package. #' #' @examples #' \dontrun{ #' fit <- brm(count ~ zAge + zBase * Trt #' + (1|patient) + (1|obs), #' data = epilepsy, family = poisson()) #' #' pp_check(fit) # shows dens_overlay plot by default #' pp_check(fit, type = "error_hist", ndraws = 11) #' pp_check(fit, type = "scatter_avg", ndraws = 100) #' pp_check(fit, type = "stat_2d") #' pp_check(fit, type = "rootogram") #' pp_check(fit, type = "loo_pit") #' #' ## get an overview of all valid types #' pp_check(fit, type = "xyz") #' #' ## get a plot without the observed data #' pp_check(fit, prefix = "ppd") #' } #' #' @importFrom bayesplot pp_check #' @export pp_check #' @export pp_check.brmsfit <- function(object, type, ndraws = NULL, prefix = c("ppc", "ppd"), group = NULL, x = NULL, newdata = NULL, resp = NULL, draw_ids = NULL, nsamples = NULL, subset = NULL, ...) { dots <- list(...) if (missing(type)) { type <- "dens_overlay" } type <- as_one_character(type) prefix <- match.arg(prefix) if (!is.null(group)) { group <- as_one_character(group) } if (!is.null(x)) { x <- as_one_character(x) } ndraws_given <- any(c("ndraws", "nsamples") %in% names(match.call())) ndraws <- use_alias(ndraws, nsamples) draw_ids <- use_alias(draw_ids, subset) resp <- validate_resp(resp, object, multiple = FALSE) if (prefix == "ppc") { # no type checking for prefix 'ppd' yet valid_types <- as.character(bayesplot::available_ppc("")) valid_types <- sub("^ppc_", "", valid_types) if (!type %in% valid_types) { stop2("Type '", type, "' is not a valid ppc type. ", "Valid types are:\n", collapse_comma(valid_types)) } } ppc_fun <- get(paste0(prefix, "_", type), asNamespace("bayesplot")) object <- restructure(object) stopifnot_resp(object, resp) family <- family(object, resp = resp) if (has_multicol(family)) { stop2("'pp_check' is not implemented for this family.") } valid_vars <- names(model.frame(object)) if ("group" %in% names(formals(ppc_fun))) { if (is.null(group)) { stop2("Argument 'group' is required for ppc type '", type, "'.") } if (!group %in% valid_vars) { stop2("Variable '", group, "' could not be found in the data.") } } if ("x" %in% names(formals(ppc_fun))) { if (!is.null(x) && !x %in% valid_vars) { stop2("Variable '", x, "' could not be found in the data.") } } if (type == "error_binned") { if (is_polytomous(family)) { stop2("Type '", type, "' is not available for polytomous models.") } method <- "posterior_epred" } else { method <- "posterior_predict" } if (!ndraws_given) { aps_types <- c( "error_scatter_avg", "error_scatter_avg_vs_x", "intervals", "intervals_grouped", "loo_intervals", "loo_pit", "loo_pit_overlay", "loo_pit_qq", "loo_ribbon", "loo_pit_ecdf", 'pit_ecdf', 'pit_ecdf_grouped', "ribbon", "ribbon_grouped", "rootogram", "scatter_avg", "scatter_avg_grouped", "stat", "stat_2d", "stat_freqpoly_grouped", "stat_grouped", "violin_grouped" ) if (!is.null(draw_ids)) { ndraws <- NULL } else if (type %in% aps_types) { ndraws <- NULL message("Using all posterior draws for ppc type '", type, "' by default.") } else { ndraws <- 10 message("Using 10 posterior draws for ppc type '", type, "' by default.") } } y <- NULL if (prefix == "ppc") { # y is ignored in prefix 'ppd' plots y <- get_y(object, resp = resp, newdata = newdata, ...) } draw_ids <- validate_draw_ids(object, draw_ids, ndraws) pred_args <- list( object, newdata = newdata, resp = resp, draw_ids = draw_ids, ... ) yrep <- do_call(method, pred_args) if (anyNA(y)) { warning2("NA responses are not shown in 'pp_check'.") take <- !is.na(y) y <- y[take] yrep <- yrep[, take, drop = FALSE] } data <- current_data( object, newdata = newdata, resp = resp, re_formula = NA, check_response = TRUE, ... ) # prepare plotting arguments ppc_args <- list() if (prefix == "ppc") { ppc_args$y <- y ppc_args$yrep <- yrep } else if (prefix == "ppd") { ppc_args$ypred <- yrep } if (!is.null(group)) { ppc_args$group <- data[[group]] } if (!is.null(x)) { ppc_args$x <- data[[x]] if (!is_like_factor(ppc_args$x)) { ppc_args$x <- as.numeric(ppc_args$x) } } if ("lw" %in% setdiff(names(formals(ppc_fun)), names(ppc_args))) { # run loo instead of psis to allow for moment matching loo_object <- do_call(loo, c(pred_args, save_psis = TRUE)) ppc_args$lw <- weights(loo_object$psis_object, log = TRUE) } else if ("psis_object" %in% setdiff(names(formals(ppc_fun)), names(ppc_args))) { # some PPCs may only support 'psis_object' but not 'lw' for whatever reason loo_object <- do_call(loo, c(pred_args, save_psis = TRUE)) ppc_args$psis_object <- loo_object$psis_object } # censored responses are misleading when displayed in pp_check bterms <- brmsterms(object$formula) cens <- get_cens(bterms, data, resp = resp) is_censoring_type <- type %in% c("km_overlay", "km_overlay_grouped") if (!is.null(cens)) { if (is_censoring_type) { if (any(cens %in% c(-1, 2))) { warning2("Left and interval censored responses are not included.") } take <- cens %in% c(0, 1) ppc_args$status_y <- 1 - cens[take] } else { warning2("Censored responses are not included.") take <- !cens } if (!any(take)) { stop2("No valid responses found to include.") } ppc_args$y <- ppc_args$y[take] ppc_args$yrep <- ppc_args$yrep[, take, drop = FALSE] if (!is.null(ppc_args$group)) { ppc_args$group <- ppc_args$group[take] } if (!is.null(ppc_args$x)) { ppc_args$x <- ppc_args$x[take] } if (!is.null(ppc_args$lw)) { ppc_args$lw <- ppc_args$lw[, take] } else if (!is.null(ppc_args$psis_object)) { ppc_args$psis_object <- subset(ppc_args$psis_object, take) } } else if (is_censoring_type) { # status_y is mandatory for some ppc types ppc_args$status_y <- rep(1, length(ppc_args$y)) } # most ... arguments are meant for the prediction function for_pred <- names(dots) %in% names(formals(prepare_predictions.brmsfit)) ppc_args <- c(ppc_args, dots[!for_pred]) do_call(ppc_fun, ppc_args) } brms/R/prior_draws.R0000644000176200001440000001175514527413457014121 0ustar liggesusers#' Extract Prior Draws #' #' Extract prior draws of specified parameters #' #' @aliases prior_draws.brmsfit prior_samples #' #' @param x An \code{R} object typically of class \code{brmsfit}. #' @inheritParams as.data.frame.brmsfit #' @param ... Arguments passed to individual methods (if applicable). #' #' @details To make use of this function, the model must contain draws of #' prior distributions. This can be ensured by setting \code{sample_prior = #' TRUE} in function \code{brm}. Priors of certain parameters cannot be saved #' for technical reasons. For instance, this is the case for the #' population-level intercept, which is only computed after fitting the model #' by default. If you want to treat the intercept as part of all the other #' regression coefficients, so that sampling from its prior becomes possible, #' use \code{... ~ 0 + Intercept + ...} in the formulas. #' #' @return A \code{data.frame} containing the prior draws. #' #' @examples #' \dontrun{ #' fit <- brm(rating ~ treat + period + carry + (1|subject), #' data = inhaler, family = "cumulative", #' prior = set_prior("normal(0,2)", class = "b"), #' sample_prior = TRUE) #' #' # extract all prior draws #' draws1 <- prior_draws(fit) #' head(draws1) #' #' # extract prior draws for the coefficient of 'treat' #' draws2 <- prior_draws(fit, "b_treat") #' head(draws2) #' } #' #' @export prior_draws.brmsfit <- function(x, variable = NULL, pars = NULL, ...) { variable <- use_alias(variable, pars) if (!is.null(variable)) { variable <- as.character(variable) } all_names <- variables(x) prior_names <- unique(all_names[grepl("^prior_", all_names)]) if (!length(prior_names)) { return(data.frame(NULL)) } draws <- as.data.frame(x, variable = prior_names) names(draws) <- sub("^prior_", "", prior_names) if (is.null(variable)) { return(draws) } # get prior draws for a single variable .prior_draws <- function(variable) { matches <- paste0("^", escape_all(names(draws))) matches <- lapply(matches, regexpr, text = variable) matches <- ulapply(matches, attr, which = "match.length") if (max(matches) == -1 || ignore_prior(x, variable)) { out <- NULL } else { take <- match(max(matches), matches) # order draws randomly to avoid artificial dependencies # between parameters using the same prior draws draws <- list(draws[sample(ndraws(x)), take]) out <- structure(draws, names = variable) } return(out) } draws <- rmNULL(lapply(variable, .prior_draws)) draws <- data.frame(draws, check.names = FALSE) draws } #' @rdname prior_draws.brmsfit #' @export prior_draws <- function(x, ...) { UseMethod("prior_draws") } #' @export prior_draws.default <- function(x, variable = NULL, pars = NULL, regex = FALSE, fixed = FALSE, ...) { call <- match.call() if ("pars" %in% names(call)) { variable <- use_alias(variable, pars) regex <- !as_one_logical(fixed) } if (is.null(variable)) { variable <- "^prior_" regex <- TRUE } else { variable <- as.character(variable) regex <- as_one_logical(regex) if (regex) { hat <- substr(variable, 1, 1) == "^" variable <- ifelse(hat, substr(variable, 2, nchar(variable)), variable) variable <- paste0("^prior_", variable) } else { variable <- paste0("prior_", variable) } } x <- as_draws_df(as.data.frame(x)) if (!regex) { # missing variables will leads to an error in posterior variable <- intersect(variable, variables(x)) if (!length(variable)) { return(data.frame(NULL)) } } x <- subset_draws(x, variable = variable, regex = regex, ...) unclass_draws(x) } #' @rdname prior_draws.brmsfit #' @export prior_samples <- function(x, ...) { warning2("'prior_samples' is deprecated. Please use 'prior_draws' instead.") UseMethod("prior_draws") } # ignore priors of certain parameters from whom we cannot obtain prior draws # currently applies only to overall intercepts of centered design matrices # fixes issue #696 # @param x a brmsfit object # @param variable name of a single variable # @return TRUE (if the prior should be ignored) or FALSE ignore_prior <- function(x, variable) { stopifnot(is.brmsfit(x)) variable <- as_one_character(variable) out <- FALSE if (grepl("^b_.*Intercept($|\\[)", variable)) { # cannot sample from intercepts if 'center' was TRUE intercept_priors <- subset2(x$prior, class = "Intercept") if (NROW(intercept_priors)) { # prefixes of the model intercepts p_intercepts <- usc(combine_prefix(intercept_priors)) # prefix of the parameter under question p_par <- sub("^b", "", variable) p_par <- sub("_Intercept($|\\[)", "", p_par) out <- p_par %in% p_intercepts if (out) { warning2( "Sampling from the prior of an overall intercept is not ", "possible by default. See the documentation of the ", "'sample_prior' argument in help('brm')." ) } } } out } brms/R/standata.R0000644000176200001440000001670015053305627013352 0ustar liggesusers#' @title Stan data for Bayesian models #' #' @description \code{standata} is a generic function that can be used to #' generate data for Bayesian models to be passed to Stan. Its original use is #' within the \pkg{brms} package, but new methods for use #' with objects from other packages can be registered to the same generic. #' #' @param object A formula object whose class will determine which method will #' be used. A symbolic description of the model to be fitted. #' @param formula Synonym of \code{object} for use in \code{make_standata}. #' @param ... Further arguments passed to the specific method. #' #' @return A named list of objects containing the required data to fit a #' Bayesian model with \pkg{Stan}. #' #' @details #' See \code{\link{standata.default}} for the default method applied for #' \pkg{brms} models. You can view the available methods by typing #' \code{methods(standata)}. The \code{make_standata} function is an alias #' of \code{standata}. #' #' @examples #' sdata1 <- standata(rating ~ treat + period + carry + (1|subject), #' data = inhaler, family = "cumulative") #' str(sdata1) #' #' @seealso #' \code{\link{standata.default}}, \code{\link{standata.brmsfit}} #' #' @export standata <- function(object, ...) { UseMethod("standata") } #' @rdname standata #' @export make_standata <- function(formula, ...) { # became an alias of standata in 2.20.14. standata(formula, ...) } #' Data for \pkg{brms} Models #' #' Generate data for \pkg{brms} models to be passed to \pkg{Stan}. #' #' @inheritParams brm #' @param object An object of class \code{\link[stats:formula]{formula}}, #' \code{\link{brmsformula}}, or \code{\link{mvbrmsformula}} (or one that can #' be coerced to that classes): A symbolic description of the model to be #' fitted. The details of model specification are explained in #' \code{\link{brmsformula}}. #' @param ... Other arguments for internal use. #' #' @return A named list of objects containing the required data #' to fit a \pkg{brms} model with \pkg{Stan}. #' #' @examples #' sdata1 <- standata(rating ~ treat + period + carry + (1|subject), #' data = inhaler, family = "cumulative") #' str(sdata1) #' #' sdata2 <- standata(count ~ zAge + zBase * Trt + (1|patient), #' data = epilepsy, family = "poisson") #' str(sdata2) #' #' @export standata.default <- function(object, data, family = gaussian(), prior = NULL, autocor = NULL, data2 = NULL, cov_ranef = NULL, sample_prior = "no", stanvars = NULL, threads = getOption("brms.threads", NULL), knots = NULL, drop_unused_levels = TRUE, ...) { object <- validate_formula( object, data = data, family = family, autocor = autocor, cov_ranef = cov_ranef ) bterms <- brmsterms(object) data2 <- validate_data2( data2, bterms = bterms, get_data2_autocor(object), get_data2_cov_ranef(object) ) data <- validate_data( data, bterms = bterms, knots = knots, data2 = data2, drop_unused_levels = drop_unused_levels ) bframe <- brmsframe(bterms, data) prior <- .validate_prior( prior, bframe = bframe, sample_prior = sample_prior ) stanvars <- validate_stanvars(stanvars) threads <- validate_threads(threads) .standata( bframe, data = data, prior = prior, data2 = data2, stanvars = stanvars, threads = threads, ... ) } # internal work function of 'standata' # @param check_response check validity of the response? # @param only_response extract data related to the response only? # @param internal prepare Stan data for use in post-processing methods? # @param basis original Stan data as prepared by 'frame_basis' # @param ... currently ignored # @return names list of data passed to Stan .standata <- function(bframe, data, prior, stanvars, data2, threads = threading(), check_response = TRUE, only_response = FALSE, internal = FALSE, ...) { stopifnot(is.anybrmsframe(bframe)) check_response <- as_one_logical(check_response) only_response <- as_one_logical(only_response) internal <- as_one_logical(internal) out <- data_response( bframe, data, check_response = check_response, internal = internal ) if (!only_response) { # pass as sdata so that data_special_prior knows about data_gr_global # TODO: compute sdata_gr_global in brmsframe in brms 3.0 # this would require passing data2 to brmsframe sdata_gr_global <- data_gr_global(bframe, data2 = data2) c(out) <- data_predictor( bframe, data = data, prior = prior, data2 = data2, sdata = sdata_gr_global ) c(out) <- sdata_gr_global c(out) <- data_Xme(bframe, data = data) } out$prior_only <- as.integer(is_prior_only(prior)) if (use_threading(threads)) { out$grainsize <- threads$grainsize if (is.null(out$grainsize)) { out$grainsize <- ceiling(out$N / (2 * threads$threads)) out$grainsize <- max(100, out$grainsize) } } if (is.stanvars(stanvars)) { stanvars <- subset_stanvars(stanvars, block = "data") inv_names <- intersect(names(stanvars), names(out)) if (length(inv_names)) { stop2("Cannot overwrite existing variables: ", collapse_comma(inv_names)) } out[names(stanvars)] <- from_list(stanvars, "sdata") } if (internal) { # allows to recover the original order of the data attr(out, "old_order") <- attr(data, "old_order") # ensures currently used grouping levels are known in post-processing set_levels(out, "used") <- get_levels(bframe, prefix = "used") } structure(out, class = c("standata", "list")) } #' Extract data passed to Stan from \code{brmsfit} objects #' #' Extract all data that was used by Stan to fit a \pkg{brms} model. #' #' @param object An object of class \code{brmsfit}. #' @param ... More arguments passed to #' \code{\link[brms:standata.default]{standata.default}}. #' and \code{\link{validate_newdata}}. #' @inheritParams prepare_predictions #' #' @return A named list containing the data passed to Stan. #' #' @export standata.brmsfit <- function(object, newdata = NULL, re_formula = NULL, newdata2 = NULL, new_objects = NULL, incl_autocor = TRUE, ...) { # allows functions to fall back to old default behavior # which was used when originally fitting the model options(.brmsfit_version = object$version$brms) on.exit(options(.brmsfit_version = NULL)) object <- exclude_terms(object, incl_autocor = incl_autocor) formula <- update_re_terms(object$formula, re_formula) bterms <- brmsterms(formula) newdata2 <- use_alias(newdata2, new_objects) data2 <- current_data2(object, newdata2) data <- current_data( object, newdata, newdata2 = data2, re_formula = re_formula, ... ) stanvars <- add_newdata_stanvars(object$stanvars, data2) basis <- object$basis if (is.null(basis)) { # this case should not happen actually, perhaps when people use # the 'empty' feature. But computing it here will be fine # for almost all models, only causing potential problems for processing # of splines on new machines (#1465) bframe_old <- brmsframe(object$formula, data = object$data) basis <- frame_basis(bframe_old, data = object$data) } bframe <- brmsframe(bterms, data = data, basis = basis) .standata( bframe, data = data, prior = object$prior, data2 = data2, stanvars = stanvars, threads = object$threads, ... ) } brms/R/stan-prior.R0000644000176200001440000007041015053072461013644 0ustar liggesusers# unless otherwise specified, functions return a single character # string defining the likelihood of the model in Stan language # Define priors for parameters in Stan language # @param prior an object of class 'brmsprior' # @param class the parameter class # @param coef the coefficients of this class # @param group the name of a grouping factor # @param type Stan type used in the definition of the parameter # if type is empty the parameter is not initialized inside 'stan_prior' # @param dim stan array dimension to be specified after the parameter name # cannot be expressed via 'suffix' as the latter should apply to # individual coefficients while 'dim' should not # TODO: decide whether to support arrays for parameters at all # an alternative would be to specify elements directly as parameters # @param coef_type Stan type used in the definition of individual parameter # coefficients # @param prefix a prefix to put at the parameter class # @param suffix a suffix to put at the parameter class # @param broadcast Stan type to which the prior should be broadcasted # in order to handle vectorized prior statements # supported values are 'vector' or 'matrix' # @param comment character string containing a comment for the parameter # @param px list or data.frame after which to subset 'prior' # @return a named list of character strings in Stan language stan_prior <- function(prior, class, coef = NULL, group = NULL, type = "real", dim = "", coef_type = "real", prefix = "", suffix = "", broadcast = "vector", header_type = "", comment = "", px = list(), normalize = TRUE) { prior_only <- isTRUE(attr(prior, "sample_prior") == "only") prior <- subset2( prior, class = class, coef = c(coef, ""), group = c(group, ""), ls = px ) # special priors cannot be passed literally to Stan is_special_prior <- is_special_prior(prior$prior) if (any(is_special_prior)) { special_prior <- prior$prior[is_special_prior] stop2("Prior ", collapse_comma(special_prior), " is used in an invalid ", "context. See ?set_prior for details on how to use special priors.") } px <- as.data.frame(px, stringsAsFactors = FALSE) upx <- unique(px) if (nrow(upx) > 1L) { # TODO: find a better solution to handle this case # can only happen for SD parameters of the same ID base_prior <- base_lprior_tag <- lb <- ub <- rep(NA, nrow(upx)) base_bounds <- data.frame(lb = lb, ub = ub) for (i in seq_rows(upx)) { sub_upx <- lapply(upx[i, ], function(x) c(x, "")) sub_prior <- subset2(prior, ls = sub_upx) base_prior[i] <- stan_base_prior(sub_prior) base_lprior_tag[i] <- stan_base_prior(sub_prior, col = "tag") base_bounds[i, ] <- stan_base_prior(sub_prior, col = c("lb", "ub")) } if (length(unique(base_prior)) > 1L) { # define prior for single coefficients manually # as there is not single base_prior anymore take_coef_prior <- nzchar(prior$coef) & !nzchar(prior$prior) prior_of_coefs <- prior[take_coef_prior, vars_prefix()] take_base_prior <- match_rows(prior_of_coefs, upx) prior$prior[take_coef_prior] <- base_prior[take_base_prior] prior$lprior[take_coef_prior] <- base_lprior_tag[take_base_prior] } base_prior <- base_prior[1] base_lprior_tag <- base_lprior_tag[1] if (nrow(unique(base_bounds)) > 1L) { stop2("Conflicting boundary information for ", "coefficients of class '", class, "'.") } base_bounds <- base_bounds[1, ] } else { # TODO: select base_prior together with tags and boundaries in one call? base_prior <- stan_base_prior(prior) base_lprior_tag <- stan_base_prior(prior, col = "tag") # select both bounds together so that they come from the same base prior base_bounds <- stan_base_prior(prior, col = c("lb", "ub")) } bound <- convert_bounds2stan(base_bounds) # generate stan prior statements out <- list() par <- paste0(prefix, class, suffix) has_constant_priors <- FALSE has_coef_prior <- any(with(prior, nzchar(coef) & nzchar(prior))) if (has_coef_prior || nzchar(dim) && length(coef)) { # priors on individual coefficients are also individually set # priors are always set on individual coefficients for arrays index_two_dims <- is.matrix(coef) coef <- as.matrix(coef) prior <- subset2(prior, coef = coef) estimated_coef_indices <- list() used_base_prior <- FALSE for (i in seq_rows(coef)) { for (j in seq_cols(coef)) { index <- i if (index_two_dims) { c(index) <- j } prior_ij <- subset2(prior, coef = coef[i, j]) if (NROW(px) > 1L) { # disambiguate priors of coefficients with the same name # coming from different model components stopifnot(NROW(px) == NROW(coef)) prior_ij <- subset2(prior_ij, ls = px[i, ]) } # zero rows can happen if only global priors present stopifnot(nrow(prior_ij) <= 1L) coef_prior <- prior_ij$prior lprior_tag <- prior_ij$tag if (!isTRUE(nzchar(coef_prior))) { used_base_prior <- TRUE coef_prior <- base_prior lprior_tag <- base_lprior_tag } if (!stan_is_constant_prior(coef_prior)) { # all parameters with non-constant priors are estimated c(estimated_coef_indices) <- list(index) } if (nzchar(coef_prior)) { # implies a proper prior or constant if (type == coef_type && !nzchar(dim)) { # the single coefficient of that parameter equals the parameter stopifnot(all(index == 1L)) par_ij <- par } else { par_ij <- paste0(par, collapse("[", index, "]")) } if (stan_is_constant_prior(coef_prior)) { coef_prior <- stan_constant_prior( coef_prior, par_ij, broadcast = broadcast ) str_add(out$tpar_prior_const) <- paste0(coef_prior, ";\n") } else { coef_prior <- stan_target_prior( coef_prior, par_ij, broadcast = broadcast, bound = bound, resp = px$resp[1], normalize = normalize ) if (isTRUE(nzchar(lprior_tag))) { # add to a local lprior variable if specified str_add(out$tpar_prior) <- paste0( lpp(tag = lprior_tag), coef_prior, ";\n" ) } else { # add to the global lprior variable directly str_add(out$tpar_prior) <- paste0(lpp(), coef_prior, ";\n") } } } } } # the base prior may be improper flat in which no Stan code is added # but we still have estimated coefficients if the base prior is used has_estimated_priors <- isTRUE(nzchar(out$tpar_prior)) || used_base_prior && !stan_is_constant_prior(base_prior) has_constant_priors <- isTRUE(nzchar(out$tpar_prior_const)) if (has_estimated_priors && has_constant_priors) { # need to mix definition in the parameters and transformed parameters block if (!nzchar(coef_type)) { stop2("Can either estimate or fix all values of parameter '", par, "'.") } coef_type <- stan_type_add_bounds(coef_type, bound) for (i in seq_along(estimated_coef_indices)) { index <- estimated_coef_indices[[i]] iu <- paste0(index, collapse = "_") str_add(out$par) <- glue( " {coef_type} par_{par}_{iu};\n" ) ib <- collapse("[", index, "]") str_add(out$tpar_prior_const) <- cglue( " {par}{ib} = par_{par}_{iu};\n" ) } } } else if (nzchar(base_prior)) { # only a global prior is present and will be broadcasted ncoef <- length(coef) has_constant_priors <- stan_is_constant_prior(base_prior) if (has_constant_priors) { constant_base_prior <- stan_constant_prior( base_prior, par = par, ncoef = ncoef, broadcast = broadcast ) str_add(out$tpar_prior_const) <- paste0(constant_base_prior, ";\n") } else { target_base_prior <- stan_target_prior( base_prior, par = par, ncoef = ncoef, bound = bound, broadcast = broadcast, resp = px$resp[1], normalize = normalize ) if (isTRUE(nzchar(base_lprior_tag))) { # add to a local lprior variable if specified str_add(out$tpar_prior) <- paste0( lpp(tag = base_lprior_tag), target_base_prior, ";\n" ) } else { # add to the global lprior variable directly str_add(out$tpar_prior) <- paste0(lpp(), target_base_prior, ";\n") } } } if (nzchar(type)) { # only define the parameter here if type is non-empty type <- stan_adjust_par_type(type, base_prior) type <- stan_type_add_bounds(type, bound) if (nzchar(dim)) { type <- glue("array{dim} {type}") } comment <- stan_comment(comment) par_definition <- glue(" {type} {par};{comment}\n") if (has_constant_priors) { # parameter must be defined in the transformed parameters block str_add(out$tpar_def) <- par_definition } else { # parameter can be defined in the parameters block str_add(out$par) <- par_definition } if (nzchar(header_type)) { str_add(out$pll_args) <- glue(", {header_type} {par}") } } else { if (has_constant_priors) { stop2("Cannot fix parameter '", par, "' in this model.") } } has_improper_prior <- !is.null(out$par) && is.null(out$tpar_prior) if (prior_only && has_improper_prior) { stop2("Sampling from priors is not possible as ", "some parameters have no proper priors. ", "Error occurred for parameter '", par, "'.") } out } # extract base prior information for a given set of priors # the base prior is the lowest level, non-flat, non-coefficient prior # @param prior a brmsprior object # @param col columns for which base prior information is to be found # @param sel_prior optional brmsprior object to subset 'prior' before # finding the base prior # @return the 'col' columns of the identified base prior stan_base_prior <- function(prior, col = "prior", sel_prior = NULL, ...) { stopifnot(all(col %in% c("prior", "lb", "ub", "tag"))) if (!is.null(sel_prior)) { # find the base prior using sel_prior for subsetting stopifnot(is.brmsprior(sel_prior)) prior <- subset2( prior, class = sel_prior$class, group = c(sel_prior$group, ""), dpar = sel_prior$dpar, nlpar = sel_prior$nlpar, resp = sel_prior$resp, ... ) } else { prior <- subset2(prior, ...) } stopifnot(length(unique(prior$class)) <= 1) # take all rows with non-zero entries on any of the chosen columns take <- !nzchar(prior$coef) & Reduce("|", lapply(prior[col], nzchar)) prior <- prior[take, ] if (!NROW(prior)) { if (length(col) == 1L) { return("") } else { return(brmsprior()[, col]) } } vars <- c("group", "nlpar", "dpar", "resp", "class", "tag") for (v in vars) { take <- nzchar(prior[[v]]) if (any(take)) { prior <- prior[take, ] } } stopifnot(NROW(prior) == 1L) prior[, col] } # Stan prior in target += notation # @param prior character string defining the prior # @param par name of the parameter on which to set the prior # @param ncoef number of coefficients in the parameter # @param bound bounds of the parameter in Stan language # @param broadcast Stan type to which the prior should be broadcasted # @param name of the response variable # @return a character string defining the prior in Stan language stan_target_prior <- function(prior, par, ncoef = 0, broadcast = "vector", bound = "", resp = "", normalize = TRUE) { prior <- gsub("[[:space:]]+\\(", "(", prior) prior_name <- get_matches( "^[^\\(]+(?=\\()", prior, perl = TRUE, simplify = FALSE ) for (i in seq_along(prior_name)) { if (length(prior_name[[i]]) != 1L) { stop2("The prior '", prior[i], "' is invalid.") } } prior_name <- unlist(prior_name) prior_args <- rep(NA, length(prior)) for (i in seq_along(prior)) { prior_args[i] <- sub(glue("^{prior_name[i]}\\("), "", prior[i]) prior_args[i] <- sub(")$", "", prior_args[i]) } if (broadcast == "matrix" && ncoef > 0) { # apply a scalar prior to all elements of a matrix par <- glue("to_vector({par})") } if (nzchar(prior_args)) { str_add(prior_args, start = TRUE) <- " | " } lpdf <- stan_lpdf_name(normalize) out <- glue("{prior_name}_{lpdf}({par}{prior_args})") par_class <- unique(get_matches("^[^_]+", par)) par_bound <- convert_stan2bounds(bound) prior_bound <- prior_bounds(prior_name) trunc_lb <- is.character(par_bound$lb) || par_bound$lb > prior_bound$lb trunc_ub <- is.character(par_bound$ub) || par_bound$ub < prior_bound$ub if (normalize) { # obtain correct normalization constants for truncated priors if (trunc_lb || trunc_ub) { wsp <- wsp(nsp = 4) # scalar parameters are of length 1 but have no coefficients ncoef <- max(1, ncoef) if (trunc_lb && !trunc_ub) { str_add(out) <- glue( "\n{wsp}- {ncoef} * {prior_name}_lccdf({par_bound$lb}{prior_args})" ) } else if (!trunc_lb && trunc_ub) { str_add(out) <- glue( "\n{wsp}- {ncoef} * {prior_name}_lcdf({par_bound$ub}{prior_args})" ) } else if (trunc_lb && trunc_ub) { str_add(out) <- glue( "\n{wsp}- {ncoef} * log_diff_exp(", "{prior_name}_lcdf({par_bound$ub}{prior_args}), ", "{prior_name}_lcdf({par_bound$lb}{prior_args}))" ) } } } out } # fix parameters to constants in Stan language # @param prior character string defining the prior # @param par name of the parameter on which to set the prior # @param ncoef number of coefficients in the parameter # @param broadcast Stan type to which the prior should be broadcasted # @return a character string defining the prior in Stan language stan_constant_prior <- function(prior, par, ncoef = 0, broadcast = "vector") { stopifnot(grepl("^constant\\(", prior)) args <- eval2(prior) if (args$broadcast) { # broadcast constant if desired and needed? if (broadcast == "vector") { if (ncoef > 0) { # broadcast the scalar prior on the whole parameter vector args$const <- glue("rep_vector({args$const}, rows({par}))") } # no action required for individual coefficients of vectors } else if (broadcast == "matrix") { if (ncoef > 0) { # broadcast the scalar prior on the whole parameter matrix args$const <- glue("rep_matrix({args$const}, rows({par}), cols({par}))") } else { # single coefficient is a row in the parameter matrix args$const <- glue("rep_row_vector({args$const}, cols({par}))") } } } glue(" {par} = {args$const}") } # Stan code for global parameters of special shrinkage priors stan_special_prior <- function(bterms, out, prior, normalize, ...) { stopifnot(is.list(out)) tp <- tp() lpp <- lpp() lpdf <- stan_lpdf_name(normalize) px <- check_prefix(bterms) p <- usc(combine_prefix(px)) if (!has_special_prior(prior, px)) { return(out) } special <- get_special_prior(prior, px, main = TRUE) str_add(out$data) <- glue( " int Kscales{p}; // number of local scale parameters\n" ) if (special$name == "horseshoe") { str_add(out$fun) <- " #include 'fun_horseshoe.stan'\n" str_add(out$data) <- glue( " // data for the horseshoe prior\n", " real hs_df{p}; // local degrees of freedom\n", " real hs_df_global{p}; // global degrees of freedom\n", " real hs_df_slab{p}; // slab degrees of freedom\n", " real hs_scale_global{p}; // global prior scale\n", " real hs_scale_slab{p}; // slab prior scale\n" ) str_add(out$par) <- glue( " // horseshoe shrinkage parameters\n", " real hs_global{p}; // global shrinkage parameter\n", " real hs_slab{p}; // slab regularization parameter\n", " vector[Kscales{p}] hs_local{p}; // local parameters for the horseshoe prior\n" ) hs_scale_global <- glue("hs_scale_global{p}") if (isTRUE(special$autoscale)) { str_add(hs_scale_global) <- glue(" * sigma{usc(px$resp)}") } str_add(out$tpar_prior) <- glue( "{lpp}student_t_{lpdf}(hs_global{p} | hs_df_global{p}, 0, {hs_scale_global})", str_if(normalize, "\n - 1 * log(0.5)"), ";\n", "{lpp}inv_gamma_{lpdf}(hs_slab{p} | 0.5 * hs_df_slab{p}, 0.5 * hs_df_slab{p});\n" ) str_add(out$tpar_def) <- glue( " vector[Kscales{p}] scales{p}; // local horseshoe scale parameters\n" ) str_add(out$tpar_comp) <- glue( " // compute horseshoe scale parameters\n", " scales{p} = scales_horseshoe(hs_local{p}, hs_global{p}, hs_scale_slab{p}^2 * hs_slab{p});\n" ) str_add(out$model_prior) <- glue( "{tp}student_t_{lpdf}(hs_local{p} | hs_df{p}, 0, 1)", str_if(normalize, "\n - rows(hs_local{p}) * log(0.5)"), ";\n" ) } else if (special$name == "R2D2") { str_add(out$fun) <- " #include 'fun_r2d2.stan'\n" str_add(out$data) <- glue( " // data for the R2D2 prior\n", " real R2D2_mean_R2{p}; // mean of the R2 prior\n", " real R2D2_prec_R2{p}; // precision of the R2 prior\n", " // concentration vector of the D2 prior\n", " vector[Kscales{p}] R2D2_cons_D2{p};\n" ) str_add(out$par) <- glue( " // parameters of the R2D2 prior\n", " real R2D2_R2{p};\n", " simplex[Kscales{p}] R2D2_phi{p};\n" ) var_mult <- "" if (isTRUE(special$autoscale)) { var_mult <- glue("sigma{usc(px$resp)}^2 * ") } str_add(out$tpar_def) <- glue( " real R2D2_tau2{p}; // global R2D2 scale parameter\n", " vector[Kscales{p}] scales{p}; // local R2D2 scale parameters\n" ) str_add(out$tpar_comp) <- glue( " // compute R2D2 scale parameters\n", " R2D2_tau2{p} = {var_mult}R2D2_R2{p} / (1 - R2D2_R2{p});\n", " scales{p} = scales_R2D2(R2D2_phi{p}, R2D2_tau2{p});\n" ) str_add(out$tpar_prior) <- glue( "{lpp}beta_{lpdf}(R2D2_R2{p} | R2D2_mean_R2{p} * R2D2_prec_R2{p}, ", "(1 - R2D2_mean_R2{p}) * R2D2_prec_R2{p});\n" ) str_add(out$model_prior) <- glue( "{tp}dirichlet_{lpdf}(R2D2_phi{p} | R2D2_cons_D2{p});\n" ) } if (has_special_prior(prior, px, class = "sd")) { # this has to be done here rather than in stan_re() # because the latter is not local to a linear predictor ids <- unique(subset2(bterms$frame$re)$id) str_add(out$prior_global_scales) <- cglue(" sd_{ids}") str_add(out$prior_global_lengths) <- cglue(" M_{ids}") } # split up scales into subsets belonging to different parameter classes # this connects the global to the local priors scales <- strsplit(trimws(out$prior_global_scales), " ")[[1]] lengths <- strsplit(trimws(out$prior_global_lengths), " ")[[1]] out$prior_global_scales <- out$prior_global_lengths <- NULL lengths <- c("1", lengths) for (i in seq_along(scales)) { lower <- paste0(lengths[1:i], collapse = "+") upper <- paste0(lengths[2:(i+1)], collapse = "+") # some scale parameters are a scalar not a vector bracket1 <- str_if(lengths[i+1] == "1", "[1]") str_add(out$tpar_comp) <- glue( " {scales[i]} = scales{p}[({lower}):({upper})]{bracket1};\n" ) } out } # Stan code of normal priors on regression coefficients # in non-centered parameterization # @param class name of the coefficient class # @param suffix shared suffix of the involved variables # @param suffix_class extra suffix of the class # @param suffix_K extra suffix of K (number of coefficients) stan_prior_non_centered <- function(class = "b", suffix = "", suffix_class = "", suffix_K = "", normalize = TRUE) { out <- list() csfx <- glue("{class}{suffix}") csfx2 <- glue("{class}{suffix_class}{suffix}") Ksfx <- glue("K{suffix_K}{suffix}") lpdf <- stan_lpdf_name(normalize) str_add(out$tpar_def) <- glue( " vector[{Ksfx}] {csfx2}; // scaled coefficients\n" ) str_add(out$par) <- glue( " vector[{Ksfx}] z{csfx}; // unscaled coefficients\n" ) str_add(out$tpar_def) <- glue( " vector[{Ksfx}] sd{csfx}; // SDs of the coefficients\n" ) str_add(out$tpar_special_prior) <- glue( " {csfx2} = z{csfx} .* sd{csfx}; // scale coefficients\n" ) str_add(out$model_prior) <- glue( "{tp()}std_normal_{lpdf}(z{csfx});\n" ) str_add(out$prior_global_scales) <- glue(" sd{csfx}") str_add(out$prior_global_lengths) <- glue(" {Ksfx}") str_add(out$pll_args) <- glue(", vector {csfx2}") out } # combine unchecked priors for use in Stan # @param prior a brmsprior object # @return a single character string in Stan language stan_unchecked_prior <- function(prior) { stopifnot(is.brmsprior(prior)) if (all(nzchar(prior$class))) { return("") } prior <- subset2(prior, class = "") collapse(" ", prior$prior, ";\n") } # Stan code to sample separately from priors # @param tpar_prior character string taken from stan_prior that contains # all priors that can potentially be sampled from separately # @param par_declars the parameters block of the Stan code # required to extract boundaries # @param gen_quantities Stan code from the generated quantities block # @param special_prior a list of values pertaining to special priors # such as horseshoe or lasso # @param sample_prior take draws from priors? stan_rngprior <- function(tpar_prior, par_declars, gen_quantities, special_prior, sample_prior = "yes") { if (!is_equal(sample_prior, "yes") || !length(tpar_prior)) { return(list()) } tpar_prior <- strsplit(gsub(" |\\n", "", tpar_prior), ";")[[1]] # D will contain all relevant information about the priors D <- data.frame(prior = tpar_prior[nzchar(tpar_prior)]) pars_regex <- "(?<=(_lpdf\\())[^|]+" D$par <- get_matches(pars_regex, D$prior, perl = TRUE, first = TRUE) # 'std_normal' has no '|' and thus the above regex matches too much np <- !grepl("\\|", D$prior) np_regex <- ".+(?=\\)$)" D$par[np] <- get_matches(np_regex, D$par[np], perl = TRUE, first = TRUE) # 'to_vector' should be removed from the parameter names has_tv <- grepl("^to_vector\\(", D$par) tv_regex <- "(^to_vector\\()|(\\)(?=((\\[[[:digit:]]+\\])?)$))" D$par[has_tv] <- gsub(tv_regex, "", D$par[has_tv], perl = TRUE) # do not sample from some auxiliary parameters excl_regex <- c("tmp") excl_regex <- paste0("(", excl_regex, ")", collapse = "|") excl_regex <- paste0("^(", excl_regex, ")(_|$)") D <- D[!grepl(excl_regex, D$par), ] if (!NROW(D)) return(list()) # rename parameters containing indices has_ind <- grepl("\\[[[:digit:]]+\\]", D$par) D$par[has_ind] <- ulapply(D$par[has_ind], function(par) { ind_regex <- "(?<=\\[)[[:digit:]]+(?=\\])" ind <- get_matches(ind_regex, par, perl = TRUE) gsub("\\[[[:digit:]]+\\]", paste0("__", ind), par) }) # cannot handle priors on variable transformations D <- D[D$par %in% stan_all_vars(D$par), ] if (!NROW(D)) return(list()) class_old <- c("^L_", "^Lrescor") class_new <- c("cor_", "rescor") D$par <- rename(D$par, class_old, class_new, fixed = FALSE) dis_regex <- "(?<=lprior\\+=)[^\\(]+(?=_lpdf\\()" D$dist <- get_matches(dis_regex, D$prior, perl = TRUE, first = TRUE) D$dist <- sub("corr_cholesky$", "corr", D$dist) args_regex <- "(?<=\\|)[^$\\|]+(?=\\)($|-))" D$args <- get_matches(args_regex, D$prior, perl = TRUE, first = TRUE) # 'std_normal_rng' does not exist in Stan has_std_normal <- D$dist == "std_normal" D$dist[has_std_normal] <- "normal" D$args[has_std_normal] <- "0,1" # extract information from the initial parameter definition par_declars <- unlist(strsplit(par_declars, "\n", fixed = TRUE)) par_declars <- gsub("^[[:blank:]]*", "", par_declars) par_declars <- par_declars[!grepl("^//", par_declars)] all_pars_regex <- "(?<= )[^[:blank:]]+(?=;)" all_pars <- get_matches(all_pars_regex, par_declars, perl = TRUE) all_pars <- rename(all_pars, class_old, class_new, fixed = FALSE) all_bounds <- get_matches("<.+>", par_declars, first = TRUE) all_types <- get_matches("^[^[:blank:]]+", par_declars) all_dims <- get_matches( "(?<=\\[)[^\\]]*", par_declars, first = TRUE, perl = TRUE ) # define parameter types and boundaries D$dim <- D$bounds <- "" D$type <- "real" for (i in seq_along(all_pars)) { k <- which(grepl(paste0("^", all_pars[i]), D$par)) D$dim[k] <- all_dims[i] D$bounds[k] <- all_bounds[i] if (grepl("^((simo_)|(theta)|(R2D2_phi))", all_pars[i])) { D$type[k] <- all_types[i] } } # exclude priors which depend on other priors # TODO: enable sampling from these priors as well found_vars <- lapply(D$args, find_vars, dot = FALSE, brackets = FALSE) contains_other_pars <- ulapply(found_vars, function(x) any(x %in% all_pars)) D <- D[!contains_other_pars, ] if (!NROW(D)) return(list()) out <- list() # sample priors in the generated quantities block D$lkj <- grepl("^lkj_corr$", D$dist) D$args <- paste0(ifelse(D$lkj, paste0(D$dim, ","), ""), D$args) D$lkj_index <- ifelse(D$lkj, "[1, 2]", "") D$prior_par <- glue("prior_{D$par}") str_add(out$gen_def) <- " // additionally sample draws from priors\n" str_add(out$gen_def) <- cglue( " {D$type} {D$prior_par} = {D$dist}_rng({D$args}){D$lkj_index};\n" ) # sample from truncated priors using rejection sampling D$lb <- stan_extract_bounds(D$bounds, bound = "lower") D$ub <- stan_extract_bounds(D$bounds, bound = "upper") Ibounds <- which(nzchar(D$bounds)) if (length(Ibounds)) { str_add(out$gen_comp) <- " // use rejection sampling for truncated priors\n" for (i in Ibounds) { wl <- if (nzchar(D$lb[i])) glue("{D$prior_par[i]} < {D$lb[i]}") wu <- if (nzchar(D$ub[i])) glue("{D$prior_par[i]} > {D$ub[i]}") prior_while <- paste0(c(wl, wu), collapse = " || ") str_add(out$gen_comp) <- glue( " while ({prior_while}) {{\n", " {D$prior_par[i]} = {D$dist[i]}_rng({D$args[i]}){D$lkj_index[i]};\n", " }}\n" ) } } out } # are multiple base priors supplied? # px list of class, dpar, etc. elements used to infer parameter suffixes stan_has_multiple_base_priors <- function(px) { px <- as.data.frame(px, stringsAsFactors = FALSE) nrow(unique(px)) > 1L } # check if any constant priors are present # @param prior a vector of character strings stan_is_constant_prior <- function(prior) { grepl("^constant\\(", prior) } # extract Stan boundaries expression from a string stan_extract_bounds <- function(x, bound = c("lower", "upper")) { bound <- match.arg(bound) x <- rm_wsp(x) regex <- glue("(?<={bound}=)[^,>]*") get_matches(regex, x, perl = TRUE, first = TRUE) } # choose the right suffix for Stan probability densities stan_lpdf_name <- function(normalize, int = FALSE) { if (normalize) { out <- ifelse(int, "lpmf", "lpdf") } else { out <- ifelse(int, "lupmf", "lupdf") } out } # add bounds to a Stan type specification which may include dimensions stan_type_add_bounds <- function(type, bound) { regex_dim <- "\\[.*$" type_type <- sub(regex_dim, "", type) type_dim <- get_matches(regex_dim, type, first = TRUE) glue("{type_type}{bound}{type_dim}") } # adjust the type of a parameter based on the assigned prior stan_adjust_par_type <- function(type, prior) { # TODO: add support for more type-prior combinations? combs <- data.frame( type = "vector", prior = "dirichlet", new_type = "simplex" ) for (i in seq_rows(combs)) { regex_type <- paste0("^", combs$type[i], "\\[?") regex_prior <- paste0("^", combs$prior[i], "\\(") if (grepl(regex_type, type) && grepl(regex_prior, prior)) { brackets <- get_matches("\\[.*\\]$", type, first = TRUE) type <- paste0(combs$new_type[i], brackets) break } } type } # stops if a prior bound is given stopif_prior_bound <- function(prior, class, ...) { lb <- stan_base_prior(prior, "lb", class = class, ...) ub <- stan_base_prior(prior, "ub", class = class, ...) if (nzchar(lb) || nzchar(ub)) { stop2("Cannot add bounds to class '", class, "' for this prior.") } return(invisible(NULL)) } # lprior plus equal lpp <- function(wsp = 2, tag = NULL) { wsp <- collapse(rep(" ", wsp)) if (is.null(tag)) { paste0(wsp, "lprior", " += ") } else { paste0(wsp, "lprior_", tag, " += ") } } brms/R/loo_predict.R0000644000176200001440000002622715057502525014063 0ustar liggesusers#' Compute Weighted Expectations Using LOO #' #' These functions are wrappers around the \code{\link[loo]{E_loo}} #' function of the \pkg{loo} package. #' #' @aliases loo_predict loo_epred loo_linpred loo_predictive_interval #' #' @param object An object of class \code{brmsfit}. #' @param type The statistic to be computed on the results. #' Can by either \code{"mean"} (default), \code{"var"}, or #' \code{"quantile"}. #' @param probs A vector of quantiles to compute. #' Only used if \code{type = quantile}. #' @param prob For \code{loo_predictive_interval}, a scalar in \eqn{(0,1)} #' indicating the desired probability mass to include in the intervals. The #' default is \code{prob = 0.9} (\eqn{90}\% intervals). #' @param psis_object An optional object returned by \code{\link[loo]{psis}}. #' If \code{psis_object} is missing then \code{\link[loo]{psis}} is executed #' internally, which may be time consuming for models fit to very large datasets. #' @param ... Optional arguments passed to the underlying methods that is #' \code{\link[brms:log_lik.brmsfit]{log_lik}}, as well as #' \code{\link[brms:posterior_predict.brmsfit]{posterior_predict}}, #' \code{\link[brms:posterior_epred.brmsfit]{posterior_epred}} or #' \code{\link[brms:posterior_linpred.brmsfit]{posterior_linpred}}. #' @inheritParams posterior_predict.brmsfit #' #' @return \code{loo_predict}, \code{loo_epred}, \code{loo_linpred}, and #' \code{loo_predictive_interval} all return a matrix with one row per #' observation and one column per summary statistic as specified by #' arguments \code{type} and \code{probs}. In multivariate or categorical models #' a third dimension is added to represent the response variables or categories, #' respectively. #' #' \code{loo_predictive_interval(..., prob = p)} is equivalent to #' \code{loo_predict(..., type = "quantile", probs = c(a, 1-a))} with #' \code{a = (1 - p)/2}. #' #' @examples #' \dontrun{ #' ## data from help("lm") #' ctl <- c(4.17,5.58,5.18,6.11,4.50,4.61,5.17,4.53,5.33,5.14) #' trt <- c(4.81,4.17,4.41,3.59,5.87,3.83,6.03,4.89,4.32,4.69) #' d <- data.frame( #' weight = c(ctl, trt), #' group = gl(2, 10, 20, labels = c("Ctl", "Trt")) #' ) #' fit <- brm(weight ~ group, data = d) #' loo_predictive_interval(fit, prob = 0.8) #' #' ## optionally log-weights can be pre-computed and reused #' psis <- loo::psis(-log_lik(fit), cores = 2) #' loo_predictive_interval(fit, prob = 0.8, psis_object = psis) #' loo_predict(fit, type = "var", psis_object = psis) #' loo_epred(fit, type = "var", psis_object = psis) #' } #' #' @method loo_predict brmsfit #' @importFrom rstantools loo_predict #' @export loo_predict #' @export loo_predict.brmsfit <- function(object, type = c("mean", "var", "quantile"), probs = 0.5, psis_object = NULL, resp = NULL, ...) { type <- match.arg(type) if (is.null(psis_object)) { message("Running PSIS to compute weights") # run loo instead of psis to allow for moment matching loo_object <- loo(object, resp = resp, save_psis = TRUE, ...) psis_object <- loo_object$psis_object } preds <- posterior_predict(object, resp = resp, ...) E_loo_value(preds, psis_object, type = type, probs = probs) } # #' @importFrom rstantools loo_epred #' @rdname loo_predict.brmsfit #' @method loo_epred brmsfit #' @export loo_epred #' @export loo_epred.brmsfit <- function(object, type = c("mean", "var", "quantile"), probs = 0.5, psis_object = NULL, resp = NULL, ...) { type <- match.arg(type) if (is.null(psis_object)) { message("Running PSIS to compute weights") # run loo instead of psis to allow for moment matching loo_object <- loo(object, resp = resp, save_psis = TRUE, ...) psis_object <- loo_object$psis_object } preds <- posterior_epred(object, resp = resp, ...) E_loo_value(preds, psis_object, type = type, probs = probs) } #' @rdname loo_predict.brmsfit #' @export loo_epred <- function(object, ...) { # TODO: remove this generic once it is available in rstantools UseMethod("loo_epred") } #' @rdname loo_predict.brmsfit #' @method loo_linpred brmsfit #' @importFrom rstantools loo_linpred #' @export loo_linpred #' @export loo_linpred.brmsfit <- function(object, type = c("mean", "var", "quantile"), probs = 0.5, psis_object = NULL, resp = NULL, ...) { type <- match.arg(type) if (is.null(psis_object)) { message("Running PSIS to compute weights") # run loo instead of psis to allow for moment matching loo_object <- loo(object, resp = resp, save_psis = TRUE, ...) psis_object <- loo_object$psis_object } preds <- posterior_linpred(object, resp = resp, ...) E_loo_value(preds, psis_object, type = type, probs = probs) } #' @rdname loo_predict.brmsfit #' @method loo_predictive_interval brmsfit #' @importFrom rstantools loo_predictive_interval #' @export loo_predictive_interval #' @export loo_predictive_interval.brmsfit <- function(object, prob = 0.9, psis_object = NULL, ...) { if (length(prob) != 1L) { stop2("Argument 'prob' should be of length 1.") } alpha <- (1 - prob) / 2 probs <- c(alpha, 1 - alpha) intervals <- loo_predict( object, type = "quantile", probs = probs, psis_object = psis_object, ... ) intervals } # convenient wrapper around loo::E_loo E_loo_value <- function(x, psis_object, type = "mean", probs = 0.5) { .E_loo_value <- function(x) { y <- loo::E_loo(x, psis_object, type = type, probs = probs)$value # loo::E_loo has output dimensions inconsistent with brms conventions # ensure that observations are stored as rows and summaries as columns if (is.matrix(y) && ncol(x) == ncol(y)) { y <- t(y) } else if (is.vector(y)) { # create a matrix with one column representing the summary statistic y <- matrix(y) } # ensure names consistent with the posterior package labs <- type if (labs == "quantile") { labs <- paste0("q", probs * 100) } colnames(y) <- labs return(y) } if (length(dim(x)) == 3) { out <- apply(x, 3, .E_loo_value, simplify = FALSE) out <- abind::abind(out, rev.along = 0) } else { out <- .E_loo_value(x) } out } #' Compute a LOO-adjusted R-squared for regression models #' #' @aliases loo_R2 #' #' @inheritParams bayes_R2.brmsfit #' @param seed Optional integer used to initialize the random number #' generator. #' @param args_epred A named list of further arguments passed only to #' \code{\link[brms:posterior_epred.brmsfit]{posterior_epred}}. #' @param args_loglik A named list of further arguments passed only to #' \code{\link[brms:log_lik.brmsfit]{log_lik}}. #' @param ... Further arguments passed to both #' \code{\link[brms:posterior_epred.brmsfit]{posterior_epred}} and #' \code{\link[brms:log_lik.brmsfit]{log_lik}}. #' #' @return If \code{summary = TRUE}, an M x C matrix is returned #' (M = number of response variables and c = \code{length(probs) + 2}) #' containing Bayesian bootstrap based summary statistics of the #' LOO-adjusted R-squared values. If \code{summary = FALSE}, the #' Bayesian bootstrap draws of the LOO-adjusted R-squared values #' are returned in an S x M matrix (S is the number of draws). #' #' @details LOO-R2 uses LOO residuals and is defined as #' \eqn{1-Var_{loo-res} / Var_y}, #' with #' \deqn{ #' Var_y = V_{n=1}^N y_n, and #' Var_{loo-res} = V_{n=1}^N \hat{e}_{loo,n}, #' } #' where \eqn{\hat{e}_{loo,n}=y_n-\hat{y}_{loo,n}}. #' Bayesian bootstrap is used to draw from the approximated uncertainty #' distribution as described by Vehtari and Lampinen (2002). #' #' @references Vehtari and Lampinen (2002). Bayesian model assessment #' and comparison using cross-validation predictive densities. Neural #' Computation, 14(10):2439-2468. #' #' @examples #' \dontrun{ #' fit <- brm(mpg ~ wt + cyl, data = mtcars) #' summary(fit) #' loo_R2(fit) #' #' # compute R2 with new data #' nd <- data.frame(mpg = c(10, 20, 30), wt = c(4, 3, 2), cyl = c(8, 6, 4)) #' loo_R2(fit, newdata = nd) #' } #' #' @method loo_R2 brmsfit #' @importFrom rstantools loo_R2 #' @export loo_R2 #' @export loo_R2.brmsfit <- function(object, resp = NULL, summary = TRUE, robust = FALSE, probs = c(0.025, 0.975), seed = NULL, args_epred = list(), args_loglik = list(), ...) { contains_draws(object) object <- restructure(object) resp <- validate_resp(resp, object) summary <- as_one_logical(summary) stopifnot(is.list(args_epred), is.list(args_loglik)) # check for precomputed values R2 <- get_criterion(object, "loo_R2") if (is.matrix(R2)) { # assumes unsummarized 'loo_R2' as ensured by 'add_criterion' take <- colnames(R2) %in% paste0("R2", resp) R2 <- R2[, take, drop = FALSE] if (summary) { R2 <- posterior_summary(R2, probs = probs, robust = robust) } return(R2) } family <- family(object, resp = resp) if (conv_cats_dpars(family)) { stop2("'loo_R2' is not defined for unordered categorical models.") } if (is_ordinal(family)) { warning2( "Predictions are treated as continuous variables in ", "'loo_R2' which is likely invalid for ordinal families." ) } # set the random seed if required if (!is.null(seed)) { if (exists(".Random.seed", envir = .GlobalEnv)) { rng_state_old <- get(".Random.seed", envir = .GlobalEnv) on.exit(assign(".Random.seed", rng_state_old, envir = .GlobalEnv)) } set.seed(seed) } args_y <- list(object, warn = TRUE, ...) args_ypred <- list(object, sort = TRUE, ...) R2 <- named_list(paste0("R2", resp)) for (i in seq_along(R2)) { # assumes expectations of different responses to be independent args_ypred$resp <- args_y$resp <- resp[i] y <- do_call(get_y, args_y) ypred <- do_call(posterior_epred, c(args_ypred, args_epred)) ll <- do_call(log_lik, c(args_ypred, args_loglik)) r_eff <- r_eff_log_lik(ll, object) if (is_ordinal(family(object, resp = resp[i]))) { ypred <- ordinal_probs_continuous(ypred) } R2[[i]] <- .loo_R2(y, ypred, ll, r_eff) } R2 <- do_call(cbind, R2) colnames(R2) <- paste0("R2", resp) if (summary) { R2 <- posterior_summary(R2, probs = probs, robust = robust) } R2 } # internal function of loo_R2.brmsfit # see http://discourse.mc-stan.org/t/stan-summary-r2-or-adjusted-r2/4308/4 # and https://github.com/stan-dev/rstanarm/blob/master/R/bayes_R2.R .loo_R2 <- function(y, ypred, ll, r_eff) { psis_object <- loo::psis(log_ratios = -ll, r_eff = r_eff) ypredloo <- loo::E_loo(ypred, psis_object, log_ratios = -ll)$value err_loo <- ypredloo - y # simulated Dirichlet weights S <- nrow(ypred) N <- ncol(ypred) exp_draws <- matrix(rexp(S * N, rate = 1), nrow = S, ncol = N) weights <- exp_draws / rowSums(exp_draws) var_y <- (N / (N - 1)) * (rowSums(sweep(weights, 2, y^2, FUN = "*")) - rowSums(sweep(weights, 2, y, FUN = "*"))^2) var_err_loo <- (N / (N - 1)) * (rowSums(sweep(weights, 2, err_loo^2, FUN = "*")) - rowSums(sweep(weights, 2, err_loo, FUN = "*"))^2) out <- unname(1 - var_err_loo / var_y) out[out < -1] <- -1 out[out > 1] <- 1 as.matrix(out) } brms/R/lsp.R0000644000176200001440000000364214527413457012360 0ustar liggesusers# find all namespace entries of a package, which are of # a particular type for instance all exported objects # retrieved from https://github.com/raredd/rawr # @param package the package name # @param what type of the objects to retrieve ("all" for all objects) # @param pattern regex that must be matches by the object names # @return a character vector of object names lsp <- function(package, what = "all", pattern = ".*") { if (!is.character(substitute(package))) package <- deparse0(substitute(package)) ns <- asNamespace(package) ## base package does not have NAMESPACE if (isBaseNamespace(ns)) { res <- ls(.BaseNamespaceEnv, all.names = TRUE) return(res[grep(pattern, res, perl = TRUE, ignore.case = TRUE)]) } else { ## for non base packages if (exists('.__NAMESPACE__.', envir = ns, inherits = FALSE)) { wh <- get('.__NAMESPACE__.', inherits = FALSE, envir = asNamespace(package, base.OK = FALSE)) what <- if (missing(what)) 'all' else if ('?' %in% what) return(ls(wh)) else ls(wh)[pmatch(what[1], ls(wh))] if (!is.null(what) && !any(what %in% c('all', ls(wh)))) stop('\'what\' should be one of ', paste0(shQuote(ls(wh)), collapse = ', '), ', or \'all\'', domain = NA) res <- sapply(ls(wh), function(x) getNamespaceInfo(ns, x)) res <- rapply(res, ls, classes = 'environment', how = 'replace', all.names = TRUE) if (is.null(what)) return(res[grep(pattern, res, perl = TRUE, ignore.case = TRUE)]) if (what %in% 'all') { res <- ls(getNamespace(package), all.names = TRUE) return(res[grep(pattern, res, perl = TRUE, ignore.case = TRUE)]) } if (any(what %in% ls(wh))) { res <- res[[what]] return(res[grep(pattern, res, perl = TRUE, ignore.case = TRUE)]) } } else stop(sprintf('no NAMESPACE file found for package %s', package)) } } brms/R/families.R0000644000176200001440000017712115053072461013346 0ustar liggesusers#' Special Family Functions for \pkg{brms} Models #' #' Family objects provide a convenient way to specify the details of the models #' used by many model fitting functions. The family functions presented here are #' for use with \pkg{brms} only and will **not** work with other model #' fitting functions such as \code{glm} or \code{glmer}. #' However, the standard family functions as described in #' \code{\link[stats:family]{family}} will work with \pkg{brms}. #' You can also specify custom families for use in \pkg{brms} with #' the \code{\link{custom_family}} function. #' #' @param family A character string naming the distribution family of the response #' variable to be used in the model. Currently, the following families are #' supported: \code{gaussian}, \code{student}, \code{binomial}, #' \code{bernoulli}, \code{beta-binomial}, \code{poisson}, \code{negbinomial}, #' \code{geometric}, \code{Gamma}, \code{skew_normal}, \code{lognormal}, #' \code{shifted_lognormal}, \code{exgaussian}, \code{wiener}, #' \code{inverse.gaussian}, \code{exponential}, \code{weibull}, #' \code{frechet}, \code{Beta}, \code{dirichlet}, \code{von_mises}, #' \code{asym_laplace}, \code{gen_extreme_value}, \code{categorical}, #' \code{multinomial}, \code{dirichlet_multinomial}, \code{cumulative}, \code{cratio}, \code{sratio}, #' \code{acat}, \code{hurdle_poisson}, \code{hurdle_negbinomial}, #' \code{hurdle_gamma}, \code{hurdle_lognormal}, \code{hurdle_cumulative}, #' \code{zero_inflated_binomial}, \code{zero_inflated_beta_binomial}, #' \code{zero_inflated_beta}, \code{zero_inflated_negbinomial}, #' \code{zero_inflated_poisson}, \code{zero_one_inflated_beta}, and \code{xbeta}. #' @param link A specification for the model link function. This can be a #' name/expression or character string. See the 'Details' section for more #' information on link functions supported by each family. #' @param link_sigma Link of auxiliary parameter \code{sigma} if being predicted. #' @param link_shape Link of auxiliary parameter \code{shape} if being predicted. #' @param link_nu Link of auxiliary parameter \code{nu} if being predicted. #' @param link_phi Link of auxiliary parameter \code{phi} if being predicted. #' @param link_kappa Link of auxiliary parameter \code{kappa} if being predicted. #' @param link_beta Link of auxiliary parameter \code{beta} if being predicted. #' @param link_zi Link of auxiliary parameter \code{zi} if being predicted. #' @param link_hu Link of auxiliary parameter \code{hu} if being predicted. #' @param link_zoi Link of auxiliary parameter \code{zoi} if being predicted. #' @param link_coi Link of auxiliary parameter \code{coi} if being predicted. #' @param link_disc Link of auxiliary parameter \code{disc} if being predicted. #' @param link_bs Link of auxiliary parameter \code{bs} if being predicted. #' @param link_ndt Link of auxiliary parameter \code{ndt} if being predicted. #' @param link_bias Link of auxiliary parameter \code{bias} if being predicted. #' @param link_alpha Link of auxiliary parameter \code{alpha} if being predicted. #' @param link_quantile Link of auxiliary parameter \code{quantile} if being predicted. #' @param link_xi Link of auxiliary parameter \code{xi} if being predicted. #' @param threshold A character string indicating the type #' of thresholds (i.e. intercepts) used in an ordinal model. #' \code{"flexible"} provides the standard unstructured thresholds, #' \code{"equidistant"} restricts the distance between #' consecutive thresholds to the same value, and #' \code{"sum_to_zero"} ensures the thresholds sum to zero. #' @param refcat Optional name of the reference response category used in #' \code{categorical}, \code{multinomial}, \code{dirichlet}, #' \code{dirichlet_multinomial} and \code{logistic_normal} models. #' If \code{NULL} (the default), the first #' category is used as the reference. If \code{NA}, all categories will be #' predicted, which requires strong priors or carefully specified predictor #' terms in order to lead to an identified model. #' #' @details #' Below, we list common use cases for the different families. #' This list is not ment to be exhaustive. #' \itemize{ #' \item{Family \code{gaussian} can be used for linear regression.} #' #' \item{Family \code{student} can be used for robust linear regression #' that is less influenced by outliers.} #' #' \item{Family \code{skew_normal} can handle skewed responses in linear #' regression.} #' #' \item{Families \code{poisson}, \code{negbinomial}, and \code{geometric} #' can be used for regression of unbounded count data.} #' #' \item{Families \code{bernoulli}, \code{binomial}, and \code{beta_binomial} #' can be used for binary regression (i.e., most commonly logistic #' regression).} #' #' \item{Families \code{categorical}, \code{multinomial} and #' \code{dirichlet_multinomial} can be used for multi-logistic regression #' when there are more than two possible outcomes.} #' #' \item{Families \code{cumulative}, \code{cratio} ('continuation ratio'), #' \code{sratio} ('stopping ratio'), and \code{acat} ('adjacent category') #' leads to ordinal regression.} #' #' \item{Families \code{Gamma}, \code{weibull}, \code{exponential}, #' \code{lognormal}, \code{frechet}, \code{inverse.gaussian}, and \code{cox} #' (Cox proportional hazards model) can be used (among others) for #' time-to-event regression also known as survival regression.} #' #' \item{Families \code{weibull}, \code{frechet}, and \code{gen_extreme_value} #' ('generalized extreme value') allow for modeling extremes.} #' #' \item{Families \code{beta}, \code{dirichlet}, and \code{logistic_normal} #' can be used to model responses representing rates or probabilities.} #' #' \item{Family \code{xbeta} extends the \code{beta} family to #' support \code{[0, 1]} responses with exact \code{0}s and / or #' \code{1}s, when each response takes values \code{0}, \code{1}, #' and \code{(0, 1)} according to a single process. If there is #' merit in assuming that 0 and 1 values arise from different #' processes than \code{(0, 1)} values, then the #' \code{zero_inflated_beta}, \code{zero_one_inflated_beta} families #' provide more flexibility. For details see Kosmidis & Zeileis #' (2024).} #' #' \item{Family \code{asym_laplace} allows for quantile regression when fixing #' the auxiliary \code{quantile} parameter to the quantile of interest.} #' #' \item{Family \code{exgaussian} ('exponentially modified Gaussian') and #' \code{shifted_lognormal} are especially suited to model reaction times.} #' #' \item{Family \code{wiener} provides an implementation of the Wiener #' diffusion model. For this family, the main formula predicts the drift #' parameter 'delta' and all other parameters are modeled as auxiliary parameters #' (see \code{\link{brmsformula}} for details).} #' #' \item{Families \code{hurdle_poisson}, \code{hurdle_negbinomial}, #' \code{hurdle_gamma}, \code{hurdle_lognormal}, \code{zero_inflated_poisson}, #' \code{zero_inflated_negbinomial}, \code{zero_inflated_binomial}, #' \code{zero_inflated_beta_binomial}, \code{zero_inflated_beta}, #' \code{zero_one_inflated_beta}, and \code{hurdle_cumulative} allow to estimate #' zero-inflated and hurdle models. These models can be very helpful when there #' are many zeros in the data (or ones in case of one-inflated models) #' that cannot be explained by the primary distribution of the response.} #' } #' #' Below, we list all possible links for each family. The first #' link mentioned for each family is the default. \itemize{ #' \item{Families \code{gaussian}, \code{student}, #' \code{skew_normal}, \code{exgaussian}, \code{asym_laplace}, and #' \code{gen_extreme_value} support the links (as names) #' \code{identity}, \code{log}, \code{inverse}, and #' \code{softplus}.} #' #' \item{Families \code{poisson}, \code{negbinomial}, \code{geometric}, #' \code{zero_inflated_poisson}, \code{zero_inflated_negbinomial}, #' \code{hurdle_poisson}, and \code{hurdle_negbinomial} support #' \code{log}, \code{identity}, \code{sqrt}, and \code{softplus}.} #' #' \item{Families \code{binomial}, \code{bernoulli}, #' \code{beta_binomial}, \code{zero_inflated_binomial}, #' \code{zero_inflated_beta_binomial}, \code{Beta}, #' \code{zero_inflated_beta}, \code{zero_one_inflated_beta}, and #' \code{xbeta} support \code{logit}, \code{probit}, #' \code{probit_approx}, \code{cloglog}, \code{cauchit}, #' \code{identity}, and \code{log}.} #' #' \item{Families \code{cumulative}, \code{cratio}, \code{sratio}, #' \code{acat}, and \code{hurdle_cumulative} support \code{logit}, #' \code{probit}, \code{probit_approx}, \code{cloglog}, and \code{cauchit}.} #' #' \item{Families \code{categorical}, \code{multinomial}, #' \code{dirichlet_multinomial} and \code{dirichlet} support \code{logit}.} #' #' \item{Families \code{Gamma}, \code{weibull}, \code{exponential}, #' \code{frechet}, and \code{hurdle_gamma} support #' \code{log}, \code{identity}, \code{inverse}, and \code{softplus}.} #' #' \item{Families \code{lognormal} and \code{hurdle_lognormal} #' support \code{identity} and \code{inverse}.} #' #' \item{Family \code{logistic_normal} supports \code{identity}.} #' #' \item{Family \code{inverse.gaussian} supports \code{1/mu^2}, #' \code{inverse}, \code{identity}, \code{log}, and \code{softplus}.} #' #' \item{Family \code{von_mises} supports \code{tan_half} and #' \code{identity}.} #' #' \item{Family \code{cox} supports \code{log}, \code{identity}, #' and \code{softplus} for the proportional hazards parameter.} #' #' \item{Family \code{wiener} supports \code{identity}, \code{log}, #' and \code{softplus} for the main parameter which represents the #' drift rate.} #' } #' #' Please note that when calling the \code{\link[stats:family]{Gamma}} family #' function of the \pkg{stats} package, the default link will be #' \code{inverse} instead of \code{log} although the latter is the default in #' \pkg{brms}. Also, when using the family functions \code{gaussian}, #' \code{binomial}, \code{poisson}, and \code{Gamma} of the \pkg{stats} #' package (see \code{\link[stats:family]{family}}), special link functions #' such as \code{softplus} or \code{cauchit} won't work. In this case, you #' have to use \code{brmsfamily} to specify the family with corresponding link #' function. #' #' @references #' #' Kosmidis I, Zeileis A (2024). Extended-Support Beta Regression for [0, 1] Responses. #' \emph{arXiv Preprint}. \doi{10.48550/arXiv.2409.07233} #' #' @seealso #' \code{\link[brms:brm]{brm}}, #' \code{\link[stats:family]{family}}, #' \code{\link{customfamily}} #' #' @examples #' # create a family object #' (fam1 <- student("log")) #' # alternatively use the brmsfamily function #' (fam2 <- brmsfamily("student", "log")) #' # both leads to the same object #' identical(fam1, fam2) #' #' @export brmsfamily <- function(family, link = NULL, link_sigma = "log", link_shape = "log", link_nu = "logm1", link_phi = "log", link_kappa = "log", link_beta = "log", link_zi = "logit", link_hu = "logit", link_zoi = "logit", link_coi = "logit", link_disc = "log", link_bs = "log", link_ndt = "log", link_bias = "logit", link_xi = "log1p", link_alpha = "identity", link_quantile = "logit", threshold = "flexible", refcat = NULL) { slink <- substitute(link) .brmsfamily( family, link = link, slink = slink, link_sigma = link_sigma, link_shape = link_shape, link_nu = link_nu, link_phi = link_phi, link_kappa = link_kappa, link_beta = link_beta, link_zi = link_zi, link_hu = link_hu, link_zoi = link_zoi, link_coi = link_coi, link_disc = link_disc, link_bs = link_bs, link_ndt = link_ndt, link_bias = link_bias, link_alpha = link_alpha, link_xi = link_xi, link_quantile = link_quantile, threshold = threshold, refcat = refcat ) } # helper function to prepare brmsfamily objects # @param family character string naming the model family # @param link character string naming the link function # @param slink can be used with substitute(link) for # non-standard evaluation of the link function # @param threshold threshold type for ordinal models # @param ... link functions (as character strings) of parameters # @return an object of 'brmsfamily' which inherits from 'family' .brmsfamily <- function(family, link = NULL, slink = link, threshold = "flexible", refcat = NULL, ...) { family <- tolower(as_one_character(family)) aux_links <- list(...) pattern <- c("^normal$", "^zi_", "^hu_") replacement <- c("gaussian", "zero_inflated_", "hurdle_") family <- rename(family, pattern, replacement, fixed = FALSE) ok_families <- lsp("brms", pattern = "^\\.family_") ok_families <- sub("^\\.family_", "", ok_families) if (!family %in% ok_families) { stop2(family, " is not a supported family. Supported ", "families are:\n", collapse_comma(ok_families)) } family_info <- get(paste0(".family_", family))() ok_links <- family_info$links family_info$links <- NULL # non-standard evaluation of link if (!is.character(slink)) { slink <- deparse0(slink) } if (!slink %in% ok_links) { if (is.character(link)) { slink <- link } else if (!length(link) || identical(link, NA)) { slink <- NA } } if (length(slink) != 1L) { stop2("Argument 'link' must be of length 1.") } if (is.na(slink)) { slink <- ok_links[1] } if (!slink %in% ok_links) { stop2("'", slink, "' is not a supported link ", "for family '", family, "'.\nSupported links are: ", collapse_comma(ok_links)) } out <- list( family = family, link = slink, linkfun = function(mu) link(mu, link = slink), linkinv = function(eta) inv_link(eta, link = slink) ) out[names(family_info)] <- family_info class(out) <- c("brmsfamily", "family") all_valid_dpars <- c(valid_dpars(out), valid_dpars(out, type = "multi")) for (dp in all_valid_dpars) { alink <- as.character(aux_links[[paste0("link_", dp)]]) if (length(alink)) { alink <- as_one_character(alink) valid_links <- links_dpars(dp) if (!alink %in% valid_links) { stop2( "'", alink, "' is not a supported link ", "for parameter '", dp, "'.\nSupported links are: ", collapse_comma(valid_links) ) } out[[paste0("link_", dp)]] <- alink } } if (is_ordinal(out$family)) { # TODO: move specification of 'threshold' to the 'resp_thres' function? thres_options <- c("flexible", "equidistant", "sum_to_zero") out$threshold <- match.arg(threshold, thres_options) } if (conv_cats_dpars(out$family)) { if (!has_joint_link(out$family)) { out$refcat <- NA } else if (!is.null(refcat)) { allow_na_ref <- !is_logistic_normal(out$family) out$refcat <- as_one_character(refcat, allow_na = allow_na_ref) } } out } # checks and corrects validity of the model family # @param family Either a function, an object of class 'family' # or a character string of length one or two # @param link an optional character string naming the link function # ignored if family is a function or a family object # @param threshold optional character string specifying the threshold # type in ordinal models validate_family <- function(family, link = NULL, threshold = NULL) { if (is.function(family)) { family <- family() } if (!is(family, "brmsfamily")) { if (is.family(family)) { link <- family$link family <- family$family } if (is.character(family)) { if (is.null(link)) { link <- family[2] } family <- .brmsfamily(family[1], link = link) } else { stop2("Argument 'family' is invalid.") } } if (is_ordinal(family) && !is.null(threshold)) { # slot 'threshold' deprecated as of brms > 1.7.0 threshold <- match.arg(threshold, c("flexible", "equidistant")) family$threshold <- threshold } family } # extract special information of families # @param x object from which to extract # @param y name of the component to extract family_info <- function(x, y, ...) { UseMethod("family_info") } #' @export family_info.default <- function(x, y, ...) { x <- as.character(x) ulapply(x, .family_info, y = y, ...) } .family_info <- function(x, y, ...) { x <- as_one_character(x) y <- as_one_character(y) if (y == "family") { return(x) } if (!nzchar(x)) { return(NULL) } info <- get(paste0(".family_", x))() if (y == "link") { out <- info$links[1] # default link } else { info$links <- NULL out <- info[[y]] } out } #' @export family_info.NULL <- function(x, y, ...) { NULL } #' @export family_info.list <- function(x, y, ...) { ulapply(x, family_info, y = y, ...) } #' @export family_info.family <- function(x, y, ...) { family_info(x$family, y = y, ...) } #' @export family_info.brmsfamily <- function(x, y, ...) { y <- as_one_character(y) out <- x[[y]] if (is.null(out)) { # required for models fitted with brms 2.2 or earlier out <- family_info(x$family, y = y, ...) } out } #' @export family_info.mixfamily <- function(x, y, ...) { out <- lapply(x$mix, family_info, y = y, ...) combine_family_info(out, y = y) } #' @export family_info.brmsformula <- function(x, y, ...) { family_info(x$family, y = y, ...) } #' @export family_info.mvbrmsformula <- function(x, y, ...) { out <- lapply(x$forms, family_info, y = y, ...) combine_family_info(out, y = y) } #' @export family_info.brmsterms <- function(x, y, ...) { family_info(x$family, y = y, ...) } #' @export family_info.mvbrmsterms <- function(x, y, ...) { out <- lapply(x$terms, family_info, y = y, ...) combine_family_info(out, y = y) } #' @export family_info.btl <- function(x, y, ...) { family_info(x$family, y = y, ...) } #' @export family_info.btnl <- function(x, y, ...) { family_info(x$family, y = y, ...) } #' @export family_info.brmsfit <- function(x, y, ...) { family_info(x$formula, y = y, ...) } # combine information from multiple families # provides special handling for certain elements combine_family_info <- function(x, y, ...) { y <- as_one_character(y) unite <- c( "dpars", "type", "specials", "include", "const", "cats", "ad", "normalized", "mix" ) if (y %in% c("family", "link")) { x <- unlist(x) } else if (y %in% unite) { x <- Reduce("union", x) } else if (y == "ybounds") { x <- do_call(rbind, x) x <- c(max(x[, 1]), min(x[, 2])) } else if (y == "closed") { # closed only if no bounds are open x <- do_call(rbind, x) clb <- !any(ulapply(x[, 1], isFALSE)) cub <- !any(ulapply(x[, 2], isFALSE)) x <- c(clb, cub) } else if (y %in% c("thres", "bhaz")) { # same across mixture components x <- x[[1]] } x } #' @rdname brmsfamily #' @export student <- function(link = "identity", link_sigma = "log", link_nu = "logm1") { slink <- substitute(link) .brmsfamily("student", link = link, slink = slink, link_sigma = link_sigma, link_nu = link_nu) } #' @rdname brmsfamily #' @export bernoulli <- function(link = "logit") { slink <- substitute(link) .brmsfamily("bernoulli", link = link, slink = slink) } #' @rdname brmsfamily #' @export beta_binomial <- function(link = "logit", link_phi = "log") { slink <- substitute(link) .brmsfamily("beta_binomial", link = link, slink = slink, link_phi = link_phi) } #' @rdname brmsfamily #' @export negbinomial <- function(link = "log", link_shape = "log") { slink <- substitute(link) .brmsfamily("negbinomial", link = link, slink = slink, link_shape = link_shape) } # not yet officially supported # @rdname brmsfamily # @export negbinomial2 <- function(link = "log", link_sigma = "log") { slink <- substitute(link) .brmsfamily("negbinomial2", link = link, slink = slink, link_sigma = link_sigma) } #' @rdname brmsfamily #' @export geometric <- function(link = "log") { slink <- substitute(link) .brmsfamily("geometric", link = link, slink = slink) } # do not export yet! # @rdname brmsfamily # @export discrete_weibull <- function(link = "logit", link_shape = "log") { slink <- substitute(link) .brmsfamily("discrete_weibull", link = link, slink = slink, link_shape = link_shape) } # do not export yet! # @rdname brmsfamily # @export com_poisson <- function(link = "log", link_shape = "log") { slink <- substitute(link) .brmsfamily("com_poisson", link = link, slink = slink, link_shape = link_shape) } #' @rdname brmsfamily #' @export lognormal <- function(link = "identity", link_sigma = "log") { slink <- substitute(link) .brmsfamily("lognormal", link = link, slink = slink, link_sigma = link_sigma) } #' @rdname brmsfamily #' @export shifted_lognormal <- function(link = "identity", link_sigma = "log", link_ndt = "log") { slink <- substitute(link) .brmsfamily("shifted_lognormal", link = link, slink = slink, link_sigma = link_sigma, link_ndt = link_ndt) } #' @rdname brmsfamily #' @export skew_normal <- function(link = "identity", link_sigma = "log", link_alpha = "identity") { slink <- substitute(link) .brmsfamily("skew_normal", link = link, slink = slink, link_sigma = link_sigma, link_alpha = link_alpha) } #' @rdname brmsfamily #' @export exponential <- function(link = "log") { slink <- substitute(link) .brmsfamily("exponential", link = link, slink = slink) } #' @rdname brmsfamily #' @export weibull <- function(link = "log", link_shape = "log") { slink <- substitute(link) .brmsfamily("weibull", link = link, slink = slink, link_shape = link_shape) } #' @rdname brmsfamily #' @export frechet <- function(link = "log", link_nu = "logm1") { slink <- substitute(link) .brmsfamily("frechet", link = link, slink = slink, link_nu = link_nu) } #' @rdname brmsfamily #' @export gen_extreme_value <- function(link = "identity", link_sigma = "log", link_xi = "log1p") { slink <- substitute(link) .brmsfamily("gen_extreme_value", link = link, slink = slink, link_sigma = link_sigma, link_xi = link_xi) } #' @rdname brmsfamily #' @export exgaussian <- function(link = "identity", link_sigma = "log", link_beta = "log") { slink <- substitute(link) .brmsfamily("exgaussian", link = link, slink = slink, link_sigma = link_sigma, link_beta = link_beta) } #' @rdname brmsfamily #' @export wiener <- function(link = "identity", link_bs = "log", link_ndt = "log", link_bias = "logit") { slink <- substitute(link) .brmsfamily("wiener", link = link, slink = slink, link_bs = link_bs, link_ndt = link_ndt, link_bias = link_bias) } #' @rdname brmsfamily #' @export Beta <- function(link = "logit", link_phi = "log") { slink <- substitute(link) .brmsfamily("beta", link = link, slink = slink, link_phi = link_phi) } #' @rdname brmsfamily #' @export xbeta <- function(link = "logit", link_phi = "log", link_kappa = "log") { slink <- substitute(link) .brmsfamily("xbeta", link = link, slink = slink, link_phi = link_phi, link_kappa = link_kappa) } #' @rdname brmsfamily #' @export dirichlet <- function(link = "logit", link_phi = "log", refcat = NULL) { slink <- substitute(link) .brmsfamily("dirichlet", link = link, slink = slink, link_phi = link_phi, refcat = refcat) } # not yet exported # @rdname brmsfamily # @export dirichlet2 <- function(link = "log") { slink <- substitute(link) .brmsfamily("dirichlet2", link = link, slink = slink, refcat = NA) } #' @rdname brmsfamily #' @export logistic_normal <- function(link = "identity", link_sigma = "log", refcat = NULL) { slink <- substitute(link) .brmsfamily("logistic_normal", link = link, slink = slink, link_sigma = link_sigma, refcat = refcat) } #' @rdname brmsfamily #' @export von_mises <- function(link = "tan_half", link_kappa = "log") { slink <- substitute(link) .brmsfamily("von_mises", link = link, slink = slink, link_kappa = link_kappa) } #' @rdname brmsfamily #' @export asym_laplace <- function(link = "identity", link_sigma = "log", link_quantile = "logit") { slink <- substitute(link) .brmsfamily("asym_laplace", link = link, slink = slink, link_sigma = link_sigma, link_quantile = link_quantile) } # do not export yet! # @rdname brmsfamily # @export zero_inflated_asym_laplace <- function(link = "identity", link_sigma = "log", link_quantile = "logit", link_zi = "logit") { slink <- substitute(link) .brmsfamily("zero_inflated_asym_laplace", link = link, slink = slink, link_sigma = link_sigma, link_quantile = link_quantile, link_zi = link_zi) } #' @rdname brmsfamily #' @export cox <- function(link = "log") { slink <- substitute(link) .brmsfamily("cox", link = link) } #' @rdname brmsfamily #' @export hurdle_poisson <- function(link = "log", link_hu = "logit") { slink <- substitute(link) .brmsfamily("hurdle_poisson", link = link, slink = slink, link_hu = link_hu) } #' @rdname brmsfamily #' @export hurdle_negbinomial <- function(link = "log", link_shape = "log", link_hu = "logit") { slink <- substitute(link) .brmsfamily("hurdle_negbinomial", link = link, slink = slink, link_shape = link_shape, link_hu = link_hu) } #' @rdname brmsfamily #' @export hurdle_gamma <- function(link = "log", link_shape = "log", link_hu = "logit") { slink <- substitute(link) .brmsfamily("hurdle_gamma", link = link, slink = slink, link_shape = link_shape, link_hu = link_hu) } #' @rdname brmsfamily #' @export hurdle_lognormal <- function(link = "identity", link_sigma = "log", link_hu = "logit") { slink <- substitute(link) .brmsfamily("hurdle_lognormal", link = link, slink = slink, link_sigma = link_sigma, link_hu = link_hu) } #' @rdname brmsfamily #' @export hurdle_cumulative <- function(link = "logit", link_hu = "logit", link_disc = "log", threshold = "flexible") { slink <- substitute(link) .brmsfamily("hurdle_cumulative", link = link, slink = slink, link_hu = link_hu, link_disc = link_disc, threshold = threshold) } #' @rdname brmsfamily #' @export zero_inflated_beta <- function(link = "logit", link_phi = "log", link_zi = "logit") { slink <- substitute(link) .brmsfamily("zero_inflated_beta", link = link, slink = slink, link_phi = link_phi, link_zi = link_zi) } #' @rdname brmsfamily #' @export zero_one_inflated_beta <- function(link = "logit", link_phi = "log", link_zoi = "logit", link_coi = "logit") { slink <- substitute(link) .brmsfamily("zero_one_inflated_beta", link = link, slink = slink, link_phi = link_phi, link_zoi = link_zoi, link_coi = link_coi) } #' @rdname brmsfamily #' @export zero_inflated_poisson <- function(link = "log", link_zi = "logit") { slink <- substitute(link) .brmsfamily("zero_inflated_poisson", link = link, slink = slink, link_zi = link_zi) } #' @rdname brmsfamily #' @export zero_inflated_negbinomial <- function(link = "log", link_shape = "log", link_zi = "logit") { slink <- substitute(link) .brmsfamily("zero_inflated_negbinomial", link = link, slink = slink, link_shape = link_shape, link_zi = link_zi) } #' @rdname brmsfamily #' @export zero_inflated_binomial <- function(link = "logit", link_zi = "logit") { slink <- substitute(link) .brmsfamily("zero_inflated_binomial", link = link, slink = slink, link_zi = link_zi) } #' @rdname brmsfamily #' @export zero_inflated_beta_binomial <- function(link = "logit", link_phi = "log", link_zi = "logit") { slink <- substitute(link) .brmsfamily("zero_inflated_beta_binomial", link = link, slink = slink, link_phi = link_phi, link_zi = link_zi) } #' @rdname brmsfamily #' @export categorical <- function(link = "logit", refcat = NULL) { slink <- substitute(link) .brmsfamily("categorical", link = link, slink = slink, refcat = refcat) } #' @rdname brmsfamily #' @export multinomial <- function(link = "logit", refcat = NULL) { slink <- substitute(link) .brmsfamily("multinomial", link = link, slink = slink, refcat = refcat) } #' @rdname brmsfamily #' @export dirichlet_multinomial <- function(link = "logit", link_phi = "log", refcat = NULL) { slink <- substitute(link) .brmsfamily("dirichlet_multinomial", link = link, slink = slink, link_phi = link_phi, refcat = refcat) } #' @rdname brmsfamily #' @export cumulative <- function(link = "logit", link_disc = "log", threshold = "flexible") { slink <- substitute(link) .brmsfamily("cumulative", link = link, slink = slink, link_disc = link_disc, threshold = threshold) } #' @rdname brmsfamily #' @export sratio <- function(link = "logit", link_disc = "log", threshold = "flexible") { slink <- substitute(link) .brmsfamily("sratio", link = link, slink = slink, link_disc = link_disc, threshold = threshold) } #' @rdname brmsfamily #' @export cratio <- function(link = "logit", link_disc = "log", threshold = "flexible") { slink <- substitute(link) .brmsfamily("cratio", link = link, slink = slink, link_disc = link_disc, threshold = threshold) } #' @rdname brmsfamily #' @export acat <- function(link = "logit", link_disc = "log", threshold = "flexible") { slink <- substitute(link) .brmsfamily("acat", link = link, slink = slink, link_disc = link_disc, threshold = threshold) } #' Finite Mixture Families in \pkg{brms} #' #' Set up a finite mixture family for use in \pkg{brms}. #' #' @param ... One or more objects providing a description of the #' response distributions to be combined in the mixture model. #' These can be family functions, calls to family functions or #' character strings naming the families. For details of supported #' families see \code{\link{brmsfamily}}. #' @param flist Optional list of objects, which are treated in the #' same way as objects passed via the \code{...} argument. #' @param nmix Optional numeric vector specifying the number of times #' each family is repeated. If specified, it must have the same length #' as the number of families passed via \code{...} and \code{flist}. #' @param order Ordering constraint to identify mixture components. #' If \code{'mu'} or \code{TRUE}, population-level intercepts #' of the mean parameters are ordered in non-ordinal models #' and fixed to the same value in ordinal models (see details). #' If \code{'none'} or \code{FALSE}, no ordering constraint is applied. #' If \code{NULL} (the default), \code{order} is set to \code{'mu'} #' if all families are the same and \code{'none'} otherwise. #' Other ordering constraints may be implemented in the future. #' #' @return An object of class \code{mixfamily}. #' #' @details #' #' Most families supported by \pkg{brms} can be used to form mixtures. The #' response variable has to be valid for all components of the mixture family. #' Currently, the number of mixture components has to be specified by the user. #' It is not yet possible to estimate the number of mixture components from the #' data. #' #' Ordering intercepts in mixtures of ordinal families is not possible as each #' family has itself a set of vector of intercepts (i.e. ordinal thresholds). #' Instead, \pkg{brms} will fix the vector of intercepts across components in #' ordinal mixtures, if desired, so that users can try to identify the mixture #' model via selective inclusion of predictors. #' #' For most mixture models, you may want to specify priors on the #' population-level intercepts via \code{\link{set_prior}} to improve #' convergence. In addition, it is sometimes necessary to set \code{init = 0} #' in the call to \code{\link{brm}} to allow chains to initialize properly. #' #' For more details on the specification of mixture #' models, see \code{\link{brmsformula}}. #' #' @examples #' \dontrun{ #' ## simulate some data #' set.seed(1234) #' dat <- data.frame( #' y = c(rnorm(200), rnorm(100, 6)), #' x = rnorm(300), #' z = sample(0:1, 300, TRUE) #' ) #' #' ## fit a simple normal mixture model #' mix <- mixture(gaussian, gaussian) #' prior <- c( #' prior(normal(0, 7), Intercept, dpar = mu1), #' prior(normal(5, 7), Intercept, dpar = mu2) #' ) #' fit1 <- brm(bf(y ~ x + z), dat, family = mix, #' prior = prior, chains = 2) #' summary(fit1) #' pp_check(fit1) #' #' ## use different predictors for the components #' fit2 <- brm(bf(y ~ 1, mu1 ~ x, mu2 ~ z), dat, family = mix, #' prior = prior, chains = 2) #' summary(fit2) #' #' ## fix the mixing proportions #' fit3 <- brm(bf(y ~ x + z, theta1 = 1, theta2 = 2), #' dat, family = mix, prior = prior, #' init = 0, chains = 2) #' summary(fit3) #' pp_check(fit3) #' #' ## predict the mixing proportions #' fit4 <- brm(bf(y ~ x + z, theta2 ~ x), #' dat, family = mix, prior = prior, #' init = 0, chains = 2) #' summary(fit4) #' pp_check(fit4) #' #' ## compare model fit #' loo(fit1, fit2, fit3, fit4) #' } #' #' @export mixture <- function(..., flist = NULL, nmix = 1, order = NULL) { dots <- c(list(...), flist) if (length(nmix) == 1L) { nmix <- rep(nmix, length(dots)) } if (length(dots) != length(nmix)) { stop2("The length of 'nmix' should be the same ", "as the number of mixture components.") } dots <- dots[rep(seq_along(dots), nmix)] family <- list( family = "mixture", link = "identity", mix = lapply(dots, validate_family) ) class(family) <- c("mixfamily", "brmsfamily", "family") # validity checks if (length(family$mix) < 2L) { stop2("Expecting at least 2 mixture components.") } if (use_real(family) && use_int(family)) { stop2("Cannot mix families with real and integer support.") } is_ordinal <- ulapply(family$mix, is_ordinal) if (any(is_ordinal) && any(!is_ordinal)) { stop2("Cannot mix ordinal and non-ordinal families.") } no_mixture <- ulapply(family$mix, no_mixture) if (any(no_mixture)) { stop2("Some of the families are not allowed in mixture models.") } for (fam in family$mix) { if (is.customfamily(fam) && "theta" %in% fam$dpars) { stop2("Parameter name 'theta' is reserved in mixture models.") } } if (is.null(order)) { if (any(is_ordinal)) { family$order <- "none" message("Setting order = 'none' for mixtures of ordinal families.") } else if (length(unique(family_names(family))) == 1L) { family$order <- "mu" message("Setting order = 'mu' for mixtures of the same family.") } else { family$order <- "none" message("Setting order = 'none' for mixtures of different families.") } } else { if (length(order) != 1L) { stop2("Argument 'order' must be of length 1.") } if (is.character(order)) { valid_order <- c("none", "mu") if (!order %in% valid_order) { stop2("Argument 'order' is invalid. Valid options are: ", collapse_comma(valid_order)) } family$order <- order } else { family$order <- ifelse(as.logical(order), "mu", "none") } } family } #' Custom Families in \pkg{brms} Models #' #' Define custom families (i.e. response distribution) for use in #' \pkg{brms} models. It allows users to benefit from the modeling #' flexibility of \pkg{brms}, while applying their self-defined likelihood #' functions. All of the post-processing methods for \code{brmsfit} #' objects can be made compatible with custom families. #' See \code{vignette("brms_customfamilies")} for more details. #' For a list of built-in families see \code{\link{brmsfamily}}. #' #' @aliases customfamily #' #' @param name Name of the custom family. #' @param dpars Names of the distributional parameters of #' the family. One parameter must be named \code{"mu"} and #' the main formula of the model will correspond to that #' parameter. #' @param links Names of the link functions of the #' distributional parameters. #' @param type Indicates if the response distribution is #' continuous (\code{"real"}) or discrete (\code{"int"}). This controls #' if the corresponding density function will be named with #' \code{_lpdf} or \code{_lpmf}. #' @param lb Vector of lower bounds of the distributional #' parameters. Defaults to \code{NA} that is no lower bound. #' @param ub Vector of upper bounds of the distributional #' parameters. Defaults to \code{NA} that is no upper bound. #' @param vars Names of variables that are part of the likelihood function #' without being distributional parameters. That is, \code{vars} can be used #' to pass data to the likelihood. Such arguments will be added to the list of #' function arguments at the end, after the distributional parameters. See #' \code{\link{stanvar}} for details about adding self-defined data to the #' generated \pkg{Stan} model. Addition arguments \code{vreal} and \code{vint} #' may be used for this purpose as well (see Examples below). See also #' \code{\link{brmsformula}} and \code{\link{addition-terms}} for more #' details. #' @param loop Logical; Should the likelihood be evaluated via a loop #' (\code{TRUE}; the default) over observations in Stan? #' If \code{FALSE}, the Stan code will be written in a vectorized #' manner over observations if possible. #' @param specials A character vector of special options to enable #' for this custom family. Currently for internal use only. #' @param threshold Optional threshold type for custom ordinal families. #' Ignored for non-ordinal families. #' @param log_lik Optional function to compute log-likelihood values of #' the model in \R. This is only relevant if one wants to ensure #' compatibility with method \code{\link[brms:log_lik.brmsfit]{log_lik}}. #' @param posterior_predict Optional function to compute posterior prediction of #' the model in \R. This is only relevant if one wants to ensure compatibility #' with method \code{\link[brms:posterior_predict.brmsfit]{posterior_predict}}. #' @param posterior_epred Optional function to compute expected values of the #' posterior predictive distribution of the model in \R. This is only relevant #' if one wants to ensure compatibility with method #' \code{\link[brms:posterior_epred.brmsfit]{posterior_epred}}. #' @param predict Deprecated alias of `posterior_predict`. #' @param fitted Deprecated alias of `posterior_epred`. #' @param env An \code{\link{environment}} in which certain post-processing #' functions related to the custom family can be found, if there were not #' directly passed to \code{custom_family}. This is only #' relevant if one wants to ensure compatibility with the methods #' \code{\link[brms:log_lik.brmsfit]{log_lik}}, #' \code{\link[brms:posterior_predict.brmsfit]{posterior_predict}}, or #' \code{\link[brms:posterior_epred.brmsfit]{posterior_epred}}. #' By default, \code{env} is the environment from which #' \code{custom_family} is called. #' #' @details The corresponding probability density or mass \code{Stan} #' functions need to have the same name as the custom family. #' That is if a family is called \code{myfamily}, then the #' \pkg{Stan} functions should be called \code{myfamily_lpdf} or #' \code{myfamily_lpmf} depending on whether it defines a #' continuous or discrete distribution. #' #' @return An object of class \code{customfamily} inheriting #' from class \code{\link{brmsfamily}}. #' #' @seealso \code{\link{brmsfamily}}, \code{\link{brmsformula}}, #' \code{\link{stanvar}} #' #' @examples #' \dontrun{ #' ## demonstrate how to fit a beta-binomial model #' ## generate some fake data #' phi <- 0.7 #' n <- 300 #' z <- rnorm(n, sd = 0.2) #' ntrials <- sample(1:10, n, replace = TRUE) #' eta <- 1 + z #' mu <- exp(eta) / (1 + exp(eta)) #' a <- mu * phi #' b <- (1 - mu) * phi #' p <- rbeta(n, a, b) #' y <- rbinom(n, ntrials, p) #' dat <- data.frame(y, z, ntrials) #' #' # define a custom family #' beta_binomial2 <- custom_family( #' "beta_binomial2", dpars = c("mu", "phi"), #' links = c("logit", "log"), lb = c(NA, 0), #' type = "int", vars = "vint1[n]" #' ) #' #' # define the corresponding Stan density function #' stan_density <- " #' real beta_binomial2_lpmf(int y, real mu, real phi, int N) { #' return beta_binomial_lpmf(y | N, mu * phi, (1 - mu) * phi); #' } #' " #' stanvars <- stanvar(scode = stan_density, block = "functions") #' #' # fit the model #' fit <- brm(y | vint(ntrials) ~ z, data = dat, #' family = beta_binomial2, stanvars = stanvars) #' summary(fit) #' #' #' # define a *vectorized* custom family (no loop over observations) #' # notice also that 'vint' no longer has an observation index #' beta_binomial2_vec <- custom_family( #' "beta_binomial2", dpars = c("mu", "phi"), #' links = c("logit", "log"), lb = c(NA, 0), #' type = "int", vars = "vint1", loop = FALSE #' ) #' #' # define the corresponding Stan density function #' stan_density_vec <- " #' real beta_binomial2_lpmf(array[] int y, vector mu, real phi, array[] int N) { #' return beta_binomial_lpmf(y | N, mu * phi, (1 - mu) * phi); #' } #' " #' stanvars_vec <- stanvar(scode = stan_density_vec, block = "functions") #' #' # fit the model #' fit_vec <- brm(y | vint(ntrials) ~ z, data = dat, #' family = beta_binomial2_vec, #' stanvars = stanvars_vec) #' summary(fit_vec) #' } #' #' @export custom_family <- function(name, dpars = "mu", links = "identity", type = c("real", "int"), lb = NA, ub = NA, vars = NULL, loop = TRUE, specials = NULL, threshold = "flexible", log_lik = NULL, posterior_predict = NULL, posterior_epred = NULL, predict = NULL, fitted = NULL, env = parent.frame()) { name <- as_one_character(name) dpars <- as.character(dpars) links <- as.character(links) type <- match.arg(type) lb <- as.character(lb) ub <- as.character(ub) vars <- as.character(vars) loop <- as_one_logical(loop) specials <- as.character(specials) env <- as.environment(env) posterior_predict <- use_alias(posterior_predict, predict) posterior_epred <- use_alias(posterior_epred, fitted) if (any(duplicated(dpars))) { stop2("Duplicated 'dpars' are not allowed.") } if (!"mu" %in% dpars) { stop2("All families must have a 'mu' parameter.") } if (any(grepl("_|\\.", dpars))) { stop2("Dots or underscores are not allowed in 'dpars'.") } if (any(grepl("[[:digit:]]+$", dpars))) { stop2("'dpars' should not end with a number.") } for (arg in c("links", "lb", "ub")) { obj <- get(arg) if (length(obj) == 1L) { obj <- rep(obj, length(dpars)) assign(arg, obj) } if (length(dpars) != length(obj)) { stop2("'", arg, "' must be of the same length as 'dpars'.") } } if (!is.null(log_lik)) { log_lik <- as.function(log_lik) args <- names(formals(log_lik)) if (!is_equal(args[1:2], c("i", "prep"))) { stop2("The first two arguments of 'log_lik' ", "should be 'i' and 'prep'.") } } if (!is.null(posterior_predict)) { posterior_predict <- as.function(posterior_predict) args <- names(formals(posterior_predict)) if (!is_equal(args[1:3], c("i", "prep", "..."))) { stop2("The first three arguments of 'posterior_predict' ", "should be 'i', 'prep', and '...'.") } } if (!is.null(posterior_epred)) { posterior_epred <- as.function(posterior_epred) args <- names(formals(posterior_epred)) if (!is_equal(args[1], "prep")) { stop2("The first argument of 'posterior_epred' should be 'prep'.") } } lb <- named_list(dpars, lb) ub <- named_list(dpars, ub) is_mu <- "mu" == dpars link <- links[is_mu] normalized <- "" out <- nlist( family = "custom", link, name, dpars, lb, ub, type, vars, loop, specials, log_lik, posterior_predict, posterior_epred, env, normalized ) if (length(dpars) > 1L) { out[paste0("link_", dpars[!is_mu])] <- links[!is_mu] } class(out) <- c("customfamily", "brmsfamily", "family") if (is_ordinal(out)) { threshold <- match.arg(threshold) out$threshold <- threshold } out } # get post-processing methods for custom families custom_family_method <- function(family, name) { if (!is.customfamily(family)) { return(NULL) } out <- family[[name]] if (!is.function(out)) { out <- paste0(name, "_", family$name) out <- get(out, family$env) } out } # get valid distributional parameters for a family valid_dpars <- function(family, ...) { UseMethod("valid_dpars") } #' @export valid_dpars.default <- function(family, type = NULL, ...) { if (!length(family)) { if (is.null(type)) { return("mu") } else { return(NULL) } } family <- validate_family(family) info <- paste0(usc(type, "suffix"), "dpars") family_info(family, info, ...) } #' @export valid_dpars.mixfamily <- function(family, type = NULL, ...) { out <- lapply(family$mix, valid_dpars, type = type, ...) for (i in seq_along(out)) { if (length(out[[i]])) { out[[i]] <- paste0(out[[i]], i) } } out <- unlist(out) if (is.null(type)) { c(out) <- paste0("theta", seq_along(family$mix)) } out } #' @export valid_dpars.brmsformula <- function(family, ...) { valid_dpars(family$family, ...) } #' @export valid_dpars.mvbrmsformula <- function(family, ...) { ulapply(family$forms, valid_dpars, ...) } #' @export valid_dpars.brmsterms <- function(family, ...) { valid_dpars(family$family, ...) } #' @export valid_dpars.mvbrmsterms <- function(family, ...) { ulapply(family$terms, valid_dpars, ...) } #' @export valid_dpars.brmsfit <- function(family, ...) { valid_dpars(family$formula, ...) } # class of a distributional parameter dpar_class <- function(dpar, family = NULL) { out <- sub("[[:digit:]]*$", "", dpar) if (!is.null(family)) { # TODO: avoid these special cases by changing naming conventions # perhaps add a protected "C" before category names # and a protected "M" for mixture components if (conv_cats_dpars(family)) { # categorical-like models have non-integer suffixes # that will not be caught by the standard procedure multi_dpars <- valid_dpars(family, type = "multi") for (dp in multi_dpars) { sel <- grepl(paste0("^", dp), out) out[sel] <- dp } } } out } # id of a distributional parameter dpar_id <- function(dpar) { out <- get_matches("[[:digit:]]+$", dpar, simplify = FALSE) ulapply(out, function(x) ifelse(length(x), x, "")) } # link functions for distributional parameters links_dpars <- function(dpar) { if (!length(dpar)) dpar <- "" switch(dpar, character(0), mu = "identity", # not actually used sigma = c("log", "identity", "softplus", "squareplus"), shape = c("log", "identity", "softplus", "squareplus"), nu = c("logm1", "identity"), phi = c("log", "identity", "softplus", "squareplus"), kappa = c("log", "identity", "softplus", "squareplus"), beta = c("log", "identity", "softplus", "squareplus"), zi = c("logit", "identity"), hu = c("logit", "identity"), zoi = c("logit", "identity"), coi = c("logit", "identity"), disc = c("log", "identity", "softplus", "squareplus"), bs = c("log", "identity", "softplus", "squareplus"), ndt = c("log", "identity", "softplus", "squareplus"), bias = c("logit", "identity"), quantile = c("logit", "identity"), xi = c("log1p", "identity"), alpha = c("identity", "log", "softplus", "squareplus"), theta = c("identity") ) } # is a distributional parameter a mixture proportion? is_mix_proportion <- function(dpar, family) { dpar_class <- dpar_class(dpar, family) dpar_class %in% "theta" & is.mixfamily(family) } # generate a family object of a distributional parameter dpar_family <- function(family, dpar, ...) { UseMethod("dpar_family") } #' @export dpar_family.default <- function(family, dpar, ...) { dp_class <- dpar_class(dpar, family) if (dp_class == "mu") { if (conv_cats_dpars(family)) { link <- NULL if (!has_joint_link(family)) { link <- family$link } # joint links are applied directly in the likelihood function # so link is treated as 'identity' out <- .dpar_family(dpar, link) } else { # standard single mu parameters just store the original family out <- family } } else { # link_ is always defined for non-mu parameters link <- family[[paste0("link_", dp_class)]] out <- .dpar_family(dpar, link) } out } #' @export dpar_family.mixfamily <- function(family, dpar, ...) { dp_id <- as.numeric(dpar_id(dpar)) if (!(length(dp_id) == 1L && is.numeric(dp_id))) { stop2("Parameter '", dpar, "' is not a valid mixture parameter.") } out <- dpar_family(family$mix[[dp_id]], dpar, ...) out$order <- family$order out } # set up special family objects for distributional parameters # @param dpar name of the distributional parameter # @param link optional link function of the parameter .dpar_family <- function(dpar = NULL, link = NULL) { links <- links_dpars(dpar_class(dpar)) if (!length(link)) { if (!length(links)) { link <- "identity" } else { link <- links[1] } } link <- as_one_character(link) structure( nlist(family = "", link, dpar), class = c("brmsfamily", "family") ) } #' @export print.brmsfamily <- function(x, links = FALSE, newline = TRUE, ...) { cat("\nFamily:", x$family, "\n") cat("Link function:", x$link, "\n") if (!is.null(x$threshold)) { cat("Threshold:", x$threshold, "\n") } if (isTRUE(links) || is.character(links)) { dp_links <- x[grepl("^link_", names(x))] names(dp_links) <- sub("^link_", "", names(dp_links)) if (is.character(links)) { dp_links <- rmNULL(dp_links[links]) } for (dp in names(dp_links)) { cat(paste0( "Link function of '", dp, "' (if predicted): ", dp_links[[dp]], "\n" )) } } if (newline) { cat("\n") } invisible(x) } #' @export print.mixfamily <- function(x, newline = TRUE, ...) { cat("\nMixture\n") for (i in seq_along(x$mix)) { print(x$mix[[i]], newline = FALSE, ...) } if (newline) { cat("\n") } invisible(x) } #' @export print.customfamily <- function(x, links = FALSE, newline = TRUE, ...) { cat("\nCustom family:", x$name, "\n") cat("Link function:", x$link, "\n") cat("Parameters:", paste0(x$dpars, collapse = ", "), "\n") if (isTRUE(links) || is.character(links)) { dp_links <- x[grepl("^link_", names(x))] names(dp_links) <- sub("^link_", "", names(dp_links)) if (is.character(links)) { dp_links <- rmNULL(dp_links[links]) } for (dp in names(dp_links)) { cat(paste0( "Link function of '", dp, "' (if predicted): ", dp_links[[dp]], "\n" )) } } if (newline) { cat("\n") } invisible(x) } #' @method summary family #' @export summary.family <- function(object, link = TRUE, ...) { out <- object$family if (link) { out <- paste0(out, "(", object$link, ")") } out } #' @method summary mixfamily #' @export summary.mixfamily <- function(object, link = FALSE, ...) { families <- ulapply(object$mix, summary, link = link, ...) paste0("mixture(", paste0(families, collapse = ", "), ")") } #' @method summary customfamily #' @export summary.customfamily <- function(object, link = TRUE, ...) { object$family <- object$name summary.family(object, link = link, ...) } summarise_families <- function(x) { # summary of families used in summary.brmsfit UseMethod("summarise_families") } #' @export summarise_families.mvbrmsformula <- function(x, ...) { out <- ulapply(x$forms, summarise_families, ...) paste0("MV(", paste0(out, collapse = ", "), ")") } #' @export summarise_families.brmsformula <- function(x, ...) { summary(x$family, link = FALSE, ...) } summarise_links <- function(x, ...) { # summary of link functions used in summary.brmsfit UseMethod("summarise_links") } #' @export summarise_links.mvbrmsformula <- function(x, wsp = 0, ...) { str_wsp <- collapse(rep(" ", wsp)) links <- ulapply(x$forms, summarise_links, mv = TRUE, ...) paste0(links, collapse = paste0("\n", str_wsp)) } #' @export summarise_links.brmsformula <- function(x, mv = FALSE, ...) { x <- brmsterms(x) dpars <- valid_dpars(x) links <- ulapply(x$dpars, function(x) x$family$link) if (conv_cats_dpars(x)) { links[grepl("^mu", names(links))] <- x$family$link } resp <- if (mv) usc(combine_prefix(x)) names(links) <- paste0(names(links), resp) paste0(names(links), " = ", links, collapse = "; ") } is.family <- function(x) { inherits(x, "family") } is.brmsfamily <- function(x) { inherits(x, "brmsfamily") } is.mixfamily <- function(x) { inherits(x, "mixfamily") } is.customfamily <- function(x) { inherits(x, "customfamily") } family_names <- function(x) { family_info(x, "family") } # indicate if family uses real responses use_real <- function(family) { "real" %in% family_info(family, "type") } # indicate if family uses integer responses use_int <- function(family) { "int" %in% family_info(family, "type") } is_binary <- function(family) { "binary" %in% family_info(family, "specials") } is_categorical <- function(family) { "categorical" %in% family_info(family, "specials") } is_ordinal <- function(family) { "ordinal" %in% family_info(family, "specials") } is_multinomial <- function(family) { "multinomial" %in% family_info(family, "specials") } is_logistic_normal <- function(family) { "logistic_normal" %in% family_info(family, "specials") } is_simplex <- function(family) { "simplex" %in% family_info(family, "specials") } is_polytomous <- function(family) { is_categorical(family) || is_ordinal(family) || is_multinomial(family) || is_simplex(family) } is_cox <- function(family) { "cox" %in% family_info(family, "specials") } # has joint link function over multiple inputs has_joint_link <- function(family) { "joint_link" %in% family_info(family, "specials") } allow_factors <- function(family) { specials <- c("binary", "categorical", "ordinal") any(specials %in% family_info(family, "specials")) } # check if the family has natural residuals has_natural_residuals <- function(family) { "residuals" %in% family_info(family, "specials") } # check if the family allows for residual correlations has_rescor <- function(family) { "rescor" %in% family_info(family, "specials") } # check if category specific effects are allowed allow_cs <- function(family) { any(c("cs", "ocs") %in% family_info(family, "specials")) } # check if category specific effects should be ordered needs_ordered_cs <- function(family) { "ocs" %in% family_info(family, "specials") } # choose dpar names based on categories? conv_cats_dpars <- function(family) { is_categorical(family) || is_multinomial(family) || is_simplex(family) } # check if mixtures of the given families are allowed no_mixture <- function(family) { is_categorical(family) || is_multinomial(family) || is_simplex(family) || is_cont_hurdle(family) } # indicate if the response should consist of multiple columns has_multicol <- function(family) { is_multinomial(family) || is_simplex(family) } # indicate if the response is modeled on the log-scale # even if formally the link function is not 'log' has_logscale <- function(family) { "logscale" %in% family_info(family, "specials") } # indicate if the family is a continuous zi/hu family is_cont_hurdle <- function(family) { "cont_hurdle" %in% family_info(family, "specials") } # indicate if family makes use of argument trials has_trials <- function(family) { "trials" %in% family_info(family, "ad") && !"custom" %in% family_names(family) } # indicate if family has more than two response categories has_cat <- function(family) { is_categorical(family) || is_multinomial(family) || is_simplex(family) } # indicate if family has thresholds has_thres <- function(family) { is_ordinal(family) } # indicate if family has equidistant thresholds has_equidistant_thres <- function(family) { "equidistant" %in% family_info(family, "threshold") } # indicate if family has sum-to-zero thresholds has_sum_to_zero_thres <- function(family) { "sum_to_zero" %in% family_info(family, "threshold") } # indicate if family has ordered thresholds has_ordered_thres <- function(family) { "ordered_thres" %in% family_info(family, "specials") } # compute threshold - eta in the likelihood has_thres_minus_eta <- function(family) { "thres_minus_eta" %in% family_info(family, "specials") } # compute eta - threshold in the likelihood has_eta_minus_thres <- function(family) { "eta_minus_thres" %in% family_info(family, "specials") } # has an extra category that is not part of the ordinal scale (#1429) has_extra_cat <- function(family) { "extra_cat" %in% family_info(family, "specials") } # get names of response categories get_cats <- function(family) { family_info(family, "cats") } # get reference category categorical-like models get_refcat <- function(family, int = FALSE) { refcat <- family_info(family, "refcat") if (int) { cats <- family_info(family, "cats") refcat <- match(refcat, cats) } refcat } # get names of predicted categories categorical-like models get_predcats <- function(family) { refcat <- family_info(family, "refcat") cats <- family_info(family, "cats") setdiff(cats, refcat) } # get names of ordinal thresholds for prior specification # @param group name of a group for which to extract categories get_thres <- function(family, group = "") { group <- as_one_character(group) thres <- family_info(family, "thres") subset2(thres, group = group)$thres } # get group names of ordinal thresholds get_thres_groups <- function(family) { thres <- family_info(family, "thres") unique(thres$group) } # has the model group specific thresholds? has_thres_groups <- function(family) { groups <- get_thres_groups(family) any(nzchar(groups)) } # get group names of baseline hazard groups get_bhaz_groups <- function(family) { bhaz <- family_info(family, "bhaz") unique(bhaz$groups) } # has the model group specific baseline hazards? has_bhaz_groups <- function(family) { groups <- get_bhaz_groups(family) any(nzchar(groups)) } has_ndt <- function(family) { "ndt" %in% dpar_class(family_info(family, "dpars")) } has_sigma <- function(family) { "sigma" %in% dpar_class(family_info(family, "dpars")) } # check if sigma should be explicitely set to 0 no_sigma <- function(bterms) { stopifnot(is.brmsterms(bterms)) if (is.formula(bterms$adforms$se)) { se <- eval_rhs(bterms$adforms$se) se_only <- isFALSE(se$flags$sigma) if (se_only && use_ac_cov_time(bterms)) { stop2("Please set argument 'sigma' of function 'se' ", "to TRUE when modeling time-series covariance matrices.") } } else { se_only <- FALSE } se_only } # has the model a non-predicted but estimated sigma parameter? simple_sigma <- function(bterms) { stopifnot(is.brmsterms(bterms)) has_sigma(bterms) && !no_sigma(bterms) && !pred_sigma(bterms) } # has the model a predicted sigma parameter? pred_sigma <- function(bterms) { stopifnot(is.brmsterms(bterms)) "sigma" %in% dpar_class(names(bterms$dpars)) } # do not include a 'nu' parameter in a univariate model? no_nu <- function(bterms) { # the multi_student_t family only has a single 'nu' parameter isTRUE(bterms$rescor) && "student" %in% family_names(bterms) } # get mixture index if specified get_mix_id <- function(family) { family_info(family, "mix") %||% "" } # does the family-link combination have a built-in Stan function? has_built_in_fun <- function(family, link = NULL, dpar = NULL, cdf = FALSE) { link <- link %||% family$link glm_special <- paste0("sbi", usc(dpar), "_", link, str_if(cdf, "_cdf")) all(glm_special %in% family_info(family, "specials")) } # suffixes of Stan lpdfs or lpmfs for which only a normalized version exists always_normalized <- function(family) { family_info(family, "normalized") } # prepare for calling family specific post-processing functions prepare_family <- function(x) { stopifnot(is.brmsformula(x) || is.brmsterms(x)) family <- x$family acframe <- frame_ac(x) family$fun <- family[["fun"]] %||% family$family if (use_ac_cov_time(acframe) && has_natural_residuals(x)) { family$fun <- paste0(family$fun, "_time") } else if (has_ac_class(acframe, "sar")) { acframe_sar <- subset2(acframe, class = "sar") if (has_ac_subset(acframe_sar, type = "lag")) { family$fun <- paste0(family$fun, "_lagsar") } else if (has_ac_subset(acframe_sar, type = "error")) { family$fun <- paste0(family$fun, "_errorsar") } } else if (has_ac_class(acframe, "fcor")) { family$fun <- paste0(family$fun, "_fcor") } family } # order intercepts to help identifying mixture components? # does not work in ordinal models as they have vectors of intercepts order_intercepts <- function(bterms) { dpar <- dpar_class(bterms[["dpar"]]) if (!length(dpar)) dpar <- "mu" isTRUE( !is_ordinal(bterms) && dpar %in% bterms$family[["order"]] && !get_nl(bterms$formula) ) } # fix intercepts to help identifying mixture components? # currently enabled only in ordinal models fix_intercepts <- function(bterms) { dpar <- dpar_class(bterms[["dpar"]]) if (!length(dpar)) dpar <- "mu" isTRUE(is_ordinal(bterms) && dpar %in% bterms$family[["order"]]) } # does the mixture have a joint parameter vector 'theta' has_joint_theta <- function(bterms) { stopifnot(is.brmsterms(bterms)) is.mixfamily(bterms$family) && !"theta" %in% dpar_class(names(c(bterms$dpars, bterms$fdpars))) } # extract family boundaries family_bounds <- function(x, ...) { UseMethod("family_bounds") } # @return a named list with one element per response variable #' @export family_bounds.mvbrmsterms <- function(x, ...) { lapply(x$terms, family_bounds, ...) } # bounds of likelihood families # @return a list with elements 'lb' and 'ub' #' @export family_bounds.brmsterms <- function(x, ...) { family <- x$family$family if (is.null(family)) { return(list(lb = -Inf, ub = Inf)) } resp <- usc(x$resp) # TODO: define in family-lists.R pos_families <- c( "poisson", "negbinomial", "negbinomial2", "geometric", "gamma", "weibull", "exponential", "lognormal", "frechet", "inverse.gaussian", "hurdle_poisson", "hurdle_negbinomial", "hurdle_gamma", "hurdle_lognormal", "zero_inflated_poisson", "zero_inflated_negbinomial" ) beta_families <- c("beta", "zero_inflated_beta", "zero_one_inflated_beta", "xbeta") ordinal_families <- c("cumulative", "cratio", "sratio", "acat") if (family %in% pos_families) { out <- list(lb = 0, ub = Inf) } else if (family %in% c("bernoulli", beta_families)) { out <- list(lb = 0, ub = 1) } else if (family %in% c("categorical", ordinal_families)) { out <- list(lb = 1, ub = paste0("ncat", resp)) } else if (family %in% c("binomial", "zero_inflated_binomial", "beta_binomial", "zero_inflated_beta_binomial")) { out <- list(lb = 0, ub = paste0("trials", resp)) } else if (family %in% "von_mises") { out <- list(lb = -pi, ub = pi) } else if (family %in% c("wiener", "shifted_lognormal")) { out <- list(lb = paste0("min_Y", resp), ub = Inf) } else if (family %in% c("hurdle_cumulative")) { out <- list(lb = 0, ub = paste0("ncat", resp)) } else { out <- list(lb = -Inf, ub = Inf) } out } brms/R/prepare_predictions.R0000644000176200001440000013761215053305627015622 0ustar liggesusers#' @export #' @rdname prepare_predictions prepare_predictions.brmsfit <- function( x, newdata = NULL, re_formula = NULL, allow_new_levels = FALSE, sample_new_levels = "uncertainty", incl_autocor = TRUE, oos = NULL, resp = NULL, ndraws = NULL, draw_ids = NULL, nsamples = NULL, subset = NULL, nug = NULL, smooths_only = FALSE, offset = TRUE, newdata2 = NULL, new_objects = NULL, point_estimate = NULL, ndraws_point_estimate = 1, ... ) { x <- restructure(x) # allows functions to fall back to old default behavior # which was used when originally fitting the model options(.brmsfit_version = x$version$brms) on.exit(options(.brmsfit_version = NULL)) snl_options <- c("uncertainty", "gaussian", "old_levels") sample_new_levels <- match.arg(sample_new_levels, snl_options) ndraws <- use_alias(ndraws, nsamples) draw_ids <- use_alias(draw_ids, subset) warn_brmsfit_multiple(x, newdata = newdata) newdata2 <- use_alias(newdata2, new_objects) x <- exclude_terms( x, incl_autocor = incl_autocor, offset = offset, smooths_only = smooths_only ) resp <- validate_resp(resp, x) draw_ids <- validate_draw_ids(x, draw_ids, ndraws) draws <- as_draws_matrix(x) draws <- suppressMessages(subset_draws(draws, draw = draw_ids, unique = FALSE)) draws <- point_draws(draws, point_estimate, ndraws_point_estimate) sdata <- standata( x, newdata = newdata, re_formula = re_formula, newdata2 = newdata2, resp = resp, allow_new_levels = allow_new_levels, internal = TRUE, ... ) new_formula <- update_re_terms(x$formula, re_formula) bframe <- brmsframe(new_formula, data = x$data) # TODO: move prep_re into prepare_predictions in brms 3.0 prep_re <- prepare_predictions_re_global( bframe = bframe, draws = draws, sdata = sdata, resp = resp, old_reframe = x$ranef, sample_new_levels = sample_new_levels, ) prepare_predictions( bframe, draws = draws, sdata = sdata, prep_re = prep_re, resp = resp, sample_new_levels = sample_new_levels, nug = nug, new = !is.null(newdata), oos = oos, stanvars = x$stanvars ) } #' @export prepare_predictions.mvbrmsframe <- function(x, draws, sdata, resp = NULL, ...) { resp <- validate_resp(resp, x$responses) if (length(resp) > 1) { if (has_subset(x)) { stop2("Argument 'resp' must be a single variable name ", "for models using addition argument 'subset'.") } out <- list(ndraws = nrow(draws), nobs = sdata$N) out$resps <- named_list(resp) out$old_order <- attr(sdata, "old_order") for (r in resp) { out$resps[[r]] <- prepare_predictions( x$terms[[r]], draws = draws, sdata = sdata, ... ) } if (x$rescor) { out$family <- out$resps[[1]]$family out$family$fun <- paste0(out$family$family, "_mv") rescor <- get_cornames(resp, type = "rescor", brackets = FALSE) out$mvpars$rescor <- prepare_draws(draws, rescor) if (out$family$family == "student") { # store in out$dpars so that get_dpar can be called on nu out$dpars$nu <- as.vector(prepare_draws(draws, "nu")) } out$data$N <- out$resps[[1]]$data$N out$data$weights <- out$resps[[1]]$data$weights Y <- lapply(out$resps, function(x) x$data$Y) out$data$Y <- do_call(cbind, Y) } out <- structure(out, class = "mvbrmsprep") } else { out <- prepare_predictions( x$terms[[resp]], draws = draws, sdata = sdata, ... ) } out } #' @export prepare_predictions.brmsframe <- function(x, draws, sdata, ...) { ndraws <- nrow(draws) nobs <- sdata[[paste0("N", usc(x$resp))]] resp <- usc(combine_prefix(x)) out <- nlist(ndraws, nobs, resp = x$resp) out$family <- prepare_family(x) out$old_order <- attr(sdata, "old_order") if (has_subset(x) && !is.null(out$old_order)) { # old_order has length equal to the full number of observations # which is inappropriate for subsetted responses (#1483) out$old_order <- as.numeric(factor(out$old_order[x$frame$resp$subset])) } valid_dpars <- valid_dpars(x) out$dpars <- named_list(valid_dpars) for (dp in valid_dpars) { dp_regex <- paste0("^", dp, resp, "$") if (is.btl(x$dpars[[dp]]) || is.btnl(x$dpars[[dp]])) { out$dpars[[dp]] <- prepare_predictions( x$dpars[[dp]], draws = draws, sdata = sdata, ... ) } else if (any(grepl(dp_regex, colnames(draws)))) { out$dpars[[dp]] <- as.vector(prepare_draws(draws, dp_regex, regex = TRUE)) } else if (is.numeric(x$fdpars[[dp]]$value)) { # fixed dpars are stored as regular draws as of brms 2.12.9 # so this manual extraction is only required for older models out$dpars[[dp]] <- x$fdpars[[dp]]$value } } out$nlpars <- named_list(names(x$nlpars)) for (nlp in names(x$nlpars)) { out$nlpars[[nlp]] <- prepare_predictions( x$nlpars[[nlp]], draws = draws, sdata = sdata, ... ) } if (is.mixfamily(x$family)) { families <- family_names(x$family) thetas <- paste0("theta", seq_along(families)) if (any(ulapply(out$dpars[thetas], is.list))) { # theta was predicted missing_id <- which(ulapply(out$dpars[thetas], is.null)) out$dpars[[paste0("theta", missing_id)]] <- structure( data2draws(0, c(ndraws, nobs)), predicted = TRUE ) } else { # theta was not predicted out$dpars$theta <- do_call(cbind, out$dpars[thetas]) out$dpars[thetas] <- NULL if (nrow(out$dpars$theta) == 1L) { dim <- c(nrow(draws), ncol(out$dpars$theta)) out$dpars$theta <- data2draws(out$dpars$theta, dim = dim) } } } if (is_ordinal(x$family)) { # it is better to handle ordinal thresholds outside the # main predictor term in particular for use in custom families if (is.mixfamily(x$family)) { mu_pars <- str_subset(names(x$dpars), "^mu[[:digit:]]+") for (mu in mu_pars) { out$thres[[mu]] <- prepare_predictions_thres(x$dpars[[mu]], draws, sdata, ...) } } else { out$thres <- prepare_predictions_thres(x$dpars$mu, draws, sdata, ...) } } if (is_logistic_normal(x$family)) { out$dpars$lncor <- prepare_draws(draws, "^lncor__", regex = TRUE) } if (is_cox(x$family)) { # prepare baseline hazard functions for the Cox model if (is.mixfamily(x$family)) { mu_pars <- str_subset(names(x$dpars), "^mu[[:digit:]]+") for (mu in mu_pars) { out$bhaz[[mu]] <- prepare_predictions_bhaz( x$dpars[[mu]], draws, sdata, ... ) } } else { out$bhaz <- prepare_predictions_bhaz(x$dpars$mu, draws, sdata, ...) } } # response category names for categorical and ordinal models out$cats <- get_cats(x) # reference category for categorical models out$refcat <- get_refcat(x, int = TRUE) # only include those autocor draws on the top-level # of the output which imply covariance matrices on natural residuals out$ac <- prepare_predictions_ac(x$dpars$mu, draws, sdata, nat_cov = TRUE, ...) out$data <- prepare_predictions_data(x, sdata = sdata, ...) structure(out, class = "brmsprep") } #' @export prepare_predictions.bframenl <- function(x, draws, sdata, ...) { out <- list( family = x$family, nlform = x$formula[[2]], env = env_stan_functions(parent = environment(x$formula)), ndraws = nrow(draws), nobs = sdata[[paste0("N", usc(x$resp))]], used_nlpars = x$used_nlpars, loop = x$loop ) class(out) <- "bprepnl" p <- usc(combine_prefix(x)) covars <- all.vars(x$covars) for (i in seq_along(covars)) { cvalues <- sdata[[paste0("C", p, "_", i)]] cdim <- c(out$ndraws, out$nobs) if (is.matrix(cvalues)) { c(cdim) <- dim(cvalues)[2] } out$C[[covars[i]]] <- data2draws(cvalues, dim = cdim) } out } #' @export prepare_predictions.bframel <- function(x, draws, sdata, ...) { ndraws <- nrow(draws) nobs <- sdata[[paste0("N", usc(x$resp))]] out <- nlist(family = x$family, ndraws, nobs) class(out) <- "bprepl" out$fe <- prepare_predictions_fe(x, draws, sdata, ...) out$sp <- prepare_predictions_sp(x, draws, sdata, ...) out$cs <- prepare_predictions_cs(x, draws, sdata, ...) out$sm <- prepare_predictions_sm(x, draws, sdata, ...) out$gp <- prepare_predictions_gp(x, draws, sdata, ...) out$re <- prepare_predictions_re(x, sdata, ...) out$ac <- prepare_predictions_ac(x, draws, sdata, nat_cov = FALSE, ...) out$offset <- prepare_predictions_offset(x, sdata, ...) out } # prepare predictions of ordinary population-level effects prepare_predictions_fe <- function(bframe, draws, sdata, ...) { stopifnot(is.bframel(bframe)) out <- list() if (is.null(bframe[["fe"]])) { return(out) } p <- usc(combine_prefix(bframe)) X <- sdata[[paste0("X", p)]] fixef <- bframe$frame$fe$vars if (length(fixef)) { out$X <- X b_pars <- paste0("b", p, "_", fixef) out$b <- prepare_draws(draws, b_pars, scalar = TRUE) } out } # prepare predictions of special effects terms prepare_predictions_sp <- function(bframe, draws, sdata, new = FALSE, ...) { stopifnot(is.bframel(bframe)) out <- list() spframe <- bframe$frame$sp meframe <- bframe$frame$me if (!has_rows(spframe)) { return(out) } p <- usc(combine_prefix(bframe)) resp <- usc(bframe$resp) # prepare calls evaluated in sp_predictor out$calls <- vector("list", nrow(spframe)) for (i in seq_along(out$calls)) { call <- spframe$joint_call[[i]] if (!is.null(spframe$calls_mo[[i]])) { new_mo <- paste0(".mo(simo_", spframe$Imo[[i]], ", Xmo_", spframe$Imo[[i]], ")") call <- rename(call, spframe$calls_mo[[i]], new_mo) } if (!is.null(spframe$calls_me[[i]])) { new_me <- paste0("Xme_", seq_along(meframe$term)) call <- rename(call, meframe$term, new_me) } if (!is.null(spframe$calls_mi[[i]])) { is_na_idx <- is.na(spframe$idx2_mi[[i]]) idx_mi <- paste0("idxl", p, "_", spframe$vars_mi[[i]], "_", spframe$idx2_mi[[i]]) idx_mi <- ifelse(is_na_idx, "", paste0("[, ", idx_mi, "]")) new_mi <- paste0("Yl_", spframe$vars_mi[[i]], idx_mi) call <- rename(call, spframe$calls_mi[[i]], new_mi) } if (spframe$Ic[i] > 0) { str_add(call) <- paste0(" * Csp_", spframe$Ic[i]) } out$calls[[i]] <- parse(text = paste0(call)) } # extract general data and parameters for special effects bsp_pars <- paste0("bsp", p, "_", spframe$coef) out$bsp <- prepare_draws(draws, bsp_pars) colnames(out$bsp) <- spframe$coef # prepare predictions specific to monotonic effects simo_coef <- get_simo_labels(spframe) Jmo <- sdata[[paste0("Jmo", p)]] out$simo <- out$Xmo <- named_list(simo_coef) for (i in seq_along(simo_coef)) { J <- seq_len(Jmo[i]) simo_par <- paste0("simo", p, "_", simo_coef[i], "[", J, "]") out$simo[[i]] <- prepare_draws(draws, simo_par) out$Xmo[[i]] <- sdata[[paste0("Xmo", p, "_", i)]] } # prepare predictions specific to noise-free effects warn_me <- FALSE if (has_rows(meframe)) { save_mevars <- any(grepl("^Xme_", colnames(draws))) warn_me <- warn_me || !new && !save_mevars out$Xme <- named_list(meframe$coef) Xme_regex <- paste0("^Xme_", escape_all(meframe$coef), "\\[") Xn <- sdata[paste0("Xn_", seq_rows(meframe))] noise <- sdata[paste0("noise_", seq_rows(meframe))] groups <- unique(meframe$grname) for (i in seq_along(groups)) { g <- groups[i] K <- which(meframe$grname %in% g) if (nzchar(g)) { Jme <- sdata[[paste0("Jme_", i)]] } if (!new && save_mevars) { # extract original draws of latent variables for (k in K) { out$Xme[[k]] <- prepare_draws(draws, Xme_regex[k], regex = TRUE) } } else { # sample new values of latent variables if (nzchar(g)) { # TODO: reuse existing levels in predictions? # represent all indices between 1 and length(unique(Jme)) Jme <- as.numeric(factor(Jme)) me_dim <- c(nrow(out$bsp), max(Jme)) } else { me_dim <- c(nrow(out$bsp), sdata$N) } for (k in K) { dXn <- data2draws(Xn[[k]], me_dim) dnoise <- data2draws(noise[[k]], me_dim) out$Xme[[k]] <- array(rnorm(prod(me_dim), dXn, dnoise), me_dim) remove(dXn, dnoise) } } if (nzchar(g)) { for (k in K) { out$Xme[[k]] <- out$Xme[[k]][, Jme, drop = FALSE] } } } } # prepare predictions specific to missing value variables dim <- c(nrow(out$bsp), sdata[[paste0("N", resp)]]) vars_mi <- unique(unlist(spframe$vars_mi)) if (length(vars_mi)) { # we know at this point that the model is multivariate Yl_names <- paste0("Yl_", vars_mi) out$Yl <- named_list(Yl_names) for (i in seq_along(out$Yl)) { vmi <- vars_mi[i] dim_y <- c(nrow(out$bsp), sdata[[paste0("N_", vmi)]]) Y <- data2draws(sdata[[paste0("Y_", vmi)]], dim_y) sdy <- sdata[[paste0("noise_", vmi)]] if (is.null(sdy)) { # missings only out$Yl[[i]] <- Y if (!new) { Ymi_regex <- paste0("^Ymi_", escape_all(vmi), "\\[") Ymi <- prepare_draws(draws, Ymi_regex, regex = TRUE) Jmi <- sdata[[paste0("Jmi_", vmi)]] out$Yl[[i]][, Jmi] <- Ymi } } else { # measurement-error in the response save_mevars <- any(grepl("^Yl_", colnames(draws))) if (save_mevars && !new) { Ymi_regex <- paste0("^Yl_", escape_all(vmi), "\\[") out$Yl[[i]] <- prepare_draws(draws, Ymi_regex, regex = TRUE) } else { warn_me <- warn_me || !new sdy <- data2draws(sdy, dim) out$Yl[[i]] <- rcontinuous( n = prod(dim), dist = "norm", mean = Y, sd = sdy, lb = sdata[[paste0("lbmi_", vmi)]], ub = sdata[[paste0("ubmi_", vmi)]] ) out$Yl[[i]] <- array(out$Yl[[i]], dim_y) } } } # extract index variables belonging to mi terms uni_mi <- na.omit(attr(spframe, "uni_mi")) idxl_vars <- paste0("idxl", p, "_", uni_mi$var, "_", uni_mi$idx2) out$idxl <- sdata[idxl_vars] } if (warn_me) { warning2( "Noise-free latent variables were not saved. ", "You can control saving those variables via 'save_pars()'. ", "Treating original data as if it was new data as a workaround." ) } # prepare covariates ncovars <- max(spframe$Ic) out$Csp <- vector("list", ncovars) for (i in seq_len(ncovars)) { out$Csp[[i]] <- sdata[[paste0("Csp", p, "_", i)]] out$Csp[[i]] <- data2draws(out$Csp[[i]], dim = dim) } out } # prepare predictions of category specific effects prepare_predictions_cs <- function(bframe, draws, sdata, ...) { stopifnot(is.bframel(bframe)) out <- list() if (!is_ordinal(bframe$family)) { return(out) } resp <- usc(bframe$resp) out$nthres <- sdata[[paste0("nthres", resp)]] csef <- bframe$frame$cs$vars if (length(csef)) { p <- usc(combine_prefix(bframe)) cs_pars <- paste0("^bcs", p, "_", escape_all(csef), "\\[") out$bcs <- prepare_draws(draws, cs_pars, regex = TRUE) out$Xcs <- sdata[[paste0("Xcs", p)]] } out } # prepare predictions of smooth terms prepare_predictions_sm <- function(bframe, draws, sdata, ...) { stopifnot(is.bframel(bframe)) out <- list() smframe <- bframe$frame$sm if (!has_rows(smframe)) { return(out) } p <- usc(combine_prefix(bframe)) Xs_names <- attr(smframe, "Xs_names") if (length(Xs_names)) { out$fe$Xs <- sdata[[paste0("Xs", p)]] # allow for "b_" prefix for compatibility with version <= 2.5.0 bspars <- paste0("^bs?", p, "_", escape_all(Xs_names), "$") out$fe$bs <- prepare_draws(draws, bspars, regex = TRUE) } out$re <- named_list(smframe$label) for (i in seq_rows(smframe)) { sm <- list() for (j in seq_len(smframe$nbases[i])) { sm$Zs[[j]] <- sdata[[paste0("Zs", p, "_", i, "_", j)]] spars <- paste0("^s", p, "_", smframe$label[i], "_", j, "\\[") sm$s[[j]] <- prepare_draws(draws, spars, regex = TRUE) } out$re[[i]] <- sm } out } # prepare predictions for Gaussian processes # @param new is new data used? # @param nug small numeric value to avoid numerical problems in GPs prepare_predictions_gp <- function(bframe, draws, sdata, new = FALSE, nug = NULL, ...) { stopifnot(is.bframel(bframe)) gpframe <- bframe$frame$gp if (!has_rows(gpframe)) { return(list()) } p <- usc(combine_prefix(bframe)) if (is.null(nug)) { # nug for old data must be the same as in the Stan code as even tiny # differences (e.g., 1e-12 vs. 1e-11) will matter for larger lscales nug <- ifelse(new, 1e-8, 1e-12) } out <- named_list(gpframe$label) for (i in seq_along(out)) { cons <- gpframe$cons[[i]] if (length(cons)) { gp <- named_list(cons) for (j in seq_along(cons)) { gp[[j]] <- .prepare_predictions_gp( gpframe, draws = draws, sdata = sdata, nug = nug, new = new, byj = j, p = p, i = i ) } attr(gp, "byfac") <- TRUE } else { gp <- .prepare_predictions_gp( gpframe, draws = draws, sdata = sdata, nug = nug, new = new, p = p, i = i ) } out[[i]] <- gp } out } # prepare predictions for Gaussian processes # @param gpframe output of frame_gp # @param p prefix created by combine_prefix() # @param i index of the Gaussian process # @param byj index for the contrast of a categorical 'by' variable # @return a list to be evaluated by .predictor_gp() .prepare_predictions_gp <- function(gpframe, draws, sdata, nug, new, p, i, byj = NULL) { sfx1 <- escape_all(gpframe$sfx1[[i]]) sfx2 <- escape_all(gpframe$sfx2[[i]]) if (is.null(byj)) { lvl <- "" } else { lvl <- gpframe$bylevels[[i]][byj] sfx1 <- sfx1[byj] sfx2 <- sfx2[byj, ] } j <- usc(byj) pi <- paste0(p, "_", i) gp <- list() gp$cov <- gpframe$cov[i] sdgp <- paste0("^sdgp", p, "_", sfx1, "$") gp$sdgp <- as.vector(prepare_draws(draws, sdgp, regex = TRUE)) lscale <- paste0("^lscale", p, "_", sfx2, "$") gp$lscale <- prepare_draws(draws, lscale, regex = TRUE) zgp_regex <- paste0("^zgp", p, "_", sfx1, "\\[") gp$zgp <- prepare_draws(draws, zgp_regex, regex = TRUE) Xgp_name <- paste0("Xgp", pi, j) Igp_name <- paste0("Igp", pi, j) Jgp_name <- paste0("Jgp", pi, j) if (new && isNA(gpframe$k[i])) { # in exact GPs old covariate values are required for predictions gp$x <- sdata[[paste0(Xgp_name, "_old")]] # nug for old data must be the same as in the Stan code as even tiny # differences (e.g., 1e-12 vs. 1e-11) will matter for larger lscales gp$nug <- 1e-12 # computing GPs for new data requires the old GP terms gp$yL <- .predictor_gp(gp) gp$x_new <- sdata[[Xgp_name]] gp$Igp <- sdata[[Igp_name]] } else { gp$x <- sdata[[Xgp_name]] gp$Igp <- sdata[[Igp_name]] if (!isNA(gpframe$k[i])) { gp$slambda <- sdata[[paste0("slambda", pi, j)]] } } gp$Jgp <- sdata[[Jgp_name]] # possible factor from 'by' variable gp$Cgp <- sdata[[paste0("Cgp", pi, j)]] gp$nug <- nug gp } # prepare predictions for all group level effects # needs to be separate from 'prepare_predictions_re' to take correlations # across responses and distributional parameters into account (#779) # @param old_reframe output of frame_re based on the original formula and data # @return a named list with one element per group containing posterior draws # of levels used in the data as well as additional meta-data prepare_predictions_re_global <- function(bframe, draws, sdata, old_reframe, resp = NULL, sample_new_levels = "uncertainty", ...) { reframe <- bframe$frame$re if (!has_rows(reframe)) { return(list()) } stopifnot(is.reframe(reframe)) # ensures subsetting 'reframe' by 'resp' works correctly resp <- resp %||% "" groups <- unique(reframe$group) old_levels <- get_levels(old_reframe) used_levels <- get_levels(sdata, prefix = "used") # used (new) levels are currently not available within the bframe argument # since it has been computed with the old data (but new formula) the likely # reason for this choice was to avoid running validate_newdata twice (in # prepare_predictions and standata). Perhaps this choice can can be # reconsidered in the future while avoiding multiple validate_newdata runs out <- named_list(groups, list()) for (g in groups) { # prepare general variables related to group g reframe_g <- subset2(reframe, group = g) old_reframe_g <- subset2(old_reframe, group = g) used_levels_g <- used_levels[[g]] old_levels_g <- old_levels[[g]] nlevels <- length(old_levels_g) nranef <- nrow(reframe_g) # prepare draws of group-level effects rpars <- paste0("^r_", g, "(__.+)?\\[") rdraws <- prepare_draws(draws, rpars, regex = TRUE) if (!length(rdraws)) { stop2( "Group-level coefficients of group '", g, "' not found. ", "You can control saving those coefficients via 'save_pars()'." ) } # only prepare predictions of effects specified in the new formula cols_match <- c("coef", "resp", "dpar", "nlpar") used_rpars <- which(find_rows(old_reframe_g, ls = reframe_g[cols_match])) used_rpars <- outer(seq_len(nlevels), (used_rpars - 1) * nlevels, "+") used_rpars <- as.vector(used_rpars) rdraws <- rdraws[, used_rpars, drop = FALSE] rdraws <- column_to_row_major_order(rdraws, nranef) # prepare data required for indexing parameters gtype <- reframe_g$gtype[1] resp_g <- intersect(reframe_g$resp, resp)[1] # any valid ID works here as J and W are independent of the ID id <- subset2(reframe_g, resp = resp)$id[1] idresp <- paste0(id, usc(resp_g)) if (gtype == "mm") { ngf <- length(reframe_g$gcall[[1]]$groups) gf <- sdata[paste0("J_", idresp, "_", seq_len(ngf))] weights <- sdata[paste0("W_", idresp, "_", seq_len(ngf))] } else { gf <- sdata[paste0("J_", idresp)] weights <- list(rep(1, length(gf[[1]]))) } # generate draws for new levels args_new_rdraws <- nlist( reframe = reframe_g, gf, used_levels = used_levels_g, old_levels = old_levels_g, rdraws = rdraws, draws, sample_new_levels ) new_rdraws <- do_call(get_new_rdraws, args_new_rdraws) max_level <- attr(new_rdraws, "max_level") gf <- attr(new_rdraws, "gf") rdraws <- cbind(rdraws, new_rdraws) # keep only those levels actually used in the current data levels <- unique(unlist(gf)) rdraws <- subset_levels(rdraws, levels, nranef) # store all information required in 'prepare_predictions_re' out[[g]]$reframe <- reframe_g out[[g]]$rdraws <- rdraws out[[g]]$levels <- levels out[[g]]$nranef <- nranef out[[g]]$max_level <- max_level out[[g]]$gf <- gf out[[g]]$weights <- weights } out } # prepare predictions of group-level effects # @param prep_re a named list with one element per group containing # posterior draws of levels as well as additional meta-data prepare_predictions_re <- function(bframe, sdata, prep_re = list(), sample_new_levels = "uncertainty", ...) { out <- list() if (!length(prep_re)) { return(out) } px <- check_prefix(bframe) p <- usc(combine_prefix(px)) reframe_px <- from_list(prep_re, "reframe") reframe_px <- do_call(rbind, reframe_px) reframe_px <- subset2(reframe_px, ls = px) if (!has_rows(reframe_px)) { return(out) } groups <- unique(reframe_px$group) # assigning S4 objects requires initialisation of list elements out[c("Z", "Zsp", "Zcs")] <- list(named_list(groups)) for (g in groups) { # extract variables specific to group 'g' reframe_g <- prep_re[[g]]$reframe reframe_g_px <- subset2(reframe_g, ls = px) rdraws <- prep_re[[g]]$rdraws nranef <- prep_re[[g]]$nranef levels <- prep_re[[g]]$levels max_level <- prep_re[[g]]$max_level gf <- prep_re[[g]]$gf weights <- prep_re[[g]]$weights # TODO: define 'select' according to parameter names not by position # store draws and corresponding data in the output # special group-level terms (mo, me, mi) reframe_g_px_sp <- subset2(reframe_g_px, type = "sp") if (nrow(reframe_g_px_sp)) { Z <- matrix(1, length(gf[[1]])) out[["Zsp"]][[g]] <- prepare_Z(Z, gf, max_level, weights) for (co in reframe_g_px_sp$coef) { # select from all varying effects of that group select <- find_rows(reframe_g, ls = px) & reframe_g$coef == co & reframe_g$type == "sp" select <- which(select) select <- select + nranef * (seq_along(levels) - 1) out[["rsp"]][[co]][[g]] <- rdraws[, select, drop = FALSE] } } # category specific group-level terms reframe_g_px_cs <- subset2(reframe_g_px, type = "cs") if (nrow(reframe_g_px_cs)) { # all categories share the same Z matrix reframe_g_px_cs_1 <- reframe_g_px_cs[grepl("\\[1\\]$", reframe_g_px_cs$coef), ] Znames <- paste0("Z_", reframe_g_px_cs_1$id, p, "_", reframe_g_px_cs_1$cn) Z <- do_call(cbind, sdata[Znames]) out[["Zcs"]][[g]] <- prepare_Z(Z, gf, max_level, weights) for (i in seq_len(sdata$nthres)) { index <- paste0("\\[", i, "\\]$") # select from all varying effects of that group select <- find_rows(reframe_g, ls = px) & grepl(index, reframe_g$coef) & reframe_g$type == "cs" select <- which(select) select <- as.vector(outer(select, nranef * (seq_along(levels) - 1), "+")) out[["rcs"]][[g]][[i]] <- rdraws[, select, drop = FALSE] } } # basic group-level terms reframe_g_px_basic <- subset2(reframe_g_px, type = c("", "mmc")) if (nrow(reframe_g_px_basic)) { Znames <- paste0("Z_", reframe_g_px_basic$id, p, "_", reframe_g_px_basic$cn) if (reframe_g_px_basic$gtype[1] == "mm") { ng <- length(reframe_g_px_basic$gcall[[1]]$groups) Z <- vector("list", ng) for (k in seq_len(ng)) { Z[[k]] <- do_call(cbind, sdata[paste0(Znames, "_", k)]) } } else { Z <- do_call(cbind, sdata[Znames]) } out[["Z"]][[g]] <- prepare_Z(Z, gf, max_level, weights) # select from all varying effects of that group select <- find_rows(reframe_g, ls = px) & reframe_g$type %in% c("", "mmc") select <- which(select) select <- as.vector(outer(select, nranef * (seq_along(levels) - 1), "+")) out[["r"]][[g]] <- rdraws[, select, drop = FALSE] } } out } # prepare predictions of autocorrelation parameters # @param nat_cov extract terms for covariance matrices of natural residuals? prepare_predictions_ac <- function(bframe, draws, sdata, oos = NULL, nat_cov = FALSE, new = FALSE, ...) { out <- list() nat_cov <- as_one_logical(nat_cov) acframe <- subset2(bframe$frame$ac, nat_cov = nat_cov) if (!has_rows(acframe)) { return(out) } stopifnot(is.acframe(acframe)) out$acframe <- acframe p <- usc(combine_prefix(bframe)) out$N_tg <- sdata[[paste0("N_tg", p)]] if (has_ac_class(acframe, "arma")) { acframe_arma <- subset2(acframe, class = "arma") out$Y <- sdata[[paste0("Y", p)]] if (!is.null(oos)) { if (any(oos > length(out$Y))) { stop2("'oos' should not contain integers larger than N.") } # .predictor_arma has special behavior for NA responses out$Y[oos] <- NA } out$J_lag <- sdata[[paste0("J_lag", p)]] if (acframe_arma$p > 0) { ar_regex <- paste0("^ar", p, "\\[") out$ar <- prepare_draws(draws, ar_regex, regex = TRUE) } if (acframe_arma$q > 0) { ma_regex <- paste0("^ma", p, "\\[") out$ma <- prepare_draws(draws, ma_regex, regex = TRUE) } } if (has_ac_class(acframe, "cosy")) { cosy_regex <- paste0("^cosy", p, "$") out$cosy <- prepare_draws(draws, cosy_regex, regex = TRUE) } if (has_ac_class(acframe, "unstr")) { cortime_regex <- paste0("^cortime", p, "__") out$cortime <- prepare_draws(draws, cortime_regex, regex = TRUE) out$Jtime_tg <- sdata[[paste0("Jtime_tg", p)]] } if (use_ac_cov_time(acframe)) { # prepare predictions for the covariance structures of time-series models out$begin_tg <- sdata[[paste0("begin_tg", p)]] out$end_tg <- sdata[[paste0("end_tg", p)]] } if (has_ac_latent_residuals(bframe)) { err_regex <- paste0("^err", p, "\\[") has_err <- any(grepl(err_regex, colnames(draws))) if (has_err && !new) { out$err <- prepare_draws(draws, err_regex, regex = TRUE) } else { if (!use_ac_cov_time(acframe)) { stop2("Cannot predict new latent residuals ", "when using cov = FALSE in autocor terms.") } # need to sample correlated residuals out$err <- matrix(nrow = nrow(draws), ncol = length(out$Y)) sderr_regex <- paste0("^sderr", p, "$") out$sderr <- prepare_draws(draws, sderr_regex, regex = TRUE) for (i in seq_len(out$N_tg)) { obs <- with(out, begin_tg[i]:end_tg[i]) Jtime <- out$Jtime_tg[i, ] cov <- get_cov_matrix_ac(list(ac = out), obs, Jtime = Jtime, latent = TRUE) zeros <- rep(0, length(obs)) .err <- function(s) rmulti_normal(1, zeros, Sigma = cov[s, , ]) out$err[, obs] <- rblapply(seq_rows(draws), .err) } } } if (has_ac_class(acframe, "sar")) { lagsar_regex <- paste0("^lagsar", p, "$") errorsar_regex <- paste0("^errorsar", p, "$") out$lagsar <- prepare_draws(draws, lagsar_regex, regex = TRUE) out$errorsar <- prepare_draws(draws, errorsar_regex, regex = TRUE) out$Msar <- sdata[[paste0("Msar", p)]] } if (has_ac_class(acframe, "car")) { acframe_car <- subset2(acframe, class = "car") if (new && acframe_car$gr == "NA") { stop2("Without a grouping factor, CAR models cannot handle newdata.") } gcar <- sdata[[paste0("Jloc", p)]] Zcar <- matrix(rep(1, length(gcar))) out$Zcar <- prepare_Z(Zcar, list(gcar)) rcar_regex <- paste0("^rcar", p, "\\[") rcar <- prepare_draws(draws, rcar_regex, regex = TRUE) rcar <- rcar[, unique(gcar), drop = FALSE] out$rcar <- rcar } if (has_ac_class(acframe, "fcor")) { out$Mfcor <- sdata[[paste0("Mfcor", p)]] } out } prepare_predictions_offset <- function(bframe, sdata, ...) { p <- usc(combine_prefix(bframe)) sdata[[paste0("offsets", p)]] } # prepare predictions of ordinal thresholds prepare_predictions_thres <- function(bframe, draws, sdata, ...) { out <- list() if (!is_ordinal(bframe$family)) { return(out) } resp <- usc(bframe$resp) out$nthres <- sdata[[paste0("nthres", resp)]] out$Jthres <- sdata[[paste0("Jthres", resp)]] p <- usc(combine_prefix(bframe)) thres_regex <- paste0("^b", p, "_Intercept\\[") out$thres <- prepare_draws(draws, thres_regex, regex = TRUE) out } # prepare predictions of baseline functions for the cox model prepare_predictions_bhaz <- function(bframe, draws, sdata, ...) { if (!is_cox(bframe$family)) { return(NULL) } out <- list() p <- usc(combine_prefix(bframe)) Zbhaz <- sdata[[paste0("Zbhaz", p)]] Zcbhaz <- sdata[[paste0("Zcbhaz", p)]] if (has_bhaz_groups(bframe)) { groups <- get_bhaz_groups(bframe) Jgrbhaz <- sdata[[paste0("Jgrbhaz", p)]] out$bhaz <- out$cbhaz <- matrix(nrow = nrow(draws), ncol = nrow(Zbhaz)) for (k in seq_along(groups)) { sbhaz_regex <- paste0("^sbhaz", p, "\\[", groups[k], ",") sbhaz <- prepare_draws(draws, sbhaz_regex, regex = TRUE) take <- Jgrbhaz == k out$bhaz[, take] <- tcrossprod(sbhaz, Zbhaz[take, ]) out$cbhaz[, take] <- tcrossprod(sbhaz, Zcbhaz[take, ]) } } else { sbhaz_regex <- paste0("^sbhaz", p) sbhaz <- prepare_draws(draws, sbhaz_regex, regex = TRUE) out$bhaz <- tcrossprod(sbhaz, Zbhaz) out$cbhaz <- tcrossprod(sbhaz, Zcbhaz) } out } # extract data mainly related to the response variable prepare_predictions_data <- function(bframe, sdata, stanvars = NULL, ...) { resp <- usc(combine_prefix(bframe)) vars <- c( "Y", "trials", "ncat", "nthres", "se", "weights", "denom", "dec", "cens", "rcens", "lb", "ub" ) vars <- paste0(vars, resp) vars <- intersect(vars, names(sdata)) # variables of variable length need to be handled via regular expression escaped_resp <- escape_all(resp) vl_vars <- c("vreal", "vint") vl_vars <- regex_or(vl_vars) vl_vars <- paste0("^", vl_vars, "[[:digit:]]+", escaped_resp, "$") vl_vars <- str_subset(names(sdata), vl_vars) vars <- union(vars, vl_vars) out <- sdata[vars] # remove resp suffix from names to simplify post-processing names(out) <- sub(paste0(escaped_resp, "$"), "", names(out)) if (length(stanvars)) { stopifnot(is.stanvars(stanvars)) out[names(stanvars)] <- sdata[names(stanvars)] } out } # choose number of observations to be used in post-processing methods choose_N <- function(prep) { stopifnot(is.brmsprep(prep) || is.mvbrmsprep(prep)) if (!is.null(prep$ac$N_tg)) prep$ac$N_tg else prep$nobs } # create pseudo brmsprep objects for components of mixture models # @param comp the mixture component number # @param draw_ids see predict_mixture pseudo_prep_for_mixture <- function(prep, comp, draw_ids = NULL) { stopifnot(is.brmsprep(prep), is.mixfamily(prep$family)) if (!is.null(draw_ids)) { ndraws <- length(draw_ids) } else { ndraws <- prep$ndraws } out <- list( family = prep$family$mix[[comp]], ndraws = ndraws, nobs = prep$nobs, data = prep$data ) out$family$fun <- out$family$family for (dp in valid_dpars(out$family)) { out$dpars[[dp]] <- prep$dpars[[paste0(dp, comp)]] if (length(draw_ids) && length(out$dpars[[dp]]) > 1L) { out$dpars[[dp]] <- p(out$dpars[[dp]], draw_ids, row = TRUE) } } if (is_ordinal(out$family)) { out$thres <- prep$thres[[paste0("mu", comp)]] } if (is_cox(out$family)) { out$bhaz <- prep$bhaz[[paste0("mu", comp)]] } # weighting should happen after computing the mixture out$data$weights <- NULL structure(out, class = "brmsprep") } # take relevant cols of a matrix of group-level terms # if only a subset of levels is provided (for newdata) # @param x a matrix typically draws of r or Z design matrices # draws need to be stored in row major order # @param levels grouping factor levels to keep # @param nranef number of group-level effects subset_levels <- function(x, levels, nranef) { take_levels <- ulapply(levels, function(l) ((l - 1) * nranef + 1):(l * nranef) ) x[, take_levels, drop = FALSE] } # transform x from column to row major order # rows represent levels and columns represent effects # @param x a matrix of draws of group-level parameters # @param nranef number of group-level effects column_to_row_major_order <- function(x, nranef) { nlevels <- ncol(x) / nranef sort_levels <- ulapply(seq_len(nlevels), function(l) seq(l, ncol(x), by = nlevels) ) x[, sort_levels, drop = FALSE] } # prepare group-level design matrices for use in 'predictor' # @param Z (list of) matrices to be prepared # @param gf (list of) vectors containing grouping factor values # @param weights optional (list of) weights of the same length as gf # @param max_level maximal level of 'gf' # @return a sparse matrix representation of Z prepare_Z <- function(Z, gf, max_level = NULL, weights = NULL) { if (!is.list(Z)) { Z <- list(Z) } if (!is.list(gf)) { gf <- list(gf) } if (is.null(weights)) { weights <- rep(1, length(gf[[1]])) } if (!is.list(weights)) { weights <- list(weights) } if (is.null(max_level)) { max_level <- max(unlist(gf)) } levels <- unique(unlist(gf)) nranef <- ncol(Z[[1]]) Z <- mapply( expand_matrix, A = Z, x = gf, weights = weights, MoreArgs = nlist(max_level) ) Z <- Reduce("+", Z) subset_levels(Z, levels, nranef) } # expand a matrix into a sparse matrix of higher dimension # @param A matrix to be expanded # @param x levels to expand the matrix # @param max_level maximal number of levels that x can take on # @param weights weights to apply to rows of A before expanding # @param a sparse matrix of dimension nrow(A) x (ncol(A) * max_level) expand_matrix <- function(A, x, max_level = max(x), weights = 1) { stopifnot(is.matrix(A)) stopifnot(length(x) == nrow(A)) stopifnot(all(is_wholenumber(x) & x > 0)) stopifnot(length(weights) %in% c(1, nrow(A), prod(dim(A)))) A <- A * as.vector(weights) K <- ncol(A) i <- rep(seq_along(x), each = K) make_j <- function(n, K, x) K * (x[n] - 1) + 1:K j <- ulapply(seq_along(x), make_j, K = K, x = x) Matrix::sparseMatrix( i = i, j = j, x = as.vector(t(A)), dims = c(nrow(A), ncol(A) * max_level) ) } # generate draws for new group levels # @param reframe 'reframe' object of only a single grouping variable # @param gf list of vectors of level indices in the current data # @param rdraws matrix of group-level draws in row major order # @param used_levels names of levels used in the current data # @param old_levels names of levels used in the original data # @param sample_new_levels specifies the way in which new draws are generated # @param draws optional matrix of draws from all model parameters # @return a matrix of draws for new group levels get_new_rdraws <- function(reframe, gf, rdraws, used_levels, old_levels, sample_new_levels, draws = NULL) { snl_options <- c("uncertainty", "gaussian", "old_levels") sample_new_levels <- match.arg(sample_new_levels, snl_options) g <- unique(reframe$group) stopifnot(length(g) == 1L) stopifnot(is.list(gf)) used_by_per_level <- attr(used_levels, "by") old_by_per_level <- attr(old_levels, "by") new_levels <- setdiff(used_levels, old_levels) nranef <- nrow(reframe) nlevels <- length(old_levels) max_level <- nlevels out <- vector("list", length(gf)) for (i in seq_along(gf)) { has_new_levels <- any(gf[[i]] > nlevels) if (has_new_levels) { new_indices <- sort(setdiff(gf[[i]], seq_len(nlevels))) out[[i]] <- matrix(NA, nrow(rdraws), nranef * length(new_indices)) if (sample_new_levels == "uncertainty") { for (j in seq_along(new_indices)) { # selected levels need to be the same for all varying effects # to correctly take their correlations into account if (length(old_by_per_level)) { # select from all levels matching the 'by' variable new_by <- used_by_per_level[used_levels == new_levels[j]] possible_levels <- old_levels[old_by_per_level == new_by] possible_levels <- which(old_levels %in% possible_levels) sel_levels <- sample(possible_levels, NROW(rdraws), TRUE) } else { # select from all levels sel_levels <- sample(seq_len(nlevels), NROW(rdraws), TRUE) } for (k in seq_len(nranef)) { for (s in seq_rows(rdraws)) { sel <- (sel_levels[s] - 1) * nranef + k out[[i]][s, (j - 1) * nranef + k] <- rdraws[s, sel] } } } } else if (sample_new_levels == "old_levels") { for (j in seq_along(new_indices)) { # choose an existing person to take the parameters from if (length(old_by_per_level)) { # select from all levels matching the 'by' variable new_by <- used_by_per_level[used_levels == new_levels[j]] possible_levels <- old_levels[old_by_per_level == new_by] possible_levels <- which(old_levels %in% possible_levels) sel_level <- sample(possible_levels, 1) } else { # select from all levels sel_level <- sample(seq_len(nlevels), 1) } for (k in seq_len(nranef)) { sel <- (sel_level - 1) * nranef + k out[[i]][, (j - 1) * nranef + k] <- rdraws[, sel] } } } else if (sample_new_levels == "gaussian") { if (any(!reframe$dist %in% "gaussian")) { stop2("Option sample_new_levels = 'gaussian' is not ", "available for non-gaussian group-level effects.") } for (j in seq_along(new_indices)) { # extract hyperparameters used to compute the covariance matrix if (length(old_by_per_level)) { new_by <- used_by_per_level[used_levels == new_levels[j]] rnames <- as.vector(get_rnames(reframe, bylevels = new_by)) } else { rnames <- get_rnames(reframe) } sd_pars <- paste0("sd_", g, "__", rnames) sd_draws <- prepare_draws(draws, sd_pars) cor_type <- paste0("cor_", g) cor_pars <- get_cornames(rnames, cor_type, brackets = FALSE) cor_draws <- matrix(0, nrow(sd_draws), length(cor_pars)) for (k in seq_along(cor_pars)) { if (cor_pars[k] %in% colnames(draws)) { cor_draws[, k] <- prepare_draws(draws, cor_pars[k]) } } cov_matrix <- get_cov_matrix(sd_draws, cor_draws) # sample new levels from the normal distribution # implied by the covariance matrix indices <- ((j - 1) * nranef + 1):(j * nranef) out[[i]][, indices] <- t(apply( cov_matrix, 1, rmulti_normal, n = 1, mu = rep(0, length(sd_pars)) )) } } max_level <- max_level + length(new_indices) } else { out[[i]] <- matrix(nrow = nrow(rdraws), ncol = 0) } } out <- do_call(cbind, out) structure(out, gf = gf, max_level = max_level) } # prepare draws of selected variables prepare_draws <- function(x, variable, ...) { x <- subset_draws(x, variable = variable, ...) # brms still assumes standard dropping behavior in many places # and so keeping the posterior format is dangerous at the moment unclass_draws(x) } # compute point estimates of posterior draws # currently used primarily for 'loo_subsample' # @param draws matrix of posterior draws # @param point_estimate optional name of the point estimate to be computed # @param ndraws_point_estimate number of repetitions of the point estimate's # value in the form of pseudo draws # @return a draws_matrix with one row point_draws <- function(draws, point_estimate = NULL, ndraws_point_estimate = 1) { if (is.null(point_estimate)) { return(draws) } point_estimate <- match.arg(point_estimate, c("mean", "median")) ndraws_point_estimate <- as_one_integer(ndraws_point_estimate) stopifnot(ndraws_point_estimate > 0) variables <- colnames(draws) if (point_estimate == "mean") { draws <- matrixStats::colMeans2(draws) } else if (point_estimate == "median") { draws <- matrixStats::colMedians(draws) } draws <- t(draws) draws <- matrix( draws, nrow = ndraws_point_estimate, ncol = ncol(draws), byrow = TRUE ) colnames(draws) <- variables as_draws_matrix(draws) } is.brmsprep <- function(x) { inherits(x, "brmsprep") } is.mvbrmsprep <- function(x) { inherits(x, "mvbrmsprep") } is.bprepl <- function(x) { inherits(x, "bprepl") } is.bprepnl <- function(x) { inherits(x, "bprepnl") } #' Prepare Predictions #' #' This method helps in preparing \pkg{brms} models for certain post-processing #' tasks most notably various forms of predictions. Unless you are a package #' developer, you will rarely need to call \code{prepare_predictions} directly. #' #' @name prepare_predictions #' @aliases prepare_predictions.brmsfit extract_draws #' #' @param x An \R object typically of class \code{'brmsfit'}. #' @param newdata An optional data.frame for which to evaluate predictions. If #' \code{NULL} (default), the original data of the model is used. \code{NA} #' values within factors (excluding grouping variables) are interpreted as if #' all dummy variables of this factor are zero. This allows, for instance, to #' make predictions of the grand mean when using sum coding. \code{NA} values #' within grouping variables are treated as a new level. #' @param re_formula formula containing group-level effects to be considered in #' the prediction. If \code{NULL} (default), include all group-level effects; #' if \code{NA} or \code{~0}, include no group-level effects. #' @param allow_new_levels A flag indicating if new levels of group-level #' effects are allowed (defaults to \code{FALSE}). Only relevant if #' \code{newdata} is provided. #'@param sample_new_levels Indicates how to sample new levels for grouping #' factors specified in \code{re_formula}. This argument is only relevant if #' \code{newdata} is provided and \code{allow_new_levels} is set to #' \code{TRUE}. If \code{"uncertainty"} (default), each posterior sample for a #' new level is drawn from the posterior draws of a randomly chosen existing #' level. Each posterior sample for a new level may be drawn from a different #' existing level such that the resulting set of new posterior draws #' represents the variation across existing levels. If \code{"gaussian"}, #' sample new levels from the (multivariate) normal distribution implied by the #' group-level standard deviations and correlations. This options may be useful #' for conducting Bayesian power analysis or predicting new levels in #' situations where relatively few levels where observed in the old_data. If #' \code{"old_levels"}, directly sample new levels from the existing levels, #' where a new level is assigned all of the posterior draws of the same #' (randomly chosen) existing level. #' @param newdata2 A named \code{list} of objects containing new data, which #' cannot be passed via argument \code{newdata}. Required for some objects #' used in autocorrelation structures, or \code{\link{stanvars}}. #' @param new_objects Deprecated alias of \code{newdata2}. #' @param incl_autocor A flag indicating if correlation structures originally #' specified via \code{autocor} should be included in the predictions. #' Defaults to \code{TRUE}. #' @param offset Logical; Indicates if offsets should be included in the #' predictions. Defaults to \code{TRUE}. #' @param oos Optional indices of observations for which to compute #' out-of-sample rather than in-sample predictions. Only required in models #' that make use of response values to make predictions, that is, currently #' only ARMA models. #' @param smooths_only Logical; If \code{TRUE} only predictions related to #' smoothing splines (i.e., \code{s} or \code{t2}) will be computed. #' Defaults to \code{FALSE}. #' @param resp Optional names of response variables. If specified, predictions #' are performed only for the specified response variables. #' @param ndraws Positive integer indicating how many posterior draws should #' be used. If \code{NULL} (the default) all draws are used. Ignored if #' \code{draw_ids} is not \code{NULL}. #' @param draw_ids An integer vector specifying the posterior draws to be used. #' If \code{NULL} (the default), all draws are used. #' @param nsamples Deprecated alias of \code{ndraws}. #' @param subset Deprecated alias of \code{draw_ids}. #' @param nug Small positive number for Gaussian process terms only. For #' numerical reasons, the covariance matrix of a Gaussian process might not be #' positive definite. Adding a very small number to the matrix's diagonal #' often solves this problem. If \code{NULL} (the default), \code{nug} is #' chosen internally. #' @param point_estimate Shall the returned object contain only point estimates #' of the parameters instead of their posterior draws? Defaults to #' \code{NULL} in which case no point estimate is computed. Alternatively, may #' be set to \code{"mean"} or \code{"median"}. This argument is primarily #' implemented to ensure compatibility with the \code{\link{loo_subsample}} #' method. #' @param ndraws_point_estimate Only used if \code{point_estimate} is not #' \code{NULL}. How often shall the point estimate's value be repeated? #' Defaults to \code{1}. #' @param ... Further arguments passed to \code{\link{validate_newdata}}. #' #' @return An object of class \code{'brmsprep'} or \code{'mvbrmsprep'}, #' depending on whether a univariate or multivariate model is passed. #' #' @export prepare_predictions <- function(x, ...) { UseMethod("prepare_predictions") } #' @export prepare_predictions.default <- function(x, ...) { NULL } # the name 'extract_draws' is deprecated as of brms 2.12.6 # remove it eventually in brms 3.0 #' @export extract_draws <- function(x, ...) { warning2("Method 'extract_draws' is deprecated. ", "Please use 'prepare_predictions' instead.") UseMethod("prepare_predictions") } brms/R/formula-sm.R0000644000176200001440000001001215053072461013620 0ustar liggesusers# This file contains functions dealing with the extended # formula syntax to specify smooth terms via mgcv #' Defining smooths in \pkg{brms} formulas #' #' Functions used in definition of smooth terms within a model formulas. #' The function does not evaluate a (spline) smooth - it exists purely #' to help set up a model using spline based smooths. #' #' @param ... Arguments passed to \code{\link[mgcv:s]{mgcv::s}} or #' \code{\link[mgcv:t2]{mgcv::t2}}. #' #' @details The function defined here are just simple wrappers of the respective #' functions of the \pkg{mgcv} package. When using them, please cite the #' appropriate references obtained via \code{citation("mgcv")}. #' #' \pkg{brms} uses the "random effects" parameterization of smoothing splines #' as explained in \code{\link[mgcv:gamm]{mgcv::gamm}}. A nice tutorial on this #' topic can be found in Pedersen et al. (2019). The answers provided in this #' \href{https://discourse.mc-stan.org/t/better-priors-non-flat-for-gams-brms/23012/4}{Stan discourse post} #' may also be helpful. #' #' @seealso \code{\link{brmsformula}}, #' \code{\link[mgcv:s]{mgcv::s}}, \code{\link[mgcv:t2]{mgcv::t2}} #' #' @references #' Pedersen, E. J., Miller, D. L., Simpson, G. L., & Ross, N. (2019). #' Hierarchical generalized additive models in ecology: an introduction with #' mgcv. PeerJ. #' #' @examples #' \dontrun{ #' # simulate some data #' dat <- mgcv::gamSim(1, n = 200, scale = 2) #' #' # fit univariate smooths for all predictors #' fit1 <- brm(y ~ s(x0) + s(x1) + s(x2) + s(x3), #' data = dat, chains = 2) #' summary(fit1) #' plot(conditional_smooths(fit1), ask = FALSE) #' #' # fit a more complicated smooth model #' fit2 <- brm(y ~ t2(x0, x1) + s(x2, by = x3), #' data = dat, chains = 2) #' summary(fit2) #' plot(conditional_smooths(fit2), ask = FALSE) #' } #' #' @export s <- function(...) { mgcv::s(...) } #' @rdname s #' @export t2 <- function(...) { mgcv::t2(...) } # extract information about smooth terms # @param x either a formula or a list containing an element "sm" # @param data optional data.frame containing the covariates # only required if frame_sm is called from outside of brmsframe frame_sm <- function(x, data = NULL) { if (is.formula(x)) { x <- brmsterms(x, check_response = FALSE)$dpars$mu } form <- x[["sm"]] if (!is.formula(form)) { return(empty_data_frame()) } # prepare information inferred from the data sdata <- x$sdata$sm if (is.null(sdata)) { # for compatibility with spline-specific post-processing methods sdata <- data_sm(x, data) } out <- data.frame(term = all_terms(form), stringsAsFactors = FALSE) nterms <- nrow(out) out$sfun <- get_matches("^[^\\(]+", out$term) out$vars <- out$byvars <- out$covars <- vector("list", nterms) for (i in seq_len(nterms)) { sm <- eval2(out$term[i]) out$covars[[i]] <- sm$term if (sm$by != "NA") { out$byvars[[i]] <- sm$by } out$vars[[i]] <- c(out$covars[[i]], out$byvars[[i]]) } out$label <- paste0(out$sfun, rename(ulapply(out$vars, collapse))) bylevels <- attr(sdata$Xs, "bylevels") nby <- lengths(bylevels) tmp <- vector("list", nterms) for (i in seq_len(nterms)) { tmp[[i]] <- out[i, , drop = FALSE] tmp[[i]]$termnum <- i if (nby[i] > 0L) { tmp[[i]] <- do_call(rbind, repl(tmp[[i]], nby[i])) tmp[[i]]$bylevel <- rm_wsp(bylevels[[i]]) tmp[[i]]$byterm <- paste0(tmp[[i]]$term, tmp[[i]]$bylevel) str_add(tmp[[i]]$label) <- rename(tmp[[i]]$bylevel) } else { tmp[[i]]$bylevel <- NA tmp[[i]]$byterm <- tmp[[i]]$term } } out <- do_call(rbind, tmp) out$knots <- sdata[grepl("^knots_", names(sdata))] out$nbases <- lengths(out$knots) attr(out, "Xs_names") <- colnames(sdata$Xs) rownames(out) <- NULL class(out) <- smframe_class() out } smframe_class <- function() { c("smframe", "data.frame") } is.smframe <- function(x) { inherits(x, "smframe") } # check if smooths are present in the model has_smooths <- function(bterms) { length(get_effect(bterms, target = "sm")) > 0L } brms/R/family-lists.R0000644000176200001440000004667315057477723014217 0ustar liggesusers# This file contains a list for every native family. # These lists may contain the following elements: # links: possible link function (first is default) # dpars: distributional parameters of the family # type: either real or int (i.e. continuous or discrete) # ybounds: area of definition of the response values # closed: is the interval closed or open? # ad: supported addition arguments # include: names of user-defined Stan functions # to be included in the Stan code # normalized: suffixes of Stan lpdfs or lpmfs which only exist as normalized # versions; can also be "" in which case the family is always normalized # specials: character vector specialties of some families # TODO: create an overview of all specials .family_gaussian <- function() { list( links = c("identity", "log", "inverse", "softplus", "squareplus", "logit", "probit", "probit_approx", "cloglog", "cauchit", "softit"), dpars = c("mu", "sigma"), type = "real", ybounds = c(-Inf, Inf), closed = c(NA, NA), ad = c("weights", "subset", "se", "cens", "trunc", "mi", "index"), normalized = c("_time_hom", "_time_het", "_lagsar", "_errorsar", "_fcor"), specials = c("residuals", "rescor") ) } .family_student <- function() { list( links = c("identity", "log", "inverse", "softplus", "squareplus", "logit", "probit", "probit_approx", "cloglog", "cauchit", "softit"), dpars = c("mu", "sigma", "nu"), type = "real", ybounds = c(-Inf, Inf), closed = c(NA, NA), ad = c("weights", "subset", "se", "cens", "trunc", "mi", "index"), include = "fun_logm1.stan", normalized = c("_time_hom", "_time_het", "_lagsar", "_errorsar", "_fcor"), specials = c("residuals", "rescor") ) } .family_skew_normal <- function() { list( links = c("identity", "log", "inverse", "softplus", "squareplus", "logit", "probit", "probit_approx", "cloglog", "cauchit", "softit"), dpars = c("mu", "sigma", "alpha"), type = "real", ybounds = c(-Inf, Inf), closed = c(NA, NA), ad = c("weights", "subset", "se", "cens", "trunc", "mi", "index") ) } .family_binomial <- function() { list( links = c( "logit", "probit", "probit_approx", "cloglog", "cauchit", "softit", "identity", "log" ), dpars = c("mu"), type = "int", ybounds = c(0, Inf), closed = c(TRUE, NA), ad = c("weights", "subset", "trials", "cens", "trunc", "index"), specials = "sbi_logit" ) } .family_xbeta <- function() { list( links = c( "logit", "probit", "probit_approx", "cloglog", "cauchit", "softit", "identity", "log" ), dpars = c("mu", "phi", "kappa"), type = "real", ybounds = c(0, 1), closed = c(TRUE, TRUE), ad = c("weights", "subset", "index"), include = "fun_xbeta.stan", prior = function(dpar, link = "identity", ...) { if (dpar == "kappa") { if (link == "identity") { return("gamma(0.01, 0.01)") } else { return("student_t(3, 0, 2.5)") } } NULL }, normalized = "" ) } .family_beta_binomial <- function() { list( links = c( "logit", "probit", "probit_approx", "cloglog", "cauchit", "softit", "identity" ), dpars = c("mu", "phi"), type = "int", ybounds = c(0, Inf), closed = c(TRUE, NA), ad = c("weights", "subset", "trials", "cens", "trunc", "index") ) } .family_bernoulli <- function() { list( links = c( "logit", "probit", "probit_approx", "cloglog", "cauchit", "softit", "identity", "log" ), dpars = c("mu"), type = "int", ybounds = c(0, 1), closed = c(TRUE, TRUE), ad = c("weights", "subset", "index"), specials = c("binary", "sbi_logit") ) } .family_categorical <- function() { list( links = "logit", dpars = NULL, multi_dpars = "mu", # size determined by the data type = "int", ybounds = c(-Inf, Inf), closed = c(NA, NA), ad = c("weights", "subset", "index"), specials = c("categorical", "joint_link", "sbi_logit") ) } .family_multinomial <- function() { list( links = "logit", dpars = NULL, multi_dpars = "mu", # size determined by the data type = "int", ybounds = c(-Inf, Inf), closed = c(NA, NA), ad = c("weights", "subset", "trials", "index"), specials = c("multinomial", "joint_link"), include = "fun_multinomial_logit.stan", normalized = "" ) } .family_dirichlet_multinomial <- function() { list( links = "logit", dpars = "phi", multi_dpars = "mu", # size determined by the data type = "int", ybounds = c(-Inf, Inf), closed = c(NA, NA), ad = c("weights", "subset", "trials", "index"), specials = c("multinomial", "joint_link"), include = "fun_dirichlet_multinomial_logit.stan", normalized = "" ) } .family_beta <- function() { list( links = c( "logit", "probit", "probit_approx", "cloglog", "cauchit", "softit", "identity", "log" ), dpars = c("mu", "phi"), type = "real", ybounds = c(0, 1), closed = c(FALSE, FALSE), ad = c("weights", "subset", "cens", "trunc", "mi", "index") ) } .family_dirichlet <- function() { list( links = "logit", dpars = "phi", multi_dpars = "mu", # size determined by the data type = "real", ybounds = c(0, 1), closed = c(FALSE, FALSE), ad = c("weights", "subset", "index"), specials = c("simplex", "joint_link"), include = "fun_dirichlet_logit.stan", normalized = "" ) } .family_dirichlet2 <- function() { list( links = c("log", "softplus", "squareplus", "identity", "logm1"), dpars = NULL, multi_dpars = "mu", # size determined by the data type = "real", ybounds = c(0, 1), closed = c(FALSE, FALSE), ad = c("weights", "subset", "index"), specials = c("simplex"), include = "fun_logm1.stan", normalized = "" ) } .family_logistic_normal <- function() { list( links = "identity", dpars = NULL, multi_dpars = c("mu", "sigma"), # size determined by the data type = "real", ybounds = c(0, 1), closed = c(FALSE, FALSE), ad = c("weights", "subset", "index"), specials = c("simplex", "logistic_normal", "joint_link"), include = "fun_logistic_normal.stan", normalized = "" ) } .family_poisson <- function() { list( links = c("log", "identity", "sqrt", "softplus", "squareplus"), dpars = c("mu"), type = "int", ybounds = c(0, Inf), closed = c(TRUE, NA), ad = c("weights", "subset", "cens", "trunc", "rate", "index"), specials = "sbi_log" ) } .family_negbinomial <- function() { list( links = c("log", "identity", "sqrt", "softplus", "squareplus"), dpars = c("mu", "shape"), type = "int", ybounds = c(0, Inf), closed = c(TRUE, NA), ad = c("weights", "subset", "cens", "trunc", "rate", "index"), specials = "sbi_log", prior = function(dpar, link = "identity", ...) { if (dpar == "shape" && link == "identity") { return("inv_gamma(0.4, 0.3)") } NULL } ) } # as negbinomial but with sigma = 1 / shape parameterization .family_negbinomial2 <- function() { list( links = c("log", "identity", "sqrt", "softplus", "squareplus"), dpars = c("mu", "sigma"), type = "int", ybounds = c(0, Inf), closed = c(TRUE, NA), ad = c("weights", "subset", "cens", "trunc", "rate", "index"), specials = "sbi_log", prior = function(dpar, link = "identity", ...) { if (dpar == "sigma" && link == "identity") { return("gamma(0.4, 0.3)") } NULL } ) } .family_geometric <- function() { list( links = c("log", "identity", "sqrt", "softplus", "squareplus"), dpars = c("mu"), type = "int", ybounds = c(0, Inf), closed = c(TRUE, NA), ad = c("weights", "subset", "cens", "trunc", "rate", "index"), specials = "sbi_log" ) } .family_discrete_weibull <- function() { list( links = c( "logit", "probit", "probit_approx", "cloglog", "cauchit", "softit", "identity" ), dpars = c("mu", "shape"), type = "int", ybounds = c(0, Inf), closed = c(TRUE, NA), ad = c("weights", "subset", "cens", "trunc", "index"), include = "fun_discrete_weibull.stan" ) } .family_com_poisson <- function() { list( links = c("log", "identity", "sqrt", "softplus", "squareplus"), dpars = c("mu", "shape"), type = "int", ybounds = c(0, Inf), closed = c(TRUE, NA), ad = c("weights", "subset", "cens", "trunc", "index"), include = "fun_com_poisson.stan", specials = "sbi_log" ) } .family_gamma <- function() { list( links = c("log", "identity", "inverse", "softplus", "squareplus"), dpars = c("mu", "shape"), type = "real", ybounds = c(0, Inf), closed = c(FALSE, NA), ad = c("weights", "subset", "cens", "trunc", "mi", "index") ) } .family_weibull <- function() { list( links = c("log", "identity", "inverse", "softplus", "squareplus"), dpars = c("mu", "shape"), type = "real", ybounds = c(0, Inf), closed = c(FALSE, NA), ad = c("weights", "subset", "cens", "trunc", "mi", "index") ) } .family_exponential <- function() { list( links = c("log", "identity", "inverse", "softplus", "squareplus"), dpars = "mu", type = "real", ybounds = c(0, Inf), closed = c(FALSE, NA), ad = c("weights", "subset", "cens", "trunc", "mi", "index") ) } .family_frechet <- function() { list( links = c("log", "identity", "inverse", "softplus", "squareplus"), dpars = c("mu", "nu"), type = "real", ybounds = c(0, Inf), closed = c(FALSE, NA), ad = c("weights", "subset", "cens", "trunc", "mi", "index"), include = "fun_logm1.stan" ) } .family_inverse.gaussian <- function() { list( links = c("1/mu^2", "inverse", "identity", "log", "softplus", "squareplus"), dpars = c("mu", "shape"), type = "real", ybounds = c(0, Inf), closed = c(FALSE, NA), ad = c("weights", "subset", "cens", "trunc", "mi", "index"), include = "fun_inv_gaussian.stan" ) } .family_lognormal <- function() { list( links = c("identity", "inverse"), dpars = c("mu", "sigma"), type = "real", ybounds = c(0, Inf), closed = c(FALSE, NA), ad = c("weights", "subset", "cens", "trunc", "mi", "index"), specials = "logscale" ) } .family_shifted_lognormal <- function() { list( links = c("identity", "inverse"), dpars = c("mu", "sigma", "ndt"), type = "real", ybounds = c(0, Inf), closed = c(FALSE, NA), ad = c("weights", "subset", "cens", "trunc", "index"), specials = "logscale" ) } .family_exgaussian <- function() { list( links = c("identity", "log", "inverse", "softplus", "squareplus"), dpars = c("mu", "sigma", "beta"), type = "real", ybounds = c(-Inf, Inf), closed = c(NA, NA), ad = c("weights", "subset", "cens", "trunc", "mi", "index") ) } .family_wiener <- function() { list( links = c("identity", "log", "softplus", "squareplus"), dpars = c("mu", "bs", "ndt", "bias"), type = "real", ybounds = c(0, Inf), closed = c(FALSE, NA), ad = c("weights", "subset", "dec", "index"), include = "fun_wiener_diffusion.stan", normalized = "" ) } .family_gen_extreme_value <- function() { list( links = c("identity", "log", "inverse", "softplus", "squareplus"), dpars = c("mu", "sigma", "xi"), tmp_dpars = "xi", type = "real", ybounds = c(-Inf, Inf), closed = c(NA, NA), ad = c("weights", "subset", "cens", "trunc", "mi", "index"), include = c("fun_gen_extreme_value.stan", "fun_scale_xi.stan"), normalized = "" ) } .family_von_mises <- function() { list( links = c("tan_half", "identity"), dpars = c("mu", "kappa"), type = "real", ybounds = c(-pi, pi), closed = c(TRUE, TRUE), ad = c("weights", "subset", "cens", "trunc", "mi", "index"), include = c("fun_tan_half.stan"), normalized = "", prior = function(dpar, link = "identity", ...) { if (dpar == "mu" && link == "tan_half") { return("student_t(1, 0, 1)") } NULL } ) } .family_asym_laplace <- function() { list( links = c("identity", "log", "inverse", "softplus", "squareplus"), dpars = c("mu", "sigma", "quantile"), type = "real", ybounds = c(-Inf, Inf), closed = c(NA, NA), ad = c("weights", "subset", "cens", "trunc", "mi", "index"), include = "fun_asym_laplace.stan", normalized = "" ) } .family_zero_inflated_asym_laplace <- function() { list( links = c("identity", "log", "inverse", "softplus", "squareplus"), dpars = c("mu", "sigma", "quantile", "zi"), type = "real", ybounds = c(-Inf, Inf), closed = c(NA, NA), ad = c("weights", "subset", "cens", "trunc", "index"), include = c("fun_asym_laplace.stan", "fun_zero_inflated_asym_laplace.stan") ) } .family_cox <- function() { list( links = c("log", "identity", "softplus", "squareplus"), dpars = c("mu"), type = "real", ybounds = c(0, Inf), closed = c(TRUE, NA), ad = c("weights", "subset", "cens", "trunc", "index", "bhaz"), include = "fun_cox.stan", specials = c("cox", "sbi_log", "sbi_log_cdf"), normalized = "" ) } .family_cumulative <- function() { list( links = c( "logit", "probit", "probit_approx", "cloglog", "cauchit", "softit" ), dpars = c("mu", "disc"), type = "int", ybounds = c(-Inf, Inf), closed = c(NA, NA), ad = c("weights", "subset", "thres", "cat", "index"), specials = c( "ordinal", "ordered_thres", "thres_minus_eta", "joint_link", "ocs", "sbi_logit" ), normalized = "" ) } .family_sratio <- function() { list( links = c( "logit", "probit", "probit_approx", "cloglog", "cauchit" # , "softit" ), dpars = c("mu", "disc"), type = "int", ybounds = c(-Inf, Inf), closed = c(NA, NA), ad = c("weights", "subset", "thres", "cat", "index"), specials = c("ordinal", "cs", "thres_minus_eta", "joint_link"), normalized = "" ) } .family_cratio <- function() { list( links = c( "logit", "probit", "probit_approx", "cloglog", "cauchit" # , "softit" ), dpars = c("mu", "disc"), type = "int", ybounds = c(-Inf, Inf), closed = c(NA, NA), ad = c("weights", "subset", "thres", "cat", "index"), specials = c("ordinal", "cs", "eta_minus_thres", "joint_link"), normalized = "" ) } .family_acat <- function() { list( links = c( "logit", "probit", "probit_approx", "cloglog", "cauchit", "softit" ), dpars = c("mu", "disc"), type = "int", ybounds = c(-Inf, Inf), closed = c(NA, NA), ad = c("weights", "subset", "thres", "cat", "index"), specials = c("ordinal", "cs", "eta_minus_thres", "joint_link"), normalized = "" ) } .family_hurdle_poisson <- function() { list( links = c("log", "identity", "sqrt", "softplus", "squareplus"), dpars = c("mu", "hu"), type = "int", ybounds = c(0, Inf), closed = c(TRUE, NA), ad = c("weights", "subset", "cens", "trunc", "index"), include = "fun_hurdle_poisson.stan", specials = c("sbi_log", "sbi_hu_logit"), normalized = "" ) } .family_hurdle_negbinomial <- function() { list( links = c("log", "identity", "sqrt", "softplus", "squareplus"), dpars = c("mu", "shape", "hu"), type = "int", ybounds = c(0, Inf), closed = c(TRUE, NA), ad = c("weights", "subset", "cens", "trunc", "index"), include = "fun_hurdle_negbinomial.stan", specials = c("sbi_log", "sbi_hu_logit"), normalized = "", prior = function(dpar, link = "identity", ...) { if (dpar == "shape" && link == "identity") { return("inv_gamma(0.4, 0.3)") } NULL } ) } .family_hurdle_gamma <- function() { list( links = c("log", "identity", "inverse", "softplus", "squareplus"), dpars = c("mu", "shape", "hu"), type = "real", ybounds = c(0, Inf), closed = c(TRUE, NA), ad = c("weights", "subset", "cens", "trunc", "index"), include = "fun_hurdle_gamma.stan", specials = c("sbi_hu_logit", "cont_hurdle"), normalized = "" ) } .family_hurdle_lognormal <- function() { list( links = c("identity", "inverse"), dpars = c("mu", "sigma", "hu"), type = "real", ybounds = c(0, Inf), closed = c(TRUE, NA), ad = c("weights", "subset", "cens", "trunc", "index"), include = "fun_hurdle_lognormal.stan", specials = c("logscale", "sbi_hu_logit", "cont_hurdle"), normalized = "" ) } .family_hurdle_cumulative <- function() { list( links = c( "logit", "probit", "probit_approx", "cloglog", "cauchit", "softit" ), dpars = c("mu", "hu", "disc"), type = "int", ybounds = c(-Inf, Inf), closed = c(NA, NA), ad = c("weights", "subset", "thres", "cat", "index"), specials = c( "ordinal", "ordered_thres", "thres_minus_eta", "joint_link", "ocs", "sbi_logit", "extra_cat" ), normalized = "" ) } .family_zero_inflated_poisson <- function() { list( links = c("log", "identity", "sqrt", "softplus", "squareplus"), dpars = c("mu", "zi"), type = "int", ybounds = c(0, Inf), closed = c(TRUE, NA), ad = c("weights", "subset", "cens", "trunc", "index"), include = "fun_zero_inflated_poisson.stan", specials = c("sbi_log", "sbi_zi_logit"), normalized = "" ) } .family_zero_inflated_negbinomial <- function() { list( links = c("log", "identity", "sqrt", "softplus", "squareplus"), dpars = c("mu", "shape", "zi"), type = "int", ybounds = c(0, Inf), closed = c(TRUE, NA), ad = c("weights", "subset", "cens", "trunc", "index"), include = "fun_zero_inflated_negbinomial.stan", specials = c("sbi_log", "sbi_zi_logit"), normalized = "", prior = function(dpar, link = "identity", ...) { if (dpar == "shape" && link == "identity") { return("inv_gamma(0.4, 0.3)") } NULL } ) } .family_zero_inflated_binomial <- function() { list( links = c( "logit", "probit", "probit_approx", "cloglog", "cauchit", "softit", "identity", "log" ), dpars = c("mu", "zi"), type = "int", ybounds = c(0, Inf), closed = c(TRUE, NA), ad = c("weights", "subset", "trials", "cens", "trunc", "index"), include = "fun_zero_inflated_binomial.stan", specials = c("sbi_logit", "sbi_zi_logit"), normalized = "" ) } .family_zero_inflated_beta_binomial <- function() { list( links = c( "logit", "probit", "probit_approx", "cloglog", "cauchit", "softit", "identity", "log" ), dpars = c("mu", "phi", "zi"), type = "int", ybounds = c(0, Inf), closed = c(TRUE, NA), ad = c("weights", "subset", "trials", "cens", "trunc", "index"), include = "fun_zero_inflated_beta_binomial.stan", specials = c("sbi_zi_logit"), normalized = "" ) } .family_zero_inflated_beta <- function() { list( links = c( "logit", "probit", "probit_approx", "cloglog", "cauchit", "softit", "identity", "log" ), dpars = c("mu", "phi", "zi"), type = "real", ybounds = c(0, 1), closed = c(TRUE, FALSE), ad = c("weights", "subset", "cens", "trunc", "index"), include = "fun_zero_inflated_beta.stan", specials = c("sbi_zi_logit", "cont_hurdle"), normalized = "" ) } .family_zero_one_inflated_beta <- function() { list( links = c( "logit", "probit", "probit_approx", "cloglog", "cauchit", "softit", "identity", "log" ), dpars = c("mu", "phi", "zoi", "coi"), type = "real", ybounds = c(0, 1), closed = c(TRUE, TRUE), ad = c("weights", "subset", "index"), include = "fun_zero_one_inflated_beta.stan", specials = c("sbi_zi_logit", "cont_hurdle"), normalized = "" ) } .family_custom <- function() { list( ad = c("weights", "subset", "se", "cens", "trunc", "trials", "thres", "cat", "dec", "mi", "index", "vreal", "vint"), ybounds = c(-Inf, Inf), closed = c(NA, NA) ) } brms/R/stan-likelihood.R0000644000176200001440000014033615053072461014641 0ustar liggesusers# unless otherwise specified, functions return a single character # string defining the likelihood of the model in Stan language # Stan code for the log likelihood stan_log_lik <- function(x, ...) { UseMethod("stan_log_lik") } #' @export stan_log_lik.brmsterms <- function(x, ...) { if (is.mixfamily(x$family)) { out <- stan_log_lik_mixfamily(x, ...) } else { out <- stan_log_lik_family(x, ...) } out } #' @export stan_log_lik.mvbrmsterms <- function(x, ...) { if (x$rescor) { out <- stan_log_lik(as.brmsterms(x), ...) } else { out <- ulapply(x$terms, stan_log_lik, ...) } out } # Stan code for the log likelihood of a regular family stan_log_lik_family <- function(bterms, threads, ...) { stopifnot(is.brmsterms(bterms)) # prepare family part of the likelihood log_lik_args <- nlist(bterms, threads, ...) log_lik_fun <- prepare_family(bterms)$fun log_lik_fun <- paste0("stan_log_lik_", log_lik_fun) ll <- do_call(log_lik_fun, log_lik_args) # incorporate other parts into the likelihood args <- nlist(ll, bterms, threads, ...) mix <- get_mix_id(bterms) if (nzchar(mix)) { out <- do_call(stan_log_lik_mix, args) } else if (is.formula(bterms$adforms$cens)) { out <- do_call(stan_log_lik_cens, args) } else if (is.formula(bterms$adforms$weights)) { out <- do_call(stan_log_lik_weights, args) } else { out <- do_call(stan_log_lik_general, args) } if (grepl(stan_nn_regex(), out) && !nzchar(mix)) { # loop over likelihood if it cannot be vectorized resp <- usc(bterms$resp) out <- paste0( " for (n in 1:N", resp, ") {\n", stan_nn_def(threads), " ", out, " }\n" ) } out } # Stan code for the log likelihood of a mixture family stan_log_lik_mixfamily <- function(bterms, threads, ...) { stopifnot(is.brmsterms(bterms), is.mixfamily(bterms$family)) dp_ids <- dpar_id(names(bterms$dpars)) fdp_ids <- dpar_id(names(bterms$fdpars)) pred_mix_prob <- any(dpar_class(names(bterms$dpars)) %in% "theta") ll <- rep(NA, length(bterms$family$mix)) for (i in seq_along(ll)) { sbterms <- bterms sbterms$family <- sbterms$family$mix[[i]] sbterms$dpars <- sbterms$dpars[dp_ids == i] sbterms$fdpars <- sbterms$fdpars[fdp_ids == i] ll[i] <- stan_log_lik_family( sbterms, pred_mix_prob = pred_mix_prob, threads = threads, ... ) } resp <- usc(bterms$resp) n <- stan_nn(threads) has_weights <- has_ad_terms(bterms, "weights") weights <- str_if(has_weights, glue("weights{resp}{n} * ")) out <- glue( " // likelihood of the mixture model\n", " for (n in 1:N{resp}) {{\n", stan_nn_def(threads), " array[{length(ll)}] real ps;\n" ) str_add(out) <- collapse(" ", ll) str_add(out) <- glue( " {tp()}{weights}log_sum_exp(ps);\n", " }}\n" ) out } # default likelihood in Stan language stan_log_lik_general <- function(ll, bterms, threads, normalize, ...) { stopifnot(is.sdist(ll)) require_n <- grepl(stan_nn_regex(), ll$args) n <- str_if(require_n, stan_nn(threads), stan_slice(threads)) lpdf <- stan_log_lik_lpdf_name(bterms, normalize, dist = ll$dist) Y <- stan_log_lik_Y_name(bterms) resp <- usc(bterms$resp) tr <- stan_log_lik_trunc(ll, bterms, threads = threads, ...) glue("{tp()}{ll$dist}_{lpdf}({Y}{resp}{n}{ll$shift} | {ll$args}){tr};\n") } # censored likelihood in Stan language stan_log_lik_cens <- function(ll, bterms, threads, normalize, ...) { stopifnot(is.sdist(ll)) cens <- eval_rhs(bterms$adforms$cens) lpdf <- stan_log_lik_lpdf_name(bterms, normalize, dist = ll$dist) Y <- stan_log_lik_Y_name(bterms) resp <- usc(bterms$resp) tp <- tp() has_weights <- has_ad_terms(bterms, "weights") has_trunc <- has_ad_terms(bterms, "trunc") has_interval_cens <- has_interval_cens(bterms) if (ll$vec && !(has_interval_cens || has_weights || has_trunc)) { # vectorized log-likelihood contributions # cannot vectorize over interval censored observations as # vectorized lpdf functions return scalars not vectors (#1657) types <- c("event", "rcens", "lcens") J <- args <- named_list(types) for (t in types) { Jt <- glue("J{t}{resp}[1:N{t}{resp}]") J[[t]] <- glue("[{Jt}]") if (use_threading(threads)) { Jtms <- glue("[add_int({Jt}, start - 1)]") args[[t]] <- rename(ll$args, c("[n]", "[nn]"), c(J[[t]], Jtms)) J[[t]] <- Jtms } else { args[[t]] <- rename(ll$args, "[n]", J[[t]]) } } out <- glue( " // vectorized log-likelihood contributions of censored data\n", "{tp}{ll$dist}_{lpdf}(Y{resp}{J$event}{ll$shift} | {args$event});\n", "{tp}{ll$dist}_lccdf(Y{resp}{J$rcens}{ll$shift} | {args$rcens});\n", "{tp}{ll$dist}_lcdf(Y{resp}{J$lcens}{ll$shift} | {args$lcens});\n" ) } else { # non-vectorized likelihood contributions n <- stan_nn(threads) w <- str_if(has_weights, glue("weights{resp}{n} * ")) tr <- stan_log_lik_trunc(ll, bterms, threads = threads) out <- glue( " // special treatment of censored data\n", " if (cens{resp}{n} == 0) {{\n", " {tp}{w}{ll$dist}_{lpdf}(Y{resp}{n}{ll$shift} | {ll$args}){tr};\n", " }} else if (cens{resp}{n} == 1) {{\n", " {tp}{w}{ll$dist}_lccdf(Y{resp}{n}{ll$shift} | {ll$args}){tr};\n", " }} else if (cens{resp}{n} == -1) {{\n", " {tp}{w}{ll$dist}_lcdf(Y{resp}{n}{ll$shift} | {ll$args}){tr};\n" ) if (has_interval_cens) { str_add(out) <- glue( " }} else if (cens{resp}{n} == 2) {{\n", " {tp}{w}log_diff_exp(\n", " {ll$dist}_lcdf(rcens{resp}{n}{ll$shift} | {ll$args}),\n", " {ll$dist}_lcdf(Y{resp}{n}{ll$shift} | {ll$args})\n", " ){tr};\n" ) } str_add(out) <- glue(" }}\n") } out } # weighted likelihood in Stan language stan_log_lik_weights <- function(ll, bterms, threads, normalize, ...) { stopifnot(is.sdist(ll)) tr <- stan_log_lik_trunc(ll, bterms, threads = threads) lpdf <- stan_log_lik_lpdf_name(bterms, normalize, dist = ll$dist) Y <- stan_log_lik_Y_name(bterms) resp <- usc(bterms$resp) n <- stan_nn(threads) glue( "{tp()}weights{resp}{n} * ({ll$dist}_{lpdf}", "({Y}{resp}{n}{ll$shift} | {ll$args}){tr});\n" ) } # likelihood of a single mixture component # @param pred_mix_prob are mixing proportions predicted? stan_log_lik_mix <- function(ll, bterms, pred_mix_prob, threads, normalize, ...) { stopifnot(is.sdist(ll)) resp <- usc(bterms$resp) mix <- get_mix_id(bterms) theta <- str_if(pred_mix_prob, glue("theta{mix}{resp}[n]"), glue("log(theta{mix}{resp})") ) tr <- stan_log_lik_trunc(ll, bterms, threads = threads) lpdf <- stan_log_lik_lpdf_name(bterms, normalize, dist = ll$dist) Y <- stan_log_lik_Y_name(bterms) n <- stan_nn(threads) if (is.formula(bterms$adforms$cens)) { # mostly copied over from stan_log_lik_cens # no vectorized version available for mixture models cens <- eval_rhs(bterms$adforms$cens) out <- glue( " // special treatment of censored data\n", " if (cens{resp}{n} == 0) {{\n", " ps[{mix}] = {theta} + ", "{ll$dist}_{lpdf}({Y}{resp}{n}{ll$shift} | {ll$args}){tr};\n", " }} else if (cens{resp}{n} == 1) {{\n", " ps[{mix}] = {theta} + ", "{ll$dist}_lccdf({Y}{resp}{n}{ll$shift} | {ll$args}){tr};\n", " }} else if (cens{resp}{n} == -1) {{\n", " ps[{mix}] = {theta} + ", "{ll$dist}_lcdf({Y}{resp}{n}{ll$shift} | {ll$args}){tr};\n" ) if (has_interval_cens(bterms)) { str_add(out) <- glue( " }} else if (cens{resp}{n} == 2) {{\n", " ps[{mix}] = {theta} + log_diff_exp(\n", " {ll$dist}_lcdf(rcens{resp}{n}{ll$shift} | {ll$args}),\n", " {ll$dist}_lcdf({Y}{resp}{n}{ll$shift} | {ll$args})\n", " ){tr};\n" ) } str_add(out) <- glue(" }}\n") } else { out <- glue( "ps[{mix}] = {theta} + ", "{ll$dist}_{lpdf}({Y}{resp}{n}{ll$shift} | {ll$args}){tr};\n" ) } out } # truncated part of the likelihood # @param short use the T[, ] syntax? stan_log_lik_trunc <- function(ll, bterms, threads, short = FALSE, ...) { stopifnot(is.sdist(ll)) bounds <- bterms$frame$resp$bounds if (!any(bounds$lb > -Inf | bounds$ub < Inf)) { return("") } resp <- usc(bterms$resp) n <- stan_nn(threads) m1 <- str_if(use_int(bterms), " - 1") lb <- str_if(any(bounds$lb > -Inf), glue("lb{resp}{n}{m1}")) ub <- str_if(any(bounds$ub < Inf), glue("ub{resp}{n}")) if (short) { # truncation using T[, ] syntax out <- glue(" T[{lb}, {ub}]") } else { # truncation making use of _lcdf functions ms <- paste0(" -\n", wsp(nsp = 6)) if (any(bounds$lb > -Inf) && !any(bounds$ub < Inf)) { out <- glue("{ms}{ll$dist}_lccdf({lb}{ll$shift} | {ll$args})") } else if (!any(bounds$lb > -Inf) && any(bounds$ub < Inf)) { out <- glue("{ms}{ll$dist}_lcdf({ub}{ll$shift} | {ll$args})") } else if (any(bounds$lb > -Inf) && any(bounds$ub < Inf)) { trr <- glue("{ll$dist}_lcdf({ub}{ll$shift} | {ll$args})") trl <- glue("{ll$dist}_lcdf({lb}{ll$shift} | {ll$args})") out <- glue("{ms}log_diff_exp({trr}, {trl})") } } out } stan_log_lik_lpdf_name <- function(bterms, normalize, dist = NULL) { if (!is.null(dist) && !normalize) { # some Stan lpdfs or lpmfs only exist as normalized versions always_normalized <- always_normalized(bterms) if (length(always_normalized)) { always_normalized <- paste0(escape_all(always_normalized), "$") normalize <- any(ulapply(always_normalized, grepl, x = dist)) } } if (normalize) { out <- ifelse(use_int(bterms$family), "lpmf", "lpdf") } else { out <- ifelse(use_int(bterms$family), "lupmf", "lupdf") } out } stan_log_lik_Y_name <- function(bterms) { ifelse(is.formula(bterms$adforms$mi), "Yl", "Y") } # prepare Stan code for distributional parameters # @param reqn will the likelihood be wrapped in a loop over n? # @param dpars optional names of distributional parameters to be prepared # if not specified will prepare all distributional parameters # @param type optional type of distribution parameters to be extract # see valid_dpars() for details # @return a named list with elements containing the Stan code per parameter stan_log_lik_dpars <- function(bterms, reqn = stan_log_lik_adj(bterms), dpars = NULL, type = NULL, ...) { resp <- usc(bterms$resp) mix <- get_mix_id(bterms) if (is.null(dpars)) { dpars <- paste0(valid_dpars(bterms, type = type), mix) } pred_dpars <- names(bterms$dpars) if (is_equal(type, "multi")) { pred_dpars <- unique(dpar_class(pred_dpars, bterms)) } is_pred <- dpars %in% pred_dpars out <- paste0(dpars, resp, ifelse(reqn & is_pred, "[n]", "")) named_list(dpars, out) } # stan code for log likelihood variables originating from addition terms stan_log_lik_advars <- function(bterms, advars, reqn = stan_log_lik_adj(bterms), threads = NULL, ...) { slice <- str_if(reqn, stan_nn(threads), stan_slice(threads)) out <- paste0(advars, usc(bterms$resp), slice) named_list(advars, out) } # adjust lpdf name if a more efficient version is available # for a specific link. For instance 'poisson_log' stan_log_lik_simple_lpdf <- function(lpdf, bterms, sep = "_") { stopifnot(is.brmsterms(bterms)) if (stan_has_built_in_fun(bterms)) { lpdf <- paste0(lpdf, sep, bterms$family$link) } lpdf } # prepare _logit suffix for distributional parameters # used in zero-inflated and hurdle models stan_log_lik_dpar_usc_logit <- function(bterms, dpar) { stopifnot(is.brmsterms(bterms)) stopifnot(dpar %in% c("zi", "hu")) has_cens_or_trunc <- has_ad_terms(bterms, c("cens", "trunc")) usc_logit <- isTRUE(bterms$dpars[[dpar]]$family$link == "logit") str_if(usc_logit && !has_cens_or_trunc, "_logit") } # add 'se' to 'sigma' within the Stan likelihood stan_log_lik_add_se <- function(sigma, bterms, reqn = stan_log_lik_adj(bterms), threads = NULL, ...) { if (!has_ad_terms(bterms, "se")) { return(sigma) } nse <- str_if(reqn, stan_nn(threads), stan_slice(threads)) resp <- usc(bterms$resp) if (no_sigma(bterms)) { sigma <- glue("se{resp}{nse}") } else { sigma <- glue("sqrt(square({sigma}) + se2{resp}{nse})") } sigma } # multiply 'dpar' by the 'rate' denominator within the Stan likelihood # @param log add the rate denominator on the log scale if sensible? stan_log_lik_multiply_rate_denom <- function( dpar, bterms, reqn = stan_log_lik_adj(bterms), log = FALSE, transform = NULL, threads = NULL, ...) { dpar_transform <- dpar if (!is.null(transform)) { dpar_transform <- glue("{transform}({dpar})") } if (!is.formula(bterms$adforms$rate)) { return(dpar_transform) } resp <- usc(bterms$resp) ndenom <- str_if(reqn, stan_nn(threads), stan_slice(threads)) denom <- glue("denom{resp}{ndenom}") has_cens_or_trunc <- has_ad_terms(bterms, c("cens", "trunc")) if (log && bterms$family$link == "log" && !has_cens_or_trunc) { denom <- glue("log_{denom}") operator <- "+" } else { # dpar without resp name or index dpar_clean <- sub("(_|\\[).*", "", dpar) is_pred <- dpar_clean %in% c("mu", names(bterms$dpars)) operator <- ".*" } glue("{dpar_transform} {operator} {denom}") } # check if the log-likelihood needs to be adjusted to a non-vectorized form # either because of addition terms or mixture modeling # @param terms vector of addition term names # @return a single logical value stan_log_lik_adj <- function(bterms, terms = c("weights", "cens", "trunc")) { stopifnot(is.brmsterms(bterms)) terms <- match.arg(terms, several.ok = TRUE) mix <- get_mix_id(bterms) has_ad_terms(bterms, terms) || any(nzchar(mix)) } # one function per family stan_log_lik_gaussian <- function(bterms, ...) { if (use_glm_primitive(bterms)) { p <- args_glm_primitive(bterms$dpars$mu, ...) p$sigma <- paste0("sigma", usc(bterms$resp)) out <- sdist("normal_id_glm", p$x, p$alpha, p$beta, p$sigma) } else { p <- stan_log_lik_dpars(bterms) p$sigma <- stan_log_lik_add_se(p$sigma, bterms, ...) out <- sdist("normal", p$mu, p$sigma) } out } stan_log_lik_gaussian_mv <- function(bterms,...) { reqn <- stan_log_lik_adj(bterms) || bterms$sigma_pred p <- list(Mu = paste0("Mu", str_if(reqn, "[n]"))) p$LSigma <- paste0("LSigma", str_if(bterms$sigma_pred, "[n]")) sdist("multi_normal_cholesky", p$Mu, p$LSigma) } stan_log_lik_gaussian_time <- function(bterms, ...) { if (stan_log_lik_adj(bterms)) { stop2("Invalid addition arguments for this model.") } has_se <- is.formula(bterms$adforms$se) flex <- has_ac_class(bterms$frame$ac, "unstr") p <- stan_log_lik_dpars(bterms, reqn = FALSE) v <- c("Lcortime", "nobs_tg", "begin_tg", "end_tg") if (has_se) { c(v) <- "se2" } if (flex) { c(v) <- "Jtime_tg" } p[v] <- as.list(paste0(v, usc(bterms$resp))) sfx <- str_if("sigma" %in% names(bterms$dpars), "het", "hom") sfx <- str_if(has_se, paste0(sfx, "_se"), sfx) sfx <- str_if(flex, paste0(sfx, "_flex"), sfx) sdist(glue("normal_time_{sfx}"), p$mu, p$sigma, p$se2, p$Lcortime, p$nobs_tg, p$begin_tg, p$end_tg, p$Jtime_tg ) } stan_log_lik_gaussian_fcor <- function(bterms, ...) { if (stan_log_lik_adj(bterms) || has_ad_terms(bterms, "se")) { stop2("Invalid addition arguments for this model.") } p <- stan_log_lik_dpars(bterms, reqn = FALSE) p$Lfcor <- paste0("Lfcor", usc(bterms$resp)) sfx <- str_if("sigma" %in% names(bterms$dpars), "het", "hom") sdist(glue("normal_fcor_{sfx}"), p$mu, p$sigma, p$Lfcor) } stan_log_lik_gaussian_lagsar <- function(bterms, ...) { p <- stan_log_lik_dpars(bterms, reqn = FALSE) p$sigma <- stan_log_lik_add_se(p$sigma, bterms, reqn = FALSE, ...) v <- c("lagsar", "Msar", "eigenMsar") p[v] <- as.list(paste0(v, usc(bterms$resp))) sdist("normal_lagsar", p$mu, p$sigma, p$lagsar, p$Msar, p$eigenMsar) } stan_log_lik_gaussian_errorsar <- function(bterms, ...) { p <- stan_log_lik_dpars(bterms, reqn = FALSE) p$sigma <- stan_log_lik_add_se(p$sigma, bterms, reqn = FALSE, ...) v <- c("errorsar", "Msar", "eigenMsar") p[v] <- as.list(paste0(v, usc(bterms$resp))) sdist("normal_errorsar", p$mu, p$sigma, p$errorsar, p$Msar, p$eigenMsar) } stan_log_lik_student <- function(bterms, ...) { p <- stan_log_lik_dpars(bterms) p$sigma <- stan_log_lik_add_se(p$sigma, bterms, ...) sdist("student_t", p$nu, p$mu, p$sigma) } stan_log_lik_student_mv <- function(bterms, ...) { reqn <- stan_log_lik_adj(bterms) || bterms$sigma_pred p <- stan_log_lik_dpars(bterms, reqn = reqn, dpars = "nu") p$Mu <- paste0("Mu", str_if(reqn, "[n]")) p$Sigma <- paste0("Sigma", str_if(bterms$sigma_pred, "[n]")) sdist("multi_student_t", p$nu, p$Mu, p$Sigma) } stan_log_lik_student_time <- function(bterms, ...) { if (stan_log_lik_adj(bterms)) { stop2("Invalid addition arguments for this model.") } has_se <- is.formula(bterms$adforms$se) flex <- has_ac_class(bterms$frame$ac, "unstr") p <- stan_log_lik_dpars(bterms, reqn = FALSE) v <- c("Lcortime", "nobs_tg", "begin_tg", "end_tg") if (has_se) { c(v) <- "se2" } if (flex) { c(v) <- "Jtime_tg" } p[v] <- as.list(paste0(v, usc(bterms$resp))) sfx <- str_if("sigma" %in% names(bterms$dpars), "het", "hom") sfx <- str_if(has_se, paste0(sfx, "_se"), sfx) sfx <- str_if(flex, paste0(sfx, "_flex"), sfx) sdist(glue("student_t_time_{sfx}"), p$nu, p$mu, p$sigma, p$se2, p$Lcortime, p$nobs_tg, p$begin_tg, p$end_tg, p$Jtime_tg ) } stan_log_lik_student_fcor <- function(bterms, ...) { if (stan_log_lik_adj(bterms) || has_ad_terms(bterms, "se")) { stop2("Invalid addition arguments for this model.") } p <- stan_log_lik_dpars(bterms, reqn = FALSE) p$Lfcor <- paste0("Lfcor", usc(bterms$resp)) sfx <- str_if("sigma" %in% names(bterms$dpars), "het", "hom") sdist(glue("student_t_fcor_{sfx}"), p$nu, p$mu, p$sigma, p$Lfcor) } stan_log_lik_student_lagsar <- function(bterms,...) { p <- stan_log_lik_dpars(bterms, reqn = FALSE) p$sigma <- stan_log_lik_add_se(p$sigma, bterms, reqn = FALSE, ...) v <- c("lagsar", "Msar", "eigenMsar") p[v] <- as.list(paste0(v, usc(bterms$resp))) sdist("student_t_lagsar", p$nu, p$mu, p$sigma, p$lagsar, p$Msar, p$eigenMsar) } stan_log_lik_student_errorsar <- function(bterms, ...) { p <- stan_log_lik_dpars(bterms, reqn = FALSE) p$sigma <- stan_log_lik_add_se(p$sigma, bterms, reqn = FALSE, ...) v <- c("errorsar", "Msar", "eigenMsar") p[v] <- as.list(paste0(v, usc(bterms$resp))) sdist("student_t_errorsar", p$nu, p$mu, p$sigma, p$errorsar, p$Msar, p$eigenMsar) } stan_log_lik_lognormal <- function(bterms, ...) { p <- stan_log_lik_dpars(bterms) sdist("lognormal", p$mu, p$sigma) } stan_log_lik_shifted_lognormal <- function(bterms, ...) { p <- stan_log_lik_dpars(bterms) sdist("lognormal", p$mu, p$sigma, shift = paste0(" - ", p$ndt)) } stan_log_lik_asym_laplace <- function(bterms,...) { p <- stan_log_lik_dpars(bterms, reqn = TRUE) sdist("asym_laplace", p$mu, p$sigma, p$quantile, vec = FALSE) } stan_log_lik_skew_normal <- function(bterms, ...) { p <- stan_log_lik_dpars(bterms) p$sigma <- stan_log_lik_add_se(p$sigma, bterms, ...) # required because of CP parameterization of mu and sigma mix <- get_mix_id(bterms) resp <- usc(bterms$resp) reqn <- any(grepl(stan_nn_regex(), c(p$sigma, p$alpha))) p$omega <- paste0("omega", mix, resp, str_if(reqn, "[n]")) sdist("skew_normal", p$mu, p$omega, p$alpha) } stan_log_lik_poisson <- function(bterms, ...) { if (use_glm_primitive(bterms)) { p <- args_glm_primitive(bterms$dpars$mu, ...) out <- sdist("poisson_log_glm", p$x, p$alpha, p$beta) } else { p <- stan_log_lik_dpars(bterms) p$mu <- stan_log_lik_multiply_rate_denom(p$mu, bterms, log = TRUE, ...) lpdf <- stan_log_lik_simple_lpdf("poisson", bterms) out <- sdist(lpdf, p$mu) } out } stan_log_lik_negbinomial <- function(bterms, ...) { if (use_glm_primitive(bterms)) { p <- args_glm_primitive(bterms$dpars$mu, ...) p$shape <- paste0("shape", usc(bterms$resp)) out <- sdist("neg_binomial_2_log_glm", p$x, p$alpha, p$beta, p$shape) } else { p <- stan_log_lik_dpars(bterms) p$mu <- stan_log_lik_multiply_rate_denom(p$mu, bterms, log = TRUE, ...) p$shape <- stan_log_lik_multiply_rate_denom(p$shape, bterms, ...) lpdf <- stan_log_lik_simple_lpdf("neg_binomial_2", bterms) out <- sdist(lpdf, p$mu, p$shape) } out } stan_log_lik_negbinomial2 <- function(bterms, ...) { if (use_glm_primitive(bterms)) { p <- args_glm_primitive(bterms$dpars$mu, ...) p$sigma <- paste0("sigma", usc(bterms$resp)) p$shape <- paste0("inv(", p$sigma, ")") out <- sdist("neg_binomial_2_log_glm", p$x, p$alpha, p$beta, p$shape) } else { p <- stan_log_lik_dpars(bterms) p$mu <- stan_log_lik_multiply_rate_denom(p$mu, bterms, log = TRUE, ...) p$shape <- stan_log_lik_multiply_rate_denom( p$sigma, bterms, transform = "inv", ... ) lpdf <- stan_log_lik_simple_lpdf("neg_binomial_2", bterms) out <- sdist(lpdf, p$mu, p$shape) } out } stan_log_lik_geometric <- function(bterms, ...) { if (use_glm_primitive(bterms)) { p <- args_glm_primitive(bterms$dpars$mu, ...) p$shape <- "1" out <- sdist("neg_binomial_2_log_glm", p$x, p$alpha, p$beta, p$shape) } else { p <- stan_log_lik_dpars(bterms) p$shape <- "1" p$mu <- stan_log_lik_multiply_rate_denom(p$mu, bterms, log = TRUE, ...) p$shape <- stan_log_lik_multiply_rate_denom(p$shape, bterms, ...) lpdf <- stan_log_lik_simple_lpdf("neg_binomial_2", bterms) out <- sdist(lpdf, p$mu, p$shape) } } stan_log_lik_binomial <- function(bterms, ...) { p <- stan_log_lik_dpars(bterms) p$trials <- stan_log_lik_advars(bterms, "trials", ...)$trials lpdf <- stan_log_lik_simple_lpdf("binomial", bterms) sdist(lpdf, p$trials, p$mu) } stan_log_lik_beta_binomial <- function(bterms, ...) { p <- stan_log_lik_dpars(bterms) p$trials <- stan_log_lik_advars(bterms, "trials", ...)$trials sdist( "beta_binomial", p$trials, paste0(p$mu, " .* ", p$phi), paste0("(1 - ", p$mu, ") .* ", p$phi) ) } stan_log_lik_bernoulli <- function(bterms, ...) { if (use_glm_primitive(bterms)) { p <- args_glm_primitive(bterms$dpars$mu, ...) out <- sdist("bernoulli_logit_glm", p$x, p$alpha, p$beta) } else { p <- stan_log_lik_dpars(bterms) lpdf <- stan_log_lik_simple_lpdf("bernoulli", bterms) out <- sdist(lpdf, p$mu) } out } stan_log_lik_discrete_weibull <- function(bterms, ...) { p <- stan_log_lik_dpars(bterms, reqn = TRUE) sdist("discrete_weibull", p$mu, p$shape, vec = FALSE) } stan_log_lik_com_poisson <- function(bterms, ...) { p <- stan_log_lik_dpars(bterms, reqn = TRUE) lpdf <- stan_log_lik_simple_lpdf("com_poisson", bterms) sdist(lpdf, p$mu, p$shape, vec = FALSE) } stan_log_lik_gamma <- function(bterms, ...) { reqn <- stan_log_lik_adj(bterms) p <- stan_log_lik_dpars(bterms, reqn = reqn) # Stan uses shape-rate parameterization with rate = shape / mean sdist("gamma", p$shape, paste0(p$shape, " ./ ", p$mu)) } stan_log_lik_exponential <- function(bterms, ...) { p <- stan_log_lik_dpars(bterms) # Stan uses rate parameterization with rate = 1 / mean sdist("exponential", paste0("inv(", p$mu, ")")) } stan_log_lik_weibull <- function(bterms, ...) { p <- stan_log_lik_dpars(bterms) # Stan uses shape-scale parameterization for weibull p$scale <- paste0(p$mu, " ./ tgamma(1 + 1 ./ ", p$shape, ")") sdist("weibull", p$shape, p$scale) } stan_log_lik_frechet <- function(bterms, ...) { p <- stan_log_lik_dpars(bterms) # Stan uses shape-scale parameterization for frechet p$scale <- paste0(p$mu, " ./ tgamma(1 - 1 ./ ", p$nu, ")") sdist("frechet", p$nu, p$scale) } stan_log_lik_gen_extreme_value <- function(bterms, ...) { p <- stan_log_lik_dpars(bterms, reqn = TRUE) sdist("gen_extreme_value", p$mu, p$sigma, p$xi, vec = FALSE) } stan_log_lik_exgaussian <- function(bterms, ...) { p <- stan_log_lik_dpars(bterms) sdist( "exp_mod_normal", paste0(p$mu, " - ", p$beta), p$sigma, paste0("inv(", p$beta, ")") ) } stan_log_lik_inverse.gaussian <- function(bterms, ...) { is_pred_shape <- is_pred_dpar(bterms, "shape") reqn <- stan_log_lik_adj(bterms) || is_pred_shape p <- stan_log_lik_dpars(bterms, reqn = reqn) sdist("inv_gaussian", p$mu, p$shape, vec = FALSE) } stan_log_lik_wiener <- function(bterms, ...) { p <- stan_log_lik_dpars(bterms, reqn = TRUE) p$dec <- stan_log_lik_advars(bterms, "dec", reqn = TRUE, ...)$dec sdist("wiener_diffusion", p$dec, p$bs, p$ndt, p$bias, p$mu, vec = FALSE) } stan_log_lik_beta <- function(bterms, ...) { p <- stan_log_lik_dpars(bterms) sdist("beta", paste0(p$mu, " .* ", p$phi), paste0("(1 - ", p$mu, ") .* ", p$phi) ) } stan_log_lik_xbeta <- function(bterms, ...) { p <- stan_log_lik_dpars(bterms) sdist("xbeta", p$mu, p$phi, p$kappa) } stan_log_lik_von_mises <- function(bterms, ...) { p <- stan_log_lik_dpars(bterms) sdist("von_mises", p$mu, p$kappa) } stan_log_lik_cox <- function(bterms, ...) { p <- stan_log_lik_dpars(bterms) c(p) <- stan_log_lik_advars(bterms, c("bhaz", "cbhaz")) lpdf <- stan_log_lik_simple_lpdf("cox", bterms) sdist(lpdf, p$mu, p$bhaz, p$cbhaz, vec = TRUE) } stan_log_lik_cumulative <- function(bterms, ...) { if (use_glm_primitive(bterms)) { p <- args_glm_primitive(bterms$dpars$mu, ...) out <- sdist("ordered_logistic_glm", p$x, p$beta, p$alpha) } else { out <- stan_log_lik_ordinal(bterms, ...) } out } stan_log_lik_sratio <- function(bterms, ...) { stan_log_lik_ordinal(bterms, ...) } stan_log_lik_cratio <- function(bterms, ...) { stan_log_lik_ordinal(bterms, ...) } stan_log_lik_acat <- function(bterms, ...) { stan_log_lik_ordinal(bterms, ...) } stan_log_lik_categorical <- function(bterms, ...) { stopifnot(bterms$family$link == "logit") if (use_glm_primitive_categorical(bterms)) { bterms1 <- bterms$dpars[[1]] bterms1$family <- bterms$family p <- args_glm_primitive(bterms1, ...) out <- sdist("categorical_logit_glm", p$x, p$alpha, p$beta) } else { p <- stan_log_lik_dpars(bterms, reqn = TRUE, dpars = "mu", type = "multi") out <- sdist("categorical_logit", p$mu, vec = FALSE) } out } stan_log_lik_multinomial <- function(bterms, ...) { stopifnot(bterms$family$link == "logit") p <- stan_log_lik_dpars(bterms, reqn = TRUE, dpars = "mu", type = "multi") sdist("multinomial_logit2", p$mu, vec = FALSE) } stan_log_lik_dirichlet_multinomial <- function(bterms, ...) { stopifnot(bterms$family$link == "logit") mu <- stan_log_lik_dpars(bterms, reqn = TRUE, dpars = "mu", type = "multi")$mu reqn_phi <- is_pred_dpar(bterms, "phi") phi <- stan_log_lik_dpars(bterms, reqn = reqn_phi, dpars = "phi")$phi sdist("dirichlet_multinomial_logit2", mu, phi, vec = FALSE) } stan_log_lik_dirichlet <- function(bterms, ...) { stopifnot(bterms$family$link == "logit") mu <- stan_log_lik_dpars(bterms, reqn = TRUE, dpars = "mu", type = "multi")$mu reqn_phi <- is_pred_dpar(bterms, "phi") phi <- stan_log_lik_dpars(bterms, reqn = reqn_phi, dpars = "phi")$phi sdist("dirichlet_logit", mu, phi, vec = FALSE) } stan_log_lik_dirichlet2 <- function(bterms,...) { mu <- stan_log_lik_dpars(bterms, reqn = TRUE, dpars = "mu", type = "multi")$mu sdist("dirichlet", mu, vec = FALSE) } stan_log_lik_logistic_normal <- function(bterms, ...) { stopifnot(bterms$family$link == "identity") resp <- usc(bterms$resp) mix <- get_mix_id(bterms) p <- stan_log_lik_dpars(bterms, reqn = TRUE, type = "multi") p$Llncor <- glue("Llncor{mix}{resp}") p$refcat <- get_refcat(bterms$family, int = TRUE) sdist( "logistic_normal_cholesky_cor", p$mu, p$sigma, p$Llncor, p$refcat, vec = FALSE ) } stan_log_lik_ordinal <- function(bterms, ...) { p <- stan_log_lik_dpars(bterms, reqn = TRUE) if (use_ordered_builtin(bterms, "logit")) { lpdf <- "ordered_logistic" p[grepl("^disc", names(p))] <- NULL } else if (use_ordered_builtin(bterms, "probit")) { lpdf <- "ordered_probit" p[grepl("^disc", names(p))] <- NULL } else { lpdf <- paste0(bterms$family$family, "_", bterms$family$link) } if (has_thres_groups(bterms)) { str_add(lpdf) <- "_merged" p$Jthres <- stan_log_lik_advars(bterms, "Jthres", reqn = TRUE, ...)$Jthres p$thres <- "merged_Intercept" } else { p$thres <- "Intercept" } resp <- usc(bterms$resp) mix <- get_mix_id(bterms) prefix <- paste0(str_if(nzchar(mix), paste0("_mu", mix)), resp) str_add(p$thres) <- prefix if (has_sum_to_zero_thres(bterms)) { str_add(p$thres) <- "_stz" } if (has_cs(bterms)) { if (has_thres_groups(bterms)) { stop2("Cannot use category specific effects ", "in models with multiple thresholds.") } str_add(p$thres) <- paste0(" - transpose(mucs", prefix, "[n])") } sdist(lpdf, p$mu, p$disc, p$thres, p$Jthres, vec = FALSE) } stan_log_lik_hurdle_poisson <- function(bterms, ...) { p <- stan_log_lik_dpars(bterms, reqn = TRUE) lpdf <- stan_log_lik_simple_lpdf("hurdle_poisson", bterms) lpdf <- paste0(lpdf, stan_log_lik_dpar_usc_logit(bterms, "hu")) sdist(lpdf, p$mu, p$hu, vec = FALSE) } stan_log_lik_hurdle_negbinomial <- function(bterms, ...) { p <- stan_log_lik_dpars(bterms, reqn = TRUE) lpdf <- stan_log_lik_simple_lpdf("hurdle_neg_binomial", bterms) lpdf <- paste0(lpdf, stan_log_lik_dpar_usc_logit(bterms, "hu")) sdist(lpdf, p$mu, p$shape, p$hu, vec = FALSE) } stan_log_lik_hurdle_gamma <- function(bterms, ...) { p <- stan_log_lik_dpars(bterms, reqn = TRUE) usc_logit <- stan_log_lik_dpar_usc_logit(bterms, "hu") lpdf <- paste0("hurdle_gamma", usc_logit) # Stan uses shape-rate parameterization for gamma with rate = shape / mean sdist(lpdf, p$shape, paste0(p$shape, " / ", p$mu), p$hu, vec = FALSE) } stan_log_lik_hurdle_lognormal <- function(bterms, ...) { p <- stan_log_lik_dpars(bterms, reqn = TRUE) usc_logit <- stan_log_lik_dpar_usc_logit(bterms, "hu") lpdf <- paste0("hurdle_lognormal", usc_logit) sdist(lpdf, p$mu, p$sigma, p$hu, vec = FALSE) } stan_log_lik_hurdle_cumulative <- function(bterms, ...) { p <- stan_log_lik_dpars(bterms, reqn = TRUE) if (use_ordered_builtin(bterms, "logit")) { lpdf <- "hurdle_cumulative_ordered_logistic" } else if (use_ordered_builtin(bterms, "probit")) { lpdf <- "hurdle_cumulative_ordered_probit" } else { lpdf <- paste0(bterms$family$family, "_", bterms$family$link) } if (has_thres_groups(bterms)) { str_add(lpdf) <- "_merged" p$Jthres <- stan_log_lik_advars(bterms, "Jthres", reqn = TRUE, ...)$Jthres p$thres <- "merged_Intercept" } else { p$thres <- "Intercept" } resp <- usc(bterms$resp) mix <- get_mix_id(bterms) prefix <- paste0(str_if(nzchar(mix), paste0("_mu", mix)), resp) str_add(p$thres) <- prefix if (has_sum_to_zero_thres(bterms)) { str_add(p$thres) <- "_stz" } if (has_cs(bterms)) { if (has_thres_groups(bterms)) { stop2("Cannot use category specific effects ", "in models with multiple thresholds.") } str_add(p$thres) <- paste0(" - transpose(mucs", prefix, "[n])") } sdist(lpdf, p$mu, p$hu, p$disc, p$thres, p$Jthres, vec = FALSE) } stan_log_lik_zero_inflated_poisson <- function(bterms, ...) { p <- stan_log_lik_dpars(bterms, reqn = TRUE) lpdf <- stan_log_lik_simple_lpdf("zero_inflated_poisson", bterms) lpdf <- paste0(lpdf, stan_log_lik_dpar_usc_logit(bterms, "zi")) sdist(lpdf, p$mu, p$zi, vec = FALSE) } stan_log_lik_zero_inflated_negbinomial <- function(bterms, ...) { p <- stan_log_lik_dpars(bterms, reqn = TRUE) lpdf <- stan_log_lik_simple_lpdf("zero_inflated_neg_binomial", bterms) lpdf <- paste0(lpdf, stan_log_lik_dpar_usc_logit(bterms, "zi")) sdist(lpdf, p$mu, p$shape, p$zi, vec = FALSE) } stan_log_lik_zero_inflated_binomial <- function(bterms, ...) { p <- stan_log_lik_dpars(bterms, reqn = TRUE) p$trials <- stan_log_lik_advars(bterms, "trials", reqn = TRUE, ...)$trials lpdf <- "zero_inflated_binomial" lpdf <- stan_log_lik_simple_lpdf(lpdf, bterms, sep = "_b") lpdf <- paste0(lpdf, stan_log_lik_dpar_usc_logit(bterms, "zi")) sdist(lpdf, p$trials, p$mu, p$zi, vec = FALSE) } stan_log_lik_zero_inflated_beta_binomial <- function(bterms, ...) { p <- stan_log_lik_dpars(bterms, reqn = TRUE) p$trials <- stan_log_lik_advars(bterms, "trials", reqn = TRUE, ...)$trials lpdf <- "zero_inflated_beta_binomial" lpdf <- paste0(lpdf, stan_log_lik_dpar_usc_logit(bterms, "zi")) sdist(lpdf, p$trials, p$mu, p$phi, p$zi, vec = FALSE) } stan_log_lik_zero_inflated_beta <- function(bterms, ...) { p <- stan_log_lik_dpars(bterms, reqn = TRUE) usc_logit <- stan_log_lik_dpar_usc_logit(bterms, "zi") lpdf <- paste0("zero_inflated_beta", usc_logit) sdist(lpdf, p$mu, p$phi, p$zi, vec = FALSE) } stan_log_lik_zero_one_inflated_beta <- function(bterms, ...) { p <- stan_log_lik_dpars(bterms, reqn = TRUE) sdist("zero_one_inflated_beta", p$mu, p$phi, p$zoi, p$coi, vec = FALSE) } stan_log_lik_zero_inflated_asym_laplace <- function(bterms, ...) { p <- stan_log_lik_dpars(bterms, reqn = TRUE) usc_logit <- stan_log_lik_dpar_usc_logit(bterms, "zi") lpdf <- paste0("zero_inflated_asym_laplace", usc_logit) sdist(lpdf, p$mu, p$sigma, p$quantile, p$zi, vec = FALSE) } stan_log_lik_custom <- function(bterms, threads = NULL, ...) { family <- bterms$family no_loop <- isFALSE(family$loop) if (no_loop && (stan_log_lik_adj(bterms))) { stop2("This model requires evaluating the custom ", "likelihood as a loop over observations.") } resp <- usc(bterms$resp) p <- stan_log_lik_dpars(bterms, reqn = !no_loop) mix <- get_mix_id(bterms) dpars <- paste0(family$dpars, mix) if (is_ordinal(family)) { prefix <- paste0(resp, if (nzchar(mix)) paste0("_mu", mix)) p$thres <- paste0("Intercept", prefix) } # insert the response name into the 'vars' strings # addition terms contain the response in their variable name n <- stan_nn(threads) var_names <- sub("\\[.+$", "", family$vars) var_indices <- get_matches("\\[.+$", family$vars, first = TRUE) has_n_index <- var_indices %in% "[n]" if (no_loop && any(has_n_index)) { stop2("Invalid use of index '[n]' in an unlooped custom likelihood.") } var_indices <- ifelse(has_n_index, n, var_indices) is_var_adterms <- var_names %in% c("se", "trials", "dec") | grepl("^((vint)|(vreal))[[:digit:]]+$", var_names) var_resps <- ifelse(is_var_adterms, resp, "") vars <- paste0(var_names, var_resps, var_indices) sdist(family$name, p[dpars], p$thres, vars, vec = no_loop) } # ordinal log-probability density functions in Stan language # @return a character string stan_ordinal_lpmf <- function(family, link) { family <- as_one_character(family) link <- as_one_character(link) inv_link <- stan_inv_link(link) th <- function(k) { # helper function generating stan code inside inv_link(.) if (family %in% c("cumulative", "sratio")) { out <- glue("thres[{k}] - mu") } else if (family %in% c("cratio", "acat")) { out <- glue("mu - thres[{k}]") } glue("disc * ({out})") } out <- glue( " /* {family}-{link} log-PDF for a single response\n", " * Args:\n", " * y: response category\n", " * mu: latent mean parameter\n", " * disc: discrimination parameter\n", " * thres: ordinal thresholds\n", " * Returns:\n", " * a scalar to be added to the log posterior\n", " */\n", " real {family}_{link}_lpmf(int y, real mu, real disc, vector thres) {{\n" ) # define the function body if (family == "cumulative") { if (inv_link == "inv_logit") { str_add(out) <- glue( " int nthres = num_elements(thres);\n", " if (y == 1) {{\n", " return log_inv_logit({th(1)});\n", " }} else if (y == nthres + 1) {{\n", " return log1m_inv_logit({th('nthres')});\n", " }} else {{\n", " return log_inv_logit_diff({th('y')}, {th('y - 1')});\n", " }}\n", " }}\n" ) } else { str_add(out) <- glue( " int nthres = num_elements(thres);\n", " real p;\n", " if (y == 1) {{\n", " p = {inv_link}({th(1)});\n", " }} else if (y == nthres + 1) {{\n", " p = 1 - {inv_link}({th('nthres')});\n", " }} else {{\n", " p = {inv_link}({th('y')}) -\n", " {inv_link}({th('y - 1')});\n", " }}\n", " return log(p);\n", " }}\n" ) } } else if (family %in% c("sratio", "cratio")) { # TODO: support 'softit' link as well if (inv_link == "inv_cloglog") { qk <- str_if( family == "sratio", "-exp({th('k')})", "log1m_exp(-exp({th('k')}))" ) } else if (inv_link == "inv_logit") { qk <- str_if( family == "sratio", "log1m_inv_logit({th('k')})", "log_inv_logit({th('k')})" ) } else if (inv_link == "Phi") { qk <- str_if( family == "sratio", "std_normal_lccdf({th('k')})", "std_normal_lcdf({th('k')})" ) } else if (inv_link == "Phi_approx") { qk <- str_if( family == "sratio", "log1m_inv_logit(0.07056 * pow({th('k')}, 3.0) + 1.5976 * {th('k')})", "log_inv_logit(0.07056 * pow({th('k')}, 3.0) + 1.5976 * {th('k')})" ) } else if (inv_link == "inv_cauchit") { qk <- str_if( family == "sratio", "cauchy_lccdf({th('k')}|0,1)", "cauchy_lcdf({th('k')}|0,1)" ) } qk <- glue(qk) str_add(out) <- glue( " int nthres = num_elements(thres);\n", " vector[nthres + 1] p;\n", " vector[nthres] q;\n", " int k = 1;\n", " while (k <= min(y, nthres)) {{\n", " q[k] = {qk};\n", " p[k] = log1m_exp(q[k]);\n", " for (kk in 1:(k - 1)) p[k] = p[k] + q[kk];\n", " k += 1;\n", " }}\n", " if (y == nthres + 1) {{\n", " p[nthres + 1] = sum(q);\n", " }}\n", " return p[y];\n", " }}\n" ) } else if (family == "acat") { if (inv_link == "inv_logit") { str_add(out) <- glue( " int nthres = num_elements(thres);\n", " vector[nthres + 1] p = append_row(0, cumulative_sum(disc * (mu - thres)));\n", " return p[y] - log_sum_exp(p);\n", " }}\n" ) } else { str_add(out) <- glue( " int nthres = num_elements(thres);\n", " vector[nthres + 1] p;\n", " vector[nthres] q;\n", " for (k in 1:(nthres))\n", " q[k] = {inv_link}({th('k')});\n", " for (k in 1:(nthres + 1)) {{\n", " p[k] = 1.0;\n", " for (kk in 1:(k - 1)) p[k] = p[k] * q[kk];\n", " for (kk in k:(nthres)) p[k] = p[k] * (1 - q[kk]);\n", " }}\n", " return log(p[y]) - log(sum(p));\n", " }}\n" ) } } # lpmf function for multiple merged thresholds str_add(out) <- glue( " /* {family}-{link} log-PDF for a single response and merged thresholds\n", " * Args:\n", " * y: response category\n", " * mu: latent mean parameter\n", " * disc: discrimination parameter\n", " * thres: vector of merged ordinal thresholds\n", " * j: start and end index for the applid threshold within 'thres'\n", " * Returns:\n", " * a scalar to be added to the log posterior\n", " */\n", " real {family}_{link}_merged_lpmf(", "int y, real mu, real disc, vector thres, array[] int j) {{\n", " return {family}_{link}_lpmf(y | mu, disc, thres[j[1]:j[2]]);\n", " }}\n" ) if (family == "cumulative" && link %in% c("logit", "probit")) { # use the more efficient ordered_link functions when disc == 1 sfx <- str_if(link == "logit", "logistic", link) str_add(out) <- glue( " /* ordered-{sfx} log-PDF for a single response and merged thresholds\n", " * Args:\n", " * y: response category\n", " * mu: latent mean parameter\n", " * thres: vector of merged ordinal thresholds\n", " * j: start and end index for the applid threshold within 'thres'\n", " * Returns:\n", " * a scalar to be added to the log posterior\n", " */\n", " real ordered_{sfx}_merged_lpmf(", "int y, real mu, vector thres, array[] int j) {{\n", " return ordered_{sfx}_lpmf(y | mu, thres[j[1]:j[2]]);\n", " }}\n" ) } out } # log probability density for hurdle ordinal models # TODO: generalize to non-cumulative families? # @return a character string stan_hurdle_ordinal_lpmf <- function(family, link) { family <- as_one_character(family) link <- as_one_character(link) stopifnot(family == "hurdle_cumulative") inv_link <- stan_inv_link(link) th <- function(k) { out <- glue("thres[{k}] - mu") glue("disc * ({out})") } out <- glue( " /* {family}-{link} log-PDF for a single response\n", " * Args:\n", " * y: response category\n", " * mu: latent mean parameter\n", " * hu: hurdle probability\n", " * disc: discrimination parameter\n", " * thres: ordinal thresholds\n", " * Returns:\n", " * a scalar to be added to the log posterior\n", " */\n", " real {family}_{link}_lpmf(int y, real mu, real hu, real disc, vector thres) {{\n", "\n" ) # define the function body if (inv_link == "inv_logit") { str_add(out) <- glue( " int nthres = num_elements(thres);\n", " if (y == 0) {{\n", " return bernoulli_lpmf(1 | hu);\n", " }} else if (y == 1) {{\n", " return log_inv_logit({th(1)}) +\n", " bernoulli_lpmf(0 | hu);\n", " }} else if (y == nthres + 2) {{\n", " return log1m_inv_logit({th('nthres')}) +\n", " bernoulli_lpmf(0 | hu);\n", " }} else {{\n", " return log_inv_logit_diff({th('y')}, {th('y - 1')}) +\n", " bernoulli_lpmf(0 | hu) ;\n", " }}\n", " }}\n" ) } else { str_add(out) <- glue( " int nthres = num_elements(thres);\n", " real p;\n", " if (y == 0){{\n", " p = hu;\n", " }} else if (y == 1) {{\n", " p = {inv_link}({th(1)}) * (1 - hu);\n", " }} else if (y == nthres + 1) {{\n", " p = (1 - {inv_link}({th('nthres')})) * (1 - hu);\n", " }} else {{\n", " p = ({inv_link}({th('y')}) -\n", " {inv_link}({th('y - 1')})) * (1 - hu);\n", " }}\n", " return log(p);\n", " }}\n" ) } # lpmf function for multiple merged thresholds str_add(out) <- glue( " /* {family}-{link} log-PDF for a single response and merged thresholds\n", " * Args:\n", " * y: response category\n", " * mu: latent mean parameter\n", " * hu: hurdle probability\n", " * disc: discrimination parameter\n", " * thres: vector of merged ordinal thresholds\n", " * j: start and end index for the applid threshold within 'thres'\n", " * Returns:\n", " * a scalar to be added to the log posterior\n", " */\n", " real {family}_{link}_merged_lpmf(", "int y, real mu, real hu, real disc, vector thres, array[] int j) {{\n", " return {family}_{link}_lpmf(y | mu, hu, disc, thres[j[1]:j[2]]);\n", " }}\n" ) if (link %in% c("logit", "probit")) { # use the more efficient ordered_link functions when disc == 1 sfx <- str_if(link == "logit", "logistic", link) str_add(out) <- glue( "\n", " // Use more efficient ordered_{sfx} function with disc == 1\n", " real hurdle_cumulative_ordered_{sfx}_lpmf(int y, real mu, real hu, real disc, vector thres) {{\n", " if (y == 0) {{\n", " return bernoulli_lpmf(1 | hu);\n", " }} else {{\n", " return ordered_{sfx}_lpmf(y | mu, thres) +\n", " bernoulli_lpmf(0 | hu);\n", " }}\n", " }}\n" ) str_add(out) <- glue( " /* use ordered-{sfx} log-PDF for a single response and merged thresholds\n", " * Args:\n", " * y: response category\n", " * mu: latent mean parameter\n", " * hu: hurdle probability\n", " * thres: vector of merged ordinal thresholds\n", " * j: start and end index for the applid threshold within 'thres'\n", " * Returns:\n", " * a scalar to be added to the log posterior\n", " */\n", " real hurdle_cumulative_ordered_{sfx}_merged_lpmf(", "int y, real mu, real hu, real disc, vector thres, array[] int j) {{\n", " return hurdle_cumulative_ordered_{sfx}_lpmf(y | mu, hu, disc, thres[j[1]:j[2]]);\n", " }}\n" ) } out } # use a Stan GLM primitive function? use_glm_primitive <- function(bterms) { stopifnot(is.brmsterms(bterms)) # the model can only have a single predicted parameter # and no additional residual or autocorrelation structure mu <- bterms$dpars[["mu"]] non_glm_adterms <- c("se", "weights", "thres", "cens", "trunc", "rate") if (!is.btl(mu) || length(bterms$dpars) > 1L || isTRUE(bterms$rescor) || is.formula(mu$ac) || has_ad_terms(bterms, non_glm_adterms)) { return(FALSE) } # some primitives do not support special terms in the way # required by brms' Stan code generation allow_special_terms <- !mu$family$family %in% c("cumulative", "categorical") if (!allow_special_terms && has_special_terms(mu)) { return(FALSE) } # supported families and link functions glm_links <- list( gaussian = "identity", bernoulli = "logit", poisson = "log", negbinomial = "log", negbinomial2 = "log", cumulative = "logit", categorical = "logit" ) if (!isTRUE(glm_links[[mu$family$family]] == mu$family$link)) { return(FALSE) } length(all_terms(mu$fe)) > 0 && !is_sparse(mu$fe) } # use Stan's categorical GLM primitive function? use_glm_primitive_categorical <- function(bterms) { stopifnot(is.brmsterms(bterms)) if (!is_categorical(bterms)) { return(FALSE) } tmp <- bterms tmp$dpars <- list() # we know that all dpars in categorical models are mu parameters out <- rep(FALSE, length(bterms$dpars)) for (i in seq_along(bterms$dpars)) { tmp$dpars$mu <- bterms$dpars[[i]] tmp$dpars$mu$family <- bterms$family out[i] <- use_glm_primitive(tmp) && # the design matrix of all mu parameters must match all.equal(tmp$dpars$mu$fe, bterms$dpars[[1]]$fe) } all(out) } # standard arguments for primitive Stan GLM functions # @param bterms a btl object # @return a named list of Stan code snippets args_glm_primitive <- function(bterms, threads = NULL, ...) { stopifnot(is.btl(bterms)) resp <- usc(bterms$resp) decomp <- get_decomp(bterms$fe) center_X <- stan_center_X(bterms) slice <- stan_slice(threads) sfx_X <- sfx_b <- "" if (decomp == "QR") { sfx_X <- sfx_b <- "Q" } else if (center_X) { sfx_X <- "c" } is_categorical <- is_categorical(bterms) if (is_categorical) { sfx_X <- glue("{sfx_X}_{bterms$dpar}") } x <- glue("X{sfx_X}{resp}{slice}") beta <- glue("b{sfx_b}{resp}") if (has_special_terms(bterms)) { # the intercept vector will contain all the remaining terms alpha <- glue("mu{resp}") } else { if (center_X) { alpha <- glue("Intercept{resp}") } else { if (is_categorical) { alpha <- glue("rep_vector(0, ncat{resp})") } else { alpha <- "0" } } } nlist(x, alpha, beta) } # use the ordered_logistic built-in functions use_ordered_builtin <- function(bterms, link) { stopifnot(is.brmsterms(bterms)) isTRUE(bterms$family$family %in% c("cumulative", "hurdle_cumulative")) && isTRUE(bterms$family$link == link) && isTRUE(bterms$fdpars$disc$value == 1) && !has_cs(bterms) } # prepare distribution and arguments for use in Stan # @param dist name of the distribution in Stan language # @param vec does the distribution have a vectorized version? # @param shift Stan code for shifting the likelihood in shifted_* families sdist <- function(dist, ..., vec = TRUE, shift = "") { args <- sargs(...) structure(nlist(dist, args, vec, shift), class = "sdist") } # prepare arguments for Stan likelihood statements sargs <- function(...) { dots <- as.character(c(...)) dots <- dots[nzchar(dots)] paste0(dots, collapse = ", ") } is.sdist <- function(x) { inherits(x, "sdist") } tp <- function(wsp = 2) { wsp <- collapse(rep(" ", wsp)) paste0(wsp, "target += ") } brms/R/log_lik.R0000644000176200001440000010634015056555177013205 0ustar liggesusers#' Compute the Pointwise Log-Likelihood #' #' @aliases log_lik logLik.brmsfit #' #' @param object A fitted model object of class \code{brmsfit}. #' @inheritParams posterior_predict.brmsfit #' @param combine Only relevant in multivariate models. #' Indicates if the log-likelihoods of the submodels should #' be combined per observation (i.e. added together; the default) #' or if the log-likelihoods should be returned separately. #' @param pointwise A flag indicating whether to compute the full #' log-likelihood matrix at once (the default), or just return #' the likelihood function along with all data and draws #' required to compute the log-likelihood separately for each #' observation. The latter option is rarely useful when #' calling \code{log_lik} directly, but rather when computing #' \code{\link{waic}} or \code{\link{loo}}. #' @param add_point_estimate For internal use only. Ensures compatibility #' with the \code{\link{loo_subsample}} method. #' #' @return Usually, an S x N matrix containing the pointwise log-likelihood #' draws, where S is the number of draws and N is the number #' of observations in the data. For multivariate models and if #' \code{combine} is \code{FALSE}, an S x N x R array is returned, #' where R is the number of response variables. #' If \code{pointwise = TRUE}, the output is a function #' with a \code{draws} attribute containing all relevant #' data and posterior draws. #' #' @template details-newdata-na #' @template details-allow_new_levels #' #' @aliases log_lik #' @method log_lik brmsfit #' @export #' @export log_lik #' @importFrom rstantools log_lik log_lik.brmsfit <- function(object, newdata = NULL, re_formula = NULL, resp = NULL, ndraws = NULL, draw_ids = NULL, pointwise = FALSE, combine = TRUE, add_point_estimate = FALSE, cores = NULL, ...) { pointwise <- as_one_logical(pointwise) combine <- as_one_logical(combine) add_point_estimate <- as_one_logical(add_point_estimate) contains_draws(object) object <- restructure(object) prep <- prepare_predictions( object, newdata = newdata, re_formula = re_formula, resp = resp, ndraws = ndraws, draw_ids = draw_ids, check_response = TRUE, ... ) if (add_point_estimate) { # required for the loo_subsample method # Computing a point estimate based on the full prep object is too # difficult due to its highly nested structure. As an alternative, a second # prep object is created from the point estimates of the draws directly. attr(prep, "point_estimate") <- prepare_predictions( object, newdata = newdata, re_formula = re_formula, resp = resp, ndraws = ndraws, draw_ids = draw_ids, check_response = TRUE, point_estimate = "median", ... ) } if (pointwise) { stopifnot(combine) log_lik <- log_lik_pointwise # names need to be 'data' and 'draws' as per ?loo::loo.function attr(log_lik, "data") <- data.frame(i = seq_len(choose_N(prep))) attr(log_lik, "draws") <- prep } else { log_lik <- log_lik(prep, combine = combine, cores = cores) if (anyNA(log_lik)) { warning2( "NAs were found in the log-likelihood. Possibly this is because ", "some of your responses contain NAs. If you use 'mi' terms, try ", "setting 'resp' to those response variables without missing values. ", "Alternatively, use 'newdata' to predict only complete cases." ) } } log_lik } #' @export logLik.brmsfit <- function(object, newdata = NULL, re_formula = NULL, resp = NULL, ndraws = NULL, draw_ids = NULL, pointwise = FALSE, combine = TRUE, cores = NULL, ...) { cl <- match.call() cl[[1]] <- quote(log_lik) eval(cl, parent.frame()) } #' @export log_lik.mvbrmsprep <- function(object, combine = TRUE, ...) { if (length(object$mvpars$rescor)) { object$mvpars$Mu <- get_Mu(object) object$mvpars$Sigma <- get_Sigma(object) out <- log_lik.brmsprep(object, ...) } else { out <- lapply(object$resps, log_lik, ...) if (combine) { out <- Reduce("+", out) } else { along <- ifelse(length(out) > 1L, 3, 2) out <- do_call(abind, c(out, along = along)) } } out } #' @export log_lik.brmsprep <- function(object, cores = NULL, ...) { cores <- validate_cores_post_processing(cores) log_lik_fun <- paste0("log_lik_", object$family$fun) log_lik_fun <- get(log_lik_fun, asNamespace("brms")) if (is.customfamily(object$family)) { # ensure that the method can be found during parallel execution object$family$log_lik <- custom_family_method(object$family, "log_lik") } for (nlp in names(object$nlpars)) { object$nlpars[[nlp]] <- get_nlpar(object, nlpar = nlp) } for (dp in names(object$dpars)) { object$dpars[[dp]] <- get_dpar(object, dpar = dp) } N <- choose_N(object) out <- plapply(seq_len(N), log_lik_fun, .cores = cores, prep = object) out <- do_call(cbind, out) colnames(out) <- NULL old_order <- object$old_order sort <- isTRUE(ncol(out) != length(old_order)) reorder_obs(out, old_order, sort = sort) } # evaluate log_lik in a pointwise manner # cannot be an S3 method since 'data_i' must be the first argument # names must be 'data_i' and 'draws' as per ?loo::loo.function log_lik_pointwise <- function(data_i, draws, ...) { i <- data_i$i if (is.mvbrmsprep(draws) && !length(draws$mvpars$rescor)) { out <- lapply(draws$resps, log_lik_pointwise, i = i) out <- Reduce("+", out) } else { log_lik_fun <- paste0("log_lik_", draws$family$fun) log_lik_fun <- get(log_lik_fun, asNamespace("brms")) out <- log_lik_fun(i, draws) } out } # All log_lik_ functions have the same arguments structure # @param i index of the observation for which to compute log-lik values # @param prep A named list returned by prepare_predictions containing # all required data and posterior draws # @return a vector of length prep$ndraws containing the pointwise # log-likelihood for the ith observation log_lik_gaussian <- function(i, prep) { mu <- get_dpar(prep, "mu", i = i) sigma <- get_dpar(prep, "sigma", i = i) sigma <- add_sigma_se(sigma, prep, i = i) args <- list(mean = mu, sd = sigma) # log_lik_censor computes the conventional log_lik in case of no censoring out <- log_lik_censor(dist = "norm", args = args, i = i, prep = prep) out <- log_lik_truncate( out, cdf = pnorm, args = args, i = i, prep = prep ) log_lik_weight(out, i = i, prep = prep) } log_lik_student <- function(i, prep) { nu <- get_dpar(prep, "nu", i = i) mu <- get_dpar(prep, "mu", i = i) sigma <- get_dpar(prep, "sigma", i = i) sigma <- add_sigma_se(sigma, prep, i = i) args <- list(df = nu, mu = mu, sigma = sigma) out <- log_lik_censor( dist = "student_t", args = args, i = i, prep = prep ) out <- log_lik_truncate( out, cdf = pstudent_t, args = args, i = i, prep = prep ) log_lik_weight(out, i = i, prep = prep) } log_lik_lognormal <- function(i, prep) { sigma <- get_dpar(prep, "sigma", i = i) args <- list(meanlog = get_dpar(prep, "mu", i), sdlog = sigma) out <- log_lik_censor(dist = "lnorm", args = args, i = i, prep = prep) out <- log_lik_truncate( out, cdf = plnorm, args = args, i = i, prep = prep ) log_lik_weight(out, i = i, prep = prep) } log_lik_shifted_lognormal <- function(i, prep) { sigma <- get_dpar(prep, "sigma", i = i) ndt <- get_dpar(prep, "ndt", i = i) args <- list(meanlog = get_dpar(prep, "mu", i), sdlog = sigma, shift = ndt) out <- log_lik_censor("shifted_lnorm", args, i = i, prep = prep) out <- log_lik_truncate(out, pshifted_lnorm, args, i = i, prep = prep) log_lik_weight(out, i = i, prep = prep) } log_lik_skew_normal <- function(i, prep) { mu <- get_dpar(prep, "mu", i) sigma <- get_dpar(prep, "sigma", i = i) sigma <- add_sigma_se(sigma, prep, i = i) alpha <- get_dpar(prep, "alpha", i = i) args <- nlist(mu, sigma, alpha) out <- log_lik_censor( dist = "skew_normal", args = args, i = i, prep = prep ) out <- log_lik_truncate( out, cdf = pskew_normal, args = args, i = i, prep = prep ) log_lik_weight(out, i = i, prep = prep) } log_lik_gaussian_mv <- function(i, prep) { Mu <- get_Mu(prep, i = i) Sigma <- get_Sigma(prep, i = i) dmn <- function(s) { dmulti_normal( prep$data$Y[i, ], mu = Mu[s, ], Sigma = Sigma[s, , ], log = TRUE ) } out <- sapply(1:prep$ndraws, dmn) log_lik_weight(out, i = i, prep = prep) } log_lik_student_mv <- function(i, prep) { nu <- get_dpar(prep, "nu", i = i) Mu <- get_Mu(prep, i = i) Sigma <- get_Sigma(prep, i = i) dmst <- function(s) { dmulti_student_t( prep$data$Y[i, ], df = nu[s], mu = Mu[s, ], Sigma = Sigma[s, , ], log = TRUE ) } out <- sapply(1:prep$ndraws, dmst) log_lik_weight(out, i = i, prep = prep) } log_lik_gaussian_time <- function(i, prep) { obs <- with(prep$ac, begin_tg[i]:end_tg[i]) Jtime <- prep$ac$Jtime_tg[i, ] Y <- as.numeric(prep$data$Y[obs]) mu <- as.matrix(get_dpar(prep, "mu", i = obs)) Sigma <- get_cov_matrix_ac(prep, obs, Jtime = Jtime) .log_lik <- function(s) { C <- as.matrix(Sigma[s, , ]) Cinv <- solve(C) e <- Y - mu[s, ] g <- solve(C, e) cbar <- diag(Cinv) yloo <- Y - g / cbar sdloo <- sqrt(1 / cbar) ll <- dnorm(Y, yloo, sdloo, log = TRUE) return(as.numeric(ll)) } rblapply(seq_len(prep$ndraws), .log_lik) } log_lik_student_time <- function(i, prep) { obs <- with(prep$ac, begin_tg[i]:end_tg[i]) Jtime <- prep$ac$Jtime_tg[i, ] Y <- as.numeric(prep$data$Y[obs]) nu <- as.matrix(get_dpar(prep, "nu", i = obs)) mu <- as.matrix(get_dpar(prep, "mu", i = obs)) Sigma <- get_cov_matrix_ac(prep, obs, Jtime = Jtime) .log_lik <- function(s) { df <- nu[s, ] C <- as.matrix(Sigma[s, , ]) Cinv <- solve(C) e <- Y - mu[s, ] g <- solve(C, e) cbar <- diag(Cinv) yloo <- Y - g / cbar sdloo <- sqrt(1 / cbar * student_t_cov_factor(df, cbar, e, g)) dfloo <- df + nrow(Cinv) - 1 ll <- dstudent_t(Y, dfloo, yloo, sdloo, log = TRUE) return(as.numeric(ll)) } rblapply(seq_len(prep$ndraws), .log_lik) } log_lik_gaussian_lagsar <- function(i, prep) { mu <- get_dpar(prep, "mu") sigma <- get_dpar(prep, "sigma") Y <- as.numeric(prep$data$Y) I <- diag(prep$nobs) stopifnot(i == 1) # see http://mc-stan.org/loo/articles/loo2-non-factorizable.html .log_lik <- function(s) { IB <- I - with(prep$ac, lagsar[s, ] * Msar) Cinv <- t(IB) %*% IB / sigma[s]^2 e <- Y - solve(IB, mu[s, ]) g <- Cinv %*% e cbar <- diag(Cinv) yloo <- Y - g / cbar sdloo <- sqrt(1 / cbar) ll <- dnorm(Y, yloo, sdloo, log = TRUE) return(as.numeric(ll)) } rblapply(seq_len(prep$ndraws), .log_lik) } log_lik_student_lagsar <- function(i, prep) { nu <- get_dpar(prep, "nu") mu <- get_dpar(prep, "mu") sigma <- get_dpar(prep, "sigma") Y <- as.numeric(prep$data$Y) I <- diag(prep$nobs) stopifnot(i == 1) # see http://mc-stan.org/loo/articles/loo2-non-factorizable.html .log_lik <- function(s) { df <- nu[s] IB <- I - with(prep$ac, lagsar[s, ] * Msar) Cinv <- t(IB) %*% IB / sigma[s]^2 e <- Y - solve(IB, mu[s, ]) g <- Cinv %*% e cbar <- diag(Cinv) yloo <- Y - g / cbar sdloo <- sqrt(1 / cbar * student_t_cov_factor(df, cbar, e, g)) dfloo <- df + nrow(Cinv) - 1 ll <- dstudent_t(Y, dfloo, yloo, sdloo, log = TRUE) return(as.numeric(ll)) } rblapply(seq_len(prep$ndraws), .log_lik) } log_lik_gaussian_errorsar <- function(i, prep) { stopifnot(i == 1) mu <- get_dpar(prep, "mu") sigma <- get_dpar(prep, "sigma") Y <- as.numeric(prep$data$Y) I <- diag(prep$nobs) .log_lik <- function(s) { IB <- I - with(prep$ac, errorsar[s, ] * Msar) Cinv <- t(IB) %*% IB / sigma[s]^2 e <- Y - mu[s, ] g <- Cinv %*% e cbar <- diag(Cinv) yloo <- Y - g / cbar sdloo <- sqrt(1 / cbar) ll <- dnorm(Y, yloo, sdloo, log = TRUE) return(as.numeric(ll)) } rblapply(seq_len(prep$ndraws), .log_lik) } log_lik_student_errorsar <- function(i, prep) { stopifnot(i == 1) nu <- get_dpar(prep, "nu") mu <- get_dpar(prep, "mu") sigma <- get_dpar(prep, "sigma") Y <- as.numeric(prep$data$Y) I <- diag(prep$nobs) .log_lik <- function(s) { df <- nu[s] IB <- I - with(prep$ac, errorsar[s, ] * Msar) Cinv <- t(IB) %*% IB / sigma[s]^2 e <- Y - mu[s, ] g <- Cinv %*% e cbar <- diag(Cinv) yloo <- Y - g / cbar sdloo <- sqrt(1 / cbar * student_t_cov_factor(df, cbar, e, g)) dfloo <- df + nrow(Cinv) - 1 ll <- dstudent_t(Y, dfloo, yloo, sdloo, log = TRUE) return(as.numeric(ll)) } rblapply(seq_len(prep$ndraws), .log_lik) } log_lik_gaussian_fcor <- function(i, prep) { stopifnot(i == 1) Y <- as.numeric(prep$data$Y) mu <- get_dpar(prep, "mu") Sigma <- get_cov_matrix_ac(prep) .log_lik <- function(s) { C <- as.matrix(Sigma[s, , ]) Cinv <- solve(C) e <- Y - mu[s, ] g <- solve(C, e) cbar <- diag(Cinv) yloo <- Y - g / cbar sdloo <- sqrt(1 / cbar) ll <- dnorm(Y, yloo, sdloo, log = TRUE) return(as.numeric(ll)) } rblapply(seq_len(prep$ndraws), .log_lik) } log_lik_student_fcor <- function(i, prep) { stopifnot(i == 1) Y <- as.numeric(prep$data$Y) nu <- get_dpar(prep, "nu") mu <- get_dpar(prep, "mu") Sigma <- get_cov_matrix_ac(prep) .log_lik <- function(s) { df <- nu[s] C <- as.matrix(Sigma[s, , ]) Cinv <- solve(C) e <- Y - mu[s, ] g <- solve(C, e) cbar <- diag(Cinv) yloo <- Y - g / cbar sdloo <- sqrt(1 / cbar * student_t_cov_factor(df, cbar, e, g)) dfloo <- df + nrow(Cinv) - 1 ll <- dstudent_t(Y, dfloo, yloo, sdloo, log = TRUE) return(as.numeric(ll)) } rblapply(seq_len(prep$ndraws), .log_lik) } log_lik_binomial <- function(i, prep) { trials <- prep$data$trials[i] args <- list(size = trials, prob = get_dpar(prep, "mu", i)) out <- log_lik_censor( dist = "binom", args = args, i = i, prep = prep ) out <- log_lik_truncate( out, cdf = pbinom, args = args, i = i, prep = prep ) log_lik_weight(out, i = i, prep = prep) } log_lik_bernoulli <- function(i, prep) { args <- list(size = 1, prob = get_dpar(prep, "mu", i)) out <- log_lik_censor( dist = "binom", args = args, i = i, prep = prep ) # no truncation allowed log_lik_weight(out, i = i, prep = prep) } log_lik_beta_binomial <- function(i, prep) { trials <- prep$data$trials[i] mu <- get_dpar(prep, "mu", i) phi <- get_dpar(prep, "phi", i) args <- nlist(size = trials, mu, phi) out <- log_lik_censor("beta_binomial", args, i, prep) out <- log_lik_truncate(out, pbeta_binomial, args, i, prep) log_lik_weight(out, i = i, prep = prep) } log_lik_poisson <- function(i, prep) { mu <- get_dpar(prep, "mu", i) mu <- multiply_dpar_rate_denom(mu, prep, i = i) args <- list(lambda = mu) out <- log_lik_censor( dist = "pois", args = args, i = i, prep = prep ) out <- log_lik_truncate( out, cdf = ppois, args = args, i = i, prep = prep ) log_lik_weight(out, i = i, prep = prep) } log_lik_negbinomial <- function(i, prep) { mu <- get_dpar(prep, "mu", i) mu <- multiply_dpar_rate_denom(mu, prep, i = i) shape <- get_dpar(prep, "shape", i) shape <- multiply_dpar_rate_denom(shape, prep, i = i) args <- list(mu = mu, size = shape) out <- log_lik_censor( dist = "nbinom", args = args, i = i, prep = prep ) out <- log_lik_truncate( out, cdf = pnbinom, args = args, i = i, prep = prep ) log_lik_weight(out, i = i, prep = prep) } log_lik_negbinomial2 <- function(i, prep) { mu <- get_dpar(prep, "mu", i) mu <- multiply_dpar_rate_denom(mu, prep, i = i) sigma <- get_dpar(prep, "sigma", i) shape <- multiply_dpar_rate_denom(1 / sigma, prep, i = i) args <- list(mu = mu, size = shape) out <- log_lik_censor( dist = "nbinom", args = args, i = i, prep = prep ) out <- log_lik_truncate( out, cdf = pnbinom, args = args, i = i, prep = prep ) log_lik_weight(out, i = i, prep = prep) } log_lik_geometric <- function(i, prep) { mu <- get_dpar(prep, "mu", i) mu <- multiply_dpar_rate_denom(mu, prep, i = i) shape <- 1 shape <- multiply_dpar_rate_denom(shape, prep, i = i) args <- list(mu = mu, size = shape) out <- log_lik_censor( dist = "nbinom", args = args, i = i, prep = prep ) out <- log_lik_truncate( out, cdf = pnbinom, args = args, i = i, prep = prep ) log_lik_weight(out, i = i, prep = prep) } log_lik_discrete_weibull <- function(i, prep) { args <- list( mu = get_dpar(prep, "mu", i), shape = get_dpar(prep, "shape", i = i) ) out <- log_lik_censor( dist = "discrete_weibull", args = args, i = i, prep = prep ) out <- log_lik_truncate( out, cdf = pdiscrete_weibull, args = args, i = i, prep = prep ) log_lik_weight(out, i = i, prep = prep) } log_lik_com_poisson <- function(i, prep) { args <- list( mu = get_dpar(prep, "mu", i), shape = get_dpar(prep, "shape", i = i) ) # no censoring or truncation allowed yet out <- do_call(dcom_poisson, c(prep$data$Y[i], args, log = TRUE)) log_lik_weight(out, i = i, prep = prep) } log_lik_exponential <- function(i, prep) { args <- list(rate = 1 / get_dpar(prep, "mu", i)) out <- log_lik_censor(dist = "exp", args = args, i = i, prep = prep) out <- log_lik_truncate( out, cdf = pexp, args = args, i = i, prep = prep ) log_lik_weight(out, i = i, prep = prep) } log_lik_gamma <- function(i, prep) { shape <- get_dpar(prep, "shape", i = i) scale <- get_dpar(prep, "mu", i) / shape args <- nlist(shape, scale) out <- log_lik_censor(dist = "gamma", args = args, i = i, prep = prep) out <- log_lik_truncate( out, cdf = pgamma, args = args, i = i, prep = prep ) log_lik_weight(out, i = i, prep = prep) } log_lik_weibull <- function(i, prep) { shape <- get_dpar(prep, "shape", i = i) scale <- get_dpar(prep, "mu", i = i) / gamma(1 + 1 / shape) args <- list(shape = shape, scale = scale) out <- log_lik_censor( dist = "weibull", args = args, i = i, prep = prep ) out <- log_lik_truncate( out, cdf = pweibull, args = args, i = i, prep = prep ) log_lik_weight(out, i = i, prep = prep) } log_lik_frechet <- function(i, prep) { nu <- get_dpar(prep, "nu", i = i) scale <- get_dpar(prep, "mu", i = i) / gamma(1 - 1 / nu) args <- list(scale = scale, shape = nu) out <- log_lik_censor( dist = "frechet", args = args, i = i, prep = prep ) out <- log_lik_truncate( out, cdf = pfrechet, args = args, i = i, prep = prep ) log_lik_weight(out, i = i, prep = prep) } log_lik_gen_extreme_value <- function(i, prep) { sigma <- get_dpar(prep, "sigma", i = i) xi <- get_dpar(prep, "xi", i = i) mu <- get_dpar(prep, "mu", i) args <- nlist(mu, sigma, xi) out <- log_lik_censor(dist = "gen_extreme_value", args = args, i = i, prep = prep) out <- log_lik_truncate(out, cdf = pgen_extreme_value, args = args, i = i, prep = prep) log_lik_weight(out, i = i, prep = prep) } log_lik_inverse.gaussian <- function(i, prep) { args <- list(mu = get_dpar(prep, "mu", i), shape = get_dpar(prep, "shape", i = i)) out <- log_lik_censor(dist = "inv_gaussian", args = args, i = i, prep = prep) out <- log_lik_truncate(out, cdf = pinv_gaussian, args = args, i = i, prep = prep) log_lik_weight(out, i = i, prep = prep) } log_lik_exgaussian <- function(i, prep) { args <- list(mu = get_dpar(prep, "mu", i), sigma = get_dpar(prep, "sigma", i = i), beta = get_dpar(prep, "beta", i = i)) out <- log_lik_censor(dist = "exgaussian", args = args, i = i, prep = prep) out <- log_lik_truncate(out, cdf = pexgaussian, args = args, i = i, prep = prep) log_lik_weight(out, i = i, prep = prep) } log_lik_wiener <- function(i, prep) { args <- list( delta = get_dpar(prep, "mu", i), alpha = get_dpar(prep, "bs", i = i), tau = get_dpar(prep, "ndt", i = i), beta = get_dpar(prep, "bias", i = i), resp = prep$data[["dec"]][i] ) out <- do_call(dwiener, c(prep$data$Y[i], args, log = TRUE)) log_lik_weight(out, i = i, prep = prep) } log_lik_beta <- function(i, prep) { mu <- get_dpar(prep, "mu", i) phi <- get_dpar(prep, "phi", i) args <- list(shape1 = mu * phi, shape2 = (1 - mu) * phi) out <- log_lik_censor(dist = "beta", args = args, i = i, prep = prep) out <- log_lik_truncate( out, cdf = pbeta, args = args, i = i, prep = prep ) log_lik_weight(out, i = i, prep = prep) } log_lik_xbeta <- function(i, prep) { args <- list( mu = get_dpar(prep, "mu", i = i), phi = get_dpar(prep, "phi", i = i), nu = get_dpar(prep, "kappa", i = i) ) out <- log_lik_censor(dist = "xbeta", args = args, i = i, prep = prep) out <- log_lik_truncate( out, cdf = pxbeta, args = args, i = i, prep = prep ) log_lik_weight(out, i = i, prep = prep) } log_lik_von_mises <- function(i, prep) { args <- list( mu = get_dpar(prep, "mu", i), kappa = get_dpar(prep, "kappa", i = i) ) out <- log_lik_censor( dist = "von_mises", args = args, i = i, prep = prep ) out <- log_lik_truncate( out, cdf = pvon_mises, args = args, i = i, prep = prep ) log_lik_weight(out, i = i, prep = prep) } log_lik_asym_laplace <- function(i, prep, ...) { args <- list( mu = get_dpar(prep, "mu", i), sigma = get_dpar(prep, "sigma", i), quantile = get_dpar(prep, "quantile", i) ) out <- log_lik_censor(dist = "asym_laplace", args, i, prep) out <- log_lik_truncate(out, pasym_laplace, args, i, prep) log_lik_weight(out, i = i, prep = prep) } log_lik_zero_inflated_asym_laplace <- function(i, prep, ...) { args <- list( mu = get_dpar(prep, "mu", i), sigma = get_dpar(prep, "sigma", i), quantile = get_dpar(prep, "quantile", i), zi = get_dpar(prep, "zi", i) ) out <- log_lik_censor(dist = "zero_inflated_asym_laplace", args, i, prep) out <- log_lik_truncate(out, pzero_inflated_asym_laplace, args, i, prep) log_lik_weight(out, i = i, prep = prep) } log_lik_cox <- function(i, prep, ...) { args <- list( mu = get_dpar(prep, "mu", i), bhaz = prep$bhaz$bhaz[, i], cbhaz = prep$bhaz$cbhaz[, i] ) out <- log_lik_censor(dist = "cox", args = args, i = i, prep = prep) out <- log_lik_truncate(out, cdf = pcox, args = args, i = i, prep = prep) log_lik_weight(out, i = i, prep = prep) } log_lik_hurdle_poisson <- function(i, prep) { hu <- get_dpar(prep, "hu", i) lambda <- get_dpar(prep, "mu", i) args <- nlist(lambda, hu) out <- log_lik_censor("hurdle_poisson", args, i, prep) out <- log_lik_truncate(out, phurdle_poisson, args, i, prep) log_lik_weight(out, i = i, prep = prep) } log_lik_hurdle_negbinomial <- function(i, prep) { hu <- get_dpar(prep, "hu", i) mu <- get_dpar(prep, "mu", i) shape <- get_dpar(prep, "shape", i = i) args <- nlist(mu, shape, hu) out <- log_lik_censor("hurdle_negbinomial", args, i, prep) out <- log_lik_truncate(out, phurdle_negbinomial, args, i, prep) log_lik_weight(out, i = i, prep = prep) } log_lik_hurdle_gamma <- function(i, prep) { hu <- get_dpar(prep, "hu", i) shape <- get_dpar(prep, "shape", i = i) scale <- get_dpar(prep, "mu", i) / shape args <- nlist(shape, scale, hu) out <- log_lik_censor("hurdle_gamma", args, i, prep) out <- log_lik_truncate(out, phurdle_gamma, args, i, prep) log_lik_weight(out, i = i, prep = prep) } log_lik_hurdle_lognormal <- function(i, prep) { hu <- get_dpar(prep, "hu", i) mu <- get_dpar(prep, "mu", i) sigma <- get_dpar(prep, "sigma", i = i) args <- nlist(mu, sigma, hu) out <- log_lik_censor("hurdle_lognormal", args, i, prep) out <- log_lik_truncate(out, phurdle_lognormal, args, i, prep) log_lik_weight(out, i = i, prep = prep) } log_lik_hurdle_cumulative <- function(i, prep) { mu <- get_dpar(prep, "mu", i = i) hu <- get_dpar(prep, "hu", i = i) disc <- get_dpar(prep, "disc", i = i) thres <- subset_thres(prep, i) nthres <- NCOL(thres) eta <- disc * (thres - mu) y <- prep$data$Y[i] if (y == 0L) { out <- dbinom(1, size = 1, prob = hu, log = TRUE) } else if (y == 1L) { out <- log_cdf(eta[, 1L], prep$family$link) + dbinom(0, size = 1, prob = hu, log = TRUE) } else if (y == nthres + 1L) { out <- log_ccdf(eta[, y - 1L], prep$family$link) + dbinom(0, size = 1, prob = hu, log = TRUE) } else { out <- log_diff_exp( log_cdf(eta[, y], prep$family$link), log_cdf(eta[, y - 1L], prep$family$link) ) + dbinom(0, size = 1, prob = hu, log = TRUE) } log_lik_weight(out, i = i, prep = prep) } log_lik_zero_inflated_poisson <- function(i, prep) { zi <- get_dpar(prep, "zi", i) lambda <- get_dpar(prep, "mu", i) args <- nlist(lambda, zi) out <- log_lik_censor("zero_inflated_poisson", args, i, prep) out <- log_lik_truncate(out, pzero_inflated_poisson, args, i, prep) log_lik_weight(out, i = i, prep = prep) } log_lik_zero_inflated_negbinomial <- function(i, prep) { zi <- get_dpar(prep, "zi", i) mu <- get_dpar(prep, "mu", i) shape <- get_dpar(prep, "shape", i = i) args <- nlist(mu, shape, zi) out <- log_lik_censor("zero_inflated_negbinomial", args, i, prep) out <- log_lik_truncate(out, pzero_inflated_negbinomial, args, i, prep) log_lik_weight(out, i = i, prep = prep) } log_lik_zero_inflated_binomial <- function(i, prep) { trials <- prep$data$trials[i] mu <- get_dpar(prep, "mu", i) zi <- get_dpar(prep, "zi", i) args <- list(size = trials, prob = mu, zi = zi) out <- log_lik_censor("zero_inflated_binomial", args, i, prep) out <- log_lik_truncate(out, pzero_inflated_binomial, args, i, prep) log_lik_weight(out, i = i, prep = prep) } log_lik_zero_inflated_beta_binomial <- function(i, prep) { trials <- prep$data$trials[i] mu <- get_dpar(prep, "mu", i) phi <- get_dpar(prep, "phi", i) zi <- get_dpar(prep, "zi", i) args <- nlist(size = trials, mu, phi, zi) out <- log_lik_censor("zero_inflated_beta_binomial", args, i, prep) out <- log_lik_truncate(out, pzero_inflated_beta_binomial, args, i, prep) log_lik_weight(out, i = i, prep = prep) } log_lik_zero_inflated_beta <- function(i, prep) { zi <- get_dpar(prep, "zi", i) mu <- get_dpar(prep, "mu", i) phi <- get_dpar(prep, "phi", i) args <- nlist(shape1 = mu * phi, shape2 = (1 - mu) * phi, zi) out <- log_lik_censor("zero_inflated_beta", args, i, prep) out <- log_lik_truncate(out, pzero_inflated_beta, args, i, prep) log_lik_weight(out, i = i, prep = prep) } log_lik_zero_one_inflated_beta <- function(i, prep) { zoi <- get_dpar(prep, "zoi", i) coi <- get_dpar(prep, "coi", i) if (prep$data$Y[i] %in% c(0, 1)) { out <- dbinom(1, size = 1, prob = zoi, log = TRUE) + dbinom(prep$data$Y[i], size = 1, prob = coi, log = TRUE) } else { phi <- get_dpar(prep, "phi", i) mu <- get_dpar(prep, "mu", i) args <- list(shape1 = mu * phi, shape2 = (1 - mu) * phi) out <- dbinom(0, size = 1, prob = zoi, log = TRUE) + do_call(dbeta, c(prep$data$Y[i], args, log = TRUE)) } log_lik_weight(out, i = i, prep = prep) } log_lik_categorical <- function(i, prep) { stopifnot(prep$family$link == "logit") eta <- get_Mu(prep, i = i) eta <- insert_refcat(eta, refcat = prep$refcat) out <- dcategorical(prep$data$Y[i], eta = eta, log = TRUE) log_lik_weight(out, i = i, prep = prep) } log_lik_multinomial <- function(i, prep) { stopifnot(prep$family$link == "logit") eta <- get_Mu(prep, i = i) eta <- insert_refcat(eta, refcat = prep$refcat) out <- dmultinomial(prep$data$Y[i, ], eta = eta, log = TRUE) log_lik_weight(out, i = i, prep = prep) } log_lik_dirichlet_multinomial <- function(i, prep) { stopifnot(prep$family$link == "logit") eta <- get_Mu(prep, i = i) eta <- insert_refcat(eta, refcat = prep$refcat) phi <- get_dpar(prep, "phi", i = i) out <- ddirichletmultinomial(prep$data$Y[i, ], eta = eta, phi = phi, log = TRUE) log_lik_weight(out, i = i, prep = prep) } log_lik_dirichlet <- function(i, prep) { stopifnot(prep$family$link == "logit") eta <- get_Mu(prep, i = i) eta <- insert_refcat(eta, refcat = prep$refcat) phi <- get_dpar(prep, "phi", i = i) cats <- seq_len(prep$data$ncat) alpha <- dcategorical(cats, eta = eta) * phi out <- ddirichlet(prep$data$Y[i, ], alpha = alpha, log = TRUE) log_lik_weight(out, i = i, prep = prep) } log_lik_dirichlet2 <- function(i, prep) { mu <- get_Mu(prep, i = i) out <- ddirichlet(prep$data$Y[i, ], alpha = mu, log = TRUE) log_lik_weight(out, i = i, prep = prep) } log_lik_logistic_normal <- function(i, prep, ...) { mu <- get_Mu(prep, i = i) Sigma <- get_Sigma(prep, i = i, cor_name = "lncor") dlmn <- function(s) { dlogistic_normal( prep$data$Y[i, ], mu = mu[s, ], Sigma = Sigma[s, , ], refcat = prep$refcat, log = TRUE ) } out <- sapply(1:prep$ndraws, dlmn) log_lik_weight(out, i = i, prep = prep) } log_lik_cumulative <- function(i, prep) { disc <- get_dpar(prep, "disc", i = i) mu <- get_dpar(prep, "mu", i = i) thres <- subset_thres(prep, i) nthres <- NCOL(thres) eta <- disc * (thres - mu) y <- prep$data$Y[i] if (y == 1L) { out <- log_cdf(eta[, 1L], prep$family$link) } else if (y == nthres + 1L) { out <- log_ccdf(eta[, y - 1L], prep$family$link) } else { out <- log_diff_exp( log_cdf(eta[, y], prep$family$link), log_cdf(eta[, y - 1L], prep$family$link) ) } log_lik_weight(out, i = i, prep = prep) } log_lik_sratio <- function(i, prep) { disc <- get_dpar(prep, "disc", i = i) mu <- get_dpar(prep, "mu", i = i) thres <- subset_thres(prep, i) nthres <- NCOL(thres) eta <- disc * (thres - mu) y <- prep$data$Y[i] q <- sapply(seq_len(min(y, nthres)), function(k) log_ccdf(eta[, k], prep$family$link) ) if (y == 1L) { out <- log1m_exp(q[, 1L]) } else if (y == 2L) { out <- log1m_exp(q[, 2L]) + q[, 1L] } else if (y == nthres + 1L) { out <- rowSums(q) } else { out <- log1m_exp(q[, y]) + rowSums(q[, 1L:(y - 1L)]) } log_lik_weight(out, i = i, prep = prep) } log_lik_cratio <- function(i, prep) { disc <- get_dpar(prep, "disc", i = i) mu <- get_dpar(prep, "mu", i = i) thres <- subset_thres(prep, i) nthres <- NCOL(thres) eta <- disc * (mu - thres) y <- prep$data$Y[i] q <- sapply(seq_len(min(y, nthres)), function(k) log_cdf(eta[, k], prep$family$link) ) if (y == 1L) { out <- log1m_exp(q[, 1L]) } else if (y == 2L) { out <- log1m_exp(q[, 2L]) + q[, 1L] } else if (y == nthres + 1L) { out <- rowSums(q) } else { out <- log1m_exp(q[, y]) + rowSums(q[, 1L:(y - 1L)]) } log_lik_weight(out, i = i, prep = prep) } log_lik_acat <- function(i, prep) { disc <- get_dpar(prep, "disc", i = i) mu <- get_dpar(prep, "mu", i = i) thres <- subset_thres(prep, i) nthres <- NCOL(thres) eta <- disc * (mu - thres) y <- prep$data$Y[i] # TODO: check if computation can be made more numerically stable if (prep$family$link == "logit") { # more efficient computation for logit link q <- sapply(1:nthres, function(k) eta[, k]) p <- cbind(rep(0, nrow(eta)), q[, 1], matrix(0, nrow = nrow(eta), ncol = nthres - 1)) if (nthres > 1L) { p[, 3:(nthres + 1)] <- sapply(3:(nthres + 1), function(k) rowSums(q[, 1:(k - 1)])) } out <- p[, y] - log(rowSums(exp(p))) } else { q <- sapply(1:nthres, function(k) inv_link(eta[, k], prep$family$link)) p <- cbind(apply(1 - q[, 1:nthres], 1, prod), matrix(0, nrow = nrow(eta), ncol = nthres)) if (nthres > 1L) { p[, 2:nthres] <- sapply(2:nthres, function(k) apply(as.matrix(q[, 1:(k - 1)]), 1, prod) * apply(as.matrix(1 - q[, k:nthres]), 1, prod)) } p[, nthres + 1] <- apply(q[, 1:nthres], 1, prod) out <- log(p[, y]) - log(apply(p, 1, sum)) } log_lik_weight(out, i = i, prep = prep) } log_lik_custom <- function(i, prep) { custom_family_method(prep$family, "log_lik")(i, prep) } log_lik_mixture <- function(i, prep) { families <- family_names(prep$family) theta <- get_theta(prep, i = i) out <- array(NA, dim = dim(theta)) for (j in seq_along(families)) { log_lik_fun <- paste0("log_lik_", families[j]) log_lik_fun <- get(log_lik_fun, asNamespace("brms")) tmp_draws <- pseudo_prep_for_mixture(prep, j) out[, j] <- exp(log(theta[, j]) + log_lik_fun(i, tmp_draws)) } if (isTRUE(prep[["pp_mixture"]])) { out <- log(out) - log(rowSums(out)) } else { out <- log(rowSums(out)) } log_lik_weight(out, i = i, prep = prep) } # ----------- log_lik helper-functions ----------- # compute (possibly censored) log_lik values # @param dist name of a distribution for which the functions # d (pdf) and p (cdf) are available # @param args additional arguments passed to pdf and cdf # @param prep a brmsprep object # @return vector of log_lik values log_lik_censor <- function(dist, args, i, prep) { pdf <- get(paste0("d", dist), mode = "function") cdf <- get(paste0("p", dist), mode = "function") y <- prep$data$Y[i] cens <- prep$data$cens[i] if (is.null(cens) || cens == 0) { x <- do_call(pdf, c(y, args, log = TRUE)) } else if (cens == 1) { x <- do_call(cdf, c(y, args, lower.tail = FALSE, log.p = TRUE)) } else if (cens == -1) { x <- do_call(cdf, c(y, args, log.p = TRUE)) } else if (cens == 2) { rcens <- prep$data$rcens[i] x <- log(do_call(cdf, c(rcens, args)) - do_call(cdf, c(y, args))) } x } # adjust log_lik in truncated models # @param x vector of log_lik values # @param cdf a cumulative distribution function # @param args arguments passed to cdf # @param i observation number # @param prep a brmsprep object # @return vector of log_lik values log_lik_truncate <- function(x, cdf, args, i, prep) { lb <- prep$data[["lb"]][i] ub <- prep$data[["ub"]][i] if (is.null(lb) && is.null(ub)) { return(x) } if (!is.null(lb)) { log_cdf_lb <- do_call(cdf, c(lb, args, log.p = TRUE)) } else { log_cdf_lb <- rep(-Inf, length(x)) } if (!is.null(ub)) { log_cdf_ub <- do_call(cdf, c(ub, args, log.p = TRUE)) } else { log_cdf_ub <- rep(0, length(x)) } x - log_diff_exp(log_cdf_ub, log_cdf_lb) } # weight log_lik values according to defined weights # @param x vector of log_lik values # @param i observation number # @param prep a brmsprep object # @return vector of log_lik values log_lik_weight <- function(x, i, prep) { weight <- prep$data$weights[i] if (!is.null(weight)) { x <- x * weight } x } # after some discussion with Aki Vehtari and Daniel Simpson, # I disallowed computation of log-likelihood values for some models # until pointwise solutions are implemented stop_no_pw <- function() { stop2("Cannot yet compute pointwise log-likelihood for this model ", "because the observations are not conditionally independent.") } # multiplicate factor for conditional student-t models # see http://proceedings.mlr.press/v33/shah14.pdf # note that brms parameterizes C instead of Cov(y) = df / (df - 2) * C # @param df degrees of freedom parameter # @param cbar vector of inverse variances (diag(Cinv)) # @param e vector of error terms, that is, y - mu # @param g vector of Cinv %*% e student_t_cov_factor <- function(df, cbar, e, g) { beta1 <- student_t_beta1(cbar, e, g) (df + beta1) / (df + length(cbar) - 1) } # beta1 in equation (6) of http://proceedings.mlr.press/v33/shah14.pdf # Optimized version that reuses existing computations (brms#1820) # @param cbar vector of inverse variances (diag(Cinv)) # @param e vector of error terms, that is, y - mu # @param g vector of Cinv %*% e student_t_beta1 <- function(cbar, e, g) { zsq <- g^2 / cbar beta0 <- as.numeric(t(e) %*% g) beta0 - zsq } brms/R/posterior.R0000644000176200001440000002276215053072461013603 0ustar liggesusers#' Index \code{brmsfit} objects #' #' @aliases variables nvariables niterations nchains ndraws #' #' Index variables, iterations, chains, and draws. #' #' @param x A \code{brmsfit} object or another \R object for which #' the methods are defined. #' @param ... Arguments passed to individual methods (if applicable). #' #' @name draws-index-brms NULL #' @rdname draws-index-brms #' @importFrom posterior variables #' @method variables brmsfit #' @export #' @export variables variables.brmsfit <- function(x, ...) { # TODO: simplify once rstan and cmdstanr support these methods out <- dimnames(x$fit) if (is.list(out)) { out <- out$parameters } out } #' @method variables data.frame variables.data.frame <- function(x, ...) { names(x) } #' @rdname draws-index-brms #' @importFrom posterior nvariables #' @method nvariables brmsfit #' @export #' @export nvariables nvariables.brmsfit <- function(x, ...) { length(variables(x, ...)) } #' @rdname draws-index-brms #' @importFrom posterior niterations #' @method niterations brmsfit #' @export #' @export niterations niterations.brmsfit <- function(x) { if (!is.stanfit(x$fit)) return(0) niterations <- x$fit@sim$n_save[1] %||% 0 niterations - nwarmup(x) } #' @rdname draws-index-brms #' @importFrom posterior nchains #' @method nchains brmsfit #' @export #' @export nchains nchains.brmsfit <- function(x) { if (!is.stanfit(x$fit)) return(0) x$fit@sim$chains %||% 0 } #' @rdname draws-index-brms #' @importFrom posterior ndraws #' @method ndraws brmsfit #' @export #' @export ndraws ndraws.brmsfit <- function(x) { niterations(x) * nchains(x) } nwarmup <- function(x) { if (!is.stanfit(x$fit)) return(0) x$fit@sim$warmup2[1] %||% 0 } nthin <- function(x) { if (!is.stanfit(x$fit)) return(1) x$fit@sim$thin %||% 1 } #' Transform \code{brmsfit} to \code{draws} objects #' #' Transform a \code{brmsfit} object to a format supported by the #' \pkg{posterior} package. #' #' @aliases as_draws as_draws_matrix as_draws_array as_draws_df #' @aliases as_draws_rvars as_draws_list #' #' @param x A \code{brmsfit} object or another \R object for which #' the methods are defined. #' @param variable A character vector providing the variables to extract. #' By default, all variables are extracted. #' @param regex Logical; Should variable should be treated as a (vector of) #' regular expressions? Any variable in \code{x} matching at least one of the #' regular expressions will be selected. Defaults to \code{FALSE}. #' @param inc_warmup Should warmup draws be included? Defaults to \code{FALSE}. #' @param ... Arguments passed to individual methods (if applicable). #' #' @details To subset iterations, chains, or draws, use the #' \code{\link[posterior:subset_draws]{subset_draws}} method after #' transforming the \code{brmsfit} to a \code{draws} object. #' #' @seealso \code{\link[posterior:draws]{draws}} #' \code{\link[posterior:subset_draws]{subset_draws}} #' #' @examples #' \dontrun{ #' fit <- brm(count ~ zAge + zBase * Trt + (1|patient), #' data = epilepsy, family = poisson()) #' #' # extract posterior draws in an array format #' (draws_fit <- as_draws_array(fit)) #' posterior::summarize_draws(draws_fit) #' #' # extract only certain variables #' as_draws_array(fit, variable = "r_patient") #' as_draws_array(fit, variable = "^b_", regex = TRUE) #' #' # extract posterior draws in a random variables format #' as_draws_rvars(fit) #' } #' #' @name draws-brms NULL #' @rdname draws-brms #' @importFrom posterior as_draws #' @method as_draws brmsfit #' @export #' @export as_draws as_draws.brmsfit <- function(x, variable = NULL, regex = FALSE, inc_warmup = FALSE, ...) { # draws_list is the fastest format to convert to at the moment as_draws_list( x, variable = variable, regex = regex, inc_warmup = inc_warmup, ... ) } #' @rdname draws-brms #' @importFrom posterior as_draws_matrix #' @method as_draws_matrix brmsfit #' @export #' @export as_draws_matrix as_draws_matrix.brmsfit <- function(x, variable = NULL, regex = FALSE, inc_warmup = FALSE, ...) { as_draws_matrix(as_draws_list( x, variable = variable, regex = regex, inc_warmup = inc_warmup, ... )) } #' @rdname draws-brms #' @importFrom posterior as_draws_array #' @method as_draws_array brmsfit #' @export #' @export as_draws_array as_draws_array.brmsfit <- function(x, variable = NULL, regex = FALSE, inc_warmup = FALSE, ...) { as_draws_array(as_draws_list( x, variable = variable, regex = regex, inc_warmup = inc_warmup, ... )) } #' @rdname draws-brms #' @importFrom posterior as_draws_df #' @method as_draws_df brmsfit #' @export #' @export as_draws_df as_draws_df.brmsfit <- function(x, variable = NULL, regex = FALSE, inc_warmup = FALSE, ...) { as_draws_df(as_draws_list( x, variable = variable, regex = regex, inc_warmup = inc_warmup, ... )) } #' @rdname draws-brms #' @importFrom posterior as_draws_list #' @method as_draws_list brmsfit #' @export #' @export as_draws_list as_draws_list.brmsfit <- function(x, variable = NULL, regex = FALSE, inc_warmup = FALSE, ...) { .as_draws_list( x$fit, variable = variable, regex = regex, inc_warmup = inc_warmup, ... ) } #' @rdname draws-brms #' @importFrom posterior as_draws_rvars #' @method as_draws_rvars brmsfit #' @export #' @export as_draws_rvars as_draws_rvars.brmsfit <- function(x, variable = NULL, regex = FALSE, inc_warmup = FALSE, ...) { as_draws_rvars(as_draws_list( x, variable = variable, regex = regex, inc_warmup = inc_warmup, ... )) } # in stanfit objects draws are stored in a draws_list-like format # so converting from there will be most efficient # may be removed once rstan supports posterior natively .as_draws_list <- function(x, variable = NULL, regex = FALSE, inc_warmup = FALSE, ...) { stopifnot(is.stanfit(x)) inc_warmup <- as_one_logical(inc_warmup) if (!length(x@sim$samples)) { stop2("The model does not contain posterior draws.") } out <- as_draws_list(x@sim$samples) # first subset variables then remove warmup as removing warmup # will take a lot of time when extracting many variables out <- subset_draws(out, variable = variable, regex = regex) if (nvariables(out) > 0 && !inc_warmup) { nwarmup <- x@sim$warmup2[1] %||% 0 warmup_ids <- seq_len(nwarmup) iteration_ids <- posterior::iteration_ids(out) if (length(warmup_ids)) { iteration_ids <- iteration_ids[-warmup_ids] } out <- subset_draws(out, iteration = iteration_ids) } out } #' Extract Posterior Draws #' #' Extract posterior draws in conventional formats #' as data.frames, matrices, or arrays. #' #' @inheritParams as_draws.brmsfit #' @param pars Deprecated alias of \code{variable}. For reasons of backwards #' compatibility, \code{pars} is interpreted as a vector of regular #' expressions by default unless \code{fixed = TRUE} is specified. #' @param draw The draw indices to be select. Subsetting draw indices will lead #' to an automatic merging of chains. #' @param subset Deprecated alias of \code{draw}. #' @param row.names,optional Unused and only added for consistency with #' the \code{\link[base:as.data.frame]{as.data.frame}} generic. #' @param ... Further arguments to be passed to the corresponding #' \code{\link[brms:draws-brms]{as_draws_*}} methods as well as to #' \code{\link[posterior:subset_draws]{subset_draws}}. #' #' @return A data.frame, matrix, or array containing the posterior draws. #' #' @seealso \code{\link[brms:draws-brms]{as_draws}}, #' \code{\link[posterior:subset_draws]{subset_draws}} #' #' @export as.data.frame.brmsfit <- function(x, row.names = NULL, optional = TRUE, pars = NA, variable = NULL, draw = NULL, subset = NULL, ...) { variable <- use_variable_alias(variable, x, pars = pars, ...) draw <- use_alias(draw, subset) out <- as_draws_df(x, variable = variable, ...) out <- suppressMessages(subset_draws(out, draw = draw, ...)) unclass_draws(out) } #' @rdname as.data.frame.brmsfit #' @export as.matrix.brmsfit <- function(x, pars = NA, variable = NULL, draw = NULL, subset = NULL, ...) { variable <- use_variable_alias(variable, x, pars = pars, ...) draw <- use_alias(draw, subset) out <- as_draws_matrix(x, variable = variable, ...) out <- suppressMessages(subset_draws(out, draw = draw, ...)) unclass_draws(out) } #' @rdname as.data.frame.brmsfit #' @export as.array.brmsfit <- function(x, pars = NA, variable = NULL, draw = NULL, subset = NULL, ...) { variable <- use_variable_alias(variable, x, pars = pars, ...) draw <- use_alias(draw, subset) out <- as_draws_array(x, variable = variable, ...) out <- suppressMessages(subset_draws(out, draw = draw, ...)) unclass_draws(out) } # use the deprecated 'pars' alias to 'variable' use_variable_alias <- function(variable, object, pars = NA, ...) { if (!anyNA(pars)) { warning2("Argument 'pars' is deprecated. Please use 'variable' instead.") variable <- extract_pars(pars, variables(object), ...) } variable } # remove the posterior draws format classes from objects unclass_draws <- function(x, ...) { UseMethod("unclass_draws") } #' @export unclass_draws.default <- function(x, ...) { unclass(x) } #' @export unclass_draws.draws_df <- function(x, ...) { x <- as.data.frame(x) x$.chain <- x$.iteration <- x$.draw <- NULL x } brms/R/kfold.R0000644000176200001440000004643115057533407012661 0ustar liggesusers#' K-Fold Cross-Validation #' #' Perform exact K-fold cross-validation by refitting the model \eqn{K} #' times each leaving out one-\eqn{K}th of the original data. #' Folds can be run in parallel using the \pkg{future} package. #' #' @aliases kfold #' #' @inheritParams loo.brmsfit #' @param K The number of subsets of equal (if possible) size #' into which the data will be partitioned for performing #' \eqn{K}-fold cross-validation. The model is refit \code{K} times, each time #' leaving out one of the \code{K} subsets. If \code{K} is equal to the total #' number of observations in the data then \eqn{K}-fold cross-validation is #' equivalent to exact leave-one-out cross-validation. #' @param Ksub Optional number of subsets (of those subsets defined by \code{K}) #' to be evaluated. If \code{NULL} (the default), \eqn{K}-fold cross-validation #' will be performed on all subsets. If \code{Ksub} is a single integer, #' \code{Ksub} subsets (out of all \code{K}) subsets will be randomly chosen. #' If \code{Ksub} consists of multiple integers or a one-dimensional array #' (created via \code{as.array}) potentially of length one, the corresponding #' subsets will be used. This argument is primarily useful, if evaluation of #' all subsets is infeasible for some reason. #' @param folds Determines how the subsets are being constructed. #' Possible values are \code{NULL} (the default), \code{"stratified"}, #' \code{"grouped"}, or \code{"loo"}. May also be a vector of length #' equal to the number of observations in the data. Alters the way #' \code{group} is handled. More information is provided in the 'Details' #' section. #' @param group Optional name of a grouping variable or factor in the model. #' What exactly is done with this variable depends on argument \code{folds}. #' More information is provided in the 'Details' section. #' @param joint Indicates which observations' log likelihoods shall be #' considered jointly in the ELPD computation. If \code{"obs"} or \code{FALSE} #' (the default), each observation is considered separately. This enables #' comparability of \code{kfold} with \code{loo}. If \code{"fold"} or #' \code{TRUE}, the joint log likelihoods per fold are used. If #' \code{"group"}, the joint log likelihoods per group within folds are used #' (only available if argument \code{group} is specified). #' @param save_fits If \code{TRUE}, a component \code{fits} is added to #' the returned object to store the cross-validated \code{brmsfit} #' objects and the indices of the omitted observations for each fold. #' Defaults to \code{FALSE}. #' @param recompile Logical, indicating whether the Stan model should be #' recompiled. This may be necessary if you are running \code{reloo} on #' another machine than the one used to fit the model. #' @param future_args A list of further arguments passed to #' \code{\link[future:future]{future}} for additional control over parallel #' execution if activated. #' @param ... Further arguments passed to \code{\link{brm}} and #' \code{\link{log_lik}}. #' #' @return \code{kfold} returns an object that has a similar structure as the #' objects returned by the \code{loo} and \code{waic} methods and #' can be used with the same post-processing functions. #' #' @details The \code{kfold} function performs exact \eqn{K}-fold #' cross-validation. First the data are partitioned into \eqn{K} folds #' (i.e. subsets) of equal (or as close to equal as possible) size by default. #' Then the model is refit \eqn{K} times, each time leaving out one of the #' \code{K} subsets. If \eqn{K} is equal to the total number of observations #' in the data then \eqn{K}-fold cross-validation is equivalent to exact #' leave-one-out cross-validation (to which \code{loo} is an efficient #' approximation). The \code{compare_ic} function is also compatible with #' the objects returned by \code{kfold}. #' #' The subsets can be constructed in multiple different ways: #' \itemize{ #' \item If both \code{folds} and \code{group} are \code{NULL}, the subsets #' are randomly chosen so that they have equal (or as close to equal as #' possible) size. #' \item If \code{folds} is \code{NULL} but \code{group} is specified, the #' data is split up into subsets, each time omitting all observations of one #' of the factor levels, while ignoring argument \code{K}. #' \item If \code{folds = "stratified"} the subsets are stratified after #' \code{group} using \code{\link[loo:kfold-helpers]{loo::kfold_split_stratified}}. #' \item If \code{folds = "grouped"} the subsets are split by #' \code{group} using \code{\link[loo:kfold-helpers]{loo::kfold_split_grouped}}. #' \item If \code{folds = "loo"} exact leave-one-out cross-validation #' will be performed and \code{K} will be ignored. Further, if \code{group} #' is specified, all observations corresponding to the factor level of the #' currently predicted single value are omitted. Thus, in this case, the #' predicted values are only a subset of the omitted ones. #' \item If \code{folds} is a numeric vector, it must contain one element per #' observation in the data. Each element of the vector is an integer in #' \code{1:K} indicating to which of the \code{K} folds the corresponding #' observation belongs. There are some convenience functions available in #' the \pkg{loo} package that create integer vectors to use for this purpose #' (see the Examples section below and also the #' \link[loo:kfold-helpers]{kfold-helpers} page). #' } #' #' When running \code{kfold} on a \code{brmsfit} created with the #' \pkg{cmdstanr} backend in a different \R session, several recompilations #' will be triggered because by default, \pkg{cmdstanr} writes the model #' executable to a temporary directory. To avoid that, set option #' \code{"cmdstanr_write_stan_file_dir"} to a nontemporary path of your choice #' before creating the original \code{brmsfit} (see section 'Examples' below). #' #' @template details-sample_new_levels_gaussian #' @template parallelization #' #' @examples #' \dontrun{ #' fit1 <- brm(count ~ zAge + zBase * Trt + (1|patient) + (1|obs), #' data = epilepsy, family = poisson()) #' # throws warning about some pareto k estimates being too high #' (loo1 <- loo(fit1)) #' # perform 10-fold cross validation #' (kfold1 <- kfold(fit1, chains = 1)) #' #' # use joint likelihoods per fold for ELPD evaluation #' kfold(fit1, chains = 1, joint = "fold") #' #' # use the future package for parallelization of models #' # that is to fit models belonging to different folds in parallel #' library(future) #' plan(multisession, workers = 4) #' kfold(fit1, chains = 1) #' plan(sequential) #' #' ## to avoid recompilations when running kfold() on a 'cmdstanr'-backend fit #' ## in a fresh R session, set option 'cmdstanr_write_stan_file_dir' before #' ## creating the initial 'brmsfit' #' ## CAUTION: the following code creates some files in the current working #' ## directory: two 'model_.stan' files, one 'model_(.exe)' #' ## executable, and one 'fit_cmdstanr_.rds' file #' set.seed(7) #' fname <- paste0("fit_cmdstanr_", sample.int(.Machine$integer.max, 1)) #' options(cmdstanr_write_stan_file_dir = getwd()) #' fit_cmdstanr <- brm(rate ~ conc + state, data = Puromycin, #' backend = "cmdstanr", file = fname) #' #' # now restart the R session and run the following (after attaching 'brms') #' set.seed(7) #' fname <- paste0("fit_cmdstanr_", sample.int(.Machine$integer.max, 1)) #' fit_cmdstanr <- brm(rate ~ conc + state, #' data = Puromycin, #' backend = "cmdstanr", #' file = fname) #' kfold_cmdstanr <- kfold(fit_cmdstanr, K = 2) #' } #' #' @seealso \code{\link{loo}}, \code{\link{reloo}} #' #' @importFrom loo kfold #' @export kfold #' @export kfold.brmsfit <- function(x, ..., K = 10, Ksub = NULL, folds = NULL, group = NULL, joint = FALSE, compare = TRUE, resp = NULL, model_names = NULL, save_fits = FALSE, recompile = NULL, future_args = list()) { args <- split_dots(x, ..., model_names = model_names) if (!"use_stored" %in% names(args)) { further_arg_names <- c( "K", "Ksub", "folds", "group", "joint", "resp", "save_fits" ) args$use_stored <- all(names(args) %in% "models") && !any(further_arg_names %in% names(match.call())) } c(args) <- nlist( criterion = "kfold", K, Ksub, folds, group, joint, compare, resp, save_fits, recompile, future_args ) do_call(compute_loolist, args) } # helper function to perform k-fold cross-validation # @inheritParams kfold.brmsfit # @param model_name ignored but included to avoid being passed to '...' .kfold <- function(x, K, Ksub, folds, group, joint, save_fits, newdata, resp, model_name, recompile = NULL, future_args = list(), newdata2 = NULL, ...) { stopifnot(is.brmsfit(x), is.list(future_args)) if (is.brmsfit_multiple(x)) { warn_brmsfit_multiple(x) class(x) <- "brmsfit" } if (is.null(newdata)) { newdata <- x$data } else { newdata <- as.data.frame(newdata) } if (is.null(newdata2)) { newdata2 <- x$data2 } else { bterms <- brmsterms(x$formula) newdata2 <- validate_data2(newdata2, bterms) } N <- nrow(newdata) joint <- validate_joint(joint) # validate argument 'group' gvar <- NULL if (!is.null(group)) { valid_groups <- get_cat_vars(x) if (length(group) != 1L || !group %in% valid_groups) { stop2("Group '", group, "' is not a valid grouping factor. ", "Valid groups are: \n", collapse_comma(valid_groups)) } gvar <- factor(get(group, newdata)) } # validate argument 'folds' if (is.null(folds)) { if (is.null(group)) { fold_type <- "random" folds <- loo::kfold_split_random(K, N) } else { fold_type <- "group" folds <- as.numeric(gvar) K <- length(levels(gvar)) message("Setting 'K' to the number of levels of '", group, "' (", K, ")") } } else if (is.character(folds) && length(folds) == 1L) { opts <- c("loo", "stratified", "grouped") fold_type <- match.arg(folds, opts) req_group_opts <- c("stratified", "grouped") if (fold_type %in% req_group_opts && is.null(group)) { stop2("Argument 'group' is required for fold type '", fold_type, "'.") } if (fold_type == "loo") { folds <- seq_len(N) K <- N message("Setting 'K' to the number of observations (", K, ")") } else if (fold_type == "stratified") { folds <- loo::kfold_split_stratified(K, gvar) } else if (fold_type == "grouped") { folds <- loo::kfold_split_grouped(K, gvar) } } else { fold_type <- "custom" folds <- as.numeric(factor(folds)) if (length(folds) != N) { stop2("If 'folds' is a vector, it must be of length N.") } K <- max(folds) message("Setting 'K' to the number of folds (", K, ")") } # validate argument 'Ksub' if (is.null(Ksub)) { Ksub <- seq_len(K) } else { # see issue #441 for reasons to check for arrays is_array_Ksub <- is.array(Ksub) Ksub <- as.integer(Ksub) if (any(Ksub <= 0 | Ksub > K)) { stop2("'Ksub' must contain positive integers not larger than 'K'.") } if (length(Ksub) == 1L && !is_array_Ksub) { Ksub <- sample(seq_len(K), Ksub) } else { Ksub <- unique(Ksub) } Ksub <- sort(Ksub) } # ensure that the model can be run in the current R session x <- recompile_model(x, recompile = recompile) # split dots for use in log_lik and update dots <- list(...) ll_arg_names <- arg_names("log_lik") ll_args <- dots[intersect(names(dots), ll_arg_names)] ll_args$allow_new_levels <- TRUE ll_args$sample_new_levels <- first_not_null(ll_args$sample_new_levels, "gaussian") ll_args$resp <- resp ll_args$combine <- TRUE up_args <- dots[setdiff(names(dots), ll_arg_names)] up_args$object <- x up_args$refresh <- 0 # function to be run inside future::future .kfold_k <- function(k) { message("Fitting model ", k, " out of ", K) if (fold_type == "loo" && !is.null(group)) { omitted <- which(folds == folds[k]) predicted <- k } else { omitted <- predicted <- which(folds == k) } newdata_omitted <- newdata[-omitted, , drop = FALSE] up_args$newdata <- newdata_omitted up_args$data2 <- subset_data2(newdata2, -omitted) fit <- SW(do_call(update, up_args)) ll_args$object <- fit ll_args$newdata <- newdata[predicted, , drop = FALSE] ll_args$newdata2 <- subset_data2(newdata2, predicted) lppds <- do_call(log_lik, ll_args) if (joint == "fold") { # compute the joint log score over all observations within a fold lppds <- rowSums(lppds) joint_obs <- 1 } else if (joint == "group") { gvar_k <- gvar[predicted] unique_gvar_k <- unique(gvar_k) ngroups <- length(unique_gvar_k) lppds_marg <- matrix(nrow = nrow(lppds), ncol = ngroups) joint_obs <- rep(NA, length(predicted)) for (j in seq_len(ngroups)) { sel_obs <- gvar_k == unique_gvar_k[j] lppds_marg[, j] <- rowSums(lppds[, sel_obs, drop = FALSE]) # tells which observations' elpds were considered jointly joint_obs[sel_obs] <- j } lppds <- lppds_marg } else { joint_obs <- seq_along(predicted) } out <- nlist(lppds, omitted, predicted, joint_obs) if (save_fits) { out$fit <- fit } return(out) } # TODO: separate parallel and non-parallel code to enable better printing? future_args$X <- Ksub future_args$FUN <- .kfold_k future_args$future.seed <- TRUE res <- do_call("future_lapply", future_args, pkg = "future.apply") lppds <- pred_obs_list <- vector("list", length(Ksub)) if (save_fits) { fits <- array(list(), dim = c(length(Ksub), 3)) dimnames(fits) <- list(NULL, c("fit", "omitted", "predicted")) } for (i in seq_along(Ksub)) { if (save_fits) { fits[i, ] <- res[[i]][c("fit", "omitted", "predicted")] } pred_obs_list[[i]] <- res[[i]]$predicted lppds[[i]] <- res[[i]]$lppds } lppds <- do_call(cbind, lppds) elpds <- apply(lppds, 2, log_mean_exp) pred_obs <- unlist(pred_obs_list) if (joint == "obs") { # bring back elpds into the original observation order elpds <- elpds[order(pred_obs)] } # compute effective number of parameters ll_args$object <- x ll_args$newdata <- newdata ll_args$newdata2 <- newdata2 pred_obs_sorted <- sort(pred_obs) if (length(Ksub) < K) { # select the correct subset of predicted observations in the original order ll_args$newdata <- ll_args$newdata[pred_obs_sorted, , drop = FALSE] ll_args$newdata2 <- subset_data2(ll_args$newdata2, pred_obs_sorted) } ll_full <- do_call(log_lik, ll_args) if (joint == "fold") { # compute the joint log score over all observations within a fold ll_full_marg <- matrix(nrow = nrow(ll_full), ncol = length(Ksub)) for (i in seq_along(Ksub)) { sel_obs <- match(pred_obs_list[[i]], pred_obs_sorted) ll_full_marg[, i] <- rowSums(ll_full[, sel_obs, drop = FALSE]) } ll_full <- ll_full_marg } else if (joint == "group") { # compute the joint log score over all observations per group within a fold ll_full_marg <- vector("list", length(Ksub)) for (i in seq_along(Ksub)) { sel_obs <- match(pred_obs_list[[i]], pred_obs_sorted) joint_obs <- res[[i]]$joint_obs unique_joint_obs <- unique(joint_obs) njoint <- length(unique_joint_obs) ll_full_marg[[i]] <- matrix(nrow = nrow(ll_full), ncol = njoint) for (j in seq_len(njoint)) { sel_obs_j <- sel_obs[joint_obs == unique_joint_obs[j]] ll_full_marg[[i]][, j] <- rowSums(ll_full[, sel_obs_j, drop = FALSE]) } } ll_full <- do_call(cbind, ll_full_marg) } lpds <- apply(ll_full, 2, log_mean_exp) ps <- lpds - elpds # put everything together in a loo object pointwise <- cbind(elpd_kfold = elpds, p_kfold = ps, kfoldic = -2 * elpds) est <- colSums(pointwise) se_est <- sqrt(nrow(pointwise) * apply(pointwise, 2, var)) estimates <- cbind(Estimate = est, SE = se_est) rownames(estimates) <- colnames(pointwise) out <- nlist(estimates, pointwise) atts <- nlist(K, Ksub, group, folds, fold_type, joint) attributes(out)[names(atts)] <- atts if (save_fits) { out$fits <- fits out$data <- newdata out$data2 <- newdata2 } structure(out, class = c("kfold", "loo")) } #' Predictions from K-Fold Cross-Validation #' #' Compute and evaluate predictions after performing K-fold #' cross-validation via \code{\link{kfold}}. #' #' @param x Object of class \code{'kfold'} computed by \code{\link{kfold}}. #' For \code{kfold_predict} to work, the fitted model objects need to have #' been stored via argument \code{save_fits} of \code{\link{kfold}}. #' @param method Method used to obtain predictions. Can be set to #' \code{"posterior_predict"} (the default), \code{"posterior_epred"}, #' or \code{"posterior_linpred"}. For more details, see the respective #' function documentations. #' @inheritParams posterior_predict.brmsfit #' #' @return A \code{list} with two slots named \code{'y'} and \code{'yrep'}. #' Slot \code{y} contains the vector of observed responses. #' Slot \code{yrep} contains the matrix of predicted responses, #' with rows being posterior draws and columns being observations. #' #' @seealso \code{\link{kfold}} #' #' @examples #' \dontrun{ #' fit <- brm(count ~ zBase * Trt + (1|patient), #' data = epilepsy, family = poisson()) #' #' # perform k-fold cross validation #' (kf <- kfold(fit, save_fits = TRUE, chains = 1)) #' #' # define a loss function #' rmse <- function(y, yrep) { #' yrep_mean <- colMeans(yrep) #' sqrt(mean((yrep_mean - y)^2)) #' } #' #' # predict responses and evaluate the loss #' kfp <- kfold_predict(kf) #' rmse(y = kfp$y, yrep = kfp$yrep) #' } #' #' @export kfold_predict <- function(x, method = "posterior_predict", resp = NULL, ...) { if (!inherits(x, "kfold")) { stop2("'x' must be a 'kfold' object.") } if (!all(c("fits", "data") %in% names(x))) { stop2( "Slots 'fits' and 'data' are required. ", "Please run kfold with 'save_fits = TRUE'." ) } method <- get(validate_pp_method(method), mode = "function") resp <- validate_resp(resp, x$fits[[1, "fit"]], multiple = FALSE) all_predicted <- as.character(sort(unlist(x$fits[, "predicted"]))) npredicted <- length(all_predicted) ndraws <- ndraws(x$fits[[1, "fit"]]) y <- rep(NA, npredicted) yrep <- matrix(NA, nrow = ndraws, ncol = npredicted) names(y) <- colnames(yrep) <- all_predicted for (k in seq_rows(x$fits)) { fit_k <- x$fits[[k, "fit"]] predicted_k <- x$fits[[k, "predicted"]] obs_names <- as.character(predicted_k) newdata <- x$data[predicted_k, , drop = FALSE] y[obs_names] <- get_y(fit_k, resp, newdata = newdata, ...) yrep[, obs_names] <- method( fit_k, newdata = newdata, resp = resp, allow_new_levels = TRUE, summary = FALSE, ... ) } nlist(y, yrep) } # validate argument 'joint' in kfold validate_joint <- function(joint) { if (length(joint) != 1L) { stop2("Argument 'joint' must be of length 1.") } if (is.logical(joint)) { # for backwards compatibility with brms < 2.20.18 joint <- as_one_logical(joint) joint <- str_if(joint, "fold", "obs") } joint <- as_one_character(joint) options <- c("obs", "fold", "group") match.arg(joint, options) } brms/R/brm_multiple.R0000644000176200001440000002263715057500075014252 0ustar liggesusers#' Run the same \pkg{brms} model on multiple datasets #' #' Run the same \pkg{brms} model on multiple datasets and then combine the #' results into one fitted model object. This is useful in particular for #' multiple missing value imputation, where the same model is fitted on multiple #' imputed data sets. Models can be run in parallel using the \pkg{future} #' package. #' #' @inheritParams brm #' @param data A \emph{list} of data.frames each of which will be used to fit a #' separate model. Alternatively, a \code{mids} object from the \pkg{mice} #' package. #' @param data2 A \emph{list} of named lists each of which will be used to fit a #' separate model. Each of the named lists contains objects representing data #' which cannot be passed via argument \code{data} (see \code{\link{brm}} for #' examples). The length of the outer list should match the length of the list #' passed to the \code{data} argument. #' @param recompile Logical, indicating whether the Stan model should be #' recompiled for every imputed data set. Defaults to \code{FALSE}. If #' \code{NULL}, \code{brm_multiple} tries to figure out internally, if recompilation #' is necessary, for example because data-dependent priors have changed. #' Using the default of no recompilation should be fine in most cases. #' @param combine Logical; Indicates if the fitted models should be combined #' into a single fitted model object via \code{\link{combine_models}}. #' Defaults to \code{TRUE}. #' @param fit An instance of S3 class \code{brmsfit_multiple} derived from a #' previous fit; defaults to \code{NA}. If \code{fit} is of class #' \code{brmsfit_multiple}, the compiled model associated with the fitted #' result is re-used and all arguments modifying the model code or data are #' ignored. It is not recommended to use this argument directly, but to call #' the \code{\link[brms:update.brmsfit_multiple]{update}} method, instead. #' @param ... Further arguments passed to \code{\link{brm}}. #' #' @details The combined model may issue false positive convergence warnings, as #' the MCMC chains corresponding to different datasets may not necessarily #' overlap, even if each of the original models did converge. To find out #' whether each of the original models converged, subset the draws belonging #' to the individual models and then run convergence diagnostics. #' See Examples below for details. #' #' @template parallelization #' #' @return If \code{combine = TRUE} a \code{brmsfit_multiple} object, which #' inherits from class \code{brmsfit} and behaves essentially the same. If #' \code{combine = FALSE} a list of \code{brmsfit} objects. #' #' @examples #' \dontrun{ #' library(mice) #' m <- 5 #' imp <- mice(nhanes2, m = m) #' #' # fit the model using mice and lm #' fit_imp1 <- with(lm(bmi ~ age + hyp + chl), data = imp) #' summary(pool(fit_imp1)) #' #' # fit the model using brms #' fit_imp2 <- brm_multiple(bmi ~ age + hyp + chl, data = imp, chains = 1) #' summary(fit_imp2) #' plot(fit_imp2, variable = "^b_", regex = TRUE) #' #' # investigate convergence of the original models #' library(posterior) #' draws <- as_draws_array(fit_imp2) #' # every dataset has just one chain here #' draws_per_dat <- lapply(1:m, \(i) subset_draws(draws, chain = i)) #' lapply(draws_per_dat, summarise_draws, default_convergence_measures()) #' #' # use the future package for parallelization #' library(future) #' plan(multisession, workers = 4) #' fit_imp3 <- brm_multiple(bmi ~ age + hyp + chl, data = imp, chains = 1) #' summary(fit_imp3) #' } #' #' @export brm_multiple <- function(formula, data, family = gaussian(), prior = NULL, data2 = NULL, autocor = NULL, cov_ranef = NULL, sample_prior = c("no", "yes", "only"), sparse = NULL, knots = NULL, stanvars = NULL, stan_funs = NULL, silent = 1, recompile = FALSE, combine = TRUE, fit = NA, algorithm = getOption("brms.algorithm", "sampling"), seed = NA, file = NULL, file_compress = TRUE, file_refit = getOption("brms.file_refit", "never"), ...) { combine <- as_one_logical(combine) file_refit <- match.arg(file_refit, file_refit_options()) if (!is.null(file)) { if (file_refit == "on_change") { stop2("file_refit = 'on_change' is not supported for brm_multiple yet.") } # optionally load saved model object if (!combine) { stop2("Cannot use 'file' if 'combine' is FALSE.") } if (file_refit != "always") { fits <- read_brmsfit(file) if (!is.null(fits)) { return(fits) } } } algorithm <- match.arg(algorithm, algorithm_choices()) silent <- validate_silent(silent) recompile <- as_one_logical(recompile) data_name <- substitute_name(data) if (inherits(data, "mids")) { require_package("mice", version = "3.0.0") data <- lapply(seq_len(data$m), mice::complete, data = data) } else if (!is_data_list(data)) { stop2("'data' must be a list of data.frames.") } if (!is.null(data2)) { if (!is_data2_list(data2)) { stop2("'data2' must be a list of named lists.") } if (length(data2) != length(data)) { stop2("'data2' must have the same length as 'data'.") } } if (is.brmsfit(fit)) { # avoid complications when updating the model class(fit) <- setdiff(class(fit), "brmsfit_multiple") } else { args <- nlist( formula, data = data[[1]], family, prior, data2 = data2[[1]], autocor, cov_ranef, sample_prior, sparse, knots, stanvars, stan_funs, algorithm, silent, seed, ... ) args$chains <- 0 if (silent < 2) { message("Compiling the C++ model") } fit <- suppressMessages(do_call(brm, args)) } dots <- list(...) # allow compiling the model without sampling (#671) if (isTRUE(dots$chains == 0) || isTRUE(dots$iter == 0)) { class(fit) <- c("brmsfit_multiple", class(fit)) return(fit) } .brm <- function(i, ...) { if (silent < 2) { message("Fitting imputed model ", i) } update(fit, newdata = data[[i]], data2 = data2[[i]], recompile = recompile, silent = silent, ...) } fits <- future.apply::future_lapply( seq_along(data), .brm, ..., future.seed = TRUE ) if (combine) { fits <- combine_models(mlist = fits, check_data = FALSE) attr(fits$data, "data_name") <- data_name # attribute to remember how many imputed datasets where used attr(fits, "nimp") <- length(data) class(fits) <- c("brmsfit_multiple", class(fits)) } if (!is.null(file)) { fits <- write_brmsfit(fits, file, compress = file_compress) } fits } #' Combine Models fitted with \pkg{brms} #' #' Combine multiple \code{brmsfit} objects, which fitted the same model. #' This is usefully for instance when having manually run models in parallel. #' #' @param ... One or more \code{brmsfit} objects. #' @param mlist Optional list of one or more \code{brmsfit} objects. #' @param check_data Logical; indicates if the data should be checked #' for being the same across models (defaults to \code{TRUE}). #' Setting it to \code{FALSE} may be useful for instance #' when combining models fitted on multiple imputed data sets. #' #' @details This function just takes the first model and replaces #' its \code{stanfit} object (slot \code{fit}) by the combined #' \code{stanfit} objects of all models. #' #' @return A \code{brmsfit} object. #' #' @export combine_models <- function(..., mlist = NULL, check_data = TRUE) { models <- c(list(...), mlist) check_data <- as_one_logical(check_data) if (!length(models)) { stop2("No models supplied to 'combine_models'.") } for (i in seq_along(models)) { if (!is.brmsfit(models[[i]])) { stop2("Model ", i, " is no 'brmsfit' object.") } models[[i]] <- restructure(models[[i]]) } ref_formula <- formula(models[[1]]) ref_pars <- variables(models[[1]]) ref_mf <- model.frame(models[[1]]) for (i in seq_along(models)[-1]) { if (!is_equal(formula(models[[i]]), ref_formula)) { stop2("Models 1 and ", i, " have different formulas.") } if (!is_equal(variables(models[[i]]), ref_pars)) { stop2("Models 1 and ", i, " have different parameters.") } if (check_data && !is_equal(model.frame(models[[i]]), ref_mf)) { stop2( "Models 1 and ", i, " have different data. ", "Set 'check_data' to FALSE to turn off checking of the data." ) } } sflist <- from_list(models, "fit") out <- models[[1]] out$fit <- rstan::sflist2stanfit(sflist) # fixes issue #1603 out <- save_old_par_order(out, models[[1]]) if (out$backend == "cmdstanr") { att <- attributes(models[[1]]$fit) attributes(out$fit)$CmdStanModel <- att$CmdStanModel attributes(out$fit)$metadata <- att$metadata } out } # validity check for 'data' input of 'brm_multiple' is_data_list <- function(x) { # see also issue #1383 is.list(x) && (is.vector(x) || all(vapply(x, is.data.frame, logical(1L)))) } # validity check for 'data2' input of 'brm_multiple' is_data2_list <- function(x) { is.list(x) && all(ulapply(x, function(y) is.list(y) && is_named(y))) } warn_brmsfit_multiple <- function(x, newdata = NULL) { if (is.brmsfit_multiple(x) && is.null(newdata)) { warning2( "Using only the first imputed data set. Please interpret the results ", "with caution until a more principled approach has been implemented." ) } invisible(x) } brms/R/hypothesis.R0000644000176200001440000005746415053306011013752 0ustar liggesusers#' Non-Linear Hypothesis Testing #' #' Perform non-linear hypothesis testing for all model parameters. #' #' @param x An \code{R} object. If it is no \code{brmsfit} object, #' it must be coercible to a \code{data.frame}. #' In the latter case, the variables used in the \code{hypothesis} argument #' need to correspond to column names of \code{x}, while the rows #' are treated as representing posterior draws of the variables. #' @param hypothesis A character vector specifying one or more #' non-linear hypothesis concerning parameters of the model. #' @param class A string specifying the class of parameters being tested. #' Default is "b" for population-level effects. #' Other typical options are "sd" or "cor". #' If \code{class = NULL}, all parameters can be tested #' against each other, but have to be specified with their full name #' (see also \code{\link[brms:draws-index-brms]{variables}}) #' @param group Name of a grouping factor to evaluate only #' group-level effects parameters related to this grouping factor. #' @param alpha The alpha-level of the tests (default is 0.05; #' see 'Details' for more information). #' @param robust If \code{FALSE} (the default) the mean is used as #' the measure of central tendency and the standard deviation as #' the measure of variability. If \code{TRUE}, the median and the #' median absolute deviation (MAD) are applied instead. #' @param scope Indicates where to look for the variables specified in #' \code{hypothesis}. If \code{"standard"}, use the full parameter names #' (subject to the restriction given by \code{class} and \code{group}). #' If \code{"coef"} or \code{"ranef"}, compute the hypothesis for all levels #' of the grouping factor given in \code{"group"}, based on the #' output of \code{\link{coef.brmsfit}} and \code{\link{ranef.brmsfit}}, #' respectively. #' @param seed A single numeric value passed to \code{\link{set.seed}} #' to make results reproducible. This is currently only relevant for point #' hypotheses that scope over at least two parameters (see Details). #' @param ... Currently ignored. #' #' @details Among others, \code{hypothesis} computes an evidence ratio #' (\code{Evid.Ratio}) for each hypothesis. For a one-sided hypothesis, this #' is just the posterior probability (\code{Post.Prob}) under the hypothesis #' against its alternative. That is, when the hypothesis is of the form #' \code{a > b}, the evidence ratio is the ratio of the posterior probability #' of \code{a > b} and the posterior probability of \code{a < b}. In this #' example, values greater than one indicate that the evidence in favor of #' \code{a > b} is larger than evidence in favor of \code{a < b}. For a #' two-sided (point) hypothesis, the evidence ratio is a Bayes factor between #' the hypothesis and its alternative computed via the Savage-Dickey density #' ratio method. That is the posterior density at the point of interest #' divided by the prior density at that point. Values greater than one #' indicate that evidence in favor of the point hypothesis has increased after #' seeing the data. In order to calculate this Bayes factor, all parameters #' related to the hypothesis must have proper priors and argument #' \code{sample_prior} of function \code{brm} must be set to \code{"yes"}. #' Otherwise \code{Evid.Ratio} (and \code{Post.Prob}) will be \code{NA}. #' #' Please note that the Savage-Dickey density ratio as implemented here provides #' only a very basic test of point hypotheses. It is recommended that you use #' bridge sampling instead (via \code{\link{bayes_factor}} which relies on the #' \pkg{bridgesampling} package). When interpreting Bayes factors for point #' hypotheses, make sure that your priors are reasonable and carefully chosen, #' as the result will depend heavily on the priors. In particular, avoid using #' default priors. Additionally, note that point hypotheses that scope over more #' than one parameter (e.g., when testing equality between two parameters) involve #' random sampling of the priors over those parameters (to accommodate the #' the assumption that priors for different parameters are independent of each other). #' This introduces an element of randomness into such hypothesis tests. Consider #' repeating the test to assure results are sufficiently stable, and use the argument #' \code{seed} for reproducibility. Finally, note that, for technical reasons, we #' cannot sample from priors of certain parameters classes. Most notably, these include #' overall intercept parameters (prior class \code{"Intercept"}) as well as group-level #' coefficients. #' #' For one-sided hypotheses, the \code{Evid.Ratio} may sometimes be \code{0} or \code{Inf} implying very #' small or large evidence, respectively, in favor of the tested hypothesis. #' For one-sided hypotheses pairs, this basically means that all posterior #' draws are on the same side of the value dividing the two hypotheses. In #' that sense, instead of \code{0} or \code{Inf,} you may rather read it as #' \code{Evid.Ratio} smaller \code{1 / S} or greater \code{S}, respectively, #' where \code{S} denotes the number of posterior draws used in the #' computations. #' #' The argument \code{alpha} specifies the size of the credible interval #' (i.e., Bayesian confidence interval). For instance, if we tested a #' two-sided hypothesis and set \code{alpha = 0.05} (5\%) an, the credible #' interval will contain \code{1 - alpha = 0.95} (95\%) of the posterior #' values. Hence, \code{alpha * 100}\% of the posterior values will #' lie outside of the credible interval. Although this allows testing of #' hypotheses in a similar manner as in the frequentist null-hypothesis #' testing framework, we strongly argue against using arbitrary cutoffs (e.g., #' \code{p < .05}) to determine the 'existence' of an effect. #' #' @return A \code{\link{brmshypothesis}} object. #' #' @seealso \code{\link{brmshypothesis}} #' #' @examples #' \dontrun{ #' ## define priors #' prior <- c(set_prior("normal(0,2)", class = "b"), #' set_prior("student_t(10,0,1)", class = "sigma"), #' set_prior("student_t(10,0,1)", class = "sd")) #' #' ## fit a linear mixed effects models #' fit <- brm(time ~ age + sex + disease + (1 + age|patient), #' data = kidney, family = lognormal(), #' prior = prior, sample_prior = "yes", #' control = list(adapt_delta = 0.95)) #' #' ## perform two-sided hypothesis testing #' (hyp1 <- hypothesis(fit, "sexfemale = age + diseasePKD")) #' plot(hyp1) #' hypothesis(fit, "exp(age) - 3 = 0", alpha = 0.01) #' #' ## perform one-sided hypothesis testing #' hypothesis(fit, "diseasePKD + diseaseGN - 3 < 0") #' #' hypothesis(fit, "age < Intercept", #' class = "sd", group = "patient") #' #' ## test the amount of random intercept variance on all variance #' h <- paste("sd_patient__Intercept^2 / (sd_patient__Intercept^2 +", #' "sd_patient__age^2 + sigma^2) = 0") #' (hyp2 <- hypothesis(fit, h, class = NULL)) #' plot(hyp2) #' #' ## test more than one hypothesis at once #' h <- c("diseaseGN = diseaseAN", "2 * diseaseGN - diseasePKD = 0") #' (hyp3 <- hypothesis(fit, h)) #' plot(hyp3, ignore_prior = TRUE) #' #' ## compute hypotheses for all levels of a grouping factor #' hypothesis(fit, "age = 0", scope = "coef", group = "patient") #' #' ## use the default method #' dat <- as.data.frame(fit) #' str(dat) #' hypothesis(dat, "b_age > 0") #' } #' #' @export hypothesis.brmsfit <- function(x, hypothesis, class = "b", group = "", scope = c("standard", "ranef", "coef"), alpha = 0.05, robust = FALSE, seed = NULL, ...) { # use a seed as prior_draws.brmsfit randomly permutes draws if (!is.null(seed)) { set.seed(seed) } contains_draws(x) x <- restructure(x) group <- as_one_character(group) scope <- match.arg(scope) if (scope == "standard") { if (!length(class)) { class <- "" } class <- as_one_character(class) if (nzchar(group)) { class <- paste0(class, "_", group, "__") } else if (nzchar(class)) { class <- paste0(class, "_") } out <- .hypothesis( x, hypothesis, class = class, alpha = alpha, robust = robust, ... ) } else { co <- do_call(scope, list(x, summary = FALSE)) if (!group %in% names(co)) { stop2("'group' should be one of ", collapse_comma(names(co))) } out <- hypothesis_coef( co[[group]], hypothesis, alpha = alpha, robust = robust, ... ) } out } #' @rdname hypothesis.brmsfit #' @export hypothesis <- function(x, ...) { UseMethod("hypothesis") } #' @rdname hypothesis.brmsfit #' @export hypothesis.default <- function(x, hypothesis, alpha = 0.05, robust = FALSE, ...) { x <- as.data.frame(x) .hypothesis( x, hypothesis, class = "", alpha = alpha, robust = robust, ... ) } #' Descriptions of \code{brmshypothesis} Objects #' #' A \code{brmshypothesis} object contains posterior draws #' as well as summary statistics of non-linear hypotheses as #' returned by \code{\link{hypothesis}}. #' #' @name brmshypothesis #' #' @param ignore_prior A flag indicating if prior distributions #' should also be plotted. Only used if priors were specified on #' the relevant parameters. #' @param digits Minimal number of significant digits, #' see \code{\link[base:print.default]{print.default}}. #' @param chars Maximum number of characters of each hypothesis #' to print or plot. If \code{NULL}, print the full hypotheses. #' Defaults to \code{20}. #' @param short A flag indicating whether to provide a shorter summary #' with less informational text. Defaults to \code{FALSE}. Can be set #' globally for the current session via the \code{brms.short_summary} option. #' @param colors Two values specifying the colors of the posterior and prior #' density respectively. If \code{NULL} (the default) colors are taken from #' the current color scheme of the \pkg{bayesplot} package. #' @param ... Currently ignored. #' @inheritParams plot.brmsfit #' #' @details #' The two most important elements of a \code{brmshypothesis} object are #' \code{hypothesis}, which is a data.frame containing the summary estimates #' of the hypotheses, and \code{samples}, which is a data.frame containing #' the corresponding posterior draws. #' #' @seealso \code{\link{hypothesis}} NULL # internal function to evaluate hypotheses # @param x the primary object passed to the hypothesis method; # needs to be a brmsfit object or coercible to a data.frame # @param hypothesis vector of character strings containing the hypotheses # @param class prefix of the parameters in the hypotheses # @param alpha the 'alpha-level' as understood by frequentist statistics # @return a 'brmshypothesis' object .hypothesis <- function(x, hypothesis, class, alpha, robust, combine = TRUE, ...) { if (!is.character(hypothesis) || !length(hypothesis)) { stop2("Argument 'hypothesis' must be a character vector.") } if (length(alpha) != 1L || alpha < 0 || alpha > 1) { stop2("Argument 'alpha' must be a single value in [0,1].") } class <- as_one_character(class) robust <- as_one_logical(robust) out <- vector("list", length(hypothesis)) for (i in seq_along(out)) { out[[i]] <- eval_hypothesis( hypothesis[i], x = x, class = class, alpha = alpha, robust = robust, name = names(hypothesis)[i] ) } if (combine) { out <- combine_hlist(out, class = class, alpha = alpha) } out } # evaluate hypotheses for an arrary of ranefs or coefs # seperaly for each grouping-factor level hypothesis_coef <- function(x, hypothesis, alpha, ...) { stopifnot(is.array(x), length(dim(x)) == 3L) levels <- dimnames(x)[[2]] coefs <- dimnames(x)[[3]] x <- lapply(seq_along(levels), function(l) structure(as.data.frame(x[, l, ]), names = coefs) ) out <- vector("list", length(levels)) for (l in seq_along(levels)) { out[[l]] <- .hypothesis( x[[l]], hypothesis, class = "", alpha = alpha, combine = FALSE, ... ) for (i in seq_along(out[[l]])) { out[[l]][[i]]$summary$Group <- levels[l] } } out <- unlist(out, recursive = FALSE) out <- as.list(matrix(out, ncol = length(hypothesis), byrow = TRUE)) out <- combine_hlist(out, class = "", alpha = alpha) out$hypothesis$Group <- factor(out$hypothesis$Group, levels) out$hypothesis <- move2start(out$hypothesis, "Group") out } # combine list of outputs of eval_hypothesis # @param hlist list of evaluate hypothesis # @return a 'brmshypothesis' object combine_hlist <- function(hlist, class, alpha) { stopifnot(is.list(hlist)) hs <- do_call(rbind, lapply(hlist, function(h) h$summary)) rownames(hs) <- NULL samples <- lapply(hlist, function(h) h$samples) samples <- as.data.frame(do_call(cbind, samples)) prior_samples <- lapply(hlist, function(h) h$prior_samples) prior_samples <- as.data.frame(do_call(cbind, prior_samples)) names(samples) <- names(prior_samples) <- paste0("H", seq_along(hlist)) class <- sub("_+$", "", class) # TODO: rename 'samples' to 'draws' in brms 3.0 out <- nlist(hypothesis = hs, samples, prior_samples, class, alpha) structure(out, class = "brmshypothesis") } # evaluate a single hypothesis based on the posterior draws eval_hypothesis <- function(h, x, class, alpha, robust, name = NULL) { stopifnot(length(h) == 1L && is.character(h)) pars <- variables(x)[grepl(paste0("^", class), variables(x))] # parse hypothesis string h <- gsub("[ \t\r\n]", "", h) sign <- get_matches("=|<|>", h) lr <- get_matches("[^=<>]+", h) if (length(sign) != 1L || length(lr) != 2L) { stop2("Every hypothesis must be of the form 'left (= OR < OR >) right'.") } h <- paste0("(", lr[1], ")") h <- paste0(h, ifelse(lr[2] != "0", paste0("-(", lr[2], ")"), "")) varsH <- find_vars(h) parsH <- paste0(class, varsH) miss_pars <- setdiff(parsH, pars) if (length(miss_pars)) { miss_pars <- collapse_comma(miss_pars) stop2("Some parameters cannot be found in the model: \n", miss_pars) } # rename hypothesis for correct evaluation h_renamed <- rename(h, c(":", "[", "]", ","), c("___", ".", ".", "..")) # get posterior and prior draws pattern <- c(paste0("^", class), ":", "\\[", "\\]", ",") repl <- c("", "___", ".", ".", "..") samples <- as.data.frame(x, variable = parsH) names(samples) <- rename(names(samples), pattern, repl, fixed = FALSE) samples <- as.matrix(eval2(h_renamed, samples)) prior_samples <- prior_draws(x, variable = parsH) if (!is.null(prior_samples) && ncol(prior_samples) == length(varsH)) { names(prior_samples) <- rename( names(prior_samples), pattern, repl, fixed = FALSE ) prior_samples <- as.matrix(eval2(h_renamed, prior_samples)) } else { prior_samples <- NULL } # summarize hypothesis wsign <- switch(sign, "=" = "equal", "<" = "less", ">" = "greater") probs <- switch(sign, "=" = c(alpha / 2, 1 - alpha / 2), "<" = c(alpha, 1 - alpha), ">" = c(alpha, 1 - alpha) ) if (robust) { measures <- c("median", "mad") } else { measures <- c("mean", "sd") } measures <- c(measures, "quantile", "evidence_ratio") sm <- lapply( measures, get_estimate, draws = samples, probs = probs, wsign = wsign, prior_samples = prior_samples ) sm <- as.data.frame(matrix(unlist(sm), nrow = 1)) names(sm) <- c("Estimate", "Est.Error", "CI.Lower", "CI.Upper", "Evid.Ratio") sm$Post.Prob <- sm$Evid.Ratio / (1 + sm$Evid.Ratio) if (is.infinite(sm$Evid.Ratio)) { sm$Post.Prob <- 1 } if (sign == "=") { sm$Star <- str_if(!(sm$CI.Lower <= 0 && 0 <= sm$CI.Upper), "*") } else { sm$Star <- str_if(sm$Post.Prob > 1 - alpha, "*") } if (!length(name) || !nzchar(name)) { name <- paste(h, sign, "0") } sm$Hypothesis <- as_one_character(name) sm <- move2start(sm, "Hypothesis") if (is.null(prior_samples)) { prior_samples <- as.matrix(rep(NA, nrow(samples))) } nlist(summary = sm, samples, prior_samples) } # find all valid variable names in a string # @param x a character string # @param dot are dots allowed in variable names? # @param brackets allow brackets at the end of variable names? # @return all valid variable names within the string # @note does not use the R parser itself to allow for double points, # square brackets, and commas at the end of names find_vars <- function(x, dot = TRUE, brackets = TRUE) { x <- gsub("[[:space:]]", "", as_one_character(x)) dot <- as_one_logical(dot) brackets <- as_one_logical(brackets) regex_all <- paste0( "([^([:digit:]|[:punct:])]", if (dot) "|\\.", ")", "[[:alnum:]_\\:", if (dot) "\\.", "]*", if (brackets) "(\\[[^],]+(,[^],]+)*\\])?" ) pos_all <- gregexpr(regex_all, x)[[1]] regex_fun <- paste0( "([^([:digit:]|[:punct:])]", if (dot) "|\\.", ")", "[[:alnum:]_", if (dot) "\\.", "]*\\(" ) pos_fun <- gregexpr(regex_fun, x)[[1]] pos_decnum <- gregexpr("\\.[[:digit:]]+", x)[[1]] keep <- !pos_all %in% c(pos_fun, pos_decnum) pos_var <- pos_all[keep] attr(pos_var, "match.length") <- attributes(pos_all)$match.length[keep] if (length(pos_var)) { out <- unique(unlist(regmatches(x, list(pos_var)))) } else { out <- character(0) } out } #' Compute Density Ratios #' #' Compute the ratio of two densities at given points based on draws of the #' corresponding distributions. #' #' @param x Vector of draws from the first distribution, usually the posterior #' distribution of the quantity of interest. #' @param y Optional vector of draws from the second distribution, usually the #' prior distribution of the quantity of interest. If \code{NULL} (the #' default), only the density of \code{x} will be evaluated. #' @param point Numeric values at which to evaluate and compare the densities. #' Defaults to \code{0}. #' @param n Single numeric value. Influences the accuracy of the density #' estimation. See \code{\link[stats:density]{density}} for details. #' @param ... Further arguments passed to \code{\link[stats:density]{density}}. #' #' @return A vector of length equal to \code{length(point)}. If \code{y} is #' provided, the density ratio of \code{x} against \code{y} is returned. Else, #' only the density of \code{x} is returned. #' #' @details In order to achieve sufficient accuracy in the density estimation, #' more draws than usual are required. That is you may need an effective #' sample size of 10,000 or more to reliably estimate the densities. #' #' @examples #' x <- rnorm(10000) #' y <- rnorm(10000, mean = 1) #' density_ratio(x, y, point = c(0, 1)) #' #' @export density_ratio <- function(x, y = NULL, point = 0, n = 4096, ...) { x <- as.numeric(x) point <- as.numeric(point) dots <- list(...) dots <- dots[names(dots) %in% names(formals("density.default"))] dots$n <- n eval_density <- function(x, point) { # evaluate density of x at point from <- min(x) to <- max(x) if (from > point) { from <- point - sd(x) / 4 } else if (to < point) { to <- point + sd(x) / 4 } dens <- do_call(density, c(nlist(x, from, to), dots)) dens <- spline(dens$x, dens$y, xout = point)$y # the spline may return negative values in extreme cases (#1816) return(pmax(dens, 0)) } out <- ulapply(point, eval_density, x = x) if (!is.null(y)) { y <- as.numeric(y) out <- out / ulapply(point, eval_density, x = y) } out } # compute the evidence ratio between two disjunct hypotheses # @param x posterior draws # @param cut the cut point between the two hypotheses # @param wsign direction of the hypothesis # @param prior_samples optional prior draws for two-sided hypothesis # @param ... optional arguments passed to density_ratio # @return the evidence ratio of the two hypothesis evidence_ratio <- function(x, cut = 0, wsign = c("equal", "less", "greater"), prior_samples = NULL, ...) { wsign <- match.arg(wsign) if (wsign == "equal") { if (is.null(prior_samples)) { out <- NA } else { out <- density_ratio(x, prior_samples, point = cut, ...) } } else if (wsign == "less") { out <- length(which(x < cut)) out <- out / (length(x) - out) } else if (wsign == "greater") { out <- length(which(x > cut)) out <- out / (length(x) - out) } out } # round all numeric elements of a list-like object round_numeric <- function(x, digits = 2) { stopifnot(is.list(x)) for (i in seq_along(x)) { if (is.numeric(x[[i]])) { x[[i]] <- round(x[[i]], digits = digits) } } x } #' @rdname brmshypothesis #' @export print.brmshypothesis <- function(x, digits = 2, chars = 20, short = getOption("brms.short_summary", FALSE), ...) { short <- as_one_logical(short) # make sure hypothesis names are not too long x$hypothesis$Hypothesis <- limit_chars( x$hypothesis$Hypothesis, chars = chars ) cat(paste0("Hypothesis Tests for class ", x$class, ":\n")) x$hypothesis <- round_numeric(x$hypothesis, digits = digits) print(x$hypothesis, quote = FALSE) pone <- (1 - x$alpha * 2) * 100 ptwo <- (1 - x$alpha) * 100 if (!short) { cat(glue( "---\n'CI': {pone}%-CI for one-sided and {ptwo}%-CI for two-sided hypotheses.\n", "'*': For one-sided hypotheses, the posterior probability exceeds {ptwo}%;\n", "for two-sided hypotheses, the value tested against lies outside the {ptwo}%-CI.\n", "Posterior probabilities of point hypotheses assume equal prior probabilities.\n" )) } invisible(x) } #' @rdname brmshypothesis #' @method plot brmshypothesis #' @export plot.brmshypothesis <- function(x, nvariables = 5, N = NULL, ignore_prior = FALSE, chars = 40, colors = NULL, theme = NULL, ask = TRUE, plot = TRUE, ...) { dots <- list(...) nvariables <- use_alias(nvariables, N) if (!is.data.frame(x$samples)) { stop2("No posterior draws found.") } plot <- use_alias(plot, dots$do_plot) if (is.null(colors)) { colors <- bayesplot::color_scheme_get()[c(4, 2)] colors <- unname(unlist(colors)) } if (length(colors) != 2L) { stop2("Argument 'colors' must be of length 2.") } .plot_fun <- function(samples) { samples <- na.omit(samples) # if no prior draws are present, there is no need to plot a legend ignore_prior <- ignore_prior || length(unique(samples$Type)) == 1L gg <- ggplot(samples, aes(x = .data[["values"]])) + facet_wrap("ind", ncol = 1, scales = "free") + xlab("") + ylab("") + theme + theme(axis.text.y = element_blank(), axis.ticks.y = element_blank()) if (ignore_prior) { gg <- gg + geom_density(alpha = 0.7, fill = colors[1], na.rm = TRUE) } else { gg <- gg + geom_density(aes(fill = .data[["Type"]]), alpha = 0.7, na.rm = TRUE) + scale_fill_manual(values = colors) } return(gg) } samples <- cbind(x$samples, Type = "Posterior") if (!ignore_prior) { prior_samples <- cbind(x$prior_samples, Type = "Prior") samples <- rbind(samples, prior_samples) } if (plot) { default_ask <- devAskNewPage() on.exit(devAskNewPage(default_ask)) devAskNewPage(ask = FALSE) } hyps <- limit_chars(x$hypothesis$Hypothesis, chars = chars) if (!is.null(x$hypothesis$Group)) { hyps <- paste0(x$hypothesis$Group, ": ", hyps) } names(samples)[seq_along(hyps)] <- hyps nplots <- ceiling(length(hyps) / nvariables) plots <- vector(mode = "list", length = nplots) for (i in seq_len(nplots)) { sub <- ((i - 1) * nvariables + 1):min(i * nvariables, length(hyps)) sub_hyps <- hyps[sub] sub_samples <- cbind( utils::stack(samples[, sub_hyps, drop = FALSE]), samples[, "Type", drop = FALSE] ) # make sure that parameters appear in the original order sub_samples$ind <- with(sub_samples, factor(ind, levels = unique(ind))) plots[[i]] <- .plot_fun(sub_samples) if (plot) { plot(plots[[i]]) if (i == 1) devAskNewPage(ask = ask) } } invisible(plots) } brms/R/posterior_predict.R0000644000176200001440000011052615053072461015311 0ustar liggesusers#' Draws from the Posterior Predictive Distribution #' #' Compute posterior draws of the posterior predictive distribution. Can be #' performed for the data used to fit the model (posterior predictive checks) or #' for new data. By definition, these draws have higher variance than draws #' of the expected value of the posterior predictive distribution computed by #' \code{\link{posterior_epred.brmsfit}}. This is because the residual error #' is incorporated in \code{posterior_predict}. However, the estimated means of #' both methods averaged across draws should be very similar. #' #' @inheritParams prepare_predictions #' @param object An object of class \code{brmsfit}. #' @param re.form Alias of \code{re_formula}. #' @param transform (Deprecated) A function or a character string naming #' a function to be applied on the predicted responses #' before summary statistics are computed. #' @param negative_rt Only relevant for Wiener diffusion models. #' A flag indicating whether response times of responses #' on the lower boundary should be returned as negative values. #' This allows to distinguish responses on the upper and #' lower boundary. Defaults to \code{FALSE}. #' @param sort Logical. Only relevant for time series models. #' Indicating whether to return predicted values in the original #' order (\code{FALSE}; default) or in the order of the #' time series (\code{TRUE}). #' @param ntrys Parameter used in rejection sampling #' for truncated discrete models only #' (defaults to \code{5}). See Details for more information. #' @param cores Number of cores (defaults to \code{1}). On non-Windows systems, #' this argument can be set globally via the \code{mc.cores} option. #' @param ... Further arguments passed to \code{\link{prepare_predictions}} #' that control several aspects of data validation and prediction. #' #' @return An \code{array} of draws. In univariate models, #' the output is as an S x N matrix, where S is the number of posterior #' draws and N is the number of observations. In multivariate models, an #' additional dimension is added to the output which indexes along the #' different response variables. #' #' @template details-newdata-na #' @template details-allow_new_levels #' @details For truncated discrete models only: In the absence of any general #' algorithm to sample from truncated discrete distributions, rejection #' sampling is applied in this special case. This means that values are #' sampled until a value lies within the defined truncation boundaries. In #' practice, this procedure may be rather slow (especially in \R). Thus, we #' try to do approximate rejection sampling by sampling each value #' \code{ntrys} times and then select a valid value. If all values are #' invalid, the closest boundary is used, instead. If there are more than a #' few of these pathological cases, a warning will occur suggesting to #' increase argument \code{ntrys}. #' #' @examples #' \dontrun{ #' ## fit a model #' fit <- brm(time | cens(censored) ~ age + sex + (1 + age || patient), #' data = kidney, family = "exponential", init = "0") #' #' ## predicted responses #' pp <- posterior_predict(fit) #' str(pp) #' #' ## predicted responses excluding the group-level effect of age #' pp <- posterior_predict(fit, re_formula = ~ (1 | patient)) #' str(pp) #' #' ## predicted responses of patient 1 for new data #' newdata <- data.frame( #' sex = factor(c("male", "female")), #' age = c(20, 50), #' patient = c(1, 1) #' ) #' pp <- posterior_predict(fit, newdata = newdata) #' str(pp) #' } #' #' @aliases posterior_predict #' @method posterior_predict brmsfit #' @importFrom rstantools posterior_predict #' @export #' @export posterior_predict posterior_predict.brmsfit <- function( object, newdata = NULL, re_formula = NULL, re.form = NULL, transform = NULL, resp = NULL, negative_rt = FALSE, ndraws = NULL, draw_ids = NULL, sort = FALSE, ntrys = 5, cores = NULL, ... ) { cl <- match.call() if ("re.form" %in% names(cl) && !missing(re.form)) { re_formula <- re.form } contains_draws(object) object <- restructure(object) prep <- prepare_predictions( object, newdata = newdata, re_formula = re_formula, resp = resp, ndraws = ndraws, draw_ids = draw_ids, check_response = FALSE, ... ) posterior_predict( prep, transform = transform, sort = sort, ntrys = ntrys, negative_rt = negative_rt, cores = cores, summary = FALSE ) } #' @export posterior_predict.mvbrmsprep <- function(object, ...) { if (length(object$mvpars$rescor)) { object$mvpars$Mu <- get_Mu(object) object$mvpars$Sigma <- get_Sigma(object) out <- posterior_predict.brmsprep(object, ...) } else { out <- lapply(object$resps, posterior_predict, ...) along <- ifelse(length(out) > 1L, 3, 2) out <- do_call(abind, c(out, along = along)) } out } #' @export posterior_predict.brmsprep <- function(object, transform = NULL, sort = FALSE, summary = FALSE, robust = FALSE, probs = c(0.025, 0.975), cores = NULL, ...) { summary <- as_one_logical(summary) cores <- validate_cores_post_processing(cores) if (is.customfamily(object$family)) { # ensure that the method can be found during parallel execution object$family$posterior_predict <- custom_family_method(object$family, "posterior_predict") } for (nlp in names(object$nlpars)) { object$nlpars[[nlp]] <- get_nlpar(object, nlpar = nlp) } for (dp in names(object$dpars)) { object$dpars[[dp]] <- get_dpar(object, dpar = dp) } pp_fun <- paste0("posterior_predict_", object$family$fun) pp_fun <- get(pp_fun, asNamespace("brms")) N <- choose_N(object) out <- plapply(seq_len(N), pp_fun, .cores = cores, prep = object, ...) if (grepl("_mv$", object$family$fun)) { out <- do_call(abind, c(out, along = 3)) out <- aperm(out, perm = c(1, 3, 2)) dimnames(out)[[3]] <- names(object$resps) } else if (has_multicol(object$family)) { out <- do_call(abind, c(out, along = 3)) out <- aperm(out, perm = c(1, 3, 2)) dimnames(out)[[3]] <- object$cats } else { out <- do_call(cbind, out) } colnames(out) <- rownames(out) <- NULL if (use_int(object$family)) { out <- check_discrete_trunc_bounds( out, lb = object$data$lb, ub = object$data$ub ) } out <- reorder_obs(out, object$old_order, sort = sort) # transform predicted response draws before summarizing them if (!is.null(transform)) { # deprecated as of brms 2.12.3 warning2("Argument 'transform' is deprecated ", "and will be removed in the future.") out <- do_call(transform, list(out)) } attr(out, "levels") <- object$cats if (summary) { # only for compatibility with the 'predict' method if (is_ordinal(object$family)) { levels <- seq_len(max(object$data$nthres) + 1) out <- posterior_table(out, levels = levels) } else if (is_categorical(object$family)) { levels <- seq_len(object$data$ncat) out <- posterior_table(out, levels = levels) } else { out <- posterior_summary(out, probs = probs, robust = robust) } } out } #' Draws from the Posterior Predictive Distribution #' #' This method is an alias of \code{\link{posterior_predict.brmsfit}} #' with additional arguments for obtaining summaries of the computed draws. #' #' @inheritParams posterior_predict.brmsfit #' @param summary Should summary statistics be returned #' instead of the raw values? Default is \code{TRUE}. #' @param robust If \code{FALSE} (the default) the mean is used as #' the measure of central tendency and the standard deviation as #' the measure of variability. If \code{TRUE}, the median and the #' median absolute deviation (MAD) are applied instead. #' Only used if \code{summary} is \code{TRUE}. #' @param probs The percentiles to be computed by the \code{quantile} #' function. Only used if \code{summary} is \code{TRUE}. #' #' @return An \code{array} of predicted response values. #' If \code{summary = FALSE} the output resembles those of #' \code{\link{posterior_predict.brmsfit}}. #' #' If \code{summary = TRUE} the output depends on the family: For categorical #' and ordinal families, the output is an N x C matrix, where N is the number #' of observations, C is the number of categories, and the values are #' predicted category probabilities. For all other families, the output is a N #' x E matrix where E = \code{2 + length(probs)} is the number of summary #' statistics: The \code{Estimate} column contains point estimates (either #' mean or median depending on argument \code{robust}), while the #' \code{Est.Error} column contains uncertainty estimates (either standard #' deviation or median absolute deviation depending on argument #' \code{robust}). The remaining columns starting with \code{Q} contain #' quantile estimates as specified via argument \code{probs}. #' #' @seealso \code{\link{posterior_predict.brmsfit}} #' #' @examples #' \dontrun{ #' ## fit a model #' fit <- brm(time | cens(censored) ~ age + sex + (1 + age || patient), #' data = kidney, family = "exponential", init = "0") #' #' ## predicted responses #' pp <- predict(fit) #' head(pp) #' #' ## predicted responses excluding the group-level effect of age #' pp <- predict(fit, re_formula = ~ (1 | patient)) #' head(pp) #' #' ## predicted responses of patient 1 for new data #' newdata <- data.frame( #' sex = factor(c("male", "female")), #' age = c(20, 50), #' patient = c(1, 1) #' ) #' predict(fit, newdata = newdata) #' } #' #' @export predict.brmsfit <- function(object, newdata = NULL, re_formula = NULL, transform = NULL, resp = NULL, negative_rt = FALSE, ndraws = NULL, draw_ids = NULL, sort = FALSE, ntrys = 5, cores = NULL, summary = TRUE, robust = FALSE, probs = c(0.025, 0.975), ...) { contains_draws(object) object <- restructure(object) prep <- prepare_predictions( object, newdata = newdata, re_formula = re_formula, resp = resp, ndraws = ndraws, draw_ids = draw_ids, check_response = FALSE, ... ) posterior_predict( prep, transform = transform, ntrys = ntrys, negative_rt = negative_rt, sort = sort, cores = cores, summary = summary, robust = robust, probs = probs ) } #' Predictive Intervals #' #' Compute intervals from the posterior predictive distribution. #' #' @aliases predictive_interval #' #' @param object An \R object of class \code{brmsfit}. #' @param prob A number p (0 < p < 1) indicating the desired probability mass to #' include in the intervals. Defaults to \code{0.9}. #' @param ... Further arguments passed to \code{\link{posterior_predict}}. #' #' @return A matrix with 2 columns for the lower and upper bounds of the #' intervals, respectively, and as many rows as observations being predicted. #' #' @examples #' \dontrun{ #' fit <- brm(count ~ zBase, data = epilepsy, family = poisson()) #' predictive_interval(fit) #' } #' #' @importFrom rstantools predictive_interval #' @export predictive_interval #' @export predictive_interval.brmsfit <- function(object, prob = 0.9, ...) { out <- posterior_predict(object, ...) predictive_interval(out, prob = prob) } # validate method name to obtain posterior predictions # @param method name of the method # @return validated name of the method validate_pp_method <- function(method) { method <- as_one_character(method) if (method %in% c("posterior_predict", "predict", "pp")) { method <- "posterior_predict" } else if (method %in% c("posterior_epred", "fitted", "pp_expect")) { method <- "posterior_epred" } else if (method %in% c("posterior_linpred")) { method <- "posterior_linpred" } else if (method %in% c("predictive_error", "residuals")) { method <- "predictive_error" } else { stop2("Posterior predictive method '", method, "' it not supported.") } method } # ------------------- family specific posterior_predict methods --------------------- # All posterior_predict_ functions have the same arguments structure # @param i index of the observatio for which to compute pp values # @param prep A named list returned by prepare_predictions containing # all required data and posterior draws # @param ... ignored arguments # @param A vector of length prep$ndraws containing draws # from the posterior predictive distribution posterior_predict_gaussian <- function(i, prep, ntrys = 5, ...) { mu <- get_dpar(prep, "mu", i = i) sigma <- get_dpar(prep, "sigma", i = i) sigma <- add_sigma_se(sigma, prep, i = i) rcontinuous( n = prep$ndraws, dist = "norm", mean = mu, sd = sigma, lb = prep$data$lb[i], ub = prep$data$ub[i], ntrys = ntrys ) } posterior_predict_student <- function(i, prep, ntrys = 5, ...) { nu <- get_dpar(prep, "nu", i = i) mu <- get_dpar(prep, "mu", i = i) sigma <- get_dpar(prep, "sigma", i = i) sigma <- add_sigma_se(sigma, prep, i = i) rcontinuous( n = prep$ndraws, dist = "student_t", df = nu, mu = mu, sigma = sigma, lb = prep$data$lb[i], ub = prep$data$ub[i], ntrys = ntrys ) } posterior_predict_lognormal <- function(i, prep, ntrys = 5, ...) { rcontinuous( n = prep$ndraws, dist = "lnorm", meanlog = get_dpar(prep, "mu", i = i), sdlog = get_dpar(prep, "sigma", i = i), lb = prep$data$lb[i], ub = prep$data$ub[i], ntrys = ntrys ) } posterior_predict_shifted_lognormal <- function(i, prep, ntrys = 5, ...) { rcontinuous( n = prep$ndraws, dist = "shifted_lnorm", meanlog = get_dpar(prep, "mu", i = i), sdlog = get_dpar(prep, "sigma", i = i), shift = get_dpar(prep, "ndt", i = i), lb = prep$data$lb[i], ub = prep$data$ub[i], ntrys = ntrys ) } posterior_predict_skew_normal <- function(i, prep, ntrys = 5, ...) { mu <- get_dpar(prep, "mu", i = i) sigma <- get_dpar(prep, "sigma", i = i) sigma <- add_sigma_se(sigma, prep, i = i) alpha <- get_dpar(prep, "alpha", i = i) rcontinuous( n = prep$ndraws, dist = "skew_normal", mu = mu, sigma = sigma, alpha = alpha, lb = prep$data$lb[i], ub = prep$data$ub[i], ntrys = ntrys ) } posterior_predict_gaussian_mv <- function(i, prep, ...) { Mu <- get_Mu(prep, i = i) Sigma <- get_Sigma(prep, i = i) .predict <- function(s) { rmulti_normal(1, mu = Mu[s, ], Sigma = Sigma[s, , ]) } rblapply(seq_len(prep$ndraws), .predict) } posterior_predict_student_mv <- function(i, prep, ...) { nu <- get_dpar(prep, "nu", i = i) Mu <- get_Mu(prep, i = i) Sigma <- get_Sigma(prep, i = i) .predict <- function(s) { rmulti_student_t(1, df = nu[s], mu = Mu[s, ], Sigma = Sigma[s, , ]) } rblapply(seq_len(prep$ndraws), .predict) } posterior_predict_gaussian_time <- function(i, prep, ...) { obs <- with(prep$ac, begin_tg[i]:end_tg[i]) Jtime <- prep$ac$Jtime_tg[i, ] mu <- as.matrix(get_dpar(prep, "mu", i = obs)) Sigma <- get_cov_matrix_ac(prep, obs, Jtime = Jtime) .predict <- function(s) { rmulti_normal(1, mu = mu[s, ], Sigma = Sigma[s, , ]) } rblapply(seq_len(prep$ndraws), .predict) } posterior_predict_student_time <- function(i, prep, ...) { obs <- with(prep$ac, begin_tg[i]:end_tg[i]) Jtime <- prep$ac$Jtime_tg[i, ] nu <- as.matrix(get_dpar(prep, "nu", i = obs)) mu <- as.matrix(get_dpar(prep, "mu", i = obs)) Sigma <- get_cov_matrix_ac(prep, obs, Jtime = Jtime) .predict <- function(s) { rmulti_student_t(1, df = nu[s, ], mu = mu[s, ], Sigma = Sigma[s, , ]) } rblapply(seq_len(prep$ndraws), .predict) } posterior_predict_gaussian_lagsar <- function(i, prep, ...) { stopifnot(i == 1) .predict <- function(s) { M_new <- with(prep, diag(nobs) - ac$lagsar[s] * ac$Msar) mu <- as.numeric(solve(M_new) %*% mu[s, ]) Sigma <- solve(crossprod(M_new)) * sigma[s]^2 rmulti_normal(1, mu = mu, Sigma = Sigma) } mu <- get_dpar(prep, "mu") sigma <- get_dpar(prep, "sigma") rblapply(seq_len(prep$ndraws), .predict) } posterior_predict_student_lagsar <- function(i, prep, ...) { stopifnot(i == 1) .predict <- function(s) { M_new <- with(prep, diag(nobs) - ac$lagsar[s] * ac$Msar) mu <- as.numeric(solve(M_new) %*% mu[s, ]) Sigma <- solve(crossprod(M_new)) * sigma[s]^2 rmulti_student_t(1, df = nu[s], mu = mu, Sigma = Sigma) } mu <- get_dpar(prep, "mu") sigma <- get_dpar(prep, "sigma") nu <- get_dpar(prep, "nu") rblapply(seq_len(prep$ndraws), .predict) } posterior_predict_gaussian_errorsar <- function(i, prep, ...) { stopifnot(i == 1) .predict <- function(s) { M_new <- with(prep, diag(nobs) - ac$errorsar[s] * ac$Msar) Sigma <- solve(crossprod(M_new)) * sigma[s]^2 rmulti_normal(1, mu = mu[s, ], Sigma = Sigma) } mu <- get_dpar(prep, "mu") sigma <- get_dpar(prep, "sigma") rblapply(seq_len(prep$ndraws), .predict) } posterior_predict_student_errorsar <- function(i, prep, ...) { stopifnot(i == 1) .predict <- function(s) { M_new <- with(prep, diag(nobs) - ac$errorsar[s] * ac$Msar) Sigma <- solve(crossprod(M_new)) * sigma[s]^2 rmulti_student_t(1, df = nu[s], mu = mu[s, ], Sigma = Sigma) } mu <- get_dpar(prep, "mu") sigma <- get_dpar(prep, "sigma") nu <- get_dpar(prep, "nu") rblapply(seq_len(prep$ndraws), .predict) } posterior_predict_gaussian_fcor <- function(i, prep, ...) { stopifnot(i == 1) mu <- as.matrix(get_dpar(prep, "mu")) Sigma <- get_cov_matrix_ac(prep) .predict <- function(s) { rmulti_normal(1, mu = mu[s, ], Sigma = Sigma[s, , ]) } rblapply(seq_len(prep$ndraws), .predict) } posterior_predict_student_fcor <- function(i, prep, ...) { stopifnot(i == 1) nu <- as.matrix(get_dpar(prep, "nu")) mu <- as.matrix(get_dpar(prep, "mu")) Sigma <- get_cov_matrix_ac(prep) .predict <- function(s) { rmulti_student_t(1, df = nu[s, ], mu = mu[s, ], Sigma = Sigma[s, , ]) } rblapply(seq_len(prep$ndraws), .predict) } posterior_predict_binomial <- function(i, prep, ntrys = 5, ...) { rdiscrete( n = prep$ndraws, dist = "binom", size = prep$data$trials[i], prob = get_dpar(prep, "mu", i = i), lb = prep$data$lb[i], ub = prep$data$ub[i], ntrys = ntrys ) } posterior_predict_beta_binomial <- function(i, prep, ntrys = 5, ...) { rdiscrete( n = prep$ndraws, dist = "beta_binomial", size = prep$data$trials[i], mu = get_dpar(prep, "mu", i = i), phi = get_dpar(prep, "phi", i = i), lb = prep$data$lb[i], ub = prep$data$ub[i], ntrys = ntrys ) } posterior_predict_bernoulli <- function(i, prep, ...) { mu <- get_dpar(prep, "mu", i = i) rbinom(length(mu), size = 1, prob = mu) } posterior_predict_poisson <- function(i, prep, ntrys = 5, ...) { mu <- get_dpar(prep, "mu", i) mu <- multiply_dpar_rate_denom(mu, prep, i = i) rdiscrete( n = prep$ndraws, dist = "pois", lambda = mu, lb = prep$data$lb[i], ub = prep$data$ub[i], ntrys = ntrys ) } posterior_predict_negbinomial <- function(i, prep, ntrys = 5, ...) { mu <- get_dpar(prep, "mu", i) mu <- multiply_dpar_rate_denom(mu, prep, i = i) shape <- get_dpar(prep, "shape", i) shape <- multiply_dpar_rate_denom(shape, prep, i = i) rdiscrete( n = prep$ndraws, dist = "nbinom", mu = mu, size = shape, lb = prep$data$lb[i], ub = prep$data$ub[i], ntrys = ntrys ) } posterior_predict_negbinomial2 <- function(i, prep, ntrys = 5, ...) { mu <- get_dpar(prep, "mu", i) mu <- multiply_dpar_rate_denom(mu, prep, i = i) sigma <- get_dpar(prep, "sigma", i) shape <- multiply_dpar_rate_denom(1 / sigma, prep, i = i) rdiscrete( n = prep$ndraws, dist = "nbinom", mu = mu, size = shape, lb = prep$data$lb[i], ub = prep$data$ub[i], ntrys = ntrys ) } posterior_predict_geometric <- function(i, prep, ntrys = 5, ...) { mu <- get_dpar(prep, "mu", i) mu <- multiply_dpar_rate_denom(mu, prep, i = i) shape <- 1 shape <- multiply_dpar_rate_denom(shape, prep, i = i) rdiscrete( n = prep$ndraws, dist = "nbinom", mu = mu, size = shape, lb = prep$data$lb[i], ub = prep$data$ub[i], ntrys = ntrys ) } posterior_predict_discrete_weibull <- function(i, prep, ntrys = 5, ...) { rdiscrete( n = prep$ndraws, dist = "discrete_weibull", mu = get_dpar(prep, "mu", i = i), shape = get_dpar(prep, "shape", i = i), lb = prep$data$lb[i], ub = prep$data$ub[i], ntrys = ntrys ) } posterior_predict_com_poisson <- function(i, prep, ntrys = 5, ...) { rdiscrete( n = prep$ndraws, dist = "com_poisson", mu = get_dpar(prep, "mu", i = i), shape = get_dpar(prep, "shape", i = i), lb = prep$data$lb[i], ub = prep$data$ub[i], ntrys = ntrys ) } posterior_predict_exponential <- function(i, prep, ntrys = 5, ...) { rcontinuous( n = prep$ndraws, dist = "exp", rate = 1 / get_dpar(prep, "mu", i = i), lb = prep$data$lb[i], ub = prep$data$ub[i], ntrys = ntrys ) } posterior_predict_gamma <- function(i, prep, ntrys = 5, ...) { shape <- get_dpar(prep, "shape", i = i) scale <- get_dpar(prep, "mu", i = i) / shape rcontinuous( n = prep$ndraws, dist = "gamma", shape = shape, scale = scale, lb = prep$data$lb[i], ub = prep$data$ub[i], ntrys = ntrys ) } posterior_predict_weibull <- function(i, prep, ntrys = 5, ...) { shape <- get_dpar(prep, "shape", i = i) scale <- get_dpar(prep, "mu", i = i) / gamma(1 + 1 / shape) rcontinuous( n = prep$ndraws, dist = "weibull", shape = shape, scale = scale, lb = prep$data$lb[i], ub = prep$data$ub[i], ntrys = ntrys ) } posterior_predict_frechet <- function(i, prep, ntrys = 5, ...) { nu <- get_dpar(prep, "nu", i = i) scale <- get_dpar(prep, "mu", i = i) / gamma(1 - 1 / nu) rcontinuous( n = prep$ndraws, dist = "frechet", scale = scale, shape = nu, lb = prep$data$lb[i], ub = prep$data$ub[i], ntrys = ntrys ) } posterior_predict_gen_extreme_value <- function(i, prep, ntrys = 5, ...) { rcontinuous( n = prep$ndraws, dist = "gen_extreme_value", sigma = get_dpar(prep, "sigma", i = i), xi = get_dpar(prep, "xi", i = i), mu = get_dpar(prep, "mu", i = i), lb = prep$data$lb[i], ub = prep$data$ub[i], ntrys = ntrys ) } posterior_predict_inverse.gaussian <- function(i, prep, ntrys = 5, ...) { rcontinuous( n = prep$ndraws, dist = "inv_gaussian", mu = get_dpar(prep, "mu", i = i), shape = get_dpar(prep, "shape", i = i), lb = prep$data$lb[i], ub = prep$data$ub[i], ntrys = ntrys ) } posterior_predict_exgaussian <- function(i, prep, ntrys = 5, ...) { rcontinuous( n = prep$ndraws, dist = "exgaussian", mu = get_dpar(prep, "mu", i = i), sigma = get_dpar(prep, "sigma", i = i), beta = get_dpar(prep, "beta", i = i), lb = prep$data$lb[i], ub = prep$data$ub[i], ntrys = ntrys ) } posterior_predict_wiener <- function(i, prep, negative_rt = FALSE, ntrys = 5, ...) { out <- rcontinuous( n = 1, dist = "wiener", delta = get_dpar(prep, "mu", i = i), alpha = get_dpar(prep, "bs", i = i), tau = get_dpar(prep, "ndt", i = i), beta = get_dpar(prep, "bias", i = i), types = if (negative_rt) c("q", "resp") else "q", lb = prep$data$lb[i], ub = prep$data$ub[i], ntrys = ntrys ) if (negative_rt) { # code lower bound responses as negative RTs out <- out[["q"]] * ifelse(out[["resp"]], 1, -1) } out } posterior_predict_beta <- function(i, prep, ntrys = 5, ...) { mu <- get_dpar(prep, "mu", i = i) phi <- get_dpar(prep, "phi", i = i) rcontinuous( n = prep$ndraws, dist = "beta", shape1 = mu * phi, shape2 = (1 - mu) * phi, lb = prep$data$lb[i], ub = prep$data$ub[i], ntrys = ntrys ) } posterior_predict_xbeta <- function(i, prep, ntrys = 5, ...) { mu <- get_dpar(prep, "mu", i = i) phi <- get_dpar(prep, "phi", i = i) kappa <- get_dpar(prep, "kappa", i = i) rcontinuous( n = prep$ndraws, dist = "xbeta", mu = mu, phi = phi, nu = kappa, lb = prep$data$lb[i], ub = prep$data$ub[i], ntrys = ntrys ) } posterior_predict_von_mises <- function(i, prep, ntrys = 5, ...) { rcontinuous( n = prep$ndraws, dist = "von_mises", mu = get_dpar(prep, "mu", i = i), kappa = get_dpar(prep, "kappa", i = i), lb = prep$data$lb[i], ub = prep$data$ub[i], ntrys = ntrys ) } posterior_predict_asym_laplace <- function(i, prep, ntrys = 5, ...) { rcontinuous( n = prep$ndraws, dist = "asym_laplace", mu = get_dpar(prep, "mu", i = i), sigma = get_dpar(prep, "sigma", i = i), quantile = get_dpar(prep, "quantile", i = i), lb = prep$data$lb[i], ub = prep$data$ub[i], ntrys = ntrys ) } posterior_predict_zero_inflated_asym_laplace <- function(i, prep, ntrys = 5, ...) { zi <- get_dpar(prep, "zi", i = i) tmp <- runif(prep$ndraws, 0, 1) ifelse( tmp < zi, 0, rcontinuous( n = prep$ndraws, dist = "asym_laplace", mu = get_dpar(prep, "mu", i = i), sigma = get_dpar(prep, "sigma", i = i), quantile = get_dpar(prep, "quantile", i = i), lb = prep$data$lb[i], ub = prep$data$ub[i], ntrys = ntrys ) ) } posterior_predict_cox <- function(i, prep, ...) { stop2("Cannot sample from the posterior predictive ", "distribution for family 'cox'.") } posterior_predict_hurdle_poisson <- function(i, prep, ...) { # hu is the bernoulli hurdle parameter hu <- get_dpar(prep, "hu", i = i) lambda <- get_dpar(prep, "mu", i = i) ndraws <- prep$ndraws # compare with hu to incorporate the hurdle process tmp <- runif(ndraws, 0, 1) # sample from a truncated poisson distribution # by adjusting lambda and adding 1 t = -log(1 - runif(ndraws) * (1 - exp(-lambda))) ifelse(tmp < hu, 0, rpois(ndraws, lambda = lambda - t) + 1) } posterior_predict_hurdle_negbinomial <- function(i, prep, ...) { hu <- get_dpar(prep, "hu", i = i) mu <- get_dpar(prep, "mu", i = i) ndraws <- prep$ndraws tmp <- runif(ndraws, 0, 1) # sample from an approximate(!) truncated negbinomial distribution # by adjusting mu and adding 1 t = -log(1 - runif(ndraws) * (1 - exp(-mu))) shape <- get_dpar(prep, "shape", i = i) ifelse(tmp < hu, 0, rnbinom(ndraws, mu = mu - t, size = shape) + 1) } posterior_predict_hurdle_gamma <- function(i, prep, ...) { hu <- get_dpar(prep, "hu", i = i) shape <- get_dpar(prep, "shape", i = i) scale <- get_dpar(prep, "mu", i = i) / shape ndraws <- prep$ndraws tmp <- runif(ndraws, 0, 1) ifelse(tmp < hu, 0, rgamma(ndraws, shape = shape, scale = scale)) } posterior_predict_hurdle_lognormal <- function(i, prep, ...) { hu <- get_dpar(prep, "hu", i = i) mu <- get_dpar(prep, "mu", i = i) sigma <- get_dpar(prep, "sigma", i = i) ndraws <- prep$ndraws tmp <- runif(ndraws, 0, 1) ifelse(tmp < hu, 0, rlnorm(ndraws, meanlog = mu, sdlog = sigma)) } posterior_predict_hurdle_cumulative <- function(i, prep, ...) { mu <- get_dpar(prep, "mu", i = i) hu <- get_dpar(prep, "hu", i = i) disc <- get_dpar(prep, "disc", i = i) thres <- subset_thres(prep) nthres <- NCOL(thres) ndraws <- prep$ndraws p <- pordinal( seq_len(nthres + 1L), eta = mu, disc = disc, thres = thres, family = "cumulative", link = prep$family$link ) tmp <- runif(ndraws, 0, 1) ifelse( tmp < hu, 0L, first_greater(p, target = runif(prep$ndraws, min = 0, max = 1)) ) } posterior_predict_zero_inflated_beta <- function(i, prep, ...) { zi <- get_dpar(prep, "zi", i = i) mu <- get_dpar(prep, "mu", i = i) phi <- get_dpar(prep, "phi", i = i) tmp <- runif(prep$ndraws, 0, 1) ifelse( tmp < zi, 0, rbeta(prep$ndraws, shape1 = mu * phi, shape2 = (1 - mu) * phi) ) } posterior_predict_zero_one_inflated_beta <- function(i, prep, ...) { zoi <- get_dpar(prep, "zoi", i) coi <- get_dpar(prep, "coi", i) mu <- get_dpar(prep, "mu", i = i) phi <- get_dpar(prep, "phi", i = i) tmp <- runif(prep$ndraws, 0, 1) one_or_zero <- runif(prep$ndraws, 0, 1) ifelse(tmp < zoi, ifelse(one_or_zero < coi, 1, 0), rbeta(prep$ndraws, shape1 = mu * phi, shape2 = (1 - mu) * phi) ) } posterior_predict_zero_inflated_poisson <- function(i, prep, ...) { # zi is the bernoulli zero-inflation parameter zi <- get_dpar(prep, "zi", i = i) lambda <- get_dpar(prep, "mu", i = i) ndraws <- prep$ndraws # compare with zi to incorporate the zero-inflation process tmp <- runif(ndraws, 0, 1) ifelse(tmp < zi, 0L, rpois(ndraws, lambda = lambda)) } posterior_predict_zero_inflated_negbinomial <- function(i, prep, ...) { zi <- get_dpar(prep, "zi", i = i) mu <- get_dpar(prep, "mu", i = i) shape <- get_dpar(prep, "shape", i = i) ndraws <- prep$ndraws tmp <- runif(ndraws, 0, 1) ifelse(tmp < zi, 0L, rnbinom(ndraws, mu = mu, size = shape)) } posterior_predict_zero_inflated_binomial <- function(i, prep, ...) { zi <- get_dpar(prep, "zi", i = i) trials <- prep$data$trials[i] prob <- get_dpar(prep, "mu", i = i) ndraws <- prep$ndraws tmp <- runif(ndraws, 0, 1) ifelse(tmp < zi, 0L, rbinom(ndraws, size = trials, prob = prob)) } posterior_predict_zero_inflated_beta_binomial <- function(i, prep, ...) { zi <- get_dpar(prep, "zi", i = i) trials <- prep$data$trials[i] mu <- get_dpar(prep, "mu", i = i) phi <- get_dpar(prep, "phi", i = i) ndraws <- prep$ndraws draws <- rbeta_binomial(ndraws, size = trials, mu = mu, phi = phi) tmp <- runif(ndraws, 0, 1) draws[tmp < zi] <- 0L draws } posterior_predict_categorical <- function(i, prep, ...) { eta <- get_Mu(prep, i = i) eta <- insert_refcat(eta, refcat = prep$refcat) p <- pcategorical(seq_len(prep$data$ncat), eta = eta) first_greater(p, target = runif(prep$ndraws, min = 0, max = 1)) } posterior_predict_multinomial <- function(i, prep, ...) { eta <- get_Mu(prep, i = i) eta <- insert_refcat(eta, refcat = prep$refcat) p <- dcategorical(seq_len(prep$data$ncat), eta = eta) size <- prep$data$trials[i] rblapply(seq_rows(p), function(s) t(rmultinom(1, size, p[s, ]))) } posterior_predict_dirichlet_multinomial <- function(i, prep, ...) { eta <- get_Mu(prep, i = i) eta <- insert_refcat(eta, refcat = prep$refcat) phi <- get_dpar(prep, "phi", i = i) alpha <- dcategorical(seq_len(prep$data$ncat), eta = eta) * phi p <- rdirichlet(prep$ndraws, alpha = alpha) size <- prep$data$trials[i] rblapply(seq_rows(p), function(s) t(rmultinom(1, size, p[s, ]))) } posterior_predict_dirichlet <- function(i, prep, ...) { eta <- get_Mu(prep, i = i) eta <- insert_refcat(eta, refcat = prep$refcat) phi <- get_dpar(prep, "phi", i = i) cats <- seq_len(prep$data$ncat) alpha <- dcategorical(cats, eta = eta) * phi rdirichlet(prep$ndraws, alpha = alpha) } posterior_predict_dirichlet2 <- function(i, prep, ...) { mu <- get_Mu(prep, i = i) rdirichlet(prep$ndraws, alpha = mu) } posterior_predict_logistic_normal <- function(i, prep, ...) { mu <- get_Mu(prep, i = i) Sigma <- get_Sigma(prep, i = i, cor_name = "lncor") .predict <- function(s) { rlogistic_normal(1, mu = mu[s, ], Sigma = Sigma[s, , ], refcat = prep$refcat) } rblapply(seq_len(prep$ndraws), .predict) } posterior_predict_cumulative <- function(i, prep, ...) { posterior_predict_ordinal(i = i, prep = prep) } posterior_predict_sratio <- function(i, prep, ...) { posterior_predict_ordinal(i = i, prep = prep) } posterior_predict_cratio <- function(i, prep, ...) { posterior_predict_ordinal(i = i, prep = prep) } posterior_predict_acat <- function(i, prep, ...) { posterior_predict_ordinal(i = i, prep = prep) } posterior_predict_ordinal <- function(i, prep, ...) { thres <- subset_thres(prep, i) nthres <- NCOL(thres) p <- pordinal( seq_len(nthres + 1), eta = get_dpar(prep, "mu", i = i), disc = get_dpar(prep, "disc", i = i), thres = thres, family = prep$family$family, link = prep$family$link ) first_greater(p, target = runif(prep$ndraws, min = 0, max = 1)) } posterior_predict_custom <- function(i, prep, ...) { custom_family_method(prep$family, "posterior_predict")(i, prep, ...) } posterior_predict_mixture <- function(i, prep, ...) { families <- family_names(prep$family) theta <- get_theta(prep, i = i) smix <- sample_mixture_ids(theta) out <- rep(NA, prep$ndraws) for (j in seq_along(families)) { draw_ids <- which(smix == j) if (length(draw_ids)) { pp_fun <- paste0("posterior_predict_", families[j]) pp_fun <- get(pp_fun, asNamespace("brms")) tmp_prep <- pseudo_prep_for_mixture(prep, j, draw_ids) out[draw_ids] <- pp_fun(i, tmp_prep, ...) } } out } # ------------ predict helper-functions ---------------------- # random numbers from (possibly truncated) continuous distributions # @param n number of random values to generate # @param dist name of a distribution for which the functions # p, q, and r are available # @param ... additional arguments passed to the distribution functions # @param ntrys number of trys in rejection sampling for truncated models # @return vector of random values prep from the distribution rcontinuous <- function(n, dist, ..., lb = NULL, ub = NULL, ntrys = 5) { args <- list(...) if (is.null(lb) && is.null(ub)) { # sample as usual rdist <- paste0("r", dist) out <- do_call(rdist, c(list(n), args)) } else { # sample from truncated distribution pdist <- paste0("p", dist) qdist <- paste0("q", dist) if (!exists(pdist, mode = "function") || !exists(qdist, mode = "function")) { # use rejection sampling as CDF or quantile function are not available out <- rdiscrete(n, dist, ..., lb = lb, ub = ub, ntrys = ntrys) } else { if (is.null(lb)) lb <- -Inf if (is.null(ub)) ub <- Inf plb <- do_call(pdist, c(list(lb), args)) pub <- do_call(pdist, c(list(ub), args)) out <- runif(n, min = plb, max = pub) out <- do_call(qdist, c(list(out), args)) # infinite values may be caused by numerical imprecision out[out %in% c(-Inf, Inf)] <- NA } } out } # random numbers from (possibly truncated) discrete distributions # currently rejection sampling is used for truncated distributions # @param n number of random values to generate # @param dist name of a distribution for which the functions # p, q, and r are available # @param ... additional arguments passed to the distribution functions # @param lb optional lower truncation bound # @param ub optional upper truncation bound # @param ntrys number of trys in rejection sampling for truncated models # @return a vector of random values draws from the distribution rdiscrete <- function(n, dist, ..., lb = NULL, ub = NULL, ntrys = 5) { args <- list(...) rdist <- paste0("r", dist) if (is.null(lb) && is.null(ub)) { # sample as usual out <- do_call(rdist, c(list(n), args)) } else { # sample from truncated distribution via rejection sampling if (is.null(lb)) lb <- -Inf if (is.null(ub)) ub <- Inf out <- vector("list", ntrys) for (i in seq_along(out)) { # loop of the trys to prevent a mismatch between 'n' # and length of the parameter vectors passed as arguments out[[i]] <- as.vector(do_call(rdist, c(list(n), args))) } out <- do_call(cbind, out) out <- apply(out, 1, extract_valid_sample, lb = lb, ub = ub) } out } # sample from the IDs of the mixture components sample_mixture_ids <- function(theta) { stopifnot(is.matrix(theta)) mix_comp <- seq_cols(theta) ulapply(seq_rows(theta), function(s) sample(mix_comp, 1, prob = theta[s, ]) ) } # extract the first valid predicted value per Stan sample per observation # @param x draws to be check against truncation boundaries # @param lb vector of lower bounds # @param ub vector of upper bound # @return a valid truncated sample or else the closest boundary extract_valid_sample <- function(x, lb, ub) { valid <- match(TRUE, x >= lb & x <= ub) if (is.na(valid)) { # no valid truncated value found # set sample to lb or ub # 1e-10 is only to identify the invalid draws later on out <- ifelse(max(x) < lb, lb - 1e-10, ub + 1e-10) } else { out <- x[valid] } out } # check for invalid predictions of truncated discrete models # @param x matrix of predicted values # @param lb optional lower truncation bound # @param ub optional upper truncation bound # @param thres threshold (in %) of invalid values at which to warn the user # @return rounded values of 'x' check_discrete_trunc_bounds <- function(x, lb = NULL, ub = NULL, thres = 0.01) { if (is.null(lb) && is.null(ub)) { return(x) } if (is.null(lb)) lb <- -Inf if (is.null(ub)) ub <- Inf thres <- as_one_numeric(thres) # ensure correct comparison with vector bounds y <- as.vector(t(x)) pct_invalid <- mean(y < lb | y > ub, na.rm = TRUE) if (pct_invalid >= thres) { warning2( round(pct_invalid * 100), "% of all predicted values ", "were invalid. Increasing argument 'ntrys' may help." ) } round(x) } brms/R/misc.R0000644000176200001440000007545515053305627012522 0ustar liggesusers# type-stable indexing of vector and matrix type objects # @param x an R object typically a vector or matrix # @param i optional index; if NULL, x is returned unchanged # @param row indicating if rows or cols should be indexed # only relevant if x has two or three dimensions p <- function(x, i = NULL, row = TRUE) { # TODO: replace by "slice" if (isTRUE(length(dim(x)) > 3L)) { stop2("'p' can only handle objects up to 3 dimensions.") } if (!length(i)) { out <- x } else if (length(dim(x)) == 2L) { if (row) { out <- x[i, , drop = FALSE] } else { out <- x[, i, drop = FALSE] } } else if (length(dim(x)) == 3L) { if (row) { out <- x[i, , , drop = FALSE] } else { out <- x[, i, , drop = FALSE] } } else { out <- x[i] } out } # extract parts of an object with selective dropping of dimensions # @param x,...,drop same as in x[..., drop] # @param drop_dim Optional numeric or logical vector controlling # which dimensions to drop. Will overwrite argument 'drop'. extract <- function(x, ..., drop = FALSE, drop_dim = NULL) { if (!length(dim(x))) { return(x[...]) } if (length(drop_dim)) { drop <- FALSE } else { drop <- as_one_logical(drop) } out <- x[..., drop = drop] if (drop || !length(drop_dim) || any(dim(out) == 0L)) { return(out) } if (is.numeric(drop_dim)) { drop_dim <- seq_along(dim(x)) %in% drop_dim } if (!is.logical(drop_dim)) { stop2("'drop_dim' needs to be logical or numeric.") } keep <- dim(out) > 1L | !drop_dim new_dim <- dim(out)[keep] if (length(new_dim) <= 1L) { # use vectors instead of 1D arrays new_dim <- NULL } dim(out) <- new_dim out } # extract slices of one array dimension without dropping other dimensions # @param x an array # @param dim dimension from which to take the slice # @param i slice index # @param drop Logical (length 1) indicating whether to drop dimension `dim`. slice <- function(x, dim, i, drop = TRUE) { ndim <- length(dim(x)) commas1 <- collapse(rep(", ", dim - 1)) commas2 <- collapse(rep(", ", ndim - dim)) drop_dim <- ifelse(drop, ", drop_dim = dim", "") expr <- paste0("extract(x, ", commas1, "i", commas2, drop_dim, ")") eval2(expr) } # slice out columns without dropping other dimensions # @param x an array; a vector or 1D array is treated as already sliced # @param i column index slice_col <- function(x, i) { if (length(dim(x)) < 2L) { # a vector or 1D array is treated as already sliced return(x) } slice(x, 2, i) } seq_rows <- function(x) { seq_len(NROW(x)) } seq_cols <- function(x) { seq_len(NCOL(x)) } seq_dim <- function(x, dim) { dim <- as_one_numeric(dim) if (dim == 1) { len <- NROW(x) } else if (dim == 2) { len <- NCOL(x) } else { len <- dim(x)[dim] } if (length(len) == 1L && !isNA(len)) { out <- seq_len(len) } else { out <- integer(0) } out } # match rows in x with rows in y match_rows <- function(x, y, ...) { x <- as.data.frame(x) y <- as.data.frame(y) x <- do.call("paste", c(x, sep = "\r")) y <- do.call("paste", c(y, sep = "\r")) match(x, y, ...) } # find elements of 'x' matching sub-elements passed via 'ls' and '...' find_elements <- function(x, ..., ls = list(), fun = '%in%') { x <- as.list(x) if (!length(x)) { return(logical(0)) } out <- rep(TRUE, length(x)) ls <- c(ls, list(...)) if (!length(ls)) { return(out) } if (is.null(names(ls))) { stop("Argument 'ls' must be named.") } for (name in names(ls)) { tmp <- from_list(x, name) out <- out & do_call(fun, list(tmp, ls[[name]])) } out } # find rows of 'x' matching columns passed via 'ls' and '...' # similar to 'find_elements' but for matrix like objects find_rows <- function(x, ..., ls = list(), fun = '%in%') { x <- as.data.frame(x) if (!nrow(x)) { return(logical(0)) } out <- rep(TRUE, nrow(x)) ls <- c(ls, list(...)) if (!length(ls)) { return(out) } if (is.null(names(ls))) { stop("Argument 'ls' must be named.") } for (name in names(ls)) { out <- out & do_call(fun, list(x[[name]], ls[[name]])) } out } # subset 'x' using arguments passed via 'ls' and '...' subset2 <- function(x, ..., ls = list(), fun = '%in%') { x[find_rows(x, ..., ls = ls, fun = fun), , drop = FALSE] } # not-in operator "%notin%" <- Negate("%in%") # convert array to list of elements with reduced dimension # @param x an arrary of dimension d # @return a list of arrays of dimension d-1 array2list <- function(x) { if (is.null(dim(x))) { return(as.list(x)) } ndim <- length(dim(x)) out <- list(length = dim(x)[ndim]) ind <- collapse(rep(",", ndim - 1)) for (i in seq_len(dim(x)[ndim])) { out[[i]] <- eval2(paste0("x[", ind, i, "]")) if (length(dim(x)) > 2) { # avoid accidental dropping of other dimensions dim(out[[i]]) <- dim(x)[-ndim] } } names(out) <- dimnames(x)[[ndim]] out } # move elements to the start of a named object move2start <- function(x, first) { x[c(first, setdiff(names(x), first))] } # move elements to the end of a named object move2end <- function(x, last) { x[c(setdiff(names(x), last), last)] } # wrapper around replicate but without simplifying repl <- function(expr, n) { replicate(n, expr, simplify = FALSE) } # find the first element in A that is greater than target # @param A a matrix # @param target a vector of length nrow(A) # @param i column of A being checked first # @return a vector of the same length as target containing the # column ids where A[,i] was first greater than target first_greater <- function(A, target, i = 1) { ifelse(target <= A[, i] | ncol(A) == i, i, first_greater(A, target, i + 1)) } # check if an object is NULL isNULL <- function(x) { is.null(x) || ifelse(is.vector(x), all(sapply(x, is.null)), FALSE) } # recursively removes NULL entries from an object rmNULL <- function(x, recursive = TRUE) { x <- Filter(Negate(isNULL), x) if (recursive) { x <- lapply(x, function(x) if (is.list(x)) rmNULL(x) else x) } x } # find the first argument that is not NULL first_not_null <- function(...) { dots <- list(...) out <- NULL i <- 1L while (isNULL(out) && i <= length(dots)) { if (!isNULL(dots[[i]])) { out <- dots[[i]] } i <- i + 1L } out } is_atomic_or_null <- function(x) { is.atomic(x) || is.null(x) } isNA <- function(x) { length(x) == 1L && is.na(x) } is_equal <- function(x, y, check.attributes = FALSE, ...) { isTRUE(all.equal(x, y, check.attributes = check.attributes, ...)) } # extract factor levels from an arbitrary variable extract_levels <- function(x) { # do not check for NAs according to #1355 if (!is.factor(x)) { x <- factor(x) } levels(x) } # check if 'x' will behave like a factor in design matrices is_like_factor <- function(x) { is.factor(x) || is.character(x) || is.logical(x) } # as.factor but allows to pass levels as_factor <- function(x, levels = NULL) { if (is.null(levels)) { out <- as.factor(x) } else { out <- factor(x, levels = levels) } out } # coerce 'x' to a single logical value as_one_logical <- function(x, allow_na = FALSE) { s <- substitute(x) x <- as.logical(x) if (length(x) != 1L || anyNA(x) && !allow_na) { s <- deparse0(s, max_char = 100L) stop2("Cannot coerce '", s, "' to a single logical value.") } x } # coerce 'x' to a single integer value as_one_integer <- function(x, allow_na = FALSE) { s <- substitute(x) x <- SW(as.integer(x)) if (length(x) != 1L || anyNA(x) && !allow_na) { s <- deparse0(s, max_char = 100L) stop2("Cannot coerce '", s, "' to a single integer value.") } x } # coerce 'x' to a single numeric value as_one_numeric <- function(x, allow_na = FALSE) { s <- substitute(x) x <- SW(as.numeric(x)) if (length(x) != 1L || anyNA(x) && !allow_na) { s <- deparse0(s, max_char = 100L) stop2("Cannot coerce '", s, "' to a single numeric value.") } x } # coerce 'x' to a single character string as_one_character <- function(x, allow_na = FALSE) { s <- substitute(x) x <- as.character(x) if (length(x) != 1L || anyNA(x) && !allow_na) { s <- deparse0(s, max_char = 100L) stop2("Cannot coerce '", s, "' to a single character value.") } x } # coerce 'x' to a single character variable name as_one_variable <- function(x, allow_na = TRUE) { x <- as_one_character(x) if (x == "NA" && allow_na) { return(x) } if (!nzchar(x) || !is_equal(x, all_vars(x))) { stop2("Cannot coerce '", x, "' to a single variable name.") } x } has_rows <- function(x) { isTRUE(nrow(x) > 0L) } has_cols <- function(x) { isTRUE(ncol(x) > 0L) } # expand arguments to the same length # @param ... arguments to expand # @param length optional expansion length # otherwise taken to be the largest supplied length # @return a data.frame with one variable per element in '...' expand <- function(..., dots = list(), length = NULL) { dots <- c(dots, list(...)) max_dim <- NULL if (is.null(length)) { lengths <- lengths(dots) length <- max(lengths) max_dim <- dim(dots[[match(length, lengths)]]) } out <- as.data.frame(lapply(dots, rep, length.out = length)) structure(out, max_dim = max_dim) } # structure but ignore NULL structure_not_null <- function(.Data, ...) { if (!is.null(.Data)) { .Data <- structure(.Data, ...) } .Data } # remove specified attributes rm_attr <- function(x, attr) { attributes(x)[attr] <- NULL x } # unidimensional subsetting while keeping attributes subset_keep_attr <- function(x, y) { att <- attributes(x) x <- x[y] att$names <- names(x) attributes(x) <- att x } '%||%' <- function(x, y) { if (is.null(x)) x <- y x } # check if 'x' is a whole number (integer) is_wholenumber <- function(x, tol = .Machine$double.eps) { if (is.numeric(x)) { out <- abs(x - round(x)) < tol } else { out <- rep(FALSE, length(x)) } dim(out) <- dim(x) out } # helper function to check symmetry of a matrix is_symmetric <- function(x, tol = sqrt(.Machine$double.eps)) { isSymmetric(x, tol = tol, check.attributes = FALSE) } # unlist lapply output ulapply <- function(X, FUN, ..., recursive = TRUE, use.names = TRUE) { unlist(lapply(X, FUN, ...), recursive, use.names) } # rbind lapply output rblapply <- function(X, FUN, ...) { do.call(rbind, lapply(X, FUN, ...)) } # cbind lapply output cblapply <- function(X, FUN, ...) { do.call(cbind, lapply(X, FUN, ...)) } # parallel lapply sensitive to the operating system # args: # .psock: use a PSOCK cluster? Default is TRUE until #. the zombie worker issue #1658 has been fully resolved plapply <- function(X, FUN, .cores = 1, .psock = TRUE, ...) { if (.cores == 1) { out <- lapply(X, FUN, ...) } else { if (!os_is_windows() && !.psock) { out <- parallel::mclapply(X = X, FUN = FUN, mc.cores = .cores, ...) } else { cl <- parallel::makePSOCKcluster(.cores) on.exit(parallel::stopCluster(cl)) out <- parallel::parLapply(cl = cl, X = X, fun = FUN, ...) } # The version below was suggested to prevent the spawning of zombies # but it does not always succeed in that. It also seems to cause # other issues as discussed in #1658, so commented out for now. # cl_type <- ifelse(os_is_windows(), "PSOCK", "FORK") # cl <- parallel::makeCluster(.cores, type = cl_type) # # Register a cleanup for the cluster in case the function fails # # Need to wrap in a tryCatch to avoid error if cluster is already stopped # on.exit(tryCatch( # { parallel::stopCluster(cl) }, # error = function(e) invisible(NULL) # )) # out <- parallel::parLapply(cl = cl, X = X, fun = FUN, ...) # parallel::stopCluster(cl) } out } # extract objects stored in each element of a list # @param x a list-like object # @param name name of the object to extract from_list <- function(x, name, ...) { lapply(x, "[[", name, ...) } # unlist from_list output ufrom_list <- function(x, name, ..., recursive = TRUE, use.names = TRUE) { unlist(from_list(x, name, ...), recursive, use.names) } # check if the operating system is Windows os_is_windows <- function() { isTRUE(Sys.info()[['sysname']] == "Windows") } # find variables in a character string or expression all_vars <- function(expr, ...) { if (is.character(expr)) { expr <- str2expression(expr) } all.vars(expr, ...) } # reimplemented for older R versions # see ?parse in R 3.6 or higher str2expression <- function(x) { parse(text = x, keep.source = FALSE) } # reimplemented for older R versions # see ?parse in R 3.6 or higher str2lang <- function(x) { str2expression(x)[[1]] } # append list(...) to x lc <- function(x, ...) { dots <- rmNULL(list(...), recursive = FALSE) c(x, dots) } 'c<-' <- function(x, value) { c(x, value) } 'lc<-' <- function(x, value) { lc(x, value) } collapse <- function(..., sep = "") { paste(..., sep = sep, collapse = "") } collapse_comma <- function(...) { paste0("'", ..., "'", collapse = ", ") } # add characters to an existing string 'str_add<-' <- function(x, start = FALSE, value) { if (start) paste0(value, x) else paste0(x, value) } # add list of characters to an existing list 'str_add_list<-' <- function(x, start = FALSE, value) { stopifnot(is.list(x), is.list(value)) out <- if (start) list(value, x) else list(x, value) collapse_lists(ls = out) } # type-stable if clause for strings with default else output str_if <- function(cond, yes, no = "") { cond <- as_one_logical(cond) if (cond) as.character(yes) else as.character(no) } # select elements which match a regex pattern str_subset <- function(x, pattern, ...) { x[grepl(pattern, x, ...)] } # similar to glue::glue but specialized for generating Stan code glue <- function(..., sep = "", collapse = NULL, envir = parent.frame(), open = "{", close = "}", na = "NA") { dots <- list(...) dots <- dots[lengths(dots) > 0L] args <- list( .x = NULL, .sep = sep, .envir = envir, .open = open, .close = close, .na = na, .trim = FALSE, .transformer = zero_length_transformer ) out <- do.call(glue::glue_data, c(dots, args)) if (!is.null(collapse)) { collapse <- as_one_character(collapse) out <- paste0(out, collapse = collapse) } out } # used in 'glue' to handle zero-length inputs zero_length_transformer <- function(text, envir) { out <- glue::identity_transformer(text, envir) if (!length(out)) { out <- "" } out } # collapse strings evaluated with glue cglue <- function(..., envir = parent.frame()) { glue(..., envir = envir, collapse = "") } # check if a certain package is installed # @param package package name # @param version optional minimal version number to require require_package <- function(package, version = NULL) { if (!requireNamespace(package, quietly = TRUE)) { stop2("Please install the '", package, "' package.") } if (!is.null(version)) { version <- as.package_version(version) if (utils::packageVersion(package) < version) { stop2("Please install package '", package, "' version ", version, " or higher.") } } invisible(TRUE) } # rename specified patterns in a character vector # @param x a character vector to be renamed # @param pattern the regular expressions in x to be replaced # @param replacement the replacements # @param fixed same as for 'gsub' # @param check_dup: logical; check for duplications in x after renaming # @param ... passed to 'gsub' # @return renamed character vector of the same length as x rename <- function(x, pattern = NULL, replacement = NULL, fixed = TRUE, check_dup = FALSE, ...) { pattern <- as.character(pattern) replacement <- as.character(replacement) if (!length(pattern) && !length(replacement)) { # default renaming to avoid special characters in coeffcient names pattern <- c( " ", "(", ")", "[", "]", ",", "\"", "'", "?", "+", "-", "*", "/", "^", "=", "$" ) replacement <- c(rep("", 9), "P", "M", "MU", "D", "E", "EQ", "USD") } if (length(replacement) == 1L) { replacement <- rep(replacement, length(pattern)) } stopifnot(length(pattern) == length(replacement)) # avoid zero-length pattern error has_chars <- nzchar(pattern) pattern <- pattern[has_chars] replacement <- replacement[has_chars] out <- x for (i in seq_along(pattern)) { out <- gsub(pattern[i], replacement[i], out, fixed = fixed, ...) } dup <- duplicated(out) if (check_dup && any(dup)) { dup <- x[out %in% out[dup]] stop2("Internal renaming led to duplicated names. ", "Consider renaming your variables to have different suffixes.\n", "Occured for: ", collapse_comma(dup)) } out } # collapse strings having the same name in different lists # @param ... named lists # @param ls a list of named lists # @param a named list containing the collapsed strings collapse_lists <- function(..., ls = list()) { ls <- c(list(...), ls) elements <- unique(unlist(lapply(ls, names))) args <- c(FUN = collapse, lapply(ls, "[", elements), SIMPLIFY = FALSE) out <- do.call(mapply, args) names(out) <- elements out } # create a named list using object names nlist <- function(...) { m <- match.call() dots <- list(...) no_names <- is.null(names(dots)) has_name <- if (no_names) FALSE else nzchar(names(dots)) if (all(has_name)) return(dots) nms <- as.character(m)[-1] if (no_names) { names(dots) <- nms } else { names(dots)[!has_name] <- nms[!has_name] } dots } # initialize a named list # @param names names of the elements # @param values optional values of the elements named_list <- function(names, values = NULL) { if (!is.null(values)) { if (length(values) <= 1L) { values <- replicate(length(names), values) } values <- as.list(values) stopifnot(length(values) == length(names)) } else { values <- vector("list", length(names)) } setNames(values, names) } # is an object named? is_named <- function(x) { names <- names(x) if (is.null(names)) { return(FALSE) } if (any(!nzchar(names) | is.na(names))) { return(FALSE) } TRUE } #' Execute a Function Call #' #' Execute a function call similar to \code{\link{do.call}}, but without #' deparsing function arguments. For large number of arguments (i.e., more #' than a few thousand) this function currently is somewhat inefficient #' and should be used with care in this case. #' #' @param what Either a function or a non-empty character string naming the #' function to be called. #' @param args A list of arguments to the function call. The names attribute of #' \code{args} gives the argument names. #' @param pkg Optional name of the package in which to search for the #' function if \code{what} is a character string. #' @param envir An environment within which to evaluate the call. #' #' @return The result of the (evaluated) function call. #' #' @keywords internal #' @export do_call <- function(what, args, pkg = NULL, envir = parent.frame()) { call <- "" if (length(args)) { if (!is.list(args)) { stop2("'args' must be a list.") } fun_args <- names(args) if (is.null(fun_args)) { fun_args <- rep("", length(args)) } else { nzc <- nzchar(fun_args) fun_args[nzc] <- paste0("`", fun_args[nzc], "` = ") } names(args) <- paste0(".x", seq_along(args)) call <- paste0(fun_args, names(args), collapse = ",") } else { args <- list() } if (is.function(what)) { args$.fun <- what what <- ".fun" } else { what <- paste0("`", as_one_character(what), "`") if (!is.null(pkg)) { what <- paste0(as_one_character(pkg), "::", what) } } call <- paste0(what, "(", call, ")") eval2(call, envir = args, enclos = envir) } # create an empty data frame empty_data_frame <- function() { as.data.frame(matrix(nrow = 0, ncol = 0)) } # replace elements in x with elements in value # @param x named list-like object # @param value another named list-like object # @param dont_replace names of elements that cannot be replaced 'replace_args<-' <- function(x, dont_replace = NULL, value) { value_name <- deparse0(substitute(value), max_char = 100L) value <- as.list(value) if (length(value) && is.null(names(value))) { stop2("Argument '", value_name, "' must be named.") } invalid <- names(value)[names(value) %in% dont_replace] if (length(invalid)) { invalid <- collapse_comma(invalid) stop2("Argument(s) ", invalid, " cannot be replaced.") } x[names(value)] <- value x } # deparse0 'x' if it is no string deparse_no_string <- function(x) { if (!is.character(x)) { x <- deparse0(x) } x } # combine deparse lines into one string # since R 4.0 we also have base::deparse1 for this purpose deparse0 <- function(x, max_char = NULL, ...) { out <- collapse(deparse(x, ...)) if (isTRUE(max_char > 0)) { out <- substr(out, 1L, max_char) } out } # like 'eval' but parses characters before evaluation eval2 <- function(expr, envir = parent.frame(), ...) { if (is.character(expr)) { expr <- str2expression(expr) } eval(expr, envir, ...) } # evaluate an expression without printing output or messages # @param expr expression to be evaluated # @param type type of output to be suppressed (see ?sink) # @param try wrap evaluation of expr in 'try' and # not suppress outputs if evaluation fails? # @param silent actually evaluate silently? eval_silent <- function(expr, type = "output", try = FALSE, silent = TRUE, ...) { try <- as_one_logical(try) silent <- as_one_logical(silent) type <- match.arg(type, c("output", "message")) expr <- substitute(expr) envir <- parent.frame() if (silent) { if (try && type == "message") { try_out <- try(utils::capture.output( out <- eval(expr, envir), type = type, ... )) if (is_try_error(try_out)) { # try again without suppressing error messages out <- eval(expr, envir) } } else { utils::capture.output(out <- eval(expr, envir), type = type, ...) } } else { out <- eval(expr, envir) } out } # find the name that 'x' had in a specific environment substitute_name <- function(x, envir = parent.frame(), nchar = 50) { out <- substitute(x) out <- eval2(paste0("substitute(", out, ")"), envir = envir) if (missing(out)) { return(NULL) } substr(collapse(deparse(out)), 1, nchar) } # recursive sorting of dependencies # @param x named list of dependencies per element # @param sorted already sorted element names # @return a vector of sorted element names sort_dependencies <- function(x, sorted = NULL) { if (!length(x)) { return(NULL) } if (length(names(x)) != length(x)) { stop2("Argument 'x' must be named.") } take <- !ulapply(x, function(dep) any(!dep %in% sorted)) new <- setdiff(names(x)[take], sorted) out <- union(sorted, new) if (length(new)) { out <- union(out, sort_dependencies(x, sorted = out)) } else if (!all(names(x) %in% out)) { stop2("Cannot handle circular dependency structures.") } out } #' Internal abort helper #' #' A drop-in replacement for the old `stop2()` that throws structured #' errors via **rlang**. #' The error message is built with **glue**, so you can use #' `{.val {x}}`, `{.arg {y}}`, etc. #' Every error inherits from `"brms_error"` plus any subclasses #' supplied through `.subclass`, making it easy to `tryCatch()`. #' #' @param message A character (or glue) string describing the error. #' @param ... Additional strings merged into the message; kept for #' backward compatibility with existing `stop2("foo", "bar")` calls. #' @param .subclass Optional character vector of extra condition classes. #' @param call A call object to store with the condition; defaults to the #' caller (set internally to avoid CRAN’s “function call as default” #' NOTE). #' @param .envir Environment in which glue expressions are evaluated. #' @keywords internal #' @noRd stop2 <- function(message = "", ..., .subclass = NULL, call = NULL, .envir = parent.frame()) { if (is.null(call)) { call <- rlang::caller_call() } rlang::abort( message = glue::glue(message, ..., .envir = .envir), .subclass = c(.subclass, "brms_error"), call = call ) } warning2 <- function(...) { warning(..., call. = FALSE) } # get first occurrence of 'x' in '...' objects # @param x The name of the required element # @param ... named R objects that may contain 'x' get_arg <- function(x, ...) { dots <- list(...) i <- 1 out <- NULL while (i <= length(dots) && is.null(out)) { if (!is.null(dots[[i]][[x]])) { out <- dots[[i]][[x]] } else { i <- i + 1 } } out } SW <- function(expr) { base::suppressWarnings(expr) } # get pattern matches in text as vector # @param simplify return an atomic vector of matches? # @param first only return the first match in each string? # @return character vector containing matches get_matches <- function(pattern, text, simplify = TRUE, first = FALSE, ...) { x <- regmatches(text, gregexpr(pattern, text, ...)) if (first) { x <- lapply(x, function(t) if (length(t)) t[1] else t) } if (simplify) { if (first) { x <- lapply(x, function(t) if (length(t)) t else "") } x <- unlist(x) } x } # find matches in the parse tree of an expression # @param pattern pattern to be matched # @param expr expression to be searched in # @return character vector containing matches get_matches_expr <- function(pattern, expr, ...) { if (is.character(expr)) { expr <- str2expression(expr) } out <- NULL for (i in seq_along(expr)) { sexpr <- try(expr[[i]], silent = TRUE) if (!is_try_error(sexpr)) { sexpr_char <- deparse0(sexpr) out <- c(out, get_matches(pattern, sexpr_char, ...)) } if (is.call(sexpr) || is.expression(sexpr)) { out <- c(out, get_matches_expr(pattern, sexpr, ...)) } } trim_wsp(unique(out)) } # like 'grepl' but handles (parse trees of) expressions grepl_expr <- function(pattern, expr, ...) { as.logical(ulapply(expr, function(e) length(get_matches_expr(pattern, e, ...)) > 0L)) } # combine character vectors into a joint regular 'or' expression # @param x a character vector # @param escape escape all special characters in 'x'? regex_or <- function(x, escape = FALSE) { if (escape) { x <- escape_all(x) } paste0("(", paste0("(", x, ")", collapse = "|"), ")") } # escape dots in character strings escape_dot <- function(x) { gsub(".", "\\.", x, fixed = TRUE) } # escape all special characters in character strings escape_all <- function(x) { specials <- c(".", "*", "+", "?", "^", "$", "(", ")", "[", "]", "|") for (s in specials) { x <- gsub(s, paste0("\\", s), x, fixed = TRUE) } x } # add an underscore to non-empty character strings # @param x a character vector # @param pos position of the underscore usc <- function(x, pos = c("prefix", "suffix")) { pos <- match.arg(pos) x <- as.character(x) if (!length(x)) x <- "" if (pos == "prefix") { x <- ifelse(nzchar(x), paste0("_", x), "") } else { x <- ifelse(nzchar(x), paste0(x, "_"), "") } x } # round using the largest remainder method round_largest_remainder <- function(x) { x <- as.numeric(x) total <- round(sum(x)) out <- floor(x) diff <- x - out J <- order(diff, decreasing = TRUE) I <- seq_len(total - floor(sum(out))) out[J[I]] <- out[J[I]] + 1 out } # add leading and trailing white spaces # @param x object accepted by paste # @param nsp number of white spaces to add wsp <- function(x = "", nsp = 1) { sp <- collapse(rep(" ", nsp)) if (length(x)) { out <- ifelse(nzchar(x), paste0(sp, x, sp), sp) } else { out <- NULL } out } # add white space per line the the strings # @param x object accepted by paste # @param nsp number of white spaces to add wsp_per_line <- function(x, nsp) { sp <- collapse(rep(" ", nsp)) x <- paste0(sp, x) x <- gsub("\\n(?=.+)", paste0("\n", sp), x, perl = TRUE) x } # remove whitespaces in character strings rm_wsp <- function(x) { out <- gsub("[ \t\r\n]+", "", x, perl = TRUE) dim(out) <- dim(x) out } # trim whitespaces in character strings trim_wsp <- function(x) { out <- gsub("[ \t\r\n]+", " ", x, perl = TRUE) dim(out) <- dim(x) out } # limit the number of characters of a vector # @param x a character vector # @param chars maximum number of characters to show # @param lsuffix number of characters to keep at the end of the strings # @return possible truncated character vector limit_chars <- function(x, chars = NULL, lsuffix = 4) { stopifnot(is.character(x)) if (!is.null(chars)) { chars_x <- nchar(x) - lsuffix suffix <- substr(x, chars_x + 1, chars_x + lsuffix) x <- substr(x, 1, chars_x) x <- ifelse(chars_x <= chars, x, paste0(substr(x, 1, chars - 3), "...")) x <- paste0(x, suffix) } x } # ensure that deprecated arguments still work # @param arg input to the new argument # @param alias input to the deprecated argument # @param default the default value of alias # @param warn should a warning be printed if alias is specified? use_alias <- function(arg, alias = NULL, default = NULL, warn = TRUE) { arg_name <- Reduce(paste, deparse(substitute(arg))) alias_name <- Reduce(paste, deparse(substitute(alias))) if (!is_equal(alias, default)) { arg <- alias if (grepl("^dots\\$", alias_name)) { alias_name <- gsub("^dots\\$", "", alias_name) } else if (grepl("^dots\\[\\[", alias_name)) { alias_name <- gsub("^dots\\[\\[\"|\"\\]\\]$", "", alias_name) } if (warn) { warning2("Argument '", alias_name, "' is deprecated. ", "Please use argument '", arg_name, "' instead.") } } arg } warn_deprecated <- function(new, old = as.character(sys.call(sys.parent()))[1]) { msg <- paste0("Function '", old, "' is deprecated.") if (!missing(new)) { msg <- paste0(msg, " Please use '", new, "' instead.") } warning2(msg) invisible(NULL) } # check if x is a try-error resulting from try() is_try_error <- function(x) { inherits(x, "try-error") } # check if verbose mode is activated is_verbose <- function() { as_one_logical(getOption("brms.verbose", FALSE)) } viridis6 <- function() { c("#440154", "#414487", "#2A788E", "#22A884", "#7AD151", "#FDE725") } expect_match2 <- function(object, regexp, ..., all = TRUE) { testthat::expect_match(object, regexp, fixed = TRUE, ..., all = all) } # startup messages for brms .onAttach <- function(libname, pkgname) { version <- utils::packageVersion("brms") packageStartupMessage( "Loading 'brms' package (version ", version, "). Useful instructions\n", "can be found by typing help('brms'). A more detailed introduction\n", "to the package is available through vignette('brms_overview')." ) invisible(NULL) } # code to execute when loading brms .onLoad <- function(libname, pkgname) { # ensure compatibility with older R versions backports::import(pkgname) # dynamically register the 'recover_data' and 'emm_basis' # methods needed by 'emmeans', if that package is installed if (requireNamespace("emmeans", quietly = TRUE) && utils::packageVersion("emmeans") >= "1.4.0") { emmeans::.emm_register("brmsfit", pkgname) } invisible(NULL) } brms/R/update.R0000644000176200001440000003474715057537616013061 0ustar liggesusers#' Update \pkg{brms} models #' #' This method allows to update an existing \code{brmsfit} object. #' #' @param object An object of class \code{brmsfit}. #' @param formula. Changes to the formula; for details see #' \code{\link{update.formula}} and \code{\link{brmsformula}}. #' @param newdata Optional \code{data.frame} to update the model with new data. #' Data-dependent default priors will not be updated automatically. #' @param recompile Logical, indicating whether the Stan model should #' be recompiled. If \code{NULL} (the default), \code{update} tries #' to figure out internally, if recompilation is necessary. #' Setting it to \code{FALSE} will cause all Stan code changing #' arguments to be ignored. #' @param ... Other arguments passed to \code{\link{brm}}. #' #' @details When updating a \code{brmsfit} created with the \pkg{cmdstanr} #' backend in a different \R session, a recompilation will be triggered #' because by default, \pkg{cmdstanr} writes the model executable to a #' temporary directory. To avoid that, set option #' \code{"cmdstanr_write_stan_file_dir"} to a nontemporary path of your choice #' before creating the original \code{brmsfit} (see section 'Examples' below). #' #' @examples #' \dontrun{ #' fit1 <- brm(time | cens(censored) ~ age * sex + disease + (1|patient), #' data = kidney, family = gaussian("log")) #' summary(fit1) #' #' ## remove effects of 'disease' #' fit2 <- update(fit1, formula. = ~ . - disease) #' summary(fit2) #' #' ## remove the group specific term of 'patient' and #' ## change the data (just take a subset in this example) #' fit3 <- update(fit1, formula. = ~ . - (1|patient), #' newdata = kidney[1:38, ]) #' summary(fit3) #' #' ## use another family and add population-level priors #' fit4 <- update(fit1, family = weibull(), init = "0", #' prior = set_prior("normal(0,5)")) #' summary(fit4) #' #' ## to avoid a recompilation when updating a 'cmdstanr'-backend fit in a fresh #' ## R session, set option 'cmdstanr_write_stan_file_dir' before creating the #' ## initial 'brmsfit' #' ## CAUTION: the following code creates some files in the current working #' ## directory: two 'model_.stan' files, one 'model_(.exe)' #' ## executable, and one 'fit_cmdstanr_.rds' file #' set.seed(7) #' fname <- paste0("fit_cmdstanr_", sample.int(.Machine$integer.max, 1)) #' options(cmdstanr_write_stan_file_dir = getwd()) #' fit_cmdstanr <- brm(rate ~ conc + state, #' data = Puromycin, #' backend = "cmdstanr", #' file = fname) #' # now restart the R session and run the following (after attaching 'brms') #' set.seed(7) #' fname <- paste0("fit_cmdstanr_", sample.int(.Machine$integer.max, 1)) #' fit_cmdstanr <- brm(rate ~ conc + state, #' data = Puromycin, #' backend = "cmdstanr", #' file = fname) #' upd_cmdstanr <- update(fit_cmdstanr, #' formula. = rate ~ conc) #' } #' #' @export update.brmsfit <- function(object, formula., newdata = NULL, recompile = NULL, ...) { dots <- list(...) testmode <- isTRUE(dots[["testmode"]]) dots$testmode <- NULL if ("silent" %in% names(dots)) { dots$silent <- validate_silent(dots$silent) } else { dots$silent <- object$stan_args$silent %||% 1L } silent <- dots$silent object <- restructure(object) if (isTRUE(object$version$brms < "2.0.0")) { warning2("Updating models fitted with older versions of brms may fail.") } object$file <- NULL if ("data" %in% names(dots)) { # otherwise the data name cannot be found by substitute stop2("Please use argument 'newdata' to update the data.") } if (!is.null(newdata)) { dots$data <- newdata data_name <- substitute_name(newdata) } else { dots$data <- object$data data_name <- get_data_name(object$data) } if (missing(formula.) || is.null(formula.)) { dots$formula <- object$formula if (!is.null(dots[["family"]])) { dots$formula <- bf(dots$formula, family = dots$family) } if (!is.null(dots[["autocor"]])) { dots$formula <- bf(dots$formula, autocor = dots$autocor) } } else { # TODO: generalize updating of the model formula if (is.mvbrmsformula(formula.) || is.mvbrmsformula(object$formula)) { stop2("Updating formulas of multivariate models is not yet possible.") } if (is.brmsformula(formula.)) { nl <- get_nl(formula.) } else { formula. <- as.formula(formula.) nl <- get_nl(formula(object)) } family <- get_arg("family", formula., dots, object) autocor <- get_arg("autocor", formula., dots, object) dots$formula <- bf(formula., family = family, autocor = autocor, nl = nl) if (is_nonlinear(object)) { if (length(setdiff(all.vars(dots$formula$formula), ".")) == 0L) { dots$formula <- update(object$formula, dots$formula, mode = "keep") } else { dots$formula <- update(object$formula, dots$formula, mode = "replace") if (silent < 2) { message("Argument 'formula.' will completely replace the ", "original formula in non-linear models.") } } } else { mvars <- all.vars(dots$formula$formula) mvars <- setdiff(mvars, c(names(object$data), ".")) if (length(mvars) && is.null(newdata)) { stop2("New variables found: ", collapse_comma(mvars), "\nPlease supply your data again via argument 'newdata'.") } dots$formula <- update(formula(object), dots$formula) } } # update response categories and ordinal thresholds dots$formula <- validate_formula(dots$formula, data = dots$data) if (is.null(dots$prior)) { dots$prior <- object$prior } else { if (!is.brmsprior(dots$prior)) { stop2("Argument 'prior' needs to be a 'brmsprior' object.") } # update existing priors manually and keep only user-specified ones # default priors are recomputed base on newdata if provided old_user_prior <- subset2(object$prior, source = "user") dots$prior <- rbind(dots$prior, old_user_prior) dupl_priors <- duplicated(dots$prior[, rcols_prior()]) dots$prior <- dots$prior[!dupl_priors, ] } # make sure potentially updated priors pass 'validate_prior' attr(dots$prior, "allow_invalid_prior") <- TRUE if (!"sample_prior" %in% names(dots)) { dots$sample_prior <- attr(object$prior, "sample_prior") if (is.null(dots$sample_prior)) { has_prior_pars <- any(grepl("^prior_", variables(object))) dots$sample_prior <- if (has_prior_pars) "yes" else "no" } } # do not use 'is.null' to allow updating arguments to NULL if (!"data2" %in% names(dots)) { dots$data2 <- object$data2 } if (!"stanvars" %in% names(dots)) { dots$stanvars <- object$stanvars } if (!"algorithm" %in% names(dots)) { dots$algorithm <- object$algorithm } if (!"backend" %in% names(dots)) { dots$backend <- object$backend } if (!"threads" %in% names(dots)) { dots$threads <- object$threads } if (!"save_pars" %in% names(dots)) { dots$save_pars <- object$save_pars } if (!"knots" %in% names(dots)) { dots$knots <- get_knots(object$data) } if (!"drop_unused_levels" %in% names(dots)) { dots$drop_unused_levels <- get_drop_unused_levels(object$data) } if (!"normalize" %in% names(dots)) { dots$normalize <- is_normalized(object$model) } # update arguments controlling the sampling process dots$algorithm <- match.arg(dots$algorithm, algorithm_choices()) dots$backend <- match.arg(dots$backend, backend_choices()) same_algorithm <- is_equal(dots$algorithm, object$algorithm) same_backend <- is_equal(dots$backend, object$backend) if (same_algorithm) { # reusing sampling arguments in other algorithms may cause errors #1564 if (is.null(dots$iter)) { # only keep old 'warmup' if also keeping old 'iter' dots$warmup <- first_not_null(dots$warmup, object$fit@sim$warmup) } dots$iter <- first_not_null(dots$iter, object$fit@sim$iter) dots$chains <- first_not_null(dots$chains, object$fit@sim$chains) dots$thin <- first_not_null(dots$thin, object$fit@sim$thin) if (same_backend) { # reusing control arguments in other backends may cause errors #1259 control <- attr(object$fit@sim$samples[[1]], "args")$control control <- control[setdiff(names(control), names(dots$control))] dots$control[names(control)] <- control # reuse backend arguments originally passed to brm #1373 names_old_stan_args <- setdiff(names(object$stan_args), names(dots)) dots[names_old_stan_args] <- object$stan_args[names_old_stan_args] } } if (is.null(recompile)) { # only recompile if new and old stan code do not match new_stancode <- suppressMessages(do_call(make_stancode, dots)) # stan code may differ just because of the version number (#288) new_stancode <- sub("^[^\n]+\n", "", new_stancode) old_stancode <- stancode(object, version = FALSE) recompile <- needs_recompilation(object) || !same_backend || !is_equal(new_stancode, old_stancode) if (recompile && silent < 2) { message("The desired updates require recompiling the model") } } recompile <- as_one_logical(recompile) if (recompile) { # recompliation is necessary dots$fit <- NA if (!testmode) { object <- do_call(brm, dots) } } else { # refit the model without compiling it again if (!is.null(dots$formula)) { object$formula <- dots$formula dots$formula <- NULL } bterms <- brmsterms(object$formula) object$data2 <- validate_data2(dots$data2, bterms = bterms) object$data <- validate_data( dots$data, bterms = bterms, data2 = object$data2, knots = dots$knots, drop_unused_levels = dots$drop_unused_levels ) bframe <- brmsframe(bterms, data = object$data) object$prior <- .validate_prior( dots$prior, bframe = bframe, sample_prior = dots$sample_prior ) object$family <- get_element(object$formula, "family") object$autocor <- get_element(object$formula, "autocor") object$ranef <- frame_re(bterms, data = object$data) object$stanvars <- validate_stanvars(dots$stanvars) object$threads <- validate_threads(dots$threads) if ("sample_prior" %in% names(dots)) { dots$sample_prior <- validate_sample_prior(dots$sample_prior) attr(object$prior, "sample_prior") <- dots$sample_prior } object$save_pars <- validate_save_pars( save_pars = dots$save_pars, save_ranef = dots$save_ranef, save_mevars = dots$save_mevars, save_all_pars = dots$save_all_pars ) object$basis <- frame_basis(bframe, data = object$data) algorithm <- match.arg(dots$algorithm, algorithm_choices()) dots$algorithm <- object$algorithm <- algorithm # can only avoid recompilation when using the old backend dots$backend <- object$backend if (!testmode) { dots$fit <- object object <- do_call(brm, dots) } } attr(object$data, "data_name") <- data_name object } #' Update \pkg{brms} models based on multiple data sets #' #' This method allows to update an existing \code{brmsfit_multiple} object. #' #' @param object An object of class \code{brmsfit_multiple}. #' @param formula. Changes to the formula; for details see #' \code{\link{update.formula}} and \code{\link{brmsformula}}. #' @param newdata List of \code{data.frames} to update the model with new data. #' Currently required even if the original data should be used. #' @param data2 A \emph{list} of named lists each of which will be used to fit a #' separate model. Each of the named lists contains objects representing data #' which cannot be passed via argument \code{data} (see \code{\link{brm}} for #' examples). The length of the outer list should match the length of the list #' passed to the \code{data} argument. Currently required even if the original #' data should be used. #' @param ... Other arguments passed to \code{\link{update.brmsfit}} #' and \code{\link{brm_multiple}}. #' #' @examples #' \dontrun{ #' library(mice) #' imp <- mice(nhanes2) #' #' # initially fit the model #' fit_imp1 <- brm_multiple(bmi ~ age + hyp + chl, data = imp, chains = 1) #' summary(fit_imp1) #' #' # update the model using fewer predictors #' fit_imp2 <- update(fit_imp1, formula. = . ~ hyp + chl, newdata = imp) #' summary(fit_imp2) #' } #' #' @export update.brmsfit_multiple <- function(object, formula., newdata = NULL, data2 = NULL, ...) { dots <- list(...) if ("data" %in% names(dots)) { # otherwise the data name cannot be found by substitute stop2("Please use argument 'newdata' to update the data.") } if (is.null(newdata)) { stop2("'newdata' is required when updating a 'brmsfit_multiple' object.") } data_name <- substitute_name(newdata) if (inherits(newdata, "mids")) { require_package("mice", version = "3.0.0") newdata <- lapply(seq_len(newdata$m), mice::complete, data = newdata) } else if (!(is.list(newdata) && is.vector(newdata))) { stop2("'newdata' must be a list of data.frames.") } if (!is.null(data2)) { if (!is_data2_list(data2)) { stop2("'data2' must be a list of named lists.") } if (length(data2) != length(newdata)) { stop2("'data2' must have the same length as 'newdata'.") } } # update the template model using all arguments if (missing(formula.)) { formula. <- NULL } args <- nlist(object, formula., newdata = newdata[[1]], data2 = data2[[1]]) args <- c(args, dots) args$file <- NULL args$chains <- 0 fit <- do_call(update.brmsfit, args) # arguments later passed to brm_multiple args <- c(nlist(fit, data = newdata, data2), dots) # update arguments controlling the sampling process # they cannot be accessed directly from the template model # as it does not contain any draws (chains = 0) if (is.null(args$iter)) { # only keep old 'warmup' if also keeping old 'iter' args$warmup <- first_not_null(args$warmup, object$fit@sim$warmup) } if (is.null(args$chains)) { # chains were combined across all submodels nimp <- max(attr(object, "nimp"), 1) args$chains <- object$fit@sim$chains / nimp } args$iter <- first_not_null(args$iter, object$fit@sim$iter) args$thin <- first_not_null(args$thin, object$fit@sim$thin) control <- attr(object$fit@sim$samples[[1]], "args")$control control <- control[setdiff(names(control), names(args$control))] args$control[names(control)] <- control args$recompile <- NULL out <- do_call(brm_multiple, args) attr(out$data, "data_name") <- data_name out } brms/R/data-response.R0000644000176200001440000005523515053305627014326 0ustar liggesusers#' Extract response values #' #' Extract response values from a \code{\link{brmsfit}} object. #' #' @param x A \code{\link{brmsfit}} object. #' @param resp Optional names of response variables for which to extract values. #' @param warn For internal use only. #' @param ... Further arguments passed to \code{\link{standata}}. #' @inheritParams posterior_predict.brmsfit #' #' @return Returns a vector of response values for univariate models and a #' matrix of response values with one column per response variable for #' multivariate models. #' #' @keywords internal #' @export get_y <- function(x, resp = NULL, sort = FALSE, warn = FALSE, ...) { stopifnot(is.brmsfit(x)) resp <- validate_resp(resp, x) sort <- as_one_logical(sort) warn <- as_one_logical(warn) args <- list(x, resp = resp, ...) args$re_formula <- NA args$check_response <- TRUE args$only_response <- TRUE args$internal <- TRUE sdata <- do_call(standata, args) if (warn) { if (any(paste0("cens", usc(resp)) %in% names(sdata))) { warning2("Results may not be meaningful for censored models.") } } Ynames <- paste0("Y", usc(resp)) if (length(Ynames) > 1L) { out <- do_call(cbind, sdata[Ynames]) colnames(out) <- resp } else { out <- sdata[[Ynames]] } old_order <- attr(sdata, "old_order") if (!is.null(old_order) && !sort) { stopifnot(length(old_order) == NROW(out)) out <- p(out, old_order) } out } #' Prepare Response Data #' #' Prepare data related to response variables in \pkg{brms}. #' Only exported for use in package development. #' #' @param x An \R object. #' @param ... Further arguments passed to or from other methods. #' #' @return A named list of data related to response variables. #' #' @keywords internal #' @export data_response <- function(x, ...) { UseMethod("data_response") } #' @export data_response.mvbrmsframe <- function(x, ...) { out <- list() for (i in seq_along(x$terms)) { c(out) <- data_response(x$terms[[i]], ...) } if (x$rescor) { out$nresp <- length(x$responses) out$nrescor <- out$nresp * (out$nresp - 1) / 2 } out } #' @export data_response.brmsframe <- function(x, data, check_response = TRUE, internal = FALSE, ...) { data <- subset_data(data, x) N <- nrow(data) # TODO: rename 'Y' to 'y' Y <- model.response(model.frame(x$respform, data, na.action = na.pass)) out <- list(N = N, Y = unname(Y)) if (is_binary(x$family)) { bin_levels <- x$frame$basis$resp_levels if (is.null(bin_levels)) { bin_levels <- levels(as.factor(out$Y)) } # fixes issues #1298 and #1511 if (is.numeric(out$Y) && length(bin_levels) == 1L) { if (0 %in% bin_levels) { # 1 as default event level bin_levels <- c(0, 1) } else { # 0 as default non-event level bin_levels <- c(0, bin_levels) } } out$Y <- as.integer(as_factor(out$Y, levels = bin_levels)) - 1 } if (is_categorical(x$family)) { out$Y <- as.integer(as_factor(out$Y, levels = x$frame$basis$resp_levels)) } if (is_ordinal(x$family) && is.ordered(out$Y)) { diff <- ifelse(has_extra_cat(x$family), 1L, 0L) out$Y <- as.integer(out$Y) - diff } if (check_response) { family4error <- family_names(x$family) if (is.mixfamily(x$family)) { family4error <- paste0(family4error, collapse = ", ") family4error <- paste0("mixture(", family4error, ")") } if (!allow_factors(x$family) && !is.numeric(out$Y)) { stop2("Family '", family4error, "' requires numeric responses.") } if (is_binary(x$family)) { if (any(!out$Y %in% c(0, 1))) { stop2("Family '", family4error, "' requires responses ", "to contain only two different values.") } } if (is_ordinal(x$family)) { extra_cat <- has_extra_cat(x$family) min_int <- ifelse(extra_cat, 0L, 1L) msg <- ifelse(extra_cat, "non-negative", "positive") if (any(!is_wholenumber(out$Y)) || any(out$Y < min_int)) { stop2("Family '", family4error, "' requires either ", msg, " integers or ordered factors as responses.") } } if (use_int(x$family)) { if (!all(is_wholenumber(out$Y))) { stop2("Family '", family4error, "' requires integer responses.") } } if (has_multicol(x$family)) { if (!is.matrix(out$Y)) { stop2("This model requires a response matrix.") } } if (is_simplex(x$family)) { if (!is_equal(rowSums(out$Y), rep(1, nrow(out$Y)))) { stop2("Response values in simplex models must sum to 1.") } } ybounds <- family_info(x$family, "ybounds") closed <- family_info(x$family, "closed") if (is.finite(ybounds[1])) { y_min <- min(out$Y, na.rm = TRUE) if (closed[1] && y_min < ybounds[1]) { stop2("Family '", family4error, "' requires response greater ", "than or equal to ", ybounds[1], ".") } else if (!closed[1] && y_min <= ybounds[1]) { stop2("Family '", family4error, "' requires response greater ", "than ", round(ybounds[1], 2), ".") } } if (is.finite(ybounds[2])) { y_max <- max(out$Y, na.rm = TRUE) if (closed[2] && y_max > ybounds[2]) { stop2("Family '", family4error, "' requires response smaller ", "than or equal to ", ybounds[2], ".") } else if (!closed[2] && y_max >= ybounds[2]) { stop2("Family '", family4error, "' requires response smaller ", "than ", round(ybounds[2], 2), ".") } } out$Y <- as.array(out$Y) } # data for addition arguments of the response # TODO: replace is.formula(x$adforms$term) pattern with has_ad_terms() if (has_trials(x$family) || is.formula(x$adforms$trials)) { if (!length(x$adforms$trials)) { stop2("Specifying 'trials' is required for this model.") } if (!is.formula(x$adforms$trials)) { stop2("Argument 'trials' is misspecified.") } trials <- get_ad_values(x, "trials", "trials", data) if (!is.numeric(trials)) { stop2("Number of trials must be numeric.") } if (any(!is_wholenumber(trials) | trials < 0)) { stop2("Number of trials must be non-negative integers.") } if (length(trials) == 1L) { trials <- rep(trials, nrow(data)) } if (check_response) { if (is_multinomial(x$family)) { if (!is_equal(rowSums(out$Y), trials)) { stop2("Number of trials does not match the number of events.") } } else if (has_trials(x$family)) { if (max(trials) == 1L && !internal) { message("Only 2 levels detected so that family 'bernoulli' ", "might be a more efficient choice.") } if (any(out$Y > trials)) { stop2("Number of trials is smaller than the number of events.") } } } out$trials <- as.array(trials) } if (has_cat(x$family)) { ncat <- length(get_cats(x$family)) if (min(ncat) < 2L) { stop2("At least two response categories are required.") } if (!has_multicol(x$family)) { if (ncat == 2L && !internal) { message("Only 2 levels detected so that family 'bernoulli' ", "might be a more efficient choice.") } if (check_response && any(out$Y > ncat)) { stop2("Number of categories is smaller than the response ", "variable would suggest.") } } out$ncat <- ncat } if (has_thres(x$family)) { thres <- family_info(x, "thres") if (has_thres_groups(x$family)) { groups <- get_thres_groups(x) out$ngrthres <- length(groups) grthres <- get_ad_values(x, "thres", "gr", data) grthres <- factor(rename(grthres), levels = groups) # create an matrix of threshold indices per observation Jgrthres <- match(grthres, groups) nthres <- as.array(rep(NA, length(groups))) for (i in seq_along(groups)) { nthres[i] <- max(subset2(thres, group = groups[i])$thres) } if (check_response && any(out$Y > nthres[Jgrthres] + 1)) { stop2("Number of thresholds is smaller than required by the response.") } Kthres_cumsum <- cumsum(nthres) Kthres_start <- c(1, Kthres_cumsum[-length(nthres)] + 1) Kthres_end <- Kthres_cumsum Jthres <- cbind(Kthres_start, Kthres_end)[Jgrthres, , drop = FALSE] out$Jthres <- Jthres } else { nthres <- max(thres$thres) if (check_response && any(out$Y > nthres + 1)) { stop2("Number of thresholds is smaller than required by the response.") } } if (max(nthres) == 1L && !internal) { message("Only 2 levels detected so that family 'bernoulli' ", "might be a more efficient choice.") } out$nthres <- nthres } if (is.formula(x$adforms$cat)) { warning2("Addition argument 'cat' is deprecated. Use 'thres' instead. ", "See ?brmsformula for more details.") } if (is.formula(x$adforms$se)) { se <- get_ad_values(x, "se", "se", data) if (!is.numeric(se)) { stop2("Standard errors must be numeric.") } if (min(se) < 0) { stop2("Standard errors must be non-negative.") } out$se <- as.array(se) } if (is.formula(x$adforms$weights)) { weights <- get_ad_values(x, "weights", "weights", data) if (!is.numeric(weights)) { stop2("Weights must be numeric.") } if (min(weights) < 0) { stop2("Weights must be non-negative.") } if (get_ad_flag(x, "weights", "scale")) { weights <- weights / sum(weights) * length(weights) } out$weights <- as.array(weights) } if (is.formula(x$adforms$dec)) { dec <- get_ad_values(x, "dec", "dec", data) if (is.character(dec) || is.factor(dec)) { if (!all(unique(dec) %in% c("lower", "upper"))) { stop2("Decisions should be 'lower' or 'upper' ", "when supplied as characters or factors.") } dec <- ifelse(dec == "lower", 0, 1) } else { dec <- as.numeric(as.logical(dec)) } out$dec <- as.array(dec) } if (is.formula(x$adforms$rate)) { denom <- get_ad_values(x, "rate", "denom", data) if (!is.numeric(denom)) { stop2("Rate denomiators should be numeric.") } if (isTRUE(any(denom <= 0))) { stop2("Rate denomiators should be positive.") } out$denom <- as.array(denom) } if (is.formula(x$adforms$cens) && check_response) { cens <- get_ad_values(x, "cens", "cens", data) cens <- prepare_cens(cens) if (!all(is_wholenumber(cens) & cens %in% -1:2)) { stop2( "Invalid censoring data. Accepted values are ", "'left', 'none', 'right', and 'interval'\n", "(abbreviations are allowed) or -1, 0, 1, and 2.\n", "TRUE and FALSE are also accepted ", "and refer to 'right' and 'none' respectively." ) } if (length(cens) == 1L) { cens <- rep(cens, N) } if (length(cens) != N) { stop2("Censoring information needs to have length ", "equal to the number of data rows.") } out$cens <- as.array(cens) icens <- cens %in% 2 if (any(icens) || has_interval_cens(x)) { # interval censoring is required y2 <- unname(get_ad_values(x, "cens", "y2", data)) if (is.null(y2)) { stop2("Argument 'y2' is required for interval censored data.") } if (length(y2) != N) { stop2("Argument 'y2' needs to have length equal to the number of data rows.") } if (anyNA(y2[icens])) { stop2("'y2' should not be NA for interval censored observations.") } if (any(out$Y[icens] >= y2[icens])) { stop2("Left censor points must be smaller than right ", "censor points for interval censored data.") } y2[!icens] <- 0 # not used in Stan out$rcens <- as.array(y2) } } if (is.formula(x$adforms$trunc)) { lb <- as.numeric(get_ad_values(x, "trunc", "lb", data)) ub <- as.numeric(get_ad_values(x, "trunc", "ub", data)) if (any(lb >= ub)) { stop2("Truncation bounds are invalid: lb >= ub") } if (length(lb) == 1L) { lb <- rep(lb, N) } if (length(ub) == 1L) { ub <- rep(ub, N) } if (length(lb) != N || length(ub) != N) { stop2("Invalid truncation bounds.") } inv_bounds <- out$Y < lb | out$Y > ub if (check_response && isTRUE(any(inv_bounds))) { stop2("Some responses are outside of the truncation bounds.") } out$lb <- lb out$ub <- ub } if (is.formula(x$adforms$mi)) { sdy <- get_sdy(x, data) if (is.null(sdy)) { # missings only which_mi <- which(is.na(out$Y)) out$Jmi <- as.array(which_mi) out$Nmi <- length(out$Jmi) } else { # measurement error in the response if (length(sdy) == 1L) { sdy <- rep(sdy, length(out$Y)) } if (length(sdy) != length(out$Y)) { stop2("'sdy' must have the same length as the response.") } # all observations will have a latent score which_mi <- which(is.na(out$Y) | is.infinite(sdy)) out$Jme <- as.array(setdiff(seq_along(out$Y), which_mi)) out$Nme <- length(out$Jme) out$noise <- as.array(sdy) if (!internal) { out$noise[which_mi] <- Inf } } # bounds are required for predicting new missing values # not required in Stan right now as bounds are hard-coded there tbounds <- trunc_bounds(x, data, incl_family = TRUE) out$lbmi <- tbounds$lb out$ubmi <- tbounds$ub if (!internal) { # Stan does not allow NAs in data # use Inf to that min(Y) is not affected out$Y[which_mi] <- Inf } } if (is.formula(x$adforms$vreal)) { # vectors of real values for use in custom families vreal <- eval_rhs(x$adforms$vreal) vreal <- lapply(vreal$vars, eval2, data) names(vreal) <- paste0("vreal", seq_along(vreal)) for (i in seq_along(vreal)) { if (length(vreal[[i]]) == 1L) { vreal[[i]] <- rep(vreal[[i]], N) } vreal[[i]] <- as.array(as.numeric(vreal[[i]])) } c(out) <- vreal } if (is.formula(x$adforms$vint)) { # vectors of integer values for use in custom families vint <- eval_rhs(x$adforms$vint) vint <- lapply(vint$vars, eval2, data) names(vint) <- paste0("vint", seq_along(vint)) for (i in seq_along(vint)) { if (length(vint[[i]]) == 1L) { vint[[i]] <- rep(vint[[i]], N) } if (!all(is_wholenumber(vint[[i]]))) { stop2("'vint' requires whole numbers as input.") } vint[[i]] <- as.array(vint[[i]]) } c(out) <- vint } if (length(out)) { resp <- usc(combine_prefix(x)) out <- setNames(out, paste0(names(out), resp)) } out } # data specific for mixture models data_mixture <- function(bframe, data2, prior) { stopifnot(is.brmsterms(bframe)) out <- list() if (is.mixfamily(bframe$family)) { families <- family_names(bframe$family) dp_classes <- dpar_class(names(c(bframe$dpars, bframe$fdpars))) if (!any(dp_classes %in% "theta")) { # estimate mixture probabilities directly take <- find_rows(prior, class = "theta", resp = bframe$resp) theta_prior <- prior$prior[take] con_theta <- eval_dirichlet(theta_prior, length(families), data2) out$con_theta <- as.array(con_theta) p <- usc(combine_prefix(bframe)) names(out) <- paste0(names(out), p) } } out } # data for the baseline functions of Cox models data_bhaz <- function(bframe, data, data2, prior) { out <- list() if (!is_cox(bframe$family)) { return(out) } y <- bframe$frame$resp$values bhaz <- family_info(bframe, "bhaz") bs <- bframe$basis$bhaz$basis_matrix out$Zbhaz <- bhaz_basis_matrix(y, bhaz$args, basis = bs) out$Zcbhaz <- bhaz_basis_matrix(y, bhaz$args, integrate = TRUE, basis = bs) out$Kbhaz <- NCOL(out$Zbhaz) groups <- bhaz$groups if (!is.null(groups)) { out$ngrbhaz <- length(groups) gr <- get_ad_values(bframe, "bhaz", "gr", data) gr <- factor(rename(gr), levels = groups) out$Jgrbhaz <- match(gr, groups) out$con_sbhaz <- matrix(nrow = out$ngrbhaz, ncol = out$Kbhaz) sbhaz_prior <- subset2(prior, class = "sbhaz", resp = bframe$resp) sbhaz_prior_global <- subset2(sbhaz_prior, group = "") con_sbhaz_global <- eval_dirichlet(sbhaz_prior_global$prior, out$Kbhaz, data2) for (k in seq_along(groups)) { sbhaz_prior_group <- subset2(sbhaz_prior, group = groups[k]) if (nzchar(sbhaz_prior_group$prior)) { out$con_sbhaz[k, ] <- eval_dirichlet(sbhaz_prior_group$prior, out$Kbhaz, data2) } else { out$con_sbhaz[k, ] <- con_sbhaz_global } } } else { sbhaz_prior <- subset2(prior, class = "sbhaz", resp = bframe$resp) con_sbhaz <- eval_dirichlet(sbhaz_prior$prior, out$Kbhaz, data2) out$con_sbhaz <- as.array(con_sbhaz) } out } # Basis matrices for baseline hazard functions of the Cox model # @param y vector of response values # @param args arguments passed to the spline generating functions # @param integrate compute the I-spline instead of the M-spline basis? # @param basis optional precomputed basis matrix # @return the design matrix of the baseline hazard function bhaz_basis_matrix <- function(y, args = list(), integrate = FALSE, basis = NULL) { # version check is required due to class name changes #1580 require_package("splines2", version = "0.5.0") if (!is.null(basis)) { # perform predictions based on an existing basis matrix stopifnot(inherits(basis, "MSpline")) if (integrate) { # for predictions just the attributes are required # which are the same of M-Splines and I-Splines class(basis) <- c("matrix", "ISpline") } return(predict(basis, y)) } stopifnot(is.list(args)) args$x <- y if (is.null(args$Boundary.knots)) { # avoid 'knots' outside 'Boundary.knots' error (#1143) # we also need a smaller lower boundary knot to avoid lp = -Inf # the below choices are ad-hoc and may need further thought min_y <- min(y, na.rm = TRUE) max_y <- max(y, na.rm = TRUE) diff_y <- max_y - min_y lower_knot <- max(min_y - diff_y / 50, 0) upper_knot <- max_y + diff_y / 50 args$Boundary.knots <- c(lower_knot, upper_knot) } if (integrate) { out <- do_call(splines2::iSpline, args) } else { out <- do_call(splines2::mSpline, args) } out } # extract baseline hazard information from data for storage in the model family # @return a named list with elements: # args: arguments that can be passed to bhaz_basis_matrix # groups: optional names of the groups for which to stratify extract_bhaz <- function(x, data) { stopifnot(is.brmsformula(x) || is.brmsterms(x), is_cox(x)) if (is.null(x$adforms)) { x$adforms <- terms_ad(x$formula, x$family) } out <- list() if (is.null(x$adforms$bhaz)) { # bhaz is an optional addition term so defaults need to be listed here too out$args <- list(df = 5, intercept = TRUE) } else { out$args <- eval_rhs(x$adforms$bhaz)$flags gr <- get_ad_values(x, "bhaz", "gr", data) if (!is.null(gr)) { out$groups <- rename(levels(factor(gr))) } } out } # extract names of response categories # @param x a brmsterms object or one that can be coerced to it # @param data user specified data # @return a vector of category names extract_cat_names <- function(x, data) { stopifnot(is.brmsformula(x) || is.brmsterms(x)) respform <- validate_resp_formula(x$formula) mr <- model.response(model.frame(respform, data)) if (has_multicol(x)) { mr <- as.matrix(mr) out <- as.character(colnames(mr)) if (!length(out)) { out <- as.character(seq_cols(mr)) } } else { out <- levels(factor(mr)) } out } # extract names of ordinal thresholds # @param x a brmsterms object or one that can be coerced to it # @param data user specified data # @return a data.frame with columns 'thres' and 'group' extract_thres_names <- function(x, data) { stopifnot(is.brmsformula(x) || is.brmsterms(x), has_thres(x)) if (is.null(x$adforms)) { x$adforms <- terms_ad(x$formula, x$family) } nthres <- get_ad_values(x, "thres", "thres", data) if (any(!is_wholenumber(nthres) | nthres < 1L)) { stop2("Number of thresholds must be a positive integer.") } # has an extra category that is not part of the ordinal scale? (#1429) extra_cat <- has_extra_cat(x$family) grthres <- get_ad_values(x, "thres", "gr", data) if (!is.null(grthres)) { # grouping variable was specified if (!is_like_factor(grthres)) { stop2("Variable 'gr' in 'thres' needs to be factor-like.") } grthres <- factor(grthres) group <- levels(grthres) if (!length(nthres)) { # extract number of thresholds from the response values nthres <- rep(NA, length(group)) for (i in seq_along(group)) { take <- grthres %in% group[i] nthres[i] <- extract_nthres( x$formula, data[take, , drop = FALSE], extra_cat = extra_cat ) } } else if (length(nthres) == 1L) { # replicate number of thresholds across groups nthres <- rep(nthres, length(group)) } else { # number of thresholds is a variable in the data for (i in seq_along(group)) { # validate values of the same level take <- grthres %in% group[i] if (length(unique(nthres[take])) > 1L) { stop2("Number of thresholds should be unique for each group.") } } nthres <- get_one_value_per_group(nthres, grthres) } group <- rep(rename(group), nthres) thres <- ulapply(unname(nthres), seq_len) } else { # no grouping variable was specified group <- "" if (!length(nthres)) { # extract number of thresholds from the response values nthres <- extract_nthres(x$formula, data, extra_cat = extra_cat) } if (length(nthres) > 1L) { stop2("Number of thresholds needs to be a single value.") } thres <- seq_len(nthres) } data.frame(thres, group, stringsAsFactors = FALSE) } # extract number of thresholds from the response values # @param formula with the response on the LHS # @param data a data.frame from which to extract responses # @param extra_cat is the first category an extra (hurdle) category? # @return a single value for the number of thresholds extract_nthres <- function(formula, data, extra_cat = FALSE) { extra_cat <- as_one_logical(extra_cat) respform <- validate_resp_formula(formula) mr <- model.response(model.frame(respform, data)) if (is_like_factor(mr)) { # the first factor level is the extra category diff <- ifelse(extra_cat, 2L, 1L) out <- length(levels(factor(mr))) - diff } else { # 0 is the extra category which does not affect max out <- max(mr) - 1L } if (out < 1L) { stop2("Could not extract the number of thresholds. Use ordered factors ", "or positive integers as your ordinal response and ensure that ", "more than on response category is present.") } out } brms/R/brmsfit-methods.R0000644000176200001440000004771515053254244014672 0ustar liggesusers# This file contains several extractor methods for brmsfit objects. # A lot of other brmsfit methods have their own dedicated files. #' Extract Population-Level Estimates #' #' Extract the population-level ('fixed') effects #' from a \code{brmsfit} object. #' #' @aliases fixef #' #' @inheritParams predict.brmsfit #' @param pars Optional names of coefficients to extract. #' By default, all coefficients are extracted. #' @param ... Currently ignored. #' #' @return If \code{summary} is \code{TRUE}, a matrix returned #' by \code{\link{posterior_summary}} for the population-level effects. #' If \code{summary} is \code{FALSE}, a matrix with one row per #' posterior draw and one column per population-level effect. #' #' @examples #' \dontrun{ #' fit <- brm(time | cens(censored) ~ age + sex + disease, #' data = kidney, family = "exponential") #' fixef(fit) #' # extract only some coefficients #' fixef(fit, pars = c("age", "sex")) #' } #' #' @method fixef brmsfit #' @export #' @export fixef #' @importFrom nlme fixef fixef.brmsfit <- function(object, summary = TRUE, robust = FALSE, probs = c(0.025, 0.975), pars = NULL, ...) { contains_draws(object) all_pars <- variables(object) fpars <- all_pars[grepl(fixef_pars(), all_pars)] if (!is.null(pars)) { pars <- as.character(pars) fpars <- fpars[sub("^[^_]+_", "", fpars) %in% pars] } if (!length(fpars)) { return(NULL) } out <- as.matrix(object, variable = fpars) colnames(out) <- gsub(fixef_pars(), "", fpars) if (summary) { out <- posterior_summary(out, probs, robust) } out } #' Covariance and Correlation Matrix of Population-Level Effects #' #' Get a point estimate of the covariance or #' correlation matrix of population-level parameters #' #' @inheritParams fixef.brmsfit #' @param correlation Logical; if \code{FALSE} (the default), compute #' the covariance matrix, if \code{TRUE}, compute the correlation matrix. #' #' @return covariance or correlation matrix of population-level parameters #' #' @details Estimates are obtained by calculating the maximum likelihood #' covariances (correlations) of the posterior draws. #' #' @examples #' \dontrun{ #' fit <- brm(count ~ zAge + zBase * Trt + (1+Trt|visit), #' data = epilepsy, family = gaussian(), chains = 2) #' vcov(fit) #' } #' #' @export vcov.brmsfit <- function(object, correlation = FALSE, pars = NULL, ...) { contains_draws(object) all_pars <- variables(object) fpars <- all_pars[grepl(fixef_pars(), all_pars)] if (!is.null(pars)) { pars <- as.character(pars) fpars <- intersect(fpars, paste0("b_", pars)) } if (!length(fpars)) { return(NULL) } draws <- as.data.frame(object, variable = fpars) names(draws) <- sub(fixef_pars(), "", names(draws)) if (correlation) { out <- cor(draws) } else { out <- cov(draws) } out } #' Extract Group-Level Estimates #' #' Extract the group-level ('random') effects of each level #' from a \code{brmsfit} object. #' #' @aliases ranef #' #' @inheritParams fixef.brmsfit #' @param groups Optional names of grouping variables #' for which to extract effects. #' @param ... Currently ignored. #' #' @return A list of 3D arrays (one per grouping factor). #' If \code{summary} is \code{TRUE}, #' the 1st dimension contains the factor levels, #' the 2nd dimension contains the summary statistics #' (see \code{\link{posterior_summary}}), and #' the 3rd dimension contains the group-level effects. #' If \code{summary} is \code{FALSE}, the 1st dimension contains #' the posterior draws, the 2nd dimension contains the factor levels, #' and the 3rd dimension contains the group-level effects. #' #' @examples #' \dontrun{ #' fit <- brm(count ~ zAge + zBase * Trt + (1+Trt|visit), #' data = epilepsy, family = gaussian(), chains = 2) #' ranef(fit) #' } #' #' @method ranef brmsfit #' @export #' @export ranef #' @importFrom nlme ranef ranef.brmsfit <- function(object, summary = TRUE, robust = FALSE, probs = c(0.025, 0.975), pars = NULL, groups = NULL, ...) { contains_draws(object) object <- restructure(object) reframe <- object$ranef if (!has_rows(reframe)) { stop2("The model does not contain group-level effects.") } all_pars <- variables(object) if (!is.null(pars)) { pars <- as.character(pars) } all_groups <- unique(reframe$group) if (!is.null(groups)) { groups <- as.character(groups) all_groups <- intersect(all_groups, groups) } group_levels <- get_levels(reframe) out <- named_list(all_groups) for (g in all_groups) { r <- subset2(reframe, group = g) coefs <- paste0(usc(combine_prefix(r), "suffix"), r$coef) rpars <- all_pars[grepl(paste0("^r_", g, "(__.+\\[|\\[)"), all_pars)] if (!is.null(pars)) { coefs <- coefs[r$coef %in% pars] if (!length(coefs)) { next } regex <- paste0("(", escape_all(coefs), ")", collapse = "|") regex <- paste0(",", regex, "\\]$") rpars <- rpars[grepl(regex, rpars)] } levels <- group_levels[[g]] if (length(rpars)) { # draws of varying coefficients were saved out[[g]] <- as.matrix(object, variable = rpars) dim(out[[g]]) <- c(nrow(out[[g]]), length(levels), length(coefs)) } else { # draws of varying coefficients were not saved out[[g]] <- array(dim = c(ndraws(object), length(levels), length(coefs))) } dimnames(out[[g]])[2:3] <- list(levels, coefs) if (summary) { out[[g]] <- posterior_summary(out[[g]], probs, robust) } } rmNULL(out, recursive = FALSE) } #' Extract Model Coefficients #' #' Extract model coefficients, which are the sum of population-level #' effects and corresponding group-level effects #' #' @inheritParams ranef.brmsfit #' @param ... Further arguments passed to \code{\link{fixef.brmsfit}} #' and \code{\link{ranef.brmsfit}}. #' #' @return A list of 3D arrays (one per grouping factor). #' If \code{summary} is \code{TRUE}, #' the 1st dimension contains the factor levels, #' the 2nd dimension contains the summary statistics #' (see \code{\link{posterior_summary}}), and #' the 3rd dimension contains the group-level effects. #' If \code{summary} is \code{FALSE}, the 1st dimension contains #' the posterior draws, the 2nd dimension contains the factor levels, #' and the 3rd dimension contains the group-level effects. #' #' @examples #' \dontrun{ #' fit <- brm(count ~ zAge + zBase * Trt + (1+Trt|visit), #' data = epilepsy, family = gaussian(), chains = 2) #' ## extract population and group-level coefficients separately #' fixef(fit) #' ranef(fit) #' ## extract combined coefficients #' coef(fit) #' } #' #' @export coef.brmsfit <- function(object, summary = TRUE, robust = FALSE, probs = c(0.025, 0.975), ...) { contains_draws(object) object <- restructure(object) if (!has_rows(object$ranef)) { stop2("No group-level effects detected. Call method ", "'fixef' to access population-level effects.") } fixef <- fixef(object, summary = FALSE, ...) coef <- ranef(object, summary = FALSE, ...) # add missing coefficients to fixef all_ranef_names <- unique(ulapply(coef, function(x) dimnames(x)[[3]])) fixef_names <- colnames(fixef) fixef_no_digits <- get_matches("^[^\\[]+", fixef_names) miss_fixef <- setdiff(all_ranef_names, fixef_names) miss_fixef_no_digits <- get_matches("^[^\\[]+", miss_fixef) new_fixef <- named_list(miss_fixef) for (k in seq_along(miss_fixef)) { # digits occur in ordinal models with category specific effects match_fixef <- match(miss_fixef_no_digits[k], fixef_names) if (!is.na(match_fixef)) { new_fixef[[k]] <- fixef[, match_fixef] } else if (!miss_fixef[k] %in% fixef_no_digits) { new_fixef[[k]] <- 0 } } rm_fixef <- fixef_names %in% miss_fixef_no_digits fixef <- fixef[, !rm_fixef, drop = FALSE] fixef <- do_call(cbind, c(list(fixef), rmNULL(new_fixef))) for (g in names(coef)) { # add missing coefficients to ranef ranef_names <- dimnames(coef[[g]])[[3]] ranef_no_digits <- get_matches("^[^\\[]+", ranef_names) miss_ranef <- setdiff(fixef_names, ranef_names) miss_ranef_no_digits <- get_matches("^[^\\[]+", miss_ranef) new_ranef <- named_list(miss_ranef) for (k in seq_along(miss_ranef)) { # digits occur in ordinal models with category specific effects match_ranef <- match(miss_ranef_no_digits[k], ranef_names) if (!is.na(match_ranef)) { new_ranef[[k]] <- coef[[g]][, , match_ranef] } else if (!miss_ranef[k] %in% ranef_no_digits) { new_ranef[[k]] <- array(0, dim = dim(coef[[g]])[1:2]) } } rm_ranef <- ranef_names %in% miss_ranef_no_digits coef[[g]] <- coef[[g]][, , !rm_ranef, drop = FALSE] coef[[g]] <- abind(c(list(coef[[g]]), rmNULL(new_ranef))) for (nm in dimnames(coef[[g]])[[3]]) { is_ord_intercept <- grepl("(^|_)Intercept\\[[[:digit:]]+\\]$", nm) if (is_ord_intercept) { # correct the sign of thresholds in ordinal models resp <- if (is_mv(object)) get_matches("^[^_]+", nm) family <- family(object, resp = resp)$family if (has_thres_minus_eta(family)) { coef[[g]][, , nm] <- fixef[, nm] - coef[[g]][, , nm] } else if (has_eta_minus_thres(family)) { coef[[g]][, , nm] <- coef[[g]][, , nm] - fixef[, nm] } else { coef[[g]][, , nm] <- fixef[, nm] + coef[[g]][, , nm] } } else { coef[[g]][, , nm] <- fixef[, nm] + coef[[g]][, , nm] } } if (summary) { coef[[g]] <- posterior_summary(coef[[g]], probs, robust) } } coef } #' Extract Variance and Correlation Components #' #' This function calculates the estimated standard deviations, #' correlations and covariances of the group-level terms #' in a multilevel model of class \code{brmsfit}. #' For linear models, the residual standard deviations, #' correlations and covariances are also returned. #' #' @aliases VarCorr #' #' @param x An object of class \code{brmsfit}. #' @inheritParams fixef.brmsfit #' @param sigma Ignored (included for compatibility with #' \code{\link[nlme:VarCorr]{VarCorr}}). #' @param ... Currently ignored. #' #' @return A list of lists (one per grouping factor), each with #' three elements: a matrix containing the standard deviations, #' an array containing the correlation matrix, and an array #' containing the covariance matrix with variances on the diagonal. #' #' @examples #' \dontrun{ #' fit <- brm(count ~ zAge + zBase * Trt + (1+Trt|visit), #' data = epilepsy, family = gaussian(), chains = 2) #' VarCorr(fit) #' } #' #' @method VarCorr brmsfit #' @import abind abind #' @importFrom nlme VarCorr #' @export VarCorr #' @export VarCorr.brmsfit <- function(x, sigma = 1, summary = TRUE, robust = FALSE, probs = c(0.025, 0.975), ...) { contains_draws(x) x <- restructure(x) reframe <- x$ranef if (!(has_rows(reframe) || any(grepl("^sigma($|_)", variables(x))))) { stop2("The model does not contain covariance matrices.") } .VarCorr <- function(y) { # extract draws for sd, cor and cov out <- list(sd = as.matrix(x, variable = y$sd_pars)) colnames(out$sd) <- y$rnames # compute correlation and covariance matrices found_cor_pars <- intersect(y$cor_pars, variables(x)) if (length(found_cor_pars)) { cor <- as.matrix(x, variable = found_cor_pars) if (length(found_cor_pars) < length(y$cor_pars)) { # some correlations are missing and will be replaced by 0 cor_all <- matrix(0, nrow = nrow(cor), ncol = length(y$cor_pars)) names(cor_all) <- y$cor_pars for (i in seq_len(ncol(cor_all))) { found <- match(names(cor_all)[i], colnames(cor)) if (!is.na(found)) { cor_all[, i] <- cor[, found] } } cor <- cor_all } out$cor <- get_cor_matrix(cor = cor) out$cov <- get_cov_matrix(sd = out$sd, cor = cor) dimnames(out$cor)[2:3] <- list(y$rnames, y$rnames) dimnames(out$cov)[2:3] <- list(y$rnames, y$rnames) if (summary) { out$cor <- posterior_summary(out$cor, probs, robust) out$cov <- posterior_summary(out$cov, probs, robust) } } if (summary) { out$sd <- posterior_summary(out$sd, probs, robust) } return(out) } tmp <- list() if (has_rows(reframe)) { get_names <- function(group) { # get names of group-level parameters r <- subset2(reframe, group = group) rnames <- as.vector(get_rnames(r)) cor_type <- paste0("cor_", group) sd_pars <- paste0("sd_", group, "__", rnames) cor_pars <- get_cornames(rnames, cor_type, brackets = FALSE) nlist(rnames, sd_pars, cor_pars) } group <- unique(reframe$group) tmp <- lapply(group, get_names) names(tmp) <- group } # include residual variances in the output as well bterms <- brmsterms(x$formula) if (is.brmsterms(bterms)) { if (simple_sigma(bterms) && !is.mixfamily(x$family)) { tmp_resid <- list(rnames = bterms$resp, sd_pars = "sigma") tmp <- c(tmp, residual__ = list(tmp_resid)) } } else if (is.mvbrmsterms(bterms)) { simple_sigma <- ulapply(bterms$terms, simple_sigma) pred_sigma <- ulapply(bterms$terms, pred_sigma) is_mix <- ulapply(x$family, is.mixfamily) if (any(simple_sigma) && !any(pred_sigma) && !any(is_mix)) { resps <- bterms$responses[simple_sigma] sd_pars <- paste0("sigma_", resps) if (bterms$rescor) { cor_pars <- get_cornames(resps, type = "rescor", brackets = FALSE) } else { cor_pars <- character(0) } tmp_resid <- nlist(rnames = resps, sd_pars, cor_pars) tmp <- c(tmp, residual__ = list(tmp_resid)) } } lapply(tmp, .VarCorr) } #' @export model.frame.brmsfit <- function(formula, ...) { formula$data } #' (Deprecated) Number of Posterior Samples #' #' Extract the number of posterior samples (draws) stored in a fitted Bayesian #' model. Method \code{nsamples} is deprecated. Please use \code{ndraws} #' instead. #' #' @aliases nsamples #' #' @param object An object of class \code{brmsfit}. #' @param subset An optional integer vector defining a subset of samples #' to be considered. #' @param incl_warmup A flag indicating whether to also count warmup / burn-in #' samples. #' @param ... Currently ignored. #' #' @method nsamples brmsfit #' @export #' @export nsamples #' @importFrom rstantools nsamples nsamples.brmsfit <- function(object, subset = NULL, incl_warmup = FALSE, ...) { warning2("'nsamples.brmsfit' is deprecated. Please use 'ndraws' instead.") if (!is(object$fit, "stanfit") || !length(object$fit@sim)) { out <- 0 } else { ntsamples <- object$fit@sim$n_save[1] if (!incl_warmup) { ntsamples <- ntsamples - object$fit@sim$warmup2[1] } ntsamples <- ntsamples * object$fit@sim$chains if (length(subset)) { out <- length(subset) if (out > ntsamples || max(subset) > ntsamples) { stop2("Argument 'subset' is invalid.") } } else { out <- ntsamples } } out } #' @export nobs.brmsfit <- function(object, resp = NULL, ...) { if (is_mv(object) && length(resp)) { resp <- validate_resp(resp, object, multiple = FALSE) bterms <- brmsterms(object$formula$forms[[resp]]) out <- nrow(subset_data(model.frame(object), bterms)) } else { out <- nrow(model.frame(object)) } out } #' Number of Grouping Factor Levels #' #' Extract the number of levels of one or more grouping factors. #' #' @aliases ngrps.brmsfit #' #' @param object An \R object. #' @param ... Currently ignored. #' #' @return A named list containing the number of levels per #' grouping factor. #' #' @export ngrps.brmsfit <- function(object, ...) { object <- restructure(object) reframe <- object$ranef if (!has_rows(reframe)) { return(NULL) } as.list(lengths(get_levels(reframe))) } #' @rdname ngrps.brmsfit #' @export ngrps <- function(object, ...) { UseMethod("ngrps") } #' @export formula.brmsfit <- function(x, ...) { x$formula } #' @export getCall.brmsfit <- function(x, ...) { x$formula } #' Extract Model Family Objects #' #' @inheritParams posterior_predict.brmsfit #' @param ... Currently unused. #' #' @return A \code{brmsfamily} object #' or a list of such objects for multivariate models. #' #' @export family.brmsfit <- function(object, resp = NULL, ...) { resp <- validate_resp(resp, object) if (!is.null(resp)) { # multivariate model family <- from_list(object$formula$forms[resp], "family") if (length(resp) == 1L) { family <- family[[1]] } } else { # univariate model family <- object$formula$family if (is.null(family)) { family <- object$family } } family } #' Expose user-defined \pkg{Stan} functions #' #' Export user-defined \pkg{Stan} function and #' optionally vectorize them. For more details see #' \code{\link[rstan:expose_stan_functions]{expose_stan_functions}}. #' #' @param x An object of class \code{brmsfit}. #' @param vectorize Logical; Indicates if the exposed functions #' should be vectorized via \code{\link{Vectorize}}. #' Defaults to \code{FALSE}. #' @param env Environment where the functions should be made #' available. Defaults to the global environment. #' @param ... Further arguments passed to #' \code{\link[rstan:expose_stan_functions]{expose_stan_functions}}. #' #' @export expose_functions.brmsfit <- function(x, vectorize = FALSE, env = globalenv(), ...) { vectorize <- as_one_logical(vectorize) stanmodel <- compiled_model(x) if (x$backend == "cmdstanr") { if ("expose_functions" %in% names(stanmodel)) { funs <- .expose_functions_cmdstanr( stanmodel, vectorize = vectorize, env = env, ... ) } else { # older versions of cmdstanr cannot export stan functions (#1176) scode <- strsplit(stancode(x), "\n")[[1]] data_line <- grep("^data[ ]+\\{$", scode) scode <- paste0(c(scode[seq_len(data_line - 1)], "\n"), collapse = "\n") stanmodel <- tempfile(fileext = ".stan") cat(scode, file = stanmodel) funs <- .expose_functions_rstan( stanmodel, vectorize = vectorize, env = env, ... ) } } else { funs <- .expose_functions_rstan( stanmodel, vectorize = vectorize, env = env, ... ) } invisible(funs) } # expose stan functions via rstan .expose_functions_rstan <- function(stanmodel, vectorize, env, ...) { fun_env <- new.env() funs <- rstan::expose_stan_functions(stanmodel, env = fun_env, ...) for (i in seq_along(funs)) { FUN <- get(funs[i], pos = fun_env) if (vectorize) { FUN <- Vectorize(FUN) } assign(funs[i], FUN, pos = env) } funs } # expose stan functions via cmdstanr .expose_functions_cmdstanr <- function(stanmodel, vectorize, env, ...) { suppressMessages(stanmodel$expose_functions()) fun_env <- stanmodel$functions funs <- names(fun_env) for (i in seq_along(funs)) { FUN <- get(funs[i], pos = fun_env) # cmdstanr adds some non-functions to the environment if (!is.function(FUN)) { next } if (vectorize) { FUN <- Vectorize(FUN) } assign(funs[i], FUN, pos = env) } funs } #' @rdname expose_functions.brmsfit #' @export expose_functions <- function(x, ...) { UseMethod("expose_functions") } #' Extract Initial Values Used for Each Chain #' #' Extract the initial values used by Stan for each chain. #' This is currently only available if the model was fitted with #' the \code{rstan} backend. #' #' @param x A \code{brmsfit} object. #' @param ... Currently ignored. #' @return The initial values (either user-specified or generated randomly) for #' all chains. This is a list with one component per chain. Each component is #' a named list containing the initial values for each parameter for the #' corresponding chain. #' @export inits.brmsfit <- function(x, ...) { if (x$backend == "rstan") { out <- rstan::get_inits(x$fit) } else { stop2("Retrieving initial values is currently only supported for rstan backend.") } out } #' @rdname inits.brmsfit #' @export inits <- function(x, ...) { UseMethod("inits") } brms/R/projpred.R0000644000176200001440000003544115053305627013403 0ustar liggesusers#' Projection Predictive Variable Selection: Get Reference Model #' #' The \code{get_refmodel.brmsfit} method can be used to create the reference #' model structure which is needed by the \pkg{projpred} package for performing #' a projection predictive variable selection. This method is called #' automatically when performing variable selection via #' \code{\link[projpred:varsel]{varsel}} or #' \code{\link[projpred:cv_varsel]{cv_varsel}}, so you will rarely need to call #' it manually yourself. #' #' @inheritParams posterior_predict.brmsfit #' @param cvfun Optional cross-validation function #' (see \code{\link[projpred:get_refmodel]{get_refmodel}} for details). #' If \code{NULL} (the default), \code{cvfun} is defined internally #' based on \code{\link{kfold.brmsfit}}. #' @param dis Passed to argument \code{dis} of #' \code{\link[projpred:init_refmodel]{init_refmodel}}, but leave this at #' \code{NULL} unless \pkg{projpred} complains about it. #' @param latent See argument \code{latent} of #' \code{\link[projpred:extend_family]{extend_family}}. Setting this to #' \code{TRUE} requires a \pkg{projpred} version >= 2.4.0. #' @param brms_seed A seed used to infer seeds for \code{\link{kfold.brmsfit}} #' and for sampling group-level effects for new levels (in multilevel models). #' If \code{NULL}, then \code{\link{set.seed}} is not called at all. If not #' \code{NULL}, then the pseudorandom number generator (PRNG) state is reset #' (to the state before calling this function) upon exiting this function. #' @param ... Further arguments passed to #' \code{\link[projpred:init_refmodel]{init_refmodel}}. #' #' @details The \code{extract_model_data} function used internally by #' \code{get_refmodel.brmsfit} ignores arguments \code{wrhs} and \code{orhs} #' (a warning is thrown if these are non-\code{NULL}). For example, arguments #' \code{weightsnew} and \code{offsetnew} of #' \code{\link[projpred:proj_linpred]{proj_linpred}}, #' \code{\link[projpred:proj_predict]{proj_predict}}, and #' \code{\link[projpred:predict.refmodel]{predict.refmodel}} are passed to #' \code{wrhs} and \code{orhs}, respectively. #' #' @return A \code{refmodel} object to be used in conjunction with the #' \pkg{projpred} package. #' #' @examples #' \dontrun{ #' # fit a simple model #' fit <- brm(count ~ zAge + zBase * Trt, #' data = epilepsy, family = poisson()) #' summary(fit) #' #' # The following code requires the 'projpred' package to be installed: #' library(projpred) #' #' # perform variable selection without cross-validation #' vs <- varsel(fit) #' summary(vs) #' plot(vs) #' #' # perform variable selection with cross-validation #' cv_vs <- cv_varsel(fit) #' summary(cv_vs) #' plot(cv_vs) #' } #' @exportS3Method projpred::get_refmodel brmsfit get_refmodel.brmsfit <- function(object, newdata = NULL, resp = NULL, cvfun = NULL, dis = NULL, latent = FALSE, brms_seed = NULL, ...) { require_package("projpred") object <- restructure(object) stopifnot_resp(object, resp) resp <- validate_resp(resp, object, multiple = FALSE) formula <- formula(object) if (!is.null(resp)) { formula <- formula$forms[[resp]] } # Infer "sub-seeds": if (exists(".Random.seed", envir = .GlobalEnv)) { rng_state_old <- get(".Random.seed", envir = .GlobalEnv) } if (!is.null(brms_seed)) { if (exists(".Random.seed", envir = .GlobalEnv)) { on.exit(assign(".Random.seed", rng_state_old, envir = .GlobalEnv)) } set.seed(brms_seed) } kfold_seed <- sample.int(.Machine$integer.max, 1) refprd_seed <- sample.int(.Machine$integer.max, 1) # prepare the family object for use in projpred family <- family(object, resp = resp) if (family$family == "bernoulli") { family$family <- "binomial" } else if (family$family == "gamma") { family$family <- "Gamma" } else if (family$family == "beta") { family$family <- "Beta" } aug_data <- (is_categorical(family) || is_ordinal(family)) && !latent # For the augmented-data and the latent approach, do not re-define the family # to preserve family-specific extra arguments ("extra" meaning "additionally # to `link`") like `refcat` and `thresholds` (see ?brmsfamily): if (!aug_data && !latent) { family <- get(family$family, mode = "function")(link = family$link) } # check if the model is supported by projpred bterms <- brmsterms(formula) if (length(bterms$dpars) > 1L && !conv_cats_dpars(family)) { stop2("Projpred does not support distributional models.") } if (conv_cats_dpars(family) && length(formula$pforms)) { stop2("Projpred does not support category-specific formulas.") } if (length(bterms$nlpars) > 0L) { stop2("Projpred does not support non-linear models.") } not_ok_term_types <- setdiff(all_term_types(), c("fe", "re", "offset", "sm")) if (any(not_ok_term_types %in% names(bterms$dpars$mu))) { stop2("Projpred only supports standard multilevel and smoothing terms as ", "well as offsets.") } # only use the raw formula for selection of terms formula <- formula$formula # LHS should only contain the response variable formula[[2]] <- bterms$respform[[2]] # projpred requires the dispersion parameter if present if (is.null(dis) && !latent) { if (family$family == "gaussian") { dis <- paste0("sigma", usc(resp)) dis <- as.data.frame(object, variable = dis)[[dis]] } else if (family$family == "Gamma") { dis <- paste0("shape", usc(resp)) dis <- as.data.frame(object, variable = dis)[[dis]] } } # allows to handle additional arguments implicitly extract_model_data <- function(object, newdata = NULL, ...) { .extract_model_data(object, newdata = newdata, resp = resp, ...) } # The default `ref_predfun` from projpred does not set `allow_new_levels`, so # use a customized `ref_predfun` which also handles some preparations for the # augmented-data projection: ref_predfun <- function(fit, newdata = NULL) { # Setting a seed is necessary for reproducible sampling of group-level # effects for new levels: if (exists(".Random.seed", envir = .GlobalEnv)) { rng_state_old <- get(".Random.seed", envir = .GlobalEnv) on.exit(assign(".Random.seed", rng_state_old, envir = .GlobalEnv)) } set.seed(refprd_seed) lprd_args <- nlist( object = fit, newdata, resp, allow_new_levels = TRUE, sample_new_levels = "gaussian" ) if (is_ordinal(family) && !latent) { c(lprd_args) <- list(incl_thres = TRUE) } out <- do_call(posterior_linpred, lprd_args) if (length(dim(out)) == 2) { out <- t(out) } out } if (utils::packageVersion("projpred") <= "2.0.2" && NROW(object$ranef)) { warning2("In projpred versions <= 2.0.2, projpred's K-fold CV results may ", "not be reproducible for multilevel brms reference models.") } # extract a list of K-fold sub-models if (is.null(cvfun)) { cvfun <- function(folds, ...) { kfold( object, K = max(folds), save_fits = TRUE, folds = folds, seed = kfold_seed, ... )$fits[, "fit"] } } else { if (!is.function(cvfun)) { stop2("'cvfun' should be a function.") } } cvrefbuilder <- function(cvfit) { # For `brms_seed` in fold `cvfit$projpred_k` (= k) of K, choose a new seed # which is based on the original `brms_seed`: if (is.null(brms_seed)) { brms_seed_k <- NULL } else { brms_seed_k <- brms_seed + cvfit$projpred_k } projpred::get_refmodel(cvfit, resp = resp, dis = dis, latent = latent, brms_seed = brms_seed_k, called_from_cvrefbuilder = TRUE, ...) } # prepare data passed to projpred if (!is.null(newdata)) { warning2("Argument 'newdata' of get_refmodel.brmsfit() is deprecated and ", "will be removed in the future.") } data <- current_data( object, newdata, resp = resp, check_response = TRUE, allow_new_levels = TRUE ) attr(data, "terms") <- NULL args <- nlist( object, data, formula, family, dis, ref_predfun, cvfun, extract_model_data, cvrefbuilder, latent, ... ) if (aug_data) { c(args) <- list( augdat_link = get(paste0("link_", family$family), mode = "function"), augdat_ilink = get(paste0("inv_link_", family$family), mode = "function") ) if (is_ordinal(family)) { c(args) <- list( augdat_args_link = list(link = family$link), augdat_args_ilink = list(link = family$link) ) } } else if (latent) { require_package("projpred", "2.4.0") if (family$family == "cumulative") { args$latent_ilink <- latent_ilink_cumulative( object = object, family = family, bterms = bterms, resp = resp ) } # TODO: If requested by users, add response-scale support for more families: # For response-scale support, they all need a specific `latent_ilink` # function; some families (those for which the response can be numeric) also # require specific `latent_ll_oscale` and `latent_ppd_oscale` functions. The # binomial family (and thereby also the brms::bernoulli() family) has # response-scale support implemented natively in projpred. } do_call(projpred::init_refmodel, args) } # auxiliary data required in predictions via projpred # @return a named list with slots 'y', 'weights', and 'offset' .extract_model_data <- function(object, newdata = NULL, resp = NULL, extract_y = TRUE, wrhs = NULL, orhs = NULL, ...) { stopifnot(is.brmsfit(object)) resp <- validate_resp(resp, object, multiple = FALSE) if (utils::packageVersion("projpred") >= "2.8.0") { if (!is.null(wrhs)) warn_wrhs_orhs("wrhs") if (!is.null(orhs)) warn_wrhs_orhs("orhs") } # extract the response variable manually instead of from standata # so that it passes input checks of validate_newdata later on (#1314) formula <- formula(object) if (!is.null(resp)) { formula <- formula$forms[[resp]] } bterms <- brmsterms(formula) y <- NULL if (extract_y) { data <- current_data( object, newdata, resp = resp, check_response = TRUE, allow_new_levels = TRUE, req_vars = all.vars(bterms$respform) ) y <- model.response(model.frame(bterms$respform, data, na.action = na.pass)) y <- unname(y) } # extract relevant auxiliary data (offsets and weights (or numbers of trials)) # call standata to ensure the correct format of the data # For this, we use `check_response = FALSE` and only include offsets and # weights (or numbers of trials) in `req_vars` because of issue #1457 (note # that all.vars(NULL) gives character(0), as desired). req_vars <- unlist(lapply(bterms$dpars, function(x) all.vars(x[["offset"]]))) req_vars <- unique(req_vars) c(req_vars) <- all.vars(bterms$adforms$weights) c(req_vars) <- all.vars(bterms$adforms$trials) args <- nlist( object, newdata, resp, allow_new_levels = TRUE, check_response = FALSE, internal = TRUE, req_vars = req_vars ) # NOTE: Missing weights don't cause an error here (see #1459) sdata <- do_call(standata, args) usc_resp <- usc(resp) N <- sdata[[paste0("N", usc_resp)]] weights <- as.vector(sdata[[paste0("weights", usc_resp)]]) trials <- as.vector(sdata[[paste0("trials", usc_resp)]]) if (is_binary(formula)) { trials <- rep(1, N) } if (!is.null(trials)) { if (!is.null(weights)) { stop2("Projpred cannot handle 'trials' and 'weights' at the same time.") } weights <- trials } if (is.null(weights)) { weights <- rep(1, N) } offset <- as.vector(sdata[[paste0("offsets", usc_resp)]]) if (is.null(offset)) { offset <- rep(0, N) } nlist(y, weights, offset) } # Helper function for throwing a warning if argument `wrhs` or `orhs` is # non-`NULL`. warn_wrhs_orhs <- function(arg_nm) { warning2("Argument `", arg_nm, "` is currently ignored. See section ", "'Details' of `?brms:::get_refmodel.brmsfit` for details.") } # Construct the inverse-link function required for the latent projection in case # of the cumulative family. # # @param object See argument `object` of get_refmodel.brmsfit(), but here, the # `object` as modified inside of get_refmodel.brmsfit() is required. # @param family The `family` object corresponding to `object` (taking `resp` # into account). Could be re-inferred from `object` and `resp`, but for # computational efficiency, this is avoided. # @param bterms The `brmsterms` object corresponding to `object` (or rather # `object`'s `formula`, taking `resp` into account). Could be re-inferred from # `object` and `resp`, but for computational efficiency, this is avoided. # @param resp See argument `resp` of get_refmodel.brmsfit(), but here, the # `resp` as modified inside of get_refmodel.brmsfit() is required. # # @return A function to be supplied to projpred::extend_family()'s argument # `latent_ilink`. latent_ilink_cumulative <- function(object, family, bterms, resp) { stopifnot(!is.null(family$cats)) draws_mat <- as_draws_matrix(object) thres_regex <- paste0("^b", usc(combine_prefix(bterms)), "_Intercept\\[") thres_draws <- prepare_draws(draws_mat, variable = thres_regex, regex = TRUE) if (ncol(thres_draws) > length(family$cats) - 1L) { stop2("Currently, projpred does not support group-specific thresholds ", "(argument `gr` of resp_thres()).") } # Note: Currently, `disc` should always be constantly 1 because # distributional models are not allowed here. disc_regex <- paste0("^", "disc", resp, "$") disc_draws <- prepare_draws(draws_mat, variable = disc_regex, regex = TRUE) out <- function(lpreds, cl_ref, wdraws_ref = rep(1, length(cl_ref))) { thres_agg <- projpred::cl_agg(thres_draws, cl = cl_ref, wdraws = wdraws_ref) disc_agg <- projpred::cl_agg(disc_draws, cl = cl_ref, wdraws = wdraws_ref) disc_agg <- as.vector(disc_agg) lpreds_thres <- apply(thres_agg, 2, function(thres_agg_c) { # Notes on dimensionalities (with S_agg = `nrow(lpreds)`): # * `disc_agg` is a vector of length S_agg (because `disc` is not # predicted here), # * `thres_agg` is S_agg x C_lat (with C_lat = `ncats - 1L` = # `nthres`) and thus `thres_agg_c` is a vector of length S_agg, # * `lpreds` is S_agg x N (with N denoting the number of (possibly # new) observations (not necessarily the original number of # observations)). disc_agg * (thres_agg_c - lpreds) }, simplify = FALSE) # Coerce to an S_agg x N x C_lat array: lpreds_thres <- do.call(abind, c(lpreds_thres, rev.along = 0)) # Transform to response space, yielding an S_agg x N x C_cat array: return(inv_link_cumulative(lpreds_thres, link = family$link)) } # Free up some memory (keeping `draws_mat` would lead to unnecessary memory # usage because `draws_mat` would continue to live in the environment of the # returned function): rm(draws_mat) out } brms/R/stan-predictor.R0000644000176200001440000024620315053305627014514 0ustar liggesusers# unless otherwise specified, functions return a named list # of Stan code snippets to be pasted together later on # generate stan code for predictor terms stan_predictor <- function(x, ...) { UseMethod("stan_predictor") } # combine effects for the predictors of a single (non-linear) parameter # @param ... arguments passed to the underlying effect-specific functions #' @export stan_predictor.bframel <- function(x, ...) { out <- collapse_lists( stan_fe(x, ...), stan_thres(x, ...), stan_sp(x, ...), stan_cs(x, ...), stan_sm(x, ...), stan_gp(x, ...), stan_ac(x, ...), stan_offset(x, ...), stan_bhaz(x, ...) ) out <- stan_special_prior(x, out = out, ...) out <- stan_eta_combine(x, out = out, ...) out } # prepare Stan code for non-linear terms #' @export stan_predictor.bframenl <- function(x, ...) { collapse_lists( stan_nl(x, ...), stan_thres(x, ...), stan_bhaz(x, ...), stan_ac(x, ...) ) } #' @export stan_predictor.brmsframe <- function(x, prior, normalize, ...) { px <- check_prefix(x) resp <- usc(combine_prefix(px)) out <- list() str_add_list(out) <- stan_response(x, normalize = normalize, ...) valid_dpars <- valid_dpars(x) family_files <- family_info(x, "include") if (length(family_files)) { str_add(out$fun) <- cglue(" #include '{family_files}'\n") } args <- nlist(prior, normalize, nlpars = names(x$nlpars), ...) args$primitive <- use_glm_primitive(x) || use_glm_primitive_categorical(x) for (nlp in names(x$nlpars)) { nlp_args <- list(x$nlpars[[nlp]]) str_add_list(out) <- do_call(stan_predictor, c(nlp_args, args)) } for (dp in valid_dpars) { dp_terms <- x$dpars[[dp]] dp_comment <- stan_dpar_comments(dp, family = x$family) if (is.btl(dp_terms) || is.btnl(dp_terms)) { # distributional parameter is predicted str_add_list(out) <- do_call(stan_predictor, c(list(dp_terms), args)) } else if (is.numeric(x$fdpars[[dp]]$value)) { # distributional parameter is fixed to constant if (is_mix_proportion(dp, family = x$family)) { # mixture proportions are handled in 'stan_mixture' next } dp_value <- x$fdpars[[dp]]$value dp_comment <- stan_comment(dp_comment) str_add(out$tpar_def) <- glue( " real {dp}{resp} = {dp_value};{dp_comment}\n" ) str_add(out$pll_args) <- glue(", real {dp}{resp}") } else if (is.character(x$fdpars[[dp]]$value)) { # distributional parameter is fixed to another distributional parameter if (!x$fdpars[[dp]]$value %in% valid_dpars) { stop2("Parameter '", x$fdpars[[dp]]$value, "' cannot be found.") } if (is_mix_proportion(dp, family = x$family)) { stop2("Cannot set mixture proportions to be equal.") } dp_value <- x$fdpars[[dp]]$value dp_comment <- stan_comment(dp_comment) str_add(out$tpar_def) <- glue( " real {dp}{resp};{dp_comment}\n" ) str_add(out$tpar_comp) <- glue( " {dp}{resp} = {dp_value}{resp};\n" ) str_add(out$pll_args) <- glue(", real {dp}{resp}") } else { # distributional parameter is estimated as a scalar if (is_mix_proportion(dp, family = x$family)) { # mixture proportions are handled in 'stan_mixture' next } prefix <- "" if (dp %in% valid_dpars(x, type = "tmp")) { # some parameters are fully computed only after the model is run prefix <- "tmp_" dp_comment <- paste0(dp_comment, " (temporary)") } str_add_list(out) <- stan_prior( prior, dp, prefix = prefix, suffix = resp, header_type = "real", px = px, comment = dp_comment, normalize = normalize ) } } str_add_list(out) <- stan_dpar_transform( x, prior = prior, normalize = normalize, ... ) str_add_list(out) <- stan_mixture( x, prior = prior, normalize = normalize, ... ) out$model_log_lik <- stan_log_lik( x, normalize = normalize, ... ) list(out) } #' @export stan_predictor.mvbrmsframe <- function(x, prior, threads, normalize, ...) { out <- lapply(x$terms, stan_predictor, prior = prior, threads = threads, normalize = normalize, ...) out <- unlist(out, recursive = FALSE) if (!x$rescor) { return(out) } resp_type <- out[[1]]$resp_type out <- collapse_lists(ls = out) out$resp_type <- "vector" adforms <- from_list(x$terms, "adforms") adnames <- unique(ulapply(adforms, names)) adallowed <- c("se", "weights", "mi") if (!all(adnames %in% adallowed)) { stop2("Only ", collapse_comma(adallowed), " are supported ", "addition arguments when 'rescor' is estimated.") } # we already know at this point that all families are identical family <- family_names(x)[1] stopifnot(family %in% c("gaussian", "student")) resp <- x$responses nresp <- length(resp) str_add(out$model_def) <- glue( " // multivariate predictor array\n", " array[N] vector[nresp] Mu;\n" ) str_add(out$model_comp_mvjoin) <- glue( " Mu[n] = {stan_vector(glue('mu_{resp}[n]'))};\n" ) str_add(out$data) <- glue( " int nresp; // number of responses\n", " int nrescor; // number of residual correlations\n" ) str_add(out$pll_args) <- glue(", data int nresp") str_add(out$tdata_def) <- glue( " array[N] vector[nresp] Y; // response array\n" ) str_add(out$tdata_comp) <- glue( " for (n in 1:N) {{\n", " Y[n] = {stan_vector(glue('Y_{resp}[n]'))};\n", " }}\n" ) str_add(out$pll_args) <- ", data array[] vector Y" if (any(adnames %in% "weights")) { str_add(out$tdata_def) <- glue( " // weights of the pointwise log-likelihood\n", " vector[N] weights = weights_{resp[1]};\n" ) str_add(out$pll_args) <- glue(", data vector weights") } miforms <- rmNULL(from_list(adforms, "mi")) if (length(miforms)) { str_add(out$model_no_pll_def) <- " array[N] vector[nresp] Yl = Y;\n" str_add(out$pll_args) <- ", array[] vector Yl" for (i in seq_along(miforms)) { j <- match(names(miforms)[i], resp) # needs to happen outside of reduce_sum # to maintain consistency of indexing Yl str_add(out$model_no_pll_comp_mvjoin) <- glue( " Yl[n][{j}] = Yl_{resp[j]}[n];\n" ) } } str_add_list(out) <- stan_prior( prior, class = "Lrescor", type = "cholesky_factor_corr[nresp]", header_type = "matrix", comment = "parameters for multivariate linear models", normalize = normalize ) if (family == "student") { str_add_list(out) <- stan_prior( prior, class = "nu", header_type = "real", normalize = normalize ) } sigma <- ulapply(x$terms, stan_sigma_transform, threads = threads) if (any(grepl(stan_nn_regex(), sigma))) { str_add(out$model_def) <- " array[N] vector[nresp] sigma;\n" str_add(out$model_comp_mvjoin) <- glue( " sigma[n] = {stan_vector(sigma)};\n" ) if (family == "gaussian") { str_add(out$model_def) <- glue( " // cholesky factor of residual covariance matrix\n", " array[N] matrix[nresp, nresp] LSigma;\n" ) str_add(out$model_comp_mvjoin) <- glue( " LSigma[n] = diag_pre_multiply(sigma[n], Lrescor);\n" ) } else if (family == "student") { str_add(out$model_def) <- glue( " // residual covariance matrix\n", " array[N] matrix[nresp, nresp] Sigma;\n" ) str_add(out$model_comp_mvjoin) <- glue( " Sigma[n] = multiply_lower_tri_self_transpose(", "diag_pre_multiply(sigma[n], Lrescor));\n" ) } } else { str_add(out$model_def) <- glue( " vector[nresp] sigma = {stan_vector(sigma)};\n" ) if (family == "gaussian") { str_add(out$model_def) <- glue( " // cholesky factor of residual covariance matrix\n", " matrix[nresp, nresp] LSigma = ", "diag_pre_multiply(sigma, Lrescor);\n" ) } else if (family == "student") { str_add(out$model_def) <- glue( " // residual covariance matrix\n", " matrix[nresp, nresp] Sigma = ", "multiply_lower_tri_self_transpose(", "diag_pre_multiply(sigma, Lrescor));\n" ) } } str_add(out$gen_def) <- glue( " // residual correlations\n", " corr_matrix[nresp] Rescor", " = multiply_lower_tri_self_transpose(Lrescor);\n", " vector[nrescor] rescor;\n" ) str_add(out$gen_comp) <- stan_cor_gen_comp("rescor", "nresp") out$model_comp_mvjoin <- paste0( " // combine univariate parameters\n", " for (n in 1:N) {\n", stan_nn_def(threads), out$model_comp_mvjoin, " }\n" ) if (isTRUE(nzchar(out$model_no_pll_comp_mvjoin))) { out$model_no_pll_comp_mvjoin <- paste0( " // combine univariate parameters\n", " for (n in 1:N) {\n", out$model_no_pll_comp_mvjoin, " }\n" ) } out$model_log_lik <- stan_log_lik( x, threads = threads, normalize = normalize, ... ) list(out) } # Stan code for population-level effects stan_fe <- function(bframe, prior, stanvars, threads, primitive, normalize, ...) { stopifnot(is.bframel(bframe)) out <- list() family <- bframe$family fixef <- bframe$frame$fe$vars_stan sparse <- bframe$frame$fe$sparse decomp <- bframe$frame$fe$decomp center <- bframe$frame$fe$center ct <- str_if(center, "c") px <- check_prefix(bframe) p <- usc(combine_prefix(px)) resp <- usc(px$resp) lpdf <- stan_lpdf_name(normalize) if (length(fixef)) { str_add(out$data) <- glue( " int K{p};", " // number of population-level effects\n", " matrix[N{resp}, K{p}] X{p};", " // population-level design matrix\n" ) if (decomp == "none") { str_add(out$pll_args) <- glue(", data matrix X{ct}{p}") } if (sparse) { if (decomp != "none") { stop2("Cannot use ", decomp, " decomposition for sparse matrices.") } if (use_threading(threads)) { stop2("Cannot use threading and sparse matrices at the same time.") } str_add(out$tdata_def) <- glue( " // sparse matrix representation of X{p}\n", " vector[rows(csr_extract_w(X{p}))] wX{p}", " = csr_extract_w(X{p});\n", " int vX{p}[size(csr_extract_v(X{p}))]", " = csr_extract_v(X{p});\n", " int uX{p}[size(csr_extract_u(X{p}))]", " = csr_extract_u(X{p});\n" ) } # prepare population-level coefficients b_type <- glue("vector[K{ct}{p}]") has_special_prior <- has_special_prior(prior, bframe, class = "b") if (decomp == "none") { if (has_special_prior) { str_add_list(out) <- stan_prior_non_centered( suffix = p, suffix_K = ct, normalize = normalize ) } else { str_add_list(out) <- stan_prior( prior, class = "b", coef = fixef, type = b_type, px = px, suffix = p, header_type = "vector", comment = "regression coefficients", normalize = normalize ) } } else { stopifnot(decomp == "QR") stopif_prior_bound(prior, class = "b", ls = px) if (has_special_prior) { str_add_list(out) <- stan_prior_non_centered( suffix = p, suffix_class = "Q", suffix_K = ct, normalize = normalize ) } else { str_add_list(out) <- stan_prior( prior, class = "b", coef = fixef, type = b_type, px = px, suffix = glue("Q{p}"), header_type = "vector", comment = "regression coefficients on QR scale", normalize = normalize ) } str_add(out$gen_def) <- glue( " // obtain the actual coefficients\n", " vector[K{ct}{p}] b{p} = XR{p}_inv * bQ{p};\n" ) } } order_intercepts <- order_intercepts(bframe) if (order_intercepts && !center) { stop2( "Identifying mixture components via ordering requires ", "population-level intercepts to be present.\n", "Try setting order = 'none' in function 'mixture'." ) } if (center) { # centering the design matrix improves convergence sub_X_means <- "" if (length(fixef)) { str_add(out$data) <- glue( " int Kc{p};", " // number of population-level effects after centering\n" ) sub_X_means <- glue(" - dot_product(means_X{p}, b{p})") if (is_ordinal(family)) { str_add(out$tdata_def) <- glue( " matrix[N{resp}, Kc{p}] Xc{p};", " // centered version of X{p}\n", " vector[Kc{p}] means_X{p};", " // column means of X{p} before centering\n" ) str_add(out$tdata_comp) <- glue( " for (i in 1:K{p}) {{\n", " means_X{p}[i] = mean(X{p}[, i]);\n", " Xc{p}[, i] = X{p}[, i] - means_X{p}[i];\n", " }}\n" ) } else { str_add(out$tdata_def) <- glue( " matrix[N{resp}, Kc{p}] Xc{p};", " // centered version of X{p} without an intercept\n", " vector[Kc{p}] means_X{p};", " // column means of X{p} before centering\n" ) str_add(out$tdata_comp) <- glue( " for (i in 2:K{p}) {{\n", " means_X{p}[i - 1] = mean(X{p}[, i]);\n", " Xc{p}[, i - 1] = X{p}[, i] - means_X{p}[i - 1];\n", " }}\n" ) } } if (!is_ordinal(family)) { # intercepts of ordinal models are handled in 'stan_thres' intercept_type <- "real" if (order_intercepts) { # identify mixtures via ordering of the intercepts dp_id <- dpar_id(px$dpar) str_add(out$tpar_def) <- glue( " // identify mixtures via ordering of the intercepts\n", " real Intercept{p} = ordered_Intercept{resp}[{dp_id}];\n" ) str_add(out$pll_args) <- glue(", real Intercept{p}") # intercept parameter needs to be defined outside of 'stan_prior' intercept_type <- "" } str_add(out$eta) <- glue(" + Intercept{p}") str_add(out$gen_def) <- glue( " // actual population-level intercept\n", " real b{p}_Intercept = Intercept{p}{sub_X_means};\n" ) str_add_list(out) <- stan_prior( prior, class = "Intercept", type = intercept_type, suffix = p, px = px, header_type = "real", comment = "temporary intercept for centered predictors", normalize = normalize ) } } if (decomp == "QR") { if (!length(fixef)) { stop2("QR decomposition requires non-intercept predictors.") } str_add(out$tdata_def) <- glue( " // matrices for QR decomposition\n", " matrix[N{resp}, K{ct}{p}] XQ{p};\n", " matrix[K{ct}{p}, K{ct}{p}] XR{p};\n", " matrix[K{ct}{p}, K{ct}{p}] XR{p}_inv;\n" ) str_add(out$tdata_comp) <- glue( " // compute and scale QR decomposition\n", " XQ{p} = qr_thin_Q(X{ct}{p}) * sqrt(N{resp} - 1);\n", " XR{p} = qr_thin_R(X{ct}{p}) / sqrt(N{resp} - 1);\n", " XR{p}_inv = inverse(XR{p});\n" ) str_add(out$pll_args) <- glue(", data matrix XQ{p}") } if (length(fixef) && !primitive) { # added in the end such that the intercept comes first in out$eta if (sparse) { stopifnot(!center && decomp == "none") csr_args <- sargs( paste0(c("rows", "cols"), "(X", p, ")"), paste0(c("wX", "vX", "uX", "b"), p) ) eta_fe <- glue(" + csr_matrix_times_vector({csr_args})") } else { sfx_X <- sfx_b <- "" if (decomp == "QR") { sfx_X <- sfx_b <- "Q" } else if (center) { sfx_X <- "c" } slice <- stan_slice(threads) eta_fe <- glue(" + X{sfx_X}{p}{slice} * b{sfx_b}{p}") } str_add(out$eta) <- eta_fe } out } # Stan code for group-level effects stan_re <- function(bframe, prior, normalize, ...) { lpdf <- ifelse(normalize, "lpdf", "lupdf") reframe <- bframe$frame$re stopifnot(is.reframe(reframe)) IDs <- unique(reframe$id) out <- list() # special handling of student-t group effects as their 'df' parameters # are defined on a per-group basis instead of a per-ID basis reframe_t <- subset_reframe_dist(reframe, "student") if (has_rows(reframe_t)) { str_add(out$par) <- " // parameters for student-t distributed group-level effects\n" for (i in seq_rows(reframe_t)) { g <- usc(reframe_t$ggn[i]) id <- reframe_t$id[i] str_add_list(out) <- stan_prior( prior, class = "df", group = reframe_t$group[i], suffix = g, normalize = normalize ) str_add(out$par) <- glue( " vector[N_{id}] udf{g};\n" ) str_add(out$model_prior) <- glue( " target += inv_chi_square_{lpdf}(udf{g} | df{g});\n" ) # separate definition from computation to support fixed parameters str_add(out$tpar_def) <- glue( " vector[N_{id}] dfm{g};\n" ) str_add(out$tpar_comp) <- glue( " dfm{g} = sqrt(df{g} * udf{g});\n" ) } } # the ID syntax requires group-level effects to be evaluated separately tmp <- lapply( IDs, .stan_re, bframe = bframe, prior = prior, normalize = normalize, ... ) out <- collapse_lists(ls = c(list(out), tmp)) out } # Stan code for group-level effects per ID # @param id the ID of the grouping factor .stan_re <- function(id, bframe, prior, threads, normalize, ...) { lpdf <- ifelse(normalize, "lpdf", "lupdf") out <- list() r <- subset2(bframe$frame$re, id = id) stopifnot(is.reframe(r)) has_cov <- nzchar(r$cov[1]) has_by <- nzchar(r$by[[1]]) has_pw <- isTRUE(nzchar(r$gcall[[1]]$pw)) Nby <- seq_along(r$bylevels[[1]]) ng <- seq_along(r$gcall[[1]]$groups) px <- check_prefix(r) uresp <- usc(unique(px$resp)) idp <- paste0(r$id, usc(combine_prefix(px))) # define data needed for group-level effects str_add(out$data) <- glue( " // data for group-level effects of ID {id}\n", " int N_{id}; // number of grouping levels\n", " int M_{id}; // number of coefficients per level\n" ) if (r$gtype[1] == "mm") { for (res in uresp) { str_add(out$data) <- cglue( " array[N{res}] int J_{id}{res}_{ng};", " // grouping indicator per observation\n", " array[N{res}] real W_{id}{res}_{ng};", " // multi-membership weights\n" ) str_add(out$pll_args) <- cglue( ", data array[] int J_{id}{res}_{ng}, data array[] real W_{id}{res}_{ng}" ) } } else { str_add(out$data) <- cglue( " array[N{uresp}] int J_{id}{uresp};", " // grouping indicator per observation\n" ) str_add(out$pll_args) <- cglue( ", data array[] int J_{id}{uresp}" ) } if (has_by) { str_add(out$data) <- glue( " int Nby_{id}; // number of by-factor levels\n", " array[N_{id}] int Jby_{id};", " // by-factor indicator per observation\n" ) } if (has_cov) { str_add(out$data) <- glue( " matrix[N_{id}, N_{id}] Lcov_{id};", " // cholesky factor of known covariance matrix\n" ) } if (has_pw) { str_add(out$data) <- glue( " vector[N_{id}] PW_{id};", " // weights for group contribution to the prior\n" ) } J <- seq_rows(r) reqZ <- !r$type %in% "sp" if (any(reqZ)) { str_add(out$data) <- " // group-level predictor values\n" if (r$gtype[1] == "mm") { for (i in which(reqZ)) { str_add(out$data) <- cglue( " vector[N{usc(r$resp[i])}] Z_{idp[i]}_{r$cn[i]}_{ng};\n" ) str_add(out$pll_args) <- cglue( ", data vector Z_{idp[i]}_{r$cn[i]}_{ng}" ) } } else { str_add(out$data) <- cglue( " vector[N{usc(r$resp[reqZ])}] Z_{idp[reqZ]}_{r$cn[reqZ]};\n" ) str_add(out$pll_args) <- cglue( ", data vector Z_{idp[reqZ]}_{r$cn[reqZ]}" ) } } # define standard deviation parameters has_special_prior <- has_special_prior(prior, px, class = "sd") if (has_by) { if (has_special_prior) { stop2("Special priors on class 'sd' are not yet compatible ", "with the 'by' argument.") } str_add_list(out) <- stan_prior( prior, class = "sd", group = r$group[1], coef = r$coef, type = glue("matrix[M_{id}, Nby_{id}]"), coef_type = glue("row_vector[Nby_{id}]"), suffix = glue("_{id}"), px = px, broadcast = "matrix", comment = "group-level standard deviations", normalize = normalize ) } else { if (has_special_prior) { if (stan_has_multiple_base_priors(px)) { stop2("Special priors on class 'sd' are not yet compatible with ", "group-level coefficients correlated across formulas.") } str_add(out$tpar_def) <- glue( " vector[M_{id}] sd_{id}; // group-level standard deviations\n" ) } else { str_add_list(out) <- stan_prior( prior, class = "sd", group = r$group[1], coef = r$coef, type = glue("vector[M_{id}]"), suffix = glue("_{id}"), px = px, comment = "group-level standard deviations", normalize = normalize ) } } # define group-level coefficients dfm <- "" tr <- subset_reframe_dist(r, "student") if (nrow(r) > 1L && r$cor[1]) { # multiple correlated group-level effects str_add(out$data) <- glue( " int NC_{id}; // number of group-level correlations\n" ) str_add(out$par) <- glue( " matrix[M_{id}, N_{id}] z_{id};", " // standardized group-level effects\n" ) if (has_pw) { str_add(out$model_prior) <- glue( " for (j in 1:N_{id}) {{\n", " target += PW_{id}[j] * std_normal_{lpdf}(z_{id}[, j]);\n", " }\n" ) } else { str_add(out$model_prior) <- glue( " target += std_normal_{lpdf}(to_vector(z_{id}));\n" ) } if (has_rows(tr)) { dfm <- glue("rep_matrix(dfm_{tr$ggn[1]}, M_{id}) .* ") } if (has_by) { str_add_list(out) <- stan_prior( prior, class = "L", group = r$group[1], coef = Nby, type = glue("cholesky_factor_corr[M_{id}]"), coef_type = glue("cholesky_factor_corr[M_{id}]"), suffix = glue("_{id}"), dim = glue("[Nby_{id}]"), comment = "cholesky factor of correlation matrix", normalize = normalize ) # separate definition from computation to support fixed parameters str_add(out$tpar_def) <- glue( " matrix[N_{id}, M_{id}] r_{id}; // actual group-level effects\n" ) if (has_cov) { str_add(out$fun) <- " #include 'fun_scale_r_cor_by_cov.stan'\n" rdef <- glue( "scale_r_cor_by_cov(z_{id}, sd_{id}, L_{id}, Jby_{id}, Lcov_{id})" ) } else { str_add(out$fun) <- " #include 'fun_scale_r_cor_by.stan'\n" rdef <- glue("scale_r_cor_by(z_{id}, sd_{id}, L_{id}, Jby_{id})") } str_add(out$tpar_comp) <- glue( " // compute actual group-level effects\n", " r_{id} = {dfm}{rdef};\n" ) str_add(out$gen_def) <- cglue( " // compute group-level correlations\n", " corr_matrix[M_{id}] Cor_{id}_{Nby}", " = multiply_lower_tri_self_transpose(L_{id}[{Nby}]);\n", " vector[NC_{id}] cor_{id}_{Nby};\n" ) str_add(out$gen_comp) <- stan_cor_gen_comp( glue("cor_{id}_{Nby}"), glue("M_{id}") ) } else { str_add_list(out) <- stan_prior( prior, class = "L", group = r$group[1], suffix = usc(id), type = glue("cholesky_factor_corr[M_{id}]"), comment = "cholesky factor of correlation matrix", normalize = normalize ) if (has_cov) { str_add(out$fun) <- " #include 'fun_scale_r_cor_cov.stan'\n" rdef <- glue("scale_r_cor_cov(z_{id}, sd_{id}, L_{id}, Lcov_{id})") } else { str_add(out$fun) <- " #include 'fun_scale_r_cor.stan'\n" rdef <- glue("scale_r_cor(z_{id}, sd_{id}, L_{id})") } # separate definition from computation to support fixed parameters str_add(out$tpar_def) <- glue( " matrix[N_{id}, M_{id}] r_{id}; // actual group-level effects\n" ) str_add(out$tpar_comp) <- glue( " // compute actual group-level effects\n", " r_{id} = {dfm}{rdef};\n" ) str_add(out$gen_def) <- glue( " // compute group-level correlations\n", " corr_matrix[M_{id}] Cor_{id}", " = multiply_lower_tri_self_transpose(L_{id});\n", " vector[NC_{id}] cor_{id};\n" ) str_add(out$gen_comp) <- stan_cor_gen_comp( cor = glue("cor_{id}"), ncol = glue("M_{id}") ) } # separate definition from computation to support fixed parameters str_add(out$tpar_def) <- " // using vectors speeds up indexing in loops\n" str_add(out$tpar_def) <- cglue( " vector[N_{id}] r_{idp}_{r$cn};\n" ) str_add(out$tpar_comp) <- cglue( " r_{idp}_{r$cn} = r_{id}[, {J}];\n" ) str_add(out$pll_args) <- cglue( ", vector r_{idp}_{r$cn}" ) } else { # single or uncorrelated group-level effects str_add(out$par) <- glue( " array[M_{id}] vector[N_{id}] z_{id};", " // standardized group-level effects\n" ) if (has_pw) { str_add(out$model_prior) <- glue( " for (j in 1:N_{id}) {{\n", cglue(" target += PW_{id}[j] * std_normal_{lpdf}(z_{id}[{seq_rows(r)}, j]);\n"), " }\n" ) } else { str_add(out$model_prior) <- cglue( " target += std_normal_{lpdf}(z_{id}[{seq_rows(r)}]);\n" ) } Lcov <- str_if(has_cov, glue("Lcov_{id} * ")) if (has_rows(tr)) { dfm <- glue("dfm_{tr$ggn[1]} .* ") } if (has_by) { # separate definition from computation to support fixed parameters str_add(out$tpar_def) <- cglue( " vector[N_{id}] r_{idp}_{r$cn}; // actual group-level effects\n" ) str_add(out$tpar_comp) <- cglue( " r_{idp}_{r$cn} = {dfm}(transpose(sd_{id}[{J}, Jby_{id}])", " .* ({Lcov}z_{id}[{J}]));\n" ) } else { # separate definition from computation to support fixed parameters str_add(out$tpar_def) <- cglue( " vector[N_{id}] r_{idp}_{r$cn}; // actual group-level effects\n" ) str_add(out$tpar_comp) <- cglue( " r_{idp}_{r$cn} = {dfm}(sd_{id}[{J}] * ({Lcov}z_{id}[{J}]));\n" ) } str_add(out$pll_args) <- cglue( ", vector r_{idp}_{r$cn}" ) } out } # Stan code of smooth terms stan_sm <- function(bframe, prior, threads, normalize, ...) { stopifnot(is.bframel(bframe)) lpdf <- ifelse(normalize, "lpdf", "lupdf") out <- list() smframe <- bframe$frame$sm if (!has_rows(smframe)) { return(out) } px <- check_prefix(bframe) p <- usc(combine_prefix(px)) resp <- usc(px$resp) slice <- stan_slice(threads) Xs_names <- attr(smframe, "Xs_names") if (length(Xs_names)) { str_add(out$data) <- glue( " // data for splines\n", " int Ks{p}; // number of linear effects\n", " matrix[N{resp}, Ks{p}] Xs{p};", " // design matrix for the linear effects\n" ) str_add(out$pll_args) <- glue(", data matrix Xs{p}") if (has_special_prior(prior, px, class = "b")) { str_add_list(out) <- stan_prior_non_centered( suffix = glue("s{p}"), normalize = normalize ) } else { str_add_list(out) <- stan_prior( prior, class = "b", coef = Xs_names, type = glue("vector[Ks{p}]"), suffix = glue("s{p}"), header_type = "vector", px = px, comment = "unpenalized spline coefficients", normalize = normalize ) } str_add(out$eta) <- glue(" + Xs{p}{slice} * bs{p}") } for (i in seq_rows(smframe)) { if (smframe$nbases[[i]] == 0) { next # no penalized spline components present } pi <- glue("{p}_{i}") nb <- seq_len(smframe$nbases[[i]]) str_add(out$data) <- glue( " // data for spline {i}\n", " int nb{pi}; // number of bases\n", " array[nb{pi}] int knots{pi}; // number of knots\n" ) str_add(out$data) <- " // basis function matrices\n" str_add(out$data) <- cglue( " matrix[N{resp}, knots{pi}[{nb}]] Zs{pi}_{nb};\n" ) str_add(out$pll_args) <- cglue(", data matrix Zs{pi}_{nb}") str_add(out$par) <- glue( " // parameters for spline {i}\n" ) str_add(out$par) <- cglue( " // standardized penalized spline coefficients\n", " vector[knots{pi}[{nb}]] zs{pi}_{nb};\n" ) if (has_special_prior(prior, px, class = "sds")) { str_add(out$tpar_def) <- glue( " // SDs of penalized spline coefficients\n", " vector[nb{pi}] sds{pi};\n" ) str_add(out$prior_global_scales) <- glue(" sds{pi}") str_add(out$prior_global_lengths) <- glue(" nb{pi}") } else { str_add_list(out) <- stan_prior( prior, class = "sds", coef = smframe$term[i], suffix = pi, px = px, type = glue("vector[nb{pi}]"), coef_type = glue("vector[nb{pi}]"), comment = "SDs of penalized spline coefficients", normalize = normalize ) } # separate definition from computation to support fixed parameters str_add(out$tpar_def) <- cglue( " // penalized spline coefficients\n", " vector[knots{pi}[{nb}]] s{pi}_{nb};\n" ) str_add(out$tpar_special_prior) <- cglue( " // compute penalized spline coefficients\n", " s{pi}_{nb} = sds{pi}[{nb}] * zs{pi}_{nb};\n" ) str_add(out$pll_args) <- cglue(", vector s{pi}_{nb}") str_add(out$model_prior) <- cglue( " target += std_normal_{lpdf}(zs{pi}_{nb});\n" ) str_add(out$eta) <- cglue( " + Zs{pi}_{nb}{slice} * s{pi}_{nb}" ) } out } # Stan code for category specific effects # @note not implemented for non-linear models stan_cs <- function(bframe, prior, threads, normalize, ...) { stopifnot(is.bframel(bframe)) out <- list() csef <- bframe$frame$cs$vars px <- check_prefix(bframe) p <- usc(combine_prefix(px)) resp <- usc(bframe$resp) slice <- stan_slice(threads) reframe <- subset2(bframe$frame$re, type = "cs") if (length(csef)) { str_add(out$data) <- glue( " int Kcs{p}; // number of category specific effects\n", " matrix[N{resp}, Kcs{p}] Xcs{p}; // category specific design matrix\n" ) str_add(out$pll_args) <- glue(", data matrix Xcs{p}") str_add_list(out) <- stan_prior( prior, class = "b", coef = csef, type = glue("matrix[Kcs{p}, nthres{resp}]"), coef_type = glue("row_vector[nthres{resp}]"), suffix = glue("cs{p}"), px = px, broadcast = "matrix", header_type = "matrix", comment = "category specific effects", normalize = normalize ) str_add(out$model_def) <- glue( " // linear predictor for category specific effects\n", " matrix[N{resp}, nthres{resp}] mucs{p} = Xcs{p}{slice} * bcs{p};\n" ) } if (has_rows(reframe)) { if (!length(csef)) { # only group-level category specific effects present str_add(out$model_def) <- glue( " // linear predictor for category specific effects\n", " matrix[N{resp}, nthres{resp}] mucs{p}", " = rep_matrix(0, N{resp}, nthres{resp});\n" ) } n <- stan_nn(threads) thres_regex <- "(?<=\\[)[[:digit:]]+(?=\\]$)" thres <- get_matches(thres_regex, reframe$coef, perl = TRUE) nthres <- max(as.numeric(thres)) mucs_loop <- "" for (i in seq_len(nthres)) { r_cat <- reframe[grepl(glue("\\[{i}\\]$"), reframe$coef), ] str_add(mucs_loop) <- glue( " mucs{p}[n, {i}] = mucs{p}[n, {i}]" ) for (id in unique(r_cat$id)) { r <- r_cat[r_cat$id == id, ] rpx <- check_prefix(r) idp <- paste0(r$id, usc(combine_prefix(rpx))) idresp <- paste0(r$id, usc(rpx$resp)) str_add(mucs_loop) <- cglue( " + r_{idp}_{r$cn}[J_{idresp}{n}] * Z_{idp}_{r$cn}{n}" ) } str_add(mucs_loop) <- ";\n" } str_add(out$model_comp_eta_loop) <- glue( " for (n in 1:N{resp}) {{\n", stan_nn_def(threads), mucs_loop, " }\n" ) } out } # Stan code for special effects stan_sp <- function(bframe, prior, stanvars, threads, normalize, ...) { stopifnot(is.bframel(bframe)) out <- list() spframe <- bframe$frame$sp reframe <- bframe$frame$re meframe <- bframe$frame$me if (!has_rows(spframe)) { return(out) } px <- check_prefix(bframe) p <- usc(combine_prefix(px)) resp <- usc(px$resp) lpdf <- stan_lpdf_name(normalize) n <- stan_nn(threads) reframe <- subset2(reframe, type = "sp") spframe_coef <- rename(spframe$term) invalid_coef <- setdiff(reframe$coef, spframe_coef) if (length(invalid_coef)) { stop2( "Special group-level terms require corresponding ", "population-level terms:\nOccured for ", collapse_comma(invalid_coef) ) } # prepare Stan code of the linear predictor component for (i in seq_rows(spframe)) { eta <- spframe$joint_call[[i]] if (!is.null(spframe$calls_mo[[i]])) { new_mo <- glue("mo(simo{p}_{spframe$Imo[[i]]}, Xmo{p}_{spframe$Imo[[i]]}{n})") eta <- rename(eta, spframe$calls_mo[[i]], new_mo) } if (!is.null(spframe$calls_me[[i]])) { Kme <- seq_along(meframe$term) Ime <- match(meframe$grname, unique(meframe$grname)) nme <- ifelse(nzchar(meframe$grname), glue("[Jme_{Ime}{n}]"), n) new_me <- glue("Xme_{Kme}{nme}") eta <- rename(eta, meframe$term, new_me) } if (!is.null(spframe$calls_mi[[i]])) { is_na_idx <- is.na(spframe$idx2_mi[[i]]) idx_mi <- glue("[idxl{p}_{spframe$vars_mi[[i]]}_{spframe$idx2_mi[[i]]}{n}]") idx_mi <- ifelse(is_na_idx, n, idx_mi) new_mi <- glue("Yl_{spframe$vars_mi[[i]]}{idx_mi}") eta <- rename(eta, spframe$calls_mi[[i]], new_mi) str_add(out$pll_args) <- glue(", vector Yl_{spframe$vars_mi[[i]]}") } if (spframe$Ic[i] > 0) { str_add(eta) <- glue(" * Csp{p}_{spframe$Ic[i]}{n}") } r <- subset2(reframe, coef = spframe_coef[i]) rpars <- str_if(nrow(r), cglue(" + {stan_eta_rsp(r, threads)}")) str_add(out$loopeta) <- glue(" + (bsp{p}[{i}]{rpars}) * {eta}") } # prepare general Stan code ncovars <- max(spframe$Ic) str_add(out$data) <- glue( " int Ksp{p}; // number of special effects terms\n" ) if (ncovars > 0L) { str_add(out$data) <- " // covariates of special effects terms\n" str_add(out$data) <- cglue( " vector[N{resp}] Csp{p}_{seq_len(ncovars)};\n" ) str_add(out$pll_args) <- cglue(", data vector Csp{p}_{seq_len(ncovars)}") } # include special Stan code for monotonic effects which_Imo <- which(lengths(spframe$Imo) > 0) if (any(which_Imo)) { str_add(out$fun) <- " #include 'fun_monotonic.stan'\n" str_add(out$data) <- glue( " int Imo{p}; // number of monotonic variables\n", " array[Imo{p}] int Jmo{p}; // length of simplexes\n" ) ids <- unlist(spframe$ids_mo) lpdf <- stan_lpdf_name(normalize) for (i in which_Imo) { for (k in seq_along(spframe$Imo[[i]])) { j <- spframe$Imo[[i]][[k]] id <- spframe$ids_mo[[i]][[k]] # index of first ID appearance j_id <- match(id, ids) str_add(out$data) <- glue( " array[N{resp}] int Xmo{p}_{j}; // monotonic variable\n" ) str_add(out$pll_args) <- glue( ", array[] int Xmo{p}_{j}, vector simo{p}_{j}" ) if (is.na(id) || j_id == j) { # no ID or first appearance of the ID str_add(out$data) <- glue( " vector[Jmo{p}[{j}]] con_simo{p}_{j};", " // prior concentration of monotonic simplex\n" ) str_add(out$par) <- glue( " simplex[Jmo{p}[{j}]] simo{p}_{j}; // monotonic simplex\n" ) str_add(out$tpar_prior) <- glue( " lprior += dirichlet_{lpdf}(simo{p}_{j} | con_simo{p}_{j});\n" ) } else { # use the simplex shared across all terms of the same ID str_add(out$tpar_def) <- glue( " simplex[Jmo{p}[{j}]] simo{p}_{j} = simo{p}_{j_id};\n" ) } } } } # include special Stan code for missing value terms uni_mi <- na.omit(attr(spframe, "uni_mi")) for (j in seq_rows(uni_mi)) { idxl <- glue("idxl{p}_{uni_mi$var[j]}_{uni_mi$idx2[j]}") str_add(out$data) <- glue( " array[N{resp}] int {idxl}; // matching indices\n" ) str_add(out$pll_args) <- glue(", data array[] int {idxl}") } # prepare special effects coefficients if (has_special_prior(prior, bframe, class = "b")) { stopif_prior_bound(prior, class = "b", ls = px) str_add_list(out) <- stan_prior_non_centered( suffix = glue("sp{p}"), normalize = normalize ) } else { str_add_list(out) <- stan_prior( prior, class = "b", coef = spframe$coef, type = glue("vector[Ksp{p}]"), px = px, suffix = glue("sp{p}"), header_type = "vector", comment = "special effects coefficients", normalize = normalize ) } out } # Stan code for latent gaussian processes stan_gp <- function(bframe, prior, threads, normalize, ...) { stopifnot(is.bframel(bframe)) lpdf <- stan_lpdf_name(normalize) out <- list() px <- check_prefix(bframe) p <- usc(combine_prefix(px)) resp <- usc(px$resp) slice <- stan_slice(threads) gpframe <- bframe$frame$gp # kernel methods cannot simply be split up into partial sums for (i in seq_rows(gpframe)) { pi <- glue("{p}_{i}") byvar <- gpframe$byvars[[i]] cons <- gpframe$cons[[i]] byfac <- length(cons) > 0L bynum <- !is.null(byvar) && !byfac k <- gpframe$k[i] is_approx <- !isNA(k) iso <- gpframe$iso[i] gr <- gpframe$gr[i] cov <- gpframe$cov[i] gp <- glue("gp_{cov}") sfx1 <- gpframe$sfx1[[i]] sfx2 <- gpframe$sfx2[[i]] str_add(out$data) <- glue( " // data related to GPs\n", " int Kgp{pi};", " // number of sub-GPs (equal to 1 unless 'by' was used)\n", " int Dgp{pi}; // GP dimension\n" ) if (is_approx) { str_add(out$fun) <- glue(" #include 'fun_spd_gp_{cov}.stan'\n") str_add(out$data) <- glue( " // number of basis functions of an approximate GP\n", " int NBgp{pi};\n" ) } else { str_add(out$fun) <- glue(" #include 'fun_gp_{cov}.stan'\n") } if (has_special_prior(prior, px, class = "sdgp")) { str_add(out$tpar_def) <- glue( " vector[Kgp{pi}] sdgp{pi}; // GP standard deviation parameters\n" ) str_add(out$prior_global_scales) <- glue(" sdgp{pi}") str_add(out$prior_global_lengths) <- glue(" Kgp{pi}") } else { str_add_list(out) <- stan_prior( prior, class = "sdgp", coef = sfx1, px = px, suffix = pi, type = glue("vector[Kgp{pi}]"), coef_type = glue("vector[Kgp{pi}]"), comment = "GP standard deviation parameters", normalize = normalize ) } if (gpframe$iso[i]) { lscale_type <- "vector[1]" lscale_dim <- glue("[Kgp{pi}]") lscale_comment <- "GP length-scale parameters" } else { lscale_type <- glue("vector[Dgp{pi}]") lscale_dim <- glue("[Kgp{pi}]") lscale_comment <- "GP length-scale parameters" } if (byfac) { J <- seq_along(cons) Ngp <- glue("Ngp{pi}") Nsubgp <- glue("N", str_if(gr, "sub"), glue("gp{pi}")) Igp <- glue("Igp{pi}_{J}") str_add(out$data) <- glue( " // number of observations relevant for a certain sub-GP\n", " array[Kgp{pi}] int {Ngp};\n" ) str_add(out$data) <- " // indices and contrasts of sub-GPs per observation\n" str_add(out$data) <- cglue( " array[{Ngp}[{J}]] int {Igp};\n", " vector[{Ngp}[{J}]] Cgp{pi}_{J};\n" ) str_add(out$pll_args) <- cglue( ", data array[] int {Igp}, data vector Cgp{pi}_{J}" ) str_add_list(out) <- stan_prior( prior, class = "lscale", coef = sfx2, type = lscale_type, dim = lscale_dim, suffix = glue("{pi}"), px = px, comment = lscale_comment, normalize = normalize ) if (gr) { str_add(out$data) <- glue( " // number of latent GP groups\n", " array[Kgp{pi}] int Nsubgp{pi};\n" ) str_add(out$data) <- cglue( " // indices of latent GP groups per observation\n", " array[{Ngp}[{J}]] int Jgp{pi}_{J};\n" ) str_add(out$pll_args) <- cglue(", data array[] int Jgp{pi}_{J}") } if (is_approx) { str_add(out$data) <- " // approximate GP basis matrices and eigenvalues\n" str_add(out$data) <- cglue( " matrix[{Nsubgp}[{J}], NBgp{pi}] Xgp{pi}_{J};\n", " array[NBgp{pi}] vector[Dgp{pi}] slambda{pi}_{J};\n" ) str_add(out$par) <- " // latent variables of the GP\n" str_add(out$par) <- cglue( " vector[NBgp{pi}] zgp{pi}_{J};\n" ) str_add(out$model_no_pll_def) <- " // scale latent variables of the GP\n" str_add(out$model_no_pll_def) <- cglue( " vector[NBgp{pi}] rgp{pi}_{J} = sqrt(spd_gp_{cov}(", "slambda{pi}_{J}, sdgp{pi}[{J}], lscale{pi}[{J}])) .* zgp{pi}_{J};\n" ) gp_call <- glue("Xgp{pi}_{J} * rgp{pi}_{J}") } else { # exact GPs str_add(out$data) <- " // covariates of the GP\n" str_add(out$data) <- cglue( " array[{Nsubgp}[{J}]] vector[Dgp{pi}] Xgp{pi}_{J};\n" ) str_add(out$par) <- " // latent variables of the GP\n" str_add(out$par) <- cglue( " vector[{Nsubgp}[{J}]] zgp{pi}_{J};\n" ) gp_call <- glue( "gp_{cov}(Xgp{pi}_{J}, sdgp{pi}[{J}], lscale{pi}[{J}], zgp{pi}_{J})" ) } slice2 <- "" Igp_sub <- Igp if (use_threading(threads)) { str_add(out$fun) <- " #include 'fun_which_range.stan'\n" str_add(out$model_comp_basic) <- cglue( " array[size_range({Igp}, start, end)] int which_gp{pi}_{J} =", " which_range({Igp}, start, end);\n" ) slice2 <- glue("[which_gp{pi}_{J}]") Igp_sub <- glue("start_at_one({Igp}{slice2}, start)") } # TODO: add all GP elements to 'eta' at the same time? eta <- combine_prefix(px, keep_mu = TRUE, nlp = TRUE) eta <- glue("{eta}[{Igp_sub}]") str_add(out$model_no_pll_def) <- cglue( " vector[{Nsubgp}[{J}]] gp_pred{pi}_{J} = {gp_call};\n" ) str_add(out$pll_args) <- cglue(", vector gp_pred{pi}_{J}") Cgp <- glue("Cgp{pi}_{J}{slice2} .* ") Jgp <- str_if(gr, glue("[Jgp{pi}_{J}{slice2}]"), slice) str_add(out$model_comp_basic) <- cglue( " {eta} += {Cgp}gp_pred{pi}_{J}{Jgp};\n" ) str_add(out$model_prior) <- cglue( "{tp()}std_normal_{lpdf}(zgp{pi}_{J});\n" ) } else { # no by-factor variable str_add_list(out) <- stan_prior( prior, class = "lscale", coef = sfx2, type = lscale_type, dim = lscale_dim, suffix = glue("{pi}"), px = px, comment = lscale_comment, normalize = normalize ) Nsubgp <- glue("N{resp}") if (gr) { Nsubgp <- glue("Nsubgp{pi}") str_add(out$data) <- glue( " // number of latent GP groups\n", " int {Nsubgp};\n", " // indices of latent GP groups per observation\n", " array[N{resp}] int Jgp{pi};\n" ) str_add(out$pll_args) <- glue(", data array[] int Jgp{pi}") } Cgp <- "" if (bynum) { str_add(out$data) <- glue( " // numeric by-variable of the GP\n", " vector[N{resp}] Cgp{pi};\n" ) str_add(out$pll_args) <- glue(", data vector Cgp{pi}") Cgp <- glue("Cgp{pi}{slice} .* ") } if (is_approx) { str_add(out$data) <- glue( " // approximate GP basis matrices\n", " matrix[{Nsubgp}, NBgp{pi}] Xgp{pi};\n", " // approximate GP eigenvalues\n", " array[NBgp{pi}] vector[Dgp{pi}] slambda{pi};\n" ) str_add(out$par) <- glue( " vector[NBgp{pi}] zgp{pi}; // latent variables of the GP\n" ) str_add(out$model_no_pll_def) <- glue( " // scale latent variables of the GP\n", " vector[NBgp{pi}] rgp{pi} = sqrt(spd_gp_{cov}(", "slambda{pi}, sdgp{pi}[1], lscale{pi}[1])) .* zgp{pi};\n" ) if (gr) { # grouping prevents GPs to be computed efficiently inside reduce_sum str_add(out$model_no_pll_def) <- glue( " vector[{Nsubgp}] gp_pred{pi} = Xgp{pi} * rgp{pi};\n" ) str_add(out$eta) <- glue(" + {Cgp}gp_pred{pi}[Jgp{pi}{slice}]") str_add(out$pll_args) <- glue(", vector gp_pred{pi}") } else { # efficient computation of approx GPs inside reduce_sum is possible str_add(out$model_def) <- glue( " vector[N{resp}] gp_pred{pi} = Xgp{pi}{slice} * rgp{pi};\n" ) str_add(out$eta) <- glue(" + {Cgp}gp_pred{pi}") str_add(out$pll_args) <- glue(", data matrix Xgp{pi}, vector rgp{pi}") } } else { # exact GPs str_add(out$data) <- glue( " array[{Nsubgp}] vector[Dgp{pi}] Xgp{pi}; // covariates of the GP\n" ) str_add(out$par) <- glue( " vector[{Nsubgp}] zgp{pi}; // latent variables of the GP\n" ) gp_call <- glue("gp_{cov}(Xgp{pi}, sdgp{pi}[1], lscale{pi}[1], zgp{pi})") # exact GPs are kernel based methods which # need to be computed outside of reduce_sum str_add(out$model_no_pll_def) <- glue( " vector[{Nsubgp}] gp_pred{pi} = {gp_call};\n" ) Jgp <- str_if(gr, glue("[Jgp{pi}{slice}]"), slice) str_add(out$eta) <- glue(" + {Cgp}gp_pred{pi}{Jgp}") str_add(out$pll_args) <- glue(", vector gp_pred{pi}") } str_add(out$model_prior) <- glue( "{tp()}std_normal_{lpdf}(zgp{pi});\n" ) } } out } # Stan code for the linear predictor of autocorrelation terms stan_ac <- function(bframe, prior, threads, normalize, ...) { lpdf <- stan_lpdf_name(normalize) out <- list() px <- check_prefix(bframe) p <- usc(combine_prefix(px)) resp <- usc(px$resp) n <- stan_nn(threads) slice <- stan_slice(threads) acframe <- bframe$frame$ac stopifnot(is.acframe(acframe)) has_natural_residuals <- has_ac_natural_residuals(acframe) has_latent_residuals <- has_ac_latent_residuals(acframe) families <- family_names(bframe) # TODO: include family-specific functions inside the corresponding # stan_log_lik functions once they return lists of character vectors if (has_latent_residuals) { # families that do not have natural residuals require latent # residuals for residual-based autocor structures err_msg <- "Latent residuals are not implemented" if (is.btnl(bframe)) { stop2(err_msg, " for non-linear models.") } str_add(out$par) <- glue( " vector[N{resp}] zerr{p}; // unscaled residuals\n" ) if (has_special_prior(prior, px, class = "sderr")) { str_add(out$tpar_def) <- glue( " real sderr{p}; // SD of residuals\n" ) str_add(out$prior_global_scales) <- glue(" sderr{p}") str_add(out$prior_global_lengths) <- glue(" 1") } else { str_add_list(out) <- stan_prior( prior, class = "sderr", px = px, suffix = p, comment = "SD of residuals", normalize = normalize ) } str_add(out$tpar_def) <- glue( " vector[N{resp}] err{p}; // actual residuals\n" ) str_add(out$pll_args) <- glue(", vector err{p}") str_add(out$model_prior) <- glue( " target += std_normal_{lpdf}(zerr{p});\n" ) str_add(out$eta) <- glue(" + err{p}{slice}") } # validity of the autocor terms has already been checked before acframe_arma <- subset2(acframe, class = "arma") if (has_rows(acframe_arma)) { if (use_threading(threads) && (!acframe_arma$cov || has_natural_residuals)) { stop2("Threading is not supported for this ARMA model.") } str_add(out$data) <- glue( " // data needed for ARMA correlations\n", " int Kar{p}; // AR order\n", " int Kma{p}; // MA order\n" ) str_add(out$tdata_def) <- glue( " int max_lag{p} = max(Kar{p}, Kma{p});\n" ) if (!acframe_arma$cov) { err_msg <- "Please set cov = TRUE in ARMA structures" if (is.formula(bframe$adforms$se)) { stop2(err_msg, " when including known standard errors.") } str_add(out$data) <- glue( " // number of lags per observation\n", " array[N{resp}] int J_lag{p};\n" ) str_add(out$model_def) <- glue( " // matrix storing lagged residuals\n", " matrix[N{resp}, max_lag{p}] Err{p}", " = rep_matrix(0, N{resp}, max_lag{p});\n" ) if (has_natural_residuals) { str_add(out$model_def) <- glue( " vector[N{resp}] err{p}; // actual residuals\n" ) Y <- str_if(is.formula(bframe$adforms$mi), "Yl", "Y") comp_err <- glue(" err{p}[n] = {Y}{p}[n] - mu{p}[n];\n") } else { if (acframe_arma$q > 0) { # AR and MA structures cannot be distinguished when # using a single vector of latent residuals stop2("Please set cov = TRUE when modeling MA structures ", "for this family.") } str_add(out$tpar_comp) <- glue( " // compute ctime-series residuals\n", " err{p} = sderr{p} * zerr{p};\n" ) comp_err <- "" } add_ar <- str_if(acframe_arma$p > 0, glue(" mu{p}[n] += Err{p}[n, 1:Kar{p}] * ar{p};\n") ) add_ma <- str_if(acframe_arma$q > 0, glue(" mu{p}[n] += Err{p}[n, 1:Kma{p}] * ma{p};\n") ) str_add(out$model_comp_arma) <- glue( " // include ARMA terms\n", " for (n in 1:N{resp}) {{\n", add_ma, comp_err, " for (i in 1:J_lag{p}[n]) {{\n", " Err{p}[n + 1, i] = err{p}[n + 1 - i];\n", " }}\n", add_ar, " }}\n" ) } if (acframe_arma$p > 0) { if (has_special_prior(prior, px, class = "ar")) { if (acframe_arma$cov) { stop2("Cannot use shrinkage priors on 'ar' if cov = TRUE.") } str_add_list(out) <- stan_prior_non_centered( class = "ar", suffix = p, suffix_K = "ar" ) } else { str_add_list(out) <- stan_prior( prior, class = "ar", px = px, suffix = p, coef = seq_along(acframe_arma$p), type = glue("vector[Kar{p}]"), header_type = "vector", comment = "autoregressive coefficients", normalize = normalize ) } } if (acframe_arma$q > 0) { if (has_special_prior(prior, px, class = "ma")) { if (acframe_arma$cov) { stop2("Cannot use shrinkage priors on 'ma' if cov = TRUE.") } str_add_list(out) <- stan_prior_non_centered( class = "ma", suffix = p, suffix_K = "ma" ) } else { str_add_list(out) <- stan_prior( prior, class = "ma", px = px, suffix = p, coef = seq_along(acframe_arma$q), type = glue("vector[Kma{p}]"), header_type = "vector", comment = "moving-average coefficients", normalize = normalize ) } } } acframe_cosy <- subset2(acframe, class = "cosy") if (has_rows(acframe_cosy)) { # compound symmetry correlation structure # most code is shared with ARMA covariance models str_add_list(out) <- stan_prior( prior, class = "cosy", px = px, suffix = p, comment = "compound symmetry correlation", normalize = normalize ) } acframe_unstr <- subset2(acframe, class = "unstr") if (has_rows(acframe_unstr)) { # unstructured correlation matrix # most code is shared with ARMA covariance models # define prior on the Cholesky scale to consistency across # autocorrelation structures str_add_list(out) <- stan_prior( prior, class = "Lcortime", px = px, suffix = p, type = glue("cholesky_factor_corr[n_unique_t{p}]"), header_type = "matrix", comment = "cholesky factor of unstructured autocorrelation matrix", normalize = normalize ) } acframe_time_cov <- subset2(acframe, dim = "time", cov = TRUE) if (has_rows(acframe_time_cov)) { # use correlation structures in covariance matrix parameterization # optional for ARMA models and obligatory for COSY and UNSTR models # can only model one covariance structure at a time stopifnot(nrow(acframe_time_cov) == 1) if (use_threading(threads)) { stop2("Threading is not supported for covariance-based autocorrelation models.") } str_add(out$fun) <- glue( " #include 'fun_sequence.stan'\n", " #include 'fun_is_equal.stan'\n", " #include 'fun_stack_vectors.stan'\n" ) if ("gaussian" %in% families) { str_add(out$fun) <- glue( " #include 'fun_normal_time.stan'\n", " #include 'fun_normal_time_se.stan'\n" ) } if ("student" %in% families) { str_add(out$fun) <- glue( " #include 'fun_student_t_time.stan'\n", " #include 'fun_student_t_time_se.stan'\n" ) } str_add(out$data) <- glue( " // see the functions block for details\n", " int N_tg{p};\n", " array[N_tg{p}] int begin_tg{p};\n", " array[N_tg{p}] int end_tg{p};\n", " array[N_tg{p}] int nobs_tg{p};\n" ) str_add(out$pll_args) <- glue( ", array[] int begin_tg{p}, array[] int end_tg{p}, array[] int nobs_tg{p}" ) str_add(out$tdata_def) <- glue( " int max_nobs_tg{p} = max(nobs_tg{p});", " // maximum dimension of the autocorrelation matrix\n" ) if (acframe_time_cov$class == "unstr") { # unstructured time-covariances require additional data and cannot # be represented directly via Cholesky factors due to potentially # different time subsets str_add(out$data) <- glue( " array[N_tg{p}, max(nobs_tg{p})] int Jtime_tg{p};\n", " int n_unique_t{p}; // total number of unique time points\n", " int n_unique_cortime{p}; // number of unique correlations\n" ) str_add(out$pll_args) <- glue(", array[,] int Jtime_tg{p}") if (has_latent_residuals) { str_add(out$fun) <- " #include 'fun_scale_time_err_flex.stan'\n" str_add(out$tpar_comp) <- glue( " // compute correlated time-series residuals\n", " err{p} = scale_time_err_flex(", "zerr{p}, sderr{p}, Lcortime{p}, nobs_tg{p}, begin_tg{p}, end_tg{p}, Jtime_tg{p});\n" ) } str_add(out$gen_def) <- glue( " // compute group-level correlations\n", " corr_matrix[n_unique_t{p}] Cortime{p}", " = multiply_lower_tri_self_transpose(Lcortime{p});\n", " vector[n_unique_cortime{p}] cortime{p};\n" ) str_add(out$gen_comp) <- stan_cor_gen_comp( glue("cortime{p}"), glue("n_unique_t{p}") ) } else { # all other time-covariance structures can be represented directly # through Cholesky factors of the correlation matrix if (acframe_time_cov$class == "arma") { if (acframe_time_cov$p > 0 && acframe_time_cov$q == 0) { cor_fun <- "ar1" cor_args <- glue("ar{p}[1]") } else if (acframe_time_cov$p == 0 && acframe_time_cov$q > 0) { cor_fun <- "ma1" cor_args <- glue("ma{p}[1]") } else { cor_fun <- "arma1" cor_args <- glue("ar{p}[1], ma{p}[1]") } } else if (acframe_time_cov$class == "cosy") { cor_fun <- "cosy" cor_args <- glue("cosy{p}") } str_add(out$fun) <- glue( " #include 'fun_cholesky_cor_{cor_fun}.stan'\n" ) str_add(out$tpar_def) <- glue( " // cholesky factor of the autocorrelation matrix\n", " matrix[max_nobs_tg{p}, max_nobs_tg{p}] Lcortime{p};\n" ) str_add(out$pll_args) <- glue(", matrix Lcortime{p}") str_add(out$tpar_comp) <- glue( " // compute residual covariance matrix\n", " Lcortime{p} = cholesky_cor_{cor_fun}({cor_args}, max_nobs_tg{p});\n" ) if (has_latent_residuals) { str_add(out$fun) <- " #include 'fun_scale_time_err.stan'\n" str_add(out$tpar_comp) <- glue( " // compute correlated time-series residuals\n", " err{p} = scale_time_err(", "zerr{p}, sderr{p}, Lcortime{p}, nobs_tg{p}, begin_tg{p}, end_tg{p});\n" ) } } } acframe_sar <- subset2(acframe, class = "sar") if (has_rows(acframe_sar)) { if (!has_natural_residuals) { stop2("SAR terms are not implemented for this family.") } if (use_threading(threads)) { stop2("Threading is not supported for SAR models.") } str_add(out$data) <- glue( " matrix[N{resp}, N{resp}] Msar{p}; // spatial weight matrix\n", " vector[N{resp}] eigenMsar{p}; // eigenvalues of Msar{p}\n" ) str_add(out$tdata_def) <- glue( " // the eigenvalues define the boundaries of the SAR correlation\n", " real min_eigenMsar{p} = min(eigenMsar{p});\n", " real max_eigenMsar{p} = max(eigenMsar{p});\n" ) if (acframe_sar$type == "lag") { if ("gaussian" %in% families) { str_add(out$fun) <- " #include 'fun_normal_lagsar.stan'\n" } if ("student" %in% families) { str_add(out$fun) <- " #include 'fun_student_t_lagsar.stan'\n" } str_add_list(out) <- stan_prior( prior, class = "lagsar", px = px, suffix = p, comment = "lag-SAR correlation parameter", normalize = normalize ) } else if (acframe_sar$type == "error") { if ("gaussian" %in% families) { str_add(out$fun) <- " #include 'fun_normal_errorsar.stan'\n" } if ("student" %in% families) { str_add(out$fun) <- " #include 'fun_student_t_errorsar.stan'\n" } str_add_list(out) <- stan_prior( prior, class = "errorsar", px = px, suffix = p, comment = "error-SAR correlation parameter", normalize = normalize ) } } acframe_car <- subset2(acframe, class = "car") if (has_rows(acframe_car)) { if (is.btnl(bframe)) { stop2("CAR terms are not implemented for non-linear models.") } str_add(out$data) <- glue( " // data for the CAR structure\n", " int Nloc{p};\n", " array[N{resp}] int Jloc{p};\n", " int Nedges{p};\n", " array[Nedges{p}] int edges1{p};\n", " array[Nedges{p}] int edges2{p};\n" ) if (has_special_prior(prior, px, class = "sdcar")) { str_add(out$tpar_def) <- glue( " real sdcar{p}; // SD of the CAR structure\n" ) str_add(out$prior_global_scales) <- glue(" sdcar{p}") str_add(out$prior_global_lengths) <- glue(" 1") } else { str_add_list(out) <- stan_prior( prior, class = "sdcar", px = px, suffix = p, comment = "SD of the CAR structure", normalize = normalize ) } str_add(out$pll_args) <- glue(", vector rcar{p}, data array[] int Jloc{p}") str_add(out$loopeta) <- glue(" + rcar{p}[Jloc{p}{n}]") if (acframe_car$type %in% c("escar", "esicar")) { str_add(out$data) <- glue( " vector[Nloc{p}] Nneigh{p};\n", " vector[Nloc{p}] eigenMcar{p};\n" ) } if (acframe_car$type == "escar") { str_add(out$fun) <- " #include 'fun_sparse_car_lpdf.stan'\n" str_add(out$par) <- glue( " vector[Nloc{p}] rcar{p};\n" ) str_add_list(out) <- stan_prior( prior, class = "car", px = px, suffix = p, normalize = normalize ) car_args <- c( "car", "sdcar", "Nloc", "Nedges", "Nneigh", "eigenMcar", "edges1", "edges2" ) car_args <- paste0(car_args, p, collapse = ", ") str_add(out$model_prior) <- glue( " target += sparse_car_lpdf(\n", " rcar{p} | {car_args}\n", " );\n" ) } else if (acframe_car$type == "esicar") { str_add(out$fun) <- " #include 'fun_sparse_icar_lpdf.stan'\n" str_add(out$par) <- glue( " vector[Nloc{p} - 1] zcar{p};\n" ) str_add(out$tpar_def) <- glue( " vector[Nloc{p}] rcar{p};\n" ) str_add(out$tpar_comp) <- glue( " // sum-to-zero constraint\n", " rcar[1:(Nloc{p} - 1)] = zcar{p};\n", " rcar[Nloc{p}] = - sum(zcar{p});\n" ) car_args <- c( "sdcar", "Nloc", "Nedges", "Nneigh", "eigenMcar", "edges1", "edges2" ) car_args <- paste0(car_args, p, collapse = ", ") str_add(out$model_prior) <- glue( " target += sparse_icar_lpdf(\n", " rcar{p} | {car_args}\n", " );\n" ) } else if (acframe_car$type %in% "icar") { # intrinsic car based on the case study of Mitzi Morris # http://mc-stan.org/users/documentation/case-studies/icar_stan.html str_add(out$par) <- glue( " // parameters for the ICAR structure\n", " vector[Nloc{p}] zcar{p};\n" ) # separate definition from computation to support fixed parameters str_add(out$tpar_def) <- glue( " // scaled parameters for the ICAR structure\n", " vector[Nloc{p}] rcar{p};\n" ) str_add(out$tpar_comp) <- glue( " // compute scaled parameters for the ICAR structure\n", " rcar{p} = zcar{p} * sdcar{p};\n" ) str_add(out$model_prior) <- glue( " // improper prior on the spatial CAR component\n", " target += -0.5 * dot_self(zcar{p}[edges1{p}] - zcar{p}[edges2{p}]);\n", " // soft sum-to-zero constraint\n", " target += normal_{lpdf}(sum(zcar{p}) | 0, 0.001 * Nloc{p});\n" ) } else if (acframe_car$type == "bym2") { # BYM2 car based on the case study of Mitzi Morris # http://mc-stan.org/users/documentation/case-studies/icar_stan.html str_add(out$data) <- glue( " // scaling factor of the spatial CAR component\n", " real car_scale{p};\n" ) str_add(out$par) <- glue( " // parameters for the BYM2 structure\n", " vector[Nloc{p}] zcar{p}; // spatial part\n", " vector[Nloc{p}] nszcar{p}; // non-spatial part\n", " // proportion of variance in the spatial part\n" ) str_add_list(out) <- stan_prior( prior, class = "rhocar", px = px, suffix = p, normalize = normalize ) # separate definition from computation to support fixed parameters str_add(out$tpar_def) <- glue( " // scaled parameters for the BYM2 structure\n", " vector[Nloc{p}] rcar{p};\n" ) str_add(out$tpar_comp) <- glue( " // join the spatial and the non-spatial CAR component\n", " rcar{p} = (sqrt(1 - rhocar{p}) * nszcar{p}", " + sqrt(rhocar{p} * inv(car_scale{p})) * zcar{p}) * sdcar{p};\n" ) str_add(out$model_prior) <- glue( " // improper prior on the spatial BYM2 component\n", " target += -0.5 * dot_self(zcar{p}[edges1{p}] - zcar{p}[edges2{p}]);\n", " // soft sum-to-zero constraint\n", " target += normal_{lpdf}(sum(zcar{p}) | 0, 0.001 * Nloc{p});\n", " // proper prior on the non-spatial BYM2 component\n", " target += std_normal_{lpdf}(nszcar{p});\n" ) } } acframe_fcor <- subset2(acframe, class = "fcor") if (has_rows(acframe_fcor)) { if (!has_natural_residuals) { stop2("FCOR terms are not implemented for this family.") } if (use_threading(threads)) { stop2("Threading is not supported for FCOR models.") } if ("gaussian" %in% families) { str_add(out$fun) <- " #include 'fun_normal_fcor.stan'\n" } if ("student" %in% families) { str_add(out$fun) <- " #include 'fun_student_t_fcor.stan'\n" } str_add(out$data) <- glue( " matrix[N{resp}, N{resp}] Mfcor{p}; // known residual covariance matrix\n" ) str_add(out$tdata_def) <- glue( " matrix[N{resp}, N{resp}] Lfcor{p} = cholesky_decompose(Mfcor{p});\n" ) } out } # stan code for offsets stan_offset <- function(bframe, threads, ...) { stopifnot(is.bframel(bframe)) out <- list() if (is.formula(bframe$offset)) { p <- usc(combine_prefix(bframe)) resp <- usc(bframe$resp) slice <- stan_slice(threads) # use 'offsets' as 'offset' is reserved in stanc3 str_add(out$data) <- glue( " vector[N{resp}] offsets{p};\n") str_add(out$pll_args) <- glue(", data vector offsets{p}") str_add(out$eta) <- glue(" + offsets{p}{slice}") } out } # Stan code for non-linear predictor terms # @param nlpars names of the non-linear parameters stan_nl <- function(bframe, nlpars, threads, ...) { stopifnot(is.bframenl(bframe)) out <- list() resp <- usc(bframe$resp) par <- combine_prefix(bframe, keep_mu = TRUE, nlp = TRUE) # prepare non-linear model n <- paste0(str_if(bframe$loop, "[n]"), " ") new_nlpars <- glue(" nlp{resp}_{nlpars}{n}") # covariates in the non-linear model covars <- all.vars(bframe$covars) new_covars <- NULL if (length(covars)) { p <- usc(combine_prefix(bframe)) new_covars <- rep(NA, length(covars)) frame <- bframe$frame$cnl # data_cnl <- data_cnl(bframe, data) if (bframe$loop) { slice <- stan_nn(threads) } else { slice <- stan_slice(threads) } slice <- paste0(slice, " ") str_add(out$data) <- " // covariates for non-linear functions\n" for (i in seq_along(covars)) { if (frame$integer[i]) { if (frame$matrix[i]) { str_add(out$data) <- glue( " array[N{resp}, {frame$dim2[i]}] int C{p}_{i};\n" ) str_add(out$pll_args) <- glue(", data array[,] int C{p}_{i}") } else { str_add(out$data) <- glue( " array[N{resp}] int C{p}_{i};\n" ) str_add(out$pll_args) <- glue(", data array[] int C{p}_{i}") } } else { if (frame$matrix[i]) { str_add(out$data) <- glue( " matrix[N{resp}, {frame$dim2[i]}] C{p}_{i};\n" ) str_add(out$pll_args) <- glue(", data matrix C{p}_{i}") } else { str_add(out$data) <- glue( " vector[N{resp}] C{p}_{i};\n" ) str_add(out$pll_args) <- glue(", data vector C{p}_{i}") } } new_covars[i] <- glue(" C{p}_{i}{slice}") } } # add white spaces to be able to replace parameters and covariates syms <- c( "+", "-", "*", "/", "%", "^", ".*", "./", "'", ")", "(", ",", "==", "!=", "<=", ">=", "<", ">", "!", "&&", "||" ) regex <- glue("(? Nme_{i}; // number of latent values\n", " array[N] int Jme_{i}; // group index per observation\n" ) str_add(out$pll_args) <- glue(", data array[] int Jme_{i}") } else { Nme <- "N" } str_add(out$data) <- glue( " int Mme_{i}; // number of groups\n" ) str_add(out$data) <- cglue( " vector[{Nme}] Xn_{K}; // noisy values\n", " vector[{Nme}] noise_{K}; // measurement noise\n" ) str_add_list(out) <- stan_prior( prior, "meanme", coef = coefs[K], suffix = usc(i), type = glue("vector[Mme_{i}]"), comment = "latent means", normalize = normalize ) str_add_list(out) <- stan_prior( prior, "sdme", coef = coefs[K], suffix = usc(i), type = glue("vector[Mme_{i}]"), comment = "latent SDs", normalize = normalize ) str_add(out$model_prior) <- cglue( " target += normal_{lpdf}(Xn_{K} | Xme_{K}, noise_{K});\n" ) if (meframe$cor[K[1]] && length(K) > 1L) { str_add(out$data) <- glue( " int NCme_{i}; // number of latent correlations\n" ) str_add(out$par) <- glue( " matrix[Mme_{i}, {Nme}] zme_{i}; // standardized latent values\n" ) str_add_list(out) <- stan_prior( prior, "Lme", group = g, suffix = usc(i), type = glue("cholesky_factor_corr[Mme_{i}]"), comment = "cholesky factor of the latent correlation matrix", normalize = normalize ) # separate definition from computation to support fixed parameters str_add(out$tpar_def) <- glue( " matrix[{Nme}, Mme_{i}] Xme{i}; // actual latent values\n" ) str_add(out$tpar_comp) <- glue( " // compute actual latent values\n", " Xme{i} = rep_matrix(transpose(meanme_{i}), {Nme})", " + transpose(diag_pre_multiply(sdme_{i}, Lme_{i}) * zme_{i});\n" ) str_add(out$tpar_def) <- cglue( " // using separate vectors increases efficiency\n", " vector[{Nme}] Xme_{K};\n" ) str_add(out$tpar_comp) <- cglue( " Xme_{K} = Xme{i}[, {J}];\n" ) str_add(out$pll_args) <- cglue(", vector Xme_{K}") str_add(out$model_prior) <- glue( " target += std_normal_{lpdf}(to_vector(zme_{i}));\n" ) str_add(out$gen_def) <- cglue( " // obtain latent correlation matrix\n", " corr_matrix[Mme_{i}] Corme_{i}", " = multiply_lower_tri_self_transpose(Lme_{i});\n", " vector[NCme_{i}] corme_{i};\n" ) str_add(out$gen_comp) <- stan_cor_gen_comp( cor = glue("corme_{i}"), ncol = glue("Mme_{i}") ) } else { str_add(out$par) <- cglue( " vector[{Nme}] zme_{K}; // standardized latent values\n" ) # separate definition from computation to support fixed parameters str_add(out$tpar_def) <- cglue( " vector[{Nme}] Xme_{K}; // actual latent values\n" ) str_add(out$tpar_comp) <- cglue( " // compute actual latent values\n", " Xme_{K} = meanme_{i}[{J}] + sdme_{i}[{J}] * zme_{K};\n" ) str_add(out$pll_args) <- cglue(", vector Xme_{K}") str_add(out$model_prior) <- cglue( " target += std_normal_{lpdf}(zme_{K});\n" ) } } out } # initialize and compute a linear predictor term in Stan language # @param out list of character strings containing Stan code # @param bframe btl object # @param primitive use Stan's GLM likelihood primitives? # @param ... currently unused # @return list of character strings containing Stan code stan_eta_combine <- function(bframe, out, threads, primitive, ...) { stopifnot(is.btl(bframe), is.list(out)) if (primitive && !has_special_terms(bframe)) { # only overall effects and perhaps an intercept are present # which will be evaluated directly in the GLM primitive likelihood return(out) } px <- check_prefix(bframe) resp <- usc(bframe$resp) eta <- combine_prefix(px, keep_mu = TRUE, nlp = TRUE) out$eta <- sub("^[ \t\r\n]+\\+", "", out$eta, perl = TRUE) str_add(out$model_def) <- glue( " // initialize linear predictor term\n", " vector[N{resp}] {eta} = rep_vector(0.0, N{resp});\n" ) if (isTRUE(nzchar(out$eta))) { str_add(out$model_comp_eta_basic) <- glue(" {eta} +={out$eta};\n") } out$eta <- NULL str_add(out$loopeta) <- stan_eta_re(bframe, threads = threads) if (isTRUE(nzchar(out$loopeta))) { # parts of eta are computed in a loop over observations out$loopeta <- sub("^[ \t\r\n]+\\+", "", out$loopeta, perl = TRUE) str_add(out$model_comp_eta_loop) <- glue( " for (n in 1:N{resp}) {{\n", " // add more terms to the linear predictor\n", stan_nn_def(threads), " {eta}[n] +={out$loopeta};\n", " }}\n" ) } out$loopeta <- NULL # some links need custom Stan functions link <- bframe$family$link link_names <- c("cauchit", "cloglog", "softplus", "squareplus", "softit", "tan_half") needs_link_fun <- isTRUE(link %in% link_names) if (needs_link_fun) { str_add(out$fun) <- glue(" #include 'fun_{link}.stan'\n") } # possibly transform eta before it is passed to the likelihood inv_link <- stan_inv_link(bframe$family$link, transform = bframe$transform) if (nzchar(inv_link)) { str_add(out$model_comp_dpar_link) <- glue( " {eta} = {inv_link}({eta});\n" ) } out } # write the group-level part of the linear predictor # @return a single character string stan_eta_re <- function(bframe, threads) { eta_re <- "" n <- stan_nn(threads) reframe <- subset2(bframe$frame$re, type = c("", "mmc")) for (id in unique(reframe$id)) { r <- subset2(reframe, id = id) rpx <- check_prefix(r) idp <- paste0(r$id, usc(combine_prefix(rpx))) idresp <- paste0(r$id, usc(rpx$resp)) if (r$gtype[1] == "mm") { ng <- seq_along(r$gcall[[1]]$groups) for (i in seq_rows(r)) { str_add(eta_re) <- cglue( " + W_{idresp[i]}_{ng}{n}", " * r_{idp[i]}_{r$cn[i]}[J_{idresp[i]}_{ng}{n}]", " * Z_{idp[i]}_{r$cn[i]}_{ng}{n}" ) } } else { str_add(eta_re) <- cglue( " + r_{idp}_{r$cn}[J_{idresp}{n}] * Z_{idp}_{r$cn}{n}" ) } } eta_re } # Stan code for group-level parameters in special predictor terms # @param r data.frame created by frame_re # @return a character vector: one element per row of 'r' stan_eta_rsp <- function(r, threads) { stopifnot(is.reframe(r)) stopifnot(nrow(r) > 0L, length(unique(r$gtype)) == 1L) n <- stan_nn(threads) rpx <- check_prefix(r) idp <- paste0(r$id, usc(combine_prefix(rpx))) idresp <- paste0(r$id, usc(rpx$resp)) if (r$gtype[1] == "mm") { ng <- seq_along(r$gcall[[1]]$groups) out <- rep("", nrow(r)) for (i in seq_along(out)) { out[i] <- glue( "W_{idresp[i]}_{ng}{n} * r_{idp[i]}_{r$cn[i]}[J_{idresp[i]}_{ng}{n}]", collapse = " + " ) } } else { out <- glue("r_{idp}_{r$cn}[J_{idresp}{n}]") } out } # does eta need to be transformed manually using the inv_link function stan_eta_transform <- function(bframe, family) { no_transform <- family$link == "identity" || has_joint_link(family) && !is.customfamily(family) !no_transform && !stan_has_built_in_fun(bframe, family) } # indicate if the population-level design matrix should be centered # implies a temporary shift in the intercept of the model stan_center_X <- function(x) { is.btl(x) && !no_center(x$fe) && has_intercept(x$fe) && !fix_intercepts(x) && !is_sparse(x$fe) && !has_sum_to_zero_thres(x) } stan_dpar_comments <- function(dpar, family) { dpar_class <- dpar_class(dpar, family) out <- switch(dpar_class, "", sigma = "dispersion parameter", shape = "shape parameter", nu = "degrees of freedom or shape", phi = "precision parameter", kappa = "precision parameter", beta = "scale parameter", zi = "zero-inflation probability", hu = "hurdle probability", zoi = "zero-one-inflation probability", coi = "conditional one-inflation probability", bs = "boundary separation parameter", ndt = "non-decision time parameter", bias = "initial bias parameter", disc = "discrimination parameters", quantile = "quantile parameter", xi = "shape parameter", alpha = "skewness parameter" ) out } # Stan code for transformations of distributional parameters # TODO: refactor into family-specific functions # TODO: add gamma and related families here to compute rate = shape / mean stan_dpar_transform <- function(bframe, prior, threads, normalize, ...) { stopifnot(is.brmsterms(bframe)) out <- list() families <- family_names(bframe) px <- check_prefix(bframe) p <- usc(combine_prefix(px)) resp <- usc(bframe$resp) if (any(conv_cats_dpars(families))) { stopifnot(length(families) == 1L) iref <- get_refcat(bframe$family, int = TRUE) mus <- make_stan_names(glue("mu{bframe$family$cats}")) mus <- glue("{mus}{p}") if (use_glm_primitive_categorical(bframe)) { bterms1 <- bframe$dpars[[1]] center <- stan_center_X(bterms1) ct <- str_if(center, "c") K <- glue("K{ct}_{bterms1$dpar}{p}") str_add(out$pll_args) <- glue(", int {K}") str_add(out$model_def) <- glue( " // joint regression coefficients over categories\n", " matrix[{K}, ncat{p}] b{p};\n" ) bnames <- glue("b_{mus}") bnames[iref] <- glue("rep_vector(0, {K})") str_add(out$model_comp_catjoin) <- cglue( " b{p}[, {seq_along(bnames)}] = {bnames};\n" ) if (center) { Inames <- glue("Intercept_{mus}") Inames[iref] <- "0" str_add(out$model_def) <- glue( " // joint intercepts over categories\n", " vector[ncat{p}] Intercept{p};\n" ) str_add(out$model_comp_catjoin) <- glue( " Intercept{p} = {stan_vector(Inames)};\n" ) } } else { is_logistic_normal <- any(is_logistic_normal(families)) len_mu <- glue("ncat{p}{str_if(is_logistic_normal, '-1')}") str_add(out$model_def) <- glue( " // linear predictor matrix\n", " array[N{resp}] vector[{len_mu}] mu{p};\n" ) mus <- glue("{mus}[n]") if (is_logistic_normal) { mus <- mus[-iref] } else { mus[iref] <- "0" } str_add(out$model_comp_catjoin) <- glue( " for (n in 1:N{resp}) {{\n", " mu{p}[n] = {stan_vector(mus)};\n", " }}\n" ) } } if (any(families %in% "skew_normal")) { # as suggested by Stephen Martin use sigma and mu of CP # but the skewness parameter alpha of DP dp_names <- names(bframe$dpars) for (i in which(families %in% "skew_normal")) { id <- str_if(length(families) == 1L, "", i) sigma <- stan_sigma_transform(bframe, id = id, threads = threads) ns <- str_if(grepl(stan_nn_regex(), sigma), "[n]") na <- str_if(glue("alpha{id}") %in% dp_names, "[n]") type_delta <- str_if(nzchar(na), glue("vector[N{resp}]"), "real") no <- str_if(any(nzchar(c(ns, na))), "[n]", "") type_omega <- str_if(nzchar(no), glue("vector[N{resp}]"), "real") str_add(out$model_def) <- glue( " // parameters used to transform the skew-normal distribution\n", " {type_delta} delta{id}{p}; // transformed alpha parameter\n", " {type_omega} omega{id}{p}; // scale parameter\n" ) alpha <- glue("alpha{id}{p}{na}") delta <- glue("delta{id}{p}{na}") omega <- glue("omega{id}{p}{no}") comp_delta <- glue( " {delta} = {alpha} / sqrt(1 + {alpha}^2);\n" ) comp_omega <- glue( " {omega} = {sigma} / sqrt(1 - sqrt(2 / pi())^2 * {delta}^2);\n" ) str_add(out$model_comp_dpar_trans) <- glue( " // use efficient skew-normal parameterization\n", str_if(!nzchar(na), comp_delta), str_if(!nzchar(no), comp_omega), " for (n in 1:N{resp}) {{\n", stan_nn_def(threads), str_if(nzchar(na), glue(" ", comp_delta)), str_if(nzchar(no), glue(" ", comp_omega)), " mu{id}{p}[n] = mu{id}{p}[n]", " - {omega} * {delta} * sqrt(2 / pi());\n", " }}\n" ) } } if (any(families %in% "gen_extreme_value")) { # TODO: remove the gen_extreme_value family in brms 3.0 warning2("The 'gen_extreme_value' family is deprecated ", "and will be removed in the future.") dp_names <- c(names(bframe$dpars), names(bframe$fdpars)) for (i in which(families %in% "gen_extreme_value")) { id <- str_if(length(families) == 1L, "", i) xi <- glue("xi{id}") if (!xi %in% dp_names) { str_add(out$model_def) <- glue( " real {xi}{p}; // scaled shape parameter\n" ) args <- sargs( glue("tmp_{xi}{p}"), glue("Y{p}"), glue("mu{id}{p}"), glue("sigma{id}{p}") ) str_add(out$model_comp_dpar_trans) <- glue( " {xi}{p} = scale_xi({args});\n" ) } } } if (any(families %in% "logistic_normal")) { stopifnot(length(families) == 1L) predcats <- make_stan_names(get_predcats(bframe$family)) sigma_dpars <- glue("sigma{predcats}") reqn <- sigma_dpars %in% names(bframe$dpars) n <- ifelse(reqn, "[n]", "") sigma_dpars <- glue("{sigma_dpars}{p}{n}") ncatm1 <- glue("ncat{p}-1") if (any(reqn)) { # some of the sigmas are predicted str_add(out$model_def) <- glue( " // sigma parameter matrix\n", " array[N{resp}] vector[{ncatm1}] sigma{p};\n" ) str_add(out$model_comp_catjoin) <- glue( " for (n in 1:N{resp}) {{\n", " sigma{p}[n] = {stan_vector(sigma_dpars)};\n", " }}\n" ) } else { # none of the sigmas is predicted str_add(out$model_def) <- glue( " // sigma parameter vector\n", " vector[{ncatm1}] sigma{p} = {stan_vector(sigma_dpars)};\n" ) } # handle the latent correlation matrix 'lncor' str_add(out$tdata_def) <- glue( " // number of logistic normal correlations\n", " int nlncor{p} = choose({ncatm1}, 2);\n" ) str_add_list(out) <- stan_prior( prior, "Llncor", suffix = p, px = px, type = glue("cholesky_factor_corr[{ncatm1}]"), header_type = "matrix", comment = "logistic-normal Cholesky correlation matrix", normalize = normalize ) str_add(out$gen_def) <- glue( " // logistic normal correlations\n", " corr_matrix[{ncatm1}] Lncor", " = multiply_lower_tri_self_transpose(Llncor);\n", " vector[nlncor] lncor;\n" ) str_add(out$gen_comp) <- stan_cor_gen_comp("lncor", ncatm1) } out } # Stan code for sigma to incorporate addition argument 'se' stan_sigma_transform <- function(bframe, id = "", threads = NULL) { if (nzchar(id)) { # find the right family in mixture models family <- family_names(bframe)[as.integer(id)] } else { family <- bframe$family$family stopifnot(!isTRUE(family == "mixture")) } p <- usc(combine_prefix(bframe)) ns <- str_if(glue("sigma{id}") %in% names(bframe$dpars), "[n]") has_sigma <- has_sigma(family) && !no_sigma(bframe) sigma <- str_if(has_sigma, glue("sigma{id}{p}{ns}")) if (is.formula(bframe$adforms$se)) { nse <- stan_nn(threads) sigma <- str_if(nzchar(sigma), glue("sqrt(square({sigma}) + se2{p}{nse})"), glue("se{p}{nse}") ) } sigma } brms/R/posterior_epred.R0000644000176200001440000007505315053072461014763 0ustar liggesusers#' Draws from the Expected Value of the Posterior Predictive Distribution #' #' Compute posterior draws of the expected value of the posterior predictive #' distribution. Can be performed for the data used to fit the model (posterior #' predictive checks) or for new data. By definition, these predictions have #' smaller variance than the posterior predictions performed by the #' \code{\link{posterior_predict.brmsfit}} method. This is because only the #' uncertainty in the expected value of the posterior predictive distribution is #' incorporated in the draws computed by \code{posterior_epred} while the #' residual error is ignored there. However, the estimated means of both methods #' averaged across draws should be very similar. #' #' @aliases pp_expect #' #' @inheritParams posterior_predict.brmsfit #' @param dpar Optional name of a predicted distributional parameter. #' If specified, expected predictions of this parameters are returned. #' @param nlpar Optional name of a predicted non-linear parameter. #' If specified, expected predictions of this parameters are returned. #' #' @return An \code{array} of draws. For #' categorical and ordinal models, the output is an S x N x C array. #' Otherwise, the output is an S x N matrix, where S is the number of #' posterior draws, N is the number of observations, and C is the number of #' categories. In multivariate models, an additional dimension is added to the #' output which indexes along the different response variables. #' #' @template details-newdata-na #' @template details-allow_new_levels #' #' @examples #' \dontrun{ #' ## fit a model #' fit <- brm(rating ~ treat + period + carry + (1|subject), #' data = inhaler) #' #' ## compute expected predictions #' ppe <- posterior_epred(fit) #' str(ppe) #' } #' #' @aliases posterior_epred #' @method posterior_epred brmsfit #' @importFrom rstantools posterior_epred #' @export posterior_epred #' @export posterior_epred.brmsfit <- function(object, newdata = NULL, re_formula = NULL, re.form = NULL, resp = NULL, dpar = NULL, nlpar = NULL, ndraws = NULL, draw_ids = NULL, sort = FALSE, ...) { cl <- match.call() if ("re.form" %in% names(cl) && !missing(re.form)) { re_formula <- re.form } contains_draws(object) object <- restructure(object) prep <- prepare_predictions( object, newdata = newdata, re_formula = re_formula, resp = resp, ndraws = ndraws, draw_ids = draw_ids, check_response = FALSE, ... ) posterior_epred( prep, dpar = dpar, nlpar = nlpar, sort = sort, scale = "response", summary = FALSE ) } #' @export posterior_epred.mvbrmsprep <- function(object, ...) { out <- lapply(object$resps, posterior_epred, ...) along <- ifelse(length(out) > 1L, 3, 2) do_call(abind, c(out, along = along)) } #' @export posterior_epred.brmsprep <- function(object, dpar, nlpar, sort, scale = "response", incl_thres = NULL, summary = FALSE, robust = FALSE, probs = c(0.025, 0.975), ...) { summary <- as_one_logical(summary) dpars <- names(object$dpars) nlpars <- names(object$nlpars) if (length(dpar)) { # predict a distributional parameter dpar <- as_one_character(dpar) if (!dpar %in% dpars) { stop2("Invalid argument 'dpar'. Valid distributional ", "parameters are: ", collapse_comma(dpars)) } if (length(nlpar)) { stop2("Cannot use 'dpar' and 'nlpar' at the same time.") } predicted <- is.bprepl(object$dpars[[dpar]]) || is.bprepnl(object$dpars[[dpar]]) if (predicted) { # parameter varies across observations if (scale == "linear") { object$dpars[[dpar]]$family$link <- "identity" } if (is_ordinal(object$family)) { object$dpars[[dpar]]$cs <- NULL object$family <- object$dpars[[dpar]]$family <- .dpar_family(link = object$dpars[[dpar]]$family$link) } if (dpar_class(dpar) == "theta" && scale == "response") { ap_id <- as.numeric(dpar_id(dpar)) out <- get_theta(object)[, , ap_id, drop = FALSE] dim(out) <- dim(out)[c(1, 2)] } else { out <- get_dpar(object, dpar = dpar, inv_link = TRUE) } } else { # parameter is constant across observations out <- object$dpars[[dpar]] out <- matrix(out, nrow = object$ndraws, ncol = object$nobs) } } else if (length(nlpar)) { # predict a non-linear parameter nlpar <- as_one_character(nlpar) if (!nlpar %in% nlpars) { stop2("Invalid argument 'nlpar'. Valid non-linear ", "parameters are: ", collapse_comma(nlpars)) } out <- get_nlpar(object, nlpar = nlpar) } else { # no dpar or nlpar specified incl_thres <- as_one_logical(incl_thres %||% FALSE) incl_thres <- incl_thres && is_ordinal(object$family) && scale == "linear" if (incl_thres) { # extract linear predictor array with thresholds etc. included if (is.mixfamily(object$family)) { stop2("'incl_thres' is not supported for mixture models.") } object$family$link <- "identity" } if (scale == "response" || incl_thres) { # predict the mean of the response distribution for (nlp in nlpars) { object$nlpars[[nlp]] <- get_nlpar(object, nlpar = nlp) } for (dp in dpars) { object$dpars[[dp]] <- get_dpar(object, dpar = dp) } if (is_trunc(object)) { out <- posterior_epred_trunc(object) } else { posterior_epred_fun <- paste0("posterior_epred_", object$family$family) posterior_epred_fun <- get(posterior_epred_fun, asNamespace("brms")) out <- posterior_epred_fun(object) } } else { # return results on the linear scale # extract all 'mu' parameters if (conv_cats_dpars(object$family)) { out <- dpars[grepl("^mu", dpars)] } else { out <- dpars[dpar_class(dpars) %in% "mu"] } if (length(out) == 1L) { out <- get_dpar(object, dpar = out, inv_link = FALSE) } else { # multiple mu parameters in categorical or mixture models out <- lapply(out, get_dpar, prep = object, inv_link = FALSE) out <- abind::abind(out, along = 3) } } } if (is.null(dim(out))) { out <- as.matrix(out) } colnames(out) <- NULL out <- reorder_obs(out, object$old_order, sort = sort) if (scale == "response" && is_polytomous(object$family) && length(dim(out)) == 3L && dim(out)[3] == length(object$cats)) { # for ordinal models with varying thresholds, dim[3] may not match cats dimnames(out)[[3]] <- object$cats } if (summary) { # only for compatibility with the 'fitted' method out <- posterior_summary(out, probs = probs, robust = robust) if (is_polytomous(object$family) && length(dim(out)) == 3L) { if (scale == "linear") { dimnames(out)[[3]] <- paste0("eta", seq_dim(out, 3)) } else { dimnames(out)[[3]] <- paste0("P(Y = ", dimnames(out)[[3]], ")") } } } out } #' Expected Values of the Posterior Predictive Distribution #' #' This method is an alias of \code{\link{posterior_epred.brmsfit}} #' with additional arguments for obtaining summaries of the computed draws. #' #' @inheritParams posterior_epred.brmsfit #' @param object An object of class \code{brmsfit}. #' @param scale Either \code{"response"} or \code{"linear"}. #' If \code{"response"}, results are returned on the scale #' of the response variable. If \code{"linear"}, #' results are returned on the scale of the linear predictor term, #' that is without applying the inverse link function or #' other transformations. #' @param summary Should summary statistics be returned #' instead of the raw values? Default is \code{TRUE}.. #' @param robust If \code{FALSE} (the default) the mean is used as #' the measure of central tendency and the standard deviation as #' the measure of variability. If \code{TRUE}, the median and the #' median absolute deviation (MAD) are applied instead. #' Only used if \code{summary} is \code{TRUE}. #' @param probs The percentiles to be computed by the \code{quantile} #' function. Only used if \code{summary} is \code{TRUE}. #' #' @return An \code{array} of predicted \emph{mean} response values. #' If \code{summary = FALSE} the output resembles those of #' \code{\link{posterior_epred.brmsfit}}. #' #' If \code{summary = TRUE} the output depends on the family: For categorical #' and ordinal families, the output is an N x E x C array, where N is the #' number of observations, E is the number of summary statistics, and C is the #' number of categories. For all other families, the output is an N x E #' matrix. The number of summary statistics E is equal to \code{2 + #' length(probs)}: The \code{Estimate} column contains point estimates (either #' mean or median depending on argument \code{robust}), while the #' \code{Est.Error} column contains uncertainty estimates (either standard #' deviation or median absolute deviation depending on argument #' \code{robust}). The remaining columns starting with \code{Q} contain #' quantile estimates as specified via argument \code{probs}. #' #' In multivariate models, an additional dimension is added to the output #' which indexes along the different response variables. #' #' @seealso \code{\link{posterior_epred.brmsfit}} #' #' @examples #' \dontrun{ #' ## fit a model #' fit <- brm(rating ~ treat + period + carry + (1|subject), #' data = inhaler) #' #' ## compute expected predictions #' fitted_values <- fitted(fit) #' head(fitted_values) #' #' ## plot expected predictions against actual response #' dat <- as.data.frame(cbind(Y = standata(fit)$Y, fitted_values)) #' ggplot(dat) + geom_point(aes(x = Estimate, y = Y)) #' } #' #' @export fitted.brmsfit <- function(object, newdata = NULL, re_formula = NULL, scale = c("response", "linear"), resp = NULL, dpar = NULL, nlpar = NULL, ndraws = NULL, draw_ids = NULL, sort = FALSE, summary = TRUE, robust = FALSE, probs = c(0.025, 0.975), ...) { scale <- match.arg(scale) summary <- as_one_logical(summary) contains_draws(object) object <- restructure(object) prep <- prepare_predictions( object, newdata = newdata, re_formula = re_formula, resp = resp, ndraws = ndraws, draw_ids = draw_ids, check_response = FALSE, ... ) posterior_epred( prep, dpar = dpar, nlpar = nlpar, sort = sort, scale = scale, summary = summary, robust = robust, probs = probs ) } #' Posterior Draws of the Linear Predictor #' #' Compute posterior draws of the linear predictor, that is draws before #' applying any link functions or other transformations. Can be performed for #' the data used to fit the model (posterior predictive checks) or for new data. #' #' @inheritParams posterior_epred.brmsfit #' @param object An object of class \code{brmsfit}. #' @param transform Logical; if \code{FALSE} #' (the default), draws of the linear predictor are returned. #' If \code{TRUE}, draws of the transformed linear predictor, #' that is, after applying the inverse link function are returned. #' @param dpar Name of a predicted distributional parameter #' for which draws are to be returned. By default, draws #' of the main distributional parameter(s) \code{"mu"} are returned. #' @param incl_thres Logical; only relevant for ordinal models when #' \code{transform} is \code{FALSE}, and ignored otherwise. Shall the #' thresholds and category-specific effects be included in the linear #' predictor? For backwards compatibility, the default is to not include them. #' #' @seealso \code{\link{posterior_epred.brmsfit}} #' #' @examples #' \dontrun{ #' ## fit a model #' fit <- brm(rating ~ treat + period + carry + (1|subject), #' data = inhaler) #' #' ## extract linear predictor values #' pl <- posterior_linpred(fit) #' str(pl) #' } #' #' @aliases posterior_linpred #' @method posterior_linpred brmsfit #' @importFrom rstantools posterior_linpred #' @export #' @export posterior_linpred posterior_linpred.brmsfit <- function( object, transform = FALSE, newdata = NULL, re_formula = NULL, re.form = NULL, resp = NULL, dpar = NULL, nlpar = NULL, incl_thres = NULL, ndraws = NULL, draw_ids = NULL, sort = FALSE, ... ) { cl <- match.call() if ("re.form" %in% names(cl) && !missing(re.form)) { re_formula <- re.form } scale <- "linear" transform <- as_one_logical(transform) if (transform) { scale <- "response" # if transform, return inv-link draws of only a single # distributional or non-linear parameter for consistency # of brms and rstanarm if (is.null(dpar) && is.null(nlpar)) { dpar <- "mu" } } contains_draws(object) object <- restructure(object) prep <- prepare_predictions( object, newdata = newdata, re_formula = re_formula, resp = resp, ndraws = ndraws, draw_ids = draw_ids, check_response = FALSE, ... ) posterior_epred( prep, dpar = dpar, nlpar = nlpar, sort = sort, scale = scale, incl_thres = incl_thres, summary = FALSE ) } # ------------------- family specific posterior_epred methods --------------------- # All posterior_epred_ functions have the same arguments structure # @param prep A named list returned by prepare_predictions containing # all required data and draws # @return transformed linear predictor representing the mean # of the posterior predictive distribution posterior_epred_gaussian <- function(prep) { if (!is.null(prep$ac$lagsar)) { prep$dpars$mu <- posterior_epred_lagsar(prep) } prep$dpars$mu } posterior_epred_student <- function(prep) { if (!is.null(prep$ac$lagsar)) { prep$dpars$mu <- posterior_epred_lagsar(prep) } prep$dpars$mu } posterior_epred_skew_normal <- function(prep) { prep$dpars$mu } posterior_epred_lognormal <- function(prep) { with(prep$dpars, exp(mu + sigma^2 / 2)) } posterior_epred_shifted_lognormal <- function(prep) { with(prep$dpars, exp(mu + sigma^2 / 2) + ndt) } posterior_epred_binomial <- function(prep) { trials <- data2draws(prep$data$trials, dim_mu(prep)) prep$dpars$mu * trials } posterior_epred_beta_binomial <- function(prep) { trials <- data2draws(prep$data$trials, dim_mu(prep)) prep$dpars$mu * trials } posterior_epred_bernoulli <- function(prep) { prep$dpars$mu } posterior_epred_poisson <- function(prep) { multiply_dpar_rate_denom(prep$dpars$mu, prep) } posterior_epred_negbinomial <- function(prep) { multiply_dpar_rate_denom(prep$dpars$mu, prep) } posterior_epred_negbinomial2 <- function(prep) { multiply_dpar_rate_denom(prep$dpars$mu, prep) } posterior_epred_geometric <- function(prep) { multiply_dpar_rate_denom(prep$dpars$mu, prep) } posterior_epred_discrete_weibull <- function(prep) { mean_discrete_weibull(prep$dpars$mu, prep$dpars$shape) } posterior_epred_com_poisson <- function(prep) { mean_com_poisson(prep$dpars$mu, prep$dpars$shape) } posterior_epred_exponential <- function(prep) { prep$dpars$mu } posterior_epred_gamma <- function(prep) { prep$dpars$mu } posterior_epred_weibull <- function(prep) { prep$dpars$mu } posterior_epred_frechet <- function(prep) { prep$dpars$mu } posterior_epred_gen_extreme_value <- function(prep) { with(prep$dpars, mu + sigma * (gamma(1 - xi) - 1) / xi) } posterior_epred_inverse.gaussian <- function(prep) { prep$dpars$mu } posterior_epred_exgaussian <- function(prep) { prep$dpars$mu } posterior_epred_wiener <- function(prep) { # obtained from https://doi.org/10.1016/j.jmp.2009.01.006 # mu is the drift rate with(prep$dpars, ndt - bias / mu + bs / mu * (exp(-2 * mu * bias) - 1) / (exp(-2 * mu * bs) - 1) ) } posterior_epred_beta <- function(prep) { prep$dpars$mu } posterior_epred_xbeta <- function(prep) { # see https://arxiv.org/abs/2409.07233 for details mu <- get_dpar(prep, "mu") phi <- get_dpar(prep, "phi") nu <- get_dpar(prep, "kappa") a <- mu * phi b <- (1 - mu) * phi d <- (1 + 2 * nu) q0 <- nu / d q1 <- (1 + nu) / d t3 <- pbeta(q1, a, b) t1 <- d * mu * (pbeta(q1, a + 1, b) - pbeta(q0, a + 1, b)) t2 <- nu * (t3 - pbeta(q0, a, b)) 1 + t1 - t2 - t3 } posterior_epred_von_mises <- function(prep) { prep$dpars$mu } posterior_epred_asym_laplace <- function(prep) { with(prep$dpars, mu + sigma * (1 - 2 * quantile) / (quantile * (1 - quantile)) ) } posterior_epred_zero_inflated_asym_laplace <- function(prep) { posterior_epred_asym_laplace(prep) * (1 - prep$dpars$zi) } posterior_epred_cox <- function(prep) { stop2("Cannot compute expected values of the posterior predictive ", "distribution for family 'cox'.") } posterior_epred_hurdle_poisson <- function(prep) { with(prep$dpars, mu / (1 - exp(-mu)) * (1 - hu)) } posterior_epred_hurdle_negbinomial <- function(prep) { with(prep$dpars, mu / (1 - (shape / (mu + shape))^shape) * (1 - hu)) } posterior_epred_hurdle_gamma <- function(prep) { with(prep$dpars, mu * (1 - hu)) } posterior_epred_hurdle_lognormal <- function(prep) { with(prep$dpars, exp(mu + sigma^2 / 2) * (1 - hu)) } posterior_epred_hurdle_cumulative <- function(prep) { adjust <- ifelse(prep$family$link == "identity", 0, 1) ncat_max <- max(prep$data$nthres) + adjust nact_min <- min(prep$data$nthres) + adjust init_mat <- matrix( ifelse(prep$family$link == "identity", NA, 0), nrow = prep$ndraws, ncol = ncat_max - nact_min ) args <- list(link = prep$family$link) out <- vector("list", prep$nobs) for (i in seq_along(out)) { args_i <- args args_i$eta <- slice_col(get_dpar(prep, "mu", i)) args_i$disc <- slice_col(get_dpar(prep, "disc", i)) args_i$thres <- subset_thres(prep, i) ncat_i <- NCOL(args_i$thres) + adjust args_i$x <- seq_len(ncat_i) out[[i]] <- do_call(dcumulative, args_i) if (ncat_i < ncat_max) { sel <- seq_len(ncat_max - ncat_i) out[[i]] <- cbind(out[[i]], init_mat[, sel]) } hu <- get_dpar(prep, "hu", i) out[[i]] <- cbind(hu, out[[i]] * (1 - hu)) } out <- abind(out, along = 3) out <- aperm(out, perm = c(1, 3, 2)) dimnames(out)[[3]] <- c(paste0(0), seq_len(ncat_max)) out } posterior_epred_zero_inflated_poisson <- function(prep) { with(prep$dpars, mu * (1 - zi)) } posterior_epred_zero_inflated_negbinomial <- function(prep) { with(prep$dpars, mu * (1 - zi)) } posterior_epred_zero_inflated_binomial <- function(prep) { trials <- data2draws(prep$data$trials, dim_mu(prep)) prep$dpars$mu * trials * (1 - prep$dpars$zi) } posterior_epred_zero_inflated_beta_binomial <- function(prep) { # same as zero_inflated_binom as beta part is included in mu trials <- data2draws(prep$data$trials, dim_mu(prep)) prep$dpars$mu * trials * (1 - prep$dpars$zi) } posterior_epred_zero_inflated_beta <- function(prep) { with(prep$dpars, mu * (1 - zi)) } posterior_epred_zero_one_inflated_beta <- function(prep) { with(prep$dpars, zoi * coi + mu * (1 - zoi)) } posterior_epred_categorical <- function(prep) { get_probs <- function(i) { eta <- insert_refcat(slice_col(eta, i), refcat = prep$refcat) dcategorical(cats, eta = eta) } eta <- get_Mu(prep) cats <- seq_len(prep$data$ncat) out <- abind(lapply(seq_cols(eta), get_probs), along = 3) out <- aperm(out, perm = c(1, 3, 2)) dimnames(out)[[3]] <- prep$cats out } posterior_epred_multinomial <- function(prep) { get_counts <- function(i) { eta <- insert_refcat(slice_col(eta, i), refcat = prep$refcat) dcategorical(cats, eta = eta) * trials[i] } eta <- get_Mu(prep) cats <- seq_len(prep$data$ncat) trials <- prep$data$trials out <- abind(lapply(seq_cols(eta), get_counts), along = 3) out <- aperm(out, perm = c(1, 3, 2)) dimnames(out)[[3]] <- prep$cats out } posterior_epred_dirichlet_multinomial <- function(prep) { # mean of dirichlet-multinomial is equal to multinomial # (phi only affects variance of distribution) posterior_epred_multinomial(prep) } posterior_epred_dirichlet <- function(prep) { get_probs <- function(i) { eta <- insert_refcat(slice_col(eta, i), refcat = prep$refcat) dcategorical(cats, eta = eta) } eta <- get_Mu(prep) cats <- seq_len(prep$data$ncat) out <- abind(lapply(seq_cols(eta), get_probs), along = 3) out <- aperm(out, perm = c(1, 3, 2)) dimnames(out)[[3]] <- prep$cats out } posterior_epred_dirichlet2 <- function(prep) { mu <- get_Mu(prep) sums_mu <- apply(mu, 1:2, sum) cats <- seq_len(prep$data$ncat) for (i in cats) { mu[, , i] <- mu[, , i] / sums_mu } dimnames(mu)[[3]] <- prep$cats mu } posterior_epred_logistic_normal <- function(prep) { stop2("Cannot compute expected values of the posterior predictive ", "distribution for family 'logistic_normal'.") } posterior_epred_cumulative <- function(prep) { posterior_epred_ordinal(prep) } posterior_epred_sratio <- function(prep) { posterior_epred_ordinal(prep) } posterior_epred_cratio <- function(prep) { posterior_epred_ordinal(prep) } posterior_epred_acat <- function(prep) { posterior_epred_ordinal(prep) } posterior_epred_custom <- function(prep) { custom_family_method(prep$family, "posterior_epred")(prep) } posterior_epred_mixture <- function(prep) { families <- family_names(prep$family) prep$dpars$theta <- get_theta(prep) out <- 0 for (j in seq_along(families)) { posterior_epred_fun <- paste0("posterior_epred_", families[j]) posterior_epred_fun <- get(posterior_epred_fun, asNamespace("brms")) tmp_prep <- pseudo_prep_for_mixture(prep, j) if (length(dim(prep$dpars$theta)) == 3L) { theta <- prep$dpars$theta[, , j] } else { theta <- prep$dpars$theta[, j] } out <- out + theta * posterior_epred_fun(tmp_prep) } out } # ------ posterior_epred helper functions ------ # compute 'posterior_epred' for ordinal models posterior_epred_ordinal <- function(prep) { dens <- get(paste0("d", prep$family$family), mode = "function") # the linear scale has one column less than the response scale adjust <- ifelse(prep$family$link == "identity", 0, 1) ncat_max <- max(prep$data$nthres) + adjust nact_min <- min(prep$data$nthres) + adjust init_mat <- matrix(ifelse(prep$family$link == "identity", NA, 0), nrow = prep$ndraws, ncol = ncat_max - nact_min) args <- list(link = prep$family$link) out <- vector("list", prep$nobs) for (i in seq_along(out)) { args_i <- args args_i$eta <- slice_col(prep$dpars$mu, i) args_i$disc <- slice_col(prep$dpars$disc, i) args_i$thres <- subset_thres(prep, i) ncat_i <- NCOL(args_i$thres) + adjust args_i$x <- seq_len(ncat_i) out[[i]] <- do_call(dens, args_i) if (ncat_i < ncat_max) { sel <- seq_len(ncat_max - ncat_i) out[[i]] <- cbind(out[[i]], init_mat[, sel]) } } out <- abind(out, along = 3) out <- aperm(out, perm = c(1, 3, 2)) dimnames(out)[[3]] <- seq_len(ncat_max) out } # compute 'posterior_epred' for lagsar models posterior_epred_lagsar <- function(prep) { stopifnot(!is.null(prep$ac$lagsar)) I <- diag(prep$nobs) .posterior_epred <- function(s) { IB <- I - with(prep$ac, lagsar[s, ] * Msar) as.numeric(solve(IB, prep$dpars$mu[s, ])) } out <- rblapply(seq_len(prep$ndraws), .posterior_epred) rownames(out) <- NULL out } # expand data to dimension appropriate for # vectorized multiplication with posterior draws data2draws <- function(x, dim) { stopifnot(length(dim) %in% 2:3) if (length(dim) == 2) { # expand vector into a matrix of draws stopifnot(length(x) %in% c(1, dim[2])) out <- matrix(x, nrow = dim[1], ncol = dim[2], byrow = TRUE) } else { # expand matrix into an array of draws stopifnot(length(x) == 1 || is_equal(dim(x), dim[2:3])) out <- array(x, dim = c(dim[2:3], dim[1])) out <- aperm(out, perm = c(3, 1, 2)) } out } # expected dimension of the main parameter 'mu' dim_mu <- function(prep) { c(prep$ndraws, prep$nobs) } # is the model truncated? is_trunc <- function(prep) { stopifnot(is.brmsprep(prep)) any(prep$data[["lb"]] > -Inf) || any(prep$data[["ub"]] < Inf) } # prepares data required for truncation and calles the # family specific truncation function for posterior_epred values posterior_epred_trunc <- function(prep) { stopifnot(is_trunc(prep)) lb <- data2draws(prep$data[["lb"]], dim_mu(prep)) ub <- data2draws(prep$data[["ub"]], dim_mu(prep)) posterior_epred_trunc_fun <- paste0("posterior_epred_trunc_", prep$family$family) posterior_epred_trunc_fun <- try( get(posterior_epred_trunc_fun, asNamespace("brms")), silent = TRUE ) if (is_try_error(posterior_epred_trunc_fun)) { stop2("posterior_epred values on the respone scale not yet implemented ", "for truncated '", prep$family$family, "' models.") } trunc_args <- nlist(prep, lb, ub) do_call(posterior_epred_trunc_fun, trunc_args) } # ----- family specific truncation functions ----- # @param prep output of 'prepare_predictions' # @param lb lower truncation bound # @param ub upper truncation bound # @return draws of the truncated mean parameter posterior_epred_trunc_gaussian <- function(prep, lb, ub) { zlb <- (lb - prep$dpars$mu) / prep$dpars$sigma zub <- (ub - prep$dpars$mu) / prep$dpars$sigma # truncated mean of standard normal; see Wikipedia trunc_zmean <- (dnorm(zlb) - dnorm(zub)) / (pnorm(zub) - pnorm(zlb)) prep$dpars$mu + trunc_zmean * prep$dpars$sigma } posterior_epred_trunc_student <- function(prep, lb, ub) { zlb <- with(prep$dpars, (lb - mu) / sigma) zub <- with(prep$dpars, (ub - mu) / sigma) nu <- prep$dpars$nu # see Kim 2008: Moments of truncated Student-t distribution G1 <- gamma((nu - 1) / 2) * nu^(nu / 2) / (2 * (pt(zub, df = nu) - pt(zlb, df = nu)) * gamma(nu / 2) * gamma(0.5)) A <- (nu + zlb^2) ^ (-(nu - 1) / 2) B <- (nu + zub^2) ^ (-(nu - 1) / 2) trunc_zmean <- G1 * (A - B) prep$dpars$mu + trunc_zmean * prep$dpars$sigma } posterior_epred_trunc_lognormal <- function(prep, lb, ub) { lb <- ifelse(lb < 0, 0, lb) m1 <- with(prep$dpars, exp(mu + sigma^2 / 2) * (pnorm((log(ub) - mu) / sigma - sigma) - pnorm((log(lb) - mu) / sigma - sigma)) ) with(prep$dpars, m1 / (plnorm(ub, meanlog = mu, sdlog = sigma) - plnorm(lb, meanlog = mu, sdlog = sigma)) ) } posterior_epred_trunc_gamma <- function(prep, lb, ub) { lb <- ifelse(lb < 0, 0, lb) prep$dpars$scale <- prep$dpars$mu / prep$dpars$shape # see Jawitz 2004: Moments of truncated continuous univariate distributions m1 <- with(prep$dpars, scale / gamma(shape) * (incgamma(1 + shape, ub / scale) - incgamma(1 + shape, lb / scale)) ) with(prep$dpars, m1 / (pgamma(ub, shape, scale = scale) - pgamma(lb, shape, scale = scale)) ) } posterior_epred_trunc_exponential <- function(prep, lb, ub) { lb <- ifelse(lb < 0, 0, lb) inv_mu <- 1 / prep$dpars$mu # see Jawitz 2004: Moments of truncated continuous univariate distributions m1 <- with(prep$dpars, mu * (incgamma(2, ub / mu) - incgamma(2, lb / mu))) m1 / (pexp(ub, rate = inv_mu) - pexp(lb, rate = inv_mu)) } posterior_epred_trunc_weibull <- function(prep, lb, ub) { lb <- ifelse(lb < 0, 0, lb) prep$dpars$a <- 1 + 1 / prep$dpars$shape prep$dpars$scale <- with(prep$dpars, mu / gamma(a)) # see Jawitz 2004: Moments of truncated continuous univariate distributions m1 <- with(prep$dpars, scale * (incgamma(a, (ub / scale)^shape) - incgamma(a, (lb / scale)^shape)) ) with(prep$dpars, m1 / (pweibull(ub, shape, scale = scale) - pweibull(lb, shape, scale = scale)) ) } posterior_epred_trunc_binomial <- function(prep, lb, ub) { lb <- ifelse(lb < -1, -1, lb) max_value <- max(prep$data$trials) ub <- ifelse(ub > max_value, max_value, ub) trials <- prep$data$trials if (length(trials) > 1) { trials <- data2draws(trials, dim_mu(prep)) } args <- list(size = trials, prob = prep$dpars$mu) posterior_epred_trunc_discrete(dist = "binom", args = args, lb = lb, ub = ub) } posterior_epred_trunc_poisson <- function(prep, lb, ub) { lb <- ifelse(lb < -1, -1, lb) mu <- multiply_dpar_rate_denom(prep$dpars$mu, prep) max_value <- 3 * max(mu) ub <- ifelse(ub > max_value, max_value, ub) args <- list(lambda = mu) posterior_epred_trunc_discrete(dist = "pois", args = args, lb = lb, ub = ub) } posterior_epred_trunc_negbinomial <- function(prep, lb, ub) { lb <- ifelse(lb < -1, -1, lb) mu <- multiply_dpar_rate_denom(prep$dpars$mu, prep) max_value <- 3 * max(mu) ub <- ifelse(ub > max_value, max_value, ub) shape <- multiply_dpar_rate_denom(prep$dpars$shape, prep) args <- list(mu = mu, size = shape) posterior_epred_trunc_discrete(dist = "nbinom", args = args, lb = lb, ub = ub) } posterior_epred_trunc_negbinomial2 <- function(prep, lb, ub) { lb <- ifelse(lb < -1, -1, lb) mu <- multiply_dpar_rate_denom(prep$dpars$mu, prep) max_value <- 3 * max(mu) ub <- ifelse(ub > max_value, max_value, ub) shape <- multiply_dpar_rate_denom(1 / prep$dpars$sigma, prep) args <- list(mu = mu, size = shape) posterior_epred_trunc_discrete(dist = "nbinom", args = args, lb = lb, ub = ub) } posterior_epred_trunc_geometric <- function(prep, lb, ub) { lb <- ifelse(lb < -1, -1, lb) mu <- multiply_dpar_rate_denom(prep$dpars$mu, prep) max_value <- 3 * max(mu) ub <- ifelse(ub > max_value, max_value, ub) shape <- multiply_dpar_rate_denom(1, prep) args <- list(mu = mu, size = shape) posterior_epred_trunc_discrete(dist = "nbinom", args = args, lb = lb, ub = ub) } # posterior_epred values for truncated discrete distributions posterior_epred_trunc_discrete <- function(dist, args, lb, ub) { stopifnot(is.matrix(lb), is.matrix(ub)) message( "Computing posterior_epred values for truncated ", "discrete models may take a while." ) pdf <- get(paste0("d", dist), mode = "function") cdf <- get(paste0("p", dist), mode = "function") mean_kernel <- function(x, args) { # just x * density(x) x * do_call(pdf, c(x, args)) } if (any(is.infinite(c(lb, ub)))) { stop("lb and ub must be finite") } # simplify lb and ub back to vector format vec_lb <- lb[1, ] vec_ub <- ub[1, ] min_lb <- min(vec_lb) # array of dimension S x N x length((lb+1):ub) mk <- lapply((min_lb + 1):max(vec_ub), mean_kernel, args = args) mk <- do_call(abind, c(mk, along = 3)) m1 <- vector("list", ncol(mk)) for (n in seq_along(m1)) { # summarize only over non-truncated values for this observation J <- (vec_lb[n] - min_lb + 1):(vec_ub[n] - min_lb) m1[[n]] <- rowSums(mk[, n, ][, J, drop = FALSE]) } rm(mk) m1 <- do.call(cbind, m1) m1 / (do.call(cdf, c(list(ub), args)) - do.call(cdf, c(list(lb), args))) } #' @export pp_expect <- function(object, ...) { warning2("Method 'pp_expect' is deprecated. ", "Please use 'posterior_epred' instead.") UseMethod("posterior_epred") } brms/R/zzz.R0000644000176200001440000000134015053072461012377 0ustar liggesusers# Uncomment the code below to enable unit tests for new stan functions # new_stan_functions <- function() { # # copy all new stan functions into a single .stan file and compile it # isystem <- system.file("chunks", package = "brms") # chunk_filenames <- list.files(isystem, pattern = "^fun_") # temp_file <- tempfile() # cat(paste0("functions { \n", # collapse(" #include '", chunk_filenames, "' \n"), # collapse(ordinal_funs), "} \nmodel {} \n"), # file = temp_file) # model <- rstan::stanc_builder(file = temp_file, isystem = isystem, # obfuscate_model_name = TRUE) # rstan::stan_model(stanc_ret = model) # } # new_stan_functions <- new_stan_functions() brms/R/posterior_samples.R0000644000176200001440000002051014536546474015333 0ustar liggesusers#' (Deprecated) Extract Posterior Samples #' #' Extract posterior samples of specified parameters. The #' \code{posterior_samples} method is deprecated. We recommend using the more #' modern and consistent \code{\link[brms:draws-brms]{as_draws_*}} extractor #' functions of the \pkg{posterior} package instead. #' #' @param x An \code{R} object typically of class \code{brmsfit} #' @param pars Names of parameters for which posterior samples #' should be returned, as given by a character vector or regular expressions. #' By default, all posterior samples of all parameters are extracted. #' @param fixed Indicates whether parameter names #' should be matched exactly (\code{TRUE}) or treated as #' regular expressions (\code{FALSE}). Default is \code{FALSE}. #' @param add_chain A flag indicating if the returned \code{data.frame} #' should contain two additional columns. The \code{chain} column #' indicates the chain in which each sample was generated, the \code{iter} #' column indicates the iteration number within each chain. #' @param subset A numeric vector indicating the rows #' (i.e., posterior samples) to be returned. #' If \code{NULL} (the default), all posterior samples are returned. #' @param as.matrix Should the output be a \code{matrix} #' instead of a \code{data.frame}? Defaults to \code{FALSE}. #' @param as.array Should the output be an \code{array} #' instead of a \code{data.frame}? Defaults to \code{FALSE}. #' @param ... Arguments passed to individual methods (if applicable). #' #' @return A data.frame (matrix or array) containing the posterior samples. #' #' @seealso \code{\link[brms:draws-brms]{as_draws}}, #' \code{\link[brms:as.data.frame.brmsfit]{as.data.frame}} #' #' @examples #' \dontrun{ #' fit <- brm(rating ~ treat + period + carry + (1|subject), #' data = inhaler, family = "cumulative") #' #' # extract posterior samples of population-level effects #' samples1 <- posterior_samples(fit, pars = "^b") #' head(samples1) #' #' # extract posterior samples of group-level standard deviations #' samples2 <- posterior_samples(fit, pars = "^sd_") #' head(samples2) #' } #' #' @export posterior_samples.brmsfit <- function(x, pars = NA, fixed = FALSE, add_chain = FALSE, subset = NULL, as.matrix = FALSE, as.array = FALSE, ...) { if (as.matrix && as.array) { stop2("Cannot use 'as.matrix' and 'as.array' at the same time.") } if (add_chain && as.array) { stop2("Cannot use 'add_chain' and 'as.array' at the same time.") } contains_draws(x) pars <- extract_pars(pars, variables(x), fixed = fixed, ...) # get basic information on the samples iter <- x$fit@sim$iter warmup <- x$fit@sim$warmup thin <- x$fit@sim$thin chains <- x$fit@sim$chains final_iter <- ceiling((iter - warmup) / thin) samples_taken <- seq(warmup + 1, iter, thin) samples <- NULL if (length(pars)) { if (as.matrix) { samples <- as.matrix(x$fit, pars = pars) } else if (as.array) { samples <- as.array(x$fit, pars = pars) } else { samples <- as.data.frame(x$fit, pars = pars) } if (add_chain) { # name the column 'chain' not 'chains' (#32) samples <- cbind(samples, chain = factor(rep(1:chains, each = final_iter)), iter = rep(samples_taken, chains) ) } if (!is.null(subset)) { if (as.array) { samples <- samples[subset, , , drop = FALSE] } else { samples <- samples[subset, , drop = FALSE] } } } samples } #' @rdname posterior_samples.brmsfit #' @export posterior_samples <- function(x, pars = NA, ...) { warning2("Method 'posterior_samples' is deprecated. ", "Please see ?as_draws for recommended alternatives.") UseMethod("posterior_samples") } #' @export posterior_samples.default <- function(x, pars = NA, fixed = FALSE, ...) { x <- as.data.frame(x) if (!anyNA(pars)) { pars <- extract_pars(pars, all_pars = names(x), fixed = fixed, ...) x <- x[, pars, drop = FALSE] } if (!ncol(x)) { x <- NULL } x } #' Extract Parameter Names #' #' Extract all parameter names of a given model. #' #' @aliases parnames.brmsfit #' #' @param x An \R object #' @param ... Further arguments passed to or from other methods. #' #' @return A character vector containing the parameter names of the model. #' #' @export parnames <- function(x, ...) { warning2("'parnames' is deprecated. Please use 'variables' instead.") UseMethod("parnames") } #' @export parnames.default <- function(x, ...) { names(x) } #' @export parnames.brmsfit <- function(x, ...) { out <- dimnames(x$fit) if (is.list(out)) { out <- out$parameters } out } # extract all valid parameter names that match pars # @param pars A character vector or regular expression # @param all_pars all parameter names of the fitted model # @param fixed should parameter names be matched exactly? # @param exact_match deprecated alias of fixed # @param na_value: what should be returned if pars is NA? # @param ... Further arguments to be passed to grepl # @return A character vector of parameter names extract_pars <- function(pars, all_pars, fixed = FALSE, exact_match = FALSE, na_value = all_pars, ...) { if (!(anyNA(pars) || is.character(pars))) { stop2("Argument 'pars' must be NA or a character vector.") } fixed <- check_deprecated_fixed(fixed, exact_match) if (!anyNA(pars)) { fixed <- as_one_logical(fixed) if (fixed) { out <- intersect(pars, all_pars) } else { out <- vector("list", length(pars)) for (i in seq_along(pars)) { out[[i]] <- all_pars[grepl(pars[i], all_pars, ...)] } out <- unique(unlist(out)) } } else { out <- na_value } out } # check deprecated alias of argument 'fixed' check_deprecated_fixed <- function(fixed, exact_match) { if (!isFALSE(exact_match)) { # deprecated as of brms 2.10.6; remove in brms 3.0 warning2("Argument 'exact_match' is deprecated. ", "Please use 'fixed' instead.") fixed <- exact_match } fixed } #' (Deprecated) Extract posterior samples for use with the \pkg{coda} package #' #' The \code{as.mcmc} method is deprecated. We recommend using the more #' modern and consistent \code{\link[brms:draws-brms]{as_draws_*}} extractor #' functions of the \pkg{posterior} package instead. #' #' @aliases as.mcmc #' #' @inheritParams posterior_samples.brmsfit #' @param ... currently unused #' @param combine_chains Indicates whether chains should be combined. #' @param inc_warmup Indicates if the warmup samples should be included. #' Default is \code{FALSE}. Warmup samples are used to tune the #' parameters of the sampling algorithm and should not be analyzed. #' #' @return If \code{combine_chains = TRUE} an \code{mcmc} object is returned. #' If \code{combine_chains = FALSE} an \code{mcmc.list} object is returned. #' #' @method as.mcmc brmsfit #' @export #' @export as.mcmc #' @importFrom coda as.mcmc as.mcmc.brmsfit <- function(x, pars = NA, fixed = FALSE, combine_chains = FALSE, inc_warmup = FALSE, ...) { warning2("as.mcmc.brmsfit is deprecated and will eventually be removed.") contains_draws(x) pars <- extract_pars(pars, all_pars = variables(x), fixed = fixed, ...) combine_chains <- as_one_logical(combine_chains) inc_warmup <- as_one_logical(inc_warmup) if (combine_chains) { if (inc_warmup) { stop2("Cannot include warmup samples when 'combine_chains' is TRUE.") } out <- as.matrix(x$fit, pars) ndraws <- nrow(out) end <- x$fit@sim$iter * x$fit@sim$chains thin <- x$fit@sim$thin start <- end - (ndraws - 1) * thin mcpar <- c(start, end, thin) attr(out, "mcpar") <- mcpar class(out) <- "mcmc" } else { thin <- x$fit@sim$thin if (inc_warmup && thin >= 2) { stop2("Cannot include warmup samples when 'thin' >= 2.") } ps <- rstan::extract(x$fit, pars, permuted = FALSE, inc_warmup = inc_warmup) ndraws <- dim(ps)[1] end <- x$fit@sim$iter start <- end - (ndraws - 1) * thin mcpar <- c(start, end, thin) out <- vector("list", length = dim(ps)[2]) for (i in seq_along(out)) { out[[i]] <- ps[, i, ] attr(out[[i]], "mcpar") <- mcpar class(out[[i]]) <- "mcmc" } class(out) <- "mcmc.list" } out } brms/R/ggplot-themes.R0000644000176200001440000000660614527413457014344 0ustar liggesusers#' (Deprecated) Black Theme for \pkg{ggplot2} Graphics #' #' A black theme for ggplot graphics inspired by a blog post of Jon Lefcheck #' (\url{https://jonlefcheck.net/2013/03/11/black-theme-for-ggplot2-2/}). #' #' @param base_size base font size #' @param base_family base font family #' #' @return A \code{theme} object used in \pkg{ggplot2} graphics. #' #' @details When using \code{theme_black} in plots powered by the #' \pkg{bayesplot} package such as \code{pp_check} or \code{stanplot}, #' I recommend using the \code{"viridisC"} color scheme (see examples). #' #' @examples #' \dontrun{ #' # change default ggplot theme #' ggplot2::theme_set(theme_black()) #' #' # change default bayesplot color scheme #' bayesplot::color_scheme_set("viridisC") #' #' # fit a simple model #' fit <- brm(count ~ zAge + zBase * Trt + (1|patient), #' data = epilepsy, family = poisson(), chains = 2) #' summary(fit) #' #' # create various plots #' plot(marginal_effects(fit), ask = FALSE) #' pp_check(fit) #' mcmc_plot(fit, type = "hex", variable = c("b_Intercept", "b_Trt1")) #' } #' #' @export theme_black = function(base_size = 12, base_family = "") { warning2("'theme_black' is deprecated. Please use the 'ggdark' package ", "for dark ggplot themes.") theme_grey(base_size = base_size, base_family = base_family) %+replace% theme( # axis options axis.line = element_blank(), axis.text.x = element_text( size = base_size * 0.8, color = "white", lineheight = 0.9 ), axis.text.y = element_text( size = base_size * 0.8, color = "white", lineheight = 0.9 ), axis.ticks = element_line(color = "white", size = 0.2), axis.title.x = element_text( size = base_size, color = "white", margin = margin(10, 0, 0, 0) ), axis.title.y = element_text( size = base_size, color = "white", angle = 90, margin = margin(0, 10, 0, 0) ), axis.ticks.length = unit(0.3, "lines"), # legend options legend.background = element_rect(color = NA, fill = "black"), legend.key = element_rect(color = "white", fill = "black"), legend.key.size = unit(1.2, "lines"), legend.key.height = NULL, legend.key.width = NULL, legend.text = element_text(size = base_size * 0.8, color = "white"), legend.title = element_text( size = base_size * 0.8, face = "bold", hjust = 0, color = "white" ), legend.position = "right", legend.text.align = NULL, legend.title.align = NULL, legend.direction = "vertical", legend.box = NULL, # panel options panel.background = element_rect(fill = "black", color = NA), panel.border = element_rect(fill = NA, color = "white"), panel.grid.major = element_line(color = "grey35"), panel.grid.minor = element_line(color = "grey20"), panel.spacing = unit(0.5, "lines"), # facetting options strip.background = element_rect(fill = "grey30", color = "grey10"), strip.text.x = element_text( size = base_size * 0.8, color = "white", margin = margin(3, 0, 4, 0) ), strip.text.y = element_text( size = base_size * 0.8, color = "white", angle = -90 ), # plot options plot.background = element_rect(color = "black", fill = "black"), plot.title = element_text(size = base_size * 1.2, color = "white"), plot.margin = unit(rep(1, 4), "lines") ) } brms/R/loo_subsample.R0000644000176200001440000000472314777730214014427 0ustar liggesusers#' Efficient approximate leave-one-out cross-validation (LOO) using subsampling #' #' @aliases loo_subsample #' #' @inheritParams loo.brmsfit #' #' @details More details can be found on #' \code{\link[loo:loo_subsample]{loo_subsample}}. #' #' @examples #' \dontrun{ #' # model with population-level effects only #' fit1 <- brm(rating ~ treat + period + carry, #' data = inhaler) #' (loo1 <- loo_subsample(fit1)) #' #' # model with an additional varying intercept for subjects #' fit2 <- brm(rating ~ treat + period + carry + (1|subject), #' data = inhaler) #' (loo2 <- loo_subsample(fit2)) #' #' # compare both models #' loo_compare(loo1, loo2) #' } #' #' @importFrom loo loo_subsample #' @export loo_subsample #' @export loo_subsample.brmsfit <- function(x, ..., compare = TRUE, resp = NULL, model_names = NULL) { args <- split_dots(x, ..., model_names = model_names) c(args) <- nlist( criterion = "loo_subsample", compare, resp, add_point_estimate = TRUE ) do_call(compute_loolist, args) } # compute 'loo_subsample' criterion using the 'loo' package # @param model_name ignored but included to avoid being passed to '...' .loo_subsample <- function(x, newdata, resp, model_name, ...) { loo_args <- prepare_loo_args( x, newdata = newdata, resp = resp, pointwise = TRUE, ... ) do_call("loo_subsample", loo_args, pkg = "loo") } # methods required in loo_subsample #' @importFrom loo .ndraws #' @export .ndraws.brmsprep <- function(x) { x$ndraws } #' @export .ndraws.mvbrmsprep <- function(x) { x$ndraws } #' @importFrom loo .thin_draws #' @export .thin_draws.brmsprep <- function(draws, loo_approximation_draws) { # brmsprep objects are too complex to implement a post-hoc subsetting method if (length(loo_approximation_draws)) { stop2("'loo_approximation_draws' is not supported for brmsfit objects.") } draws } #' @export .thin_draws.mvbrmsprep <- function(draws, loo_approximation_draws) { if (length(loo_approximation_draws)) { stop2("'loo_approximation_draws' is not supported for brmsfit objects.") } draws } #' @importFrom loo .compute_point_estimate #' @export .compute_point_estimate.brmsprep <- function(draws) { # point estimates are stored in the form of an attribute rather # than computed on the fly due to the complexity of brmsprep objects attr(draws, "point_estimate") } #' @export .compute_point_estimate.mvbrmsprep <- function(draws) { attr(draws, "point_estimate") } brms/R/restructure.R0000644000176200001440000006361415053072461014145 0ustar liggesusers#' Restructure Old R Objects #' #' \code{restructure} is a generic function used to restructure old R objects to #' work with newer versions of the package that generated them. Its original #' use is within the \pkg{brms} package, but new methods for use with objects #' from other packages can be registered to the same generic. #' #' @param x An object to be restructured. The object's class will determine #' which method to apply #' @param ... Additional arguments to pass to the specific methods #' #' @details Usually the version of the package that generated the object will be #' stored somewhere in the object and this information will be used by the #' specific method to determine what transformations to apply. See #' \code{\link[brms:restructure.brmsfit]{restructure.brmsfit}} for the default #' method applied for \pkg{brms} models. You can view the available methods by #' typing: \code{methods(restructure)} #' #' @return An object of the same class as \code{x} compatible with the latest #' version of the package that generated it. #' #' @seealso \code{\link{restructure.brmsfit}} #' @export restructure <- function(x, ...) { UseMethod("restructure") } #' Restructure Old \code{brmsfit} Objects #' #' Restructure old \code{brmsfit} objects to work with #' the latest \pkg{brms} version. This function is called #' internally when applying post-processing methods. #' However, in order to avoid unnecessary run time caused #' by the restructuring, I recommend explicitly calling #' \code{restructure} once per model after updating \pkg{brms}. #' #' @param x An object of class \code{brmsfit}. #' @param ... Currently ignored. #' #' @details #' If you are restructuring an old spline model (fitted with brms < 2.19.3) to #' avoid prediction inconsistencies between machines (see GitHub issue #1465), #' please make sure to \code{restructure} your model on the machine on which it #' was originally fitted. #' #' @return A \code{brmsfit} object compatible with the latest version #' of \pkg{brms}. #' #' @export restructure.brmsfit <- function(x, ...) { if (is.null(x$version)) { # this is the latest version without saving the version number x$version <- list(brms = package_version("0.9.1")) } else if (is.package_version(x$version)) { # also added the rstan version in brms 1.5.0 x$version <- list(brms = x$version) } current_version <- utils::packageVersion("brms") restr_version <- restructure_version(x) if (restr_version >= current_version) { # object is up to date with the current brms version return(x) } if (restr_version < "2.0.0") { x <- restructure_v1(x) } if (restr_version < "3.0.0") { x <- restructure_v2(x) } # remember the version with which the object was restructured x$version$restructure <- current_version # remove unused attribute attr(x, "restructured") <- NULL x } restructure_v2 <- function(x) { # restructure models fitted with brms 2.x x$formula <- update_old_family(x$formula) bterms <- SW(brmsterms(x$formula)) pars <- variables(x) version <- restructure_version(x) if (version < "2.1.2") { x <- do_renaming(x, rename_old_bsp(pars)) } if (version < "2.1.3") { if ("weibull" %in% family_names(x)) { stop_parameterization_changed("weibull", "2.1.3") } } if (version < "2.1.8") { if ("exgaussian" %in% family_names(x)) { stop_parameterization_changed("exgaussian", "2.1.8") } } if (version < "2.1.9") { # reworked 'me' terms (#372) meframe <- frame_me(bterms, model.frame(x)) if (isTRUE(nrow(meframe) > 0)) { warning2( "Measurement error ('me') terms have been reworked ", "in version 2.1.9. I strongly recommend refitting your ", "model with the latest version of brms." ) } } if (version < "2.2.4") { # added 'dist' argument to grouping terms x$ranef <- frame_re(bterms, model.frame(x)) } if (version < "2.3.7") { check_old_nl_dpars(bterms) } if (version < "2.8.3") { # argument 'sparse' is now specified within 'formula' sparse <- if (grepl("sparse matrix", stancode(x))) TRUE x$formula <- SW(validate_formula(x$formula, data = x$data, sparse = sparse)) } if (version < "2.8.4") { x <- rescale_old_mo(x) } if (version < "2.8.5") { if (any(grepl("^arr(\\[|_|$)", pars))) { warning2("ARR structures are no longer supported.") } } if (version < "2.8.6") { # internal handling of special effects terms has changed # this requires updating the 'terms' attribute of the data x$data <- rm_attr(x$data, c("brmsframe", "terms")) x$data <- validate_data(x$data, bterms) } if (version < "2.8.9") { if (any(grepl("^loclev(\\[|_|$)", pars))) { warning2("BSTS structures are no longer supported.") } } if (version < "2.10.4") { # model fit criteria have been moved to x$criteria criterion_names <- c("loo", "waic", "kfold", "R2", "marglik") criteria <- x[intersect(criterion_names, names(x))] x[criterion_names] <- NULL # rename 'R2' to 'bayes_R2' according to #793 names(criteria)[names(criteria) == "R2"] <- "bayes_R2" x$criteria <- criteria } if (version < "2.10.5") { # new slot 'thres' stored inside ordinal families if (is_ordinal(x$formula)) { x$formula <- SW(validate_formula(x$formula, data = x$data)) } } if (version < "2.11.2") { # 'autocor' was integrated into the formula interface x$formula <- SW(validate_formula(x$formula)) x$data2 <- validate_data2( data2 = list(), bterms = bterms, get_data2_autocor(x$formula) ) } if (version < "2.11.3") { # ordering after IDs matches the order of the posterior draws # if multiple IDs are used for the same grouping factor (#835) x$ranef <- x$ranef[order(x$ranef$id), , drop = FALSE] } if (version < "2.11.5") { # 'cats' is stored inside ordinal families again if (is_ordinal(x$formula)) { x$formula <- SW(validate_formula(x$formula, data = x$data)) } } if (version < "2.12.5") { # 'cov_ranef' was integrated into the formula interface if (length(x$cov_ranef)) { x$formula <- SW(validate_formula(x$formula, cov_ranef = x$cov_ranef)) cov_ranef <- get_data2_cov_ranef(x$formula) x$data2[names(cov_ranef)] <- cov_ranef } } if (version < "2.12.6") { # minor structural changes as part of internal interface improvements attr(x$data, "data_name") <- x$data.name x$stanvars <- SW(validate_stanvars(x$stanvars, stan_funs = x$stan_funs)) } if (version < "2.12.11") { # argument 'position' was added to stanvars for (i in seq_along(x$stanvars)) { x$stanvars[[i]]$position <- "start" } } if (version < "2.13.2") { # added support for 'cmdstanr' as additional backend x$backend <- "rstan" } if (version < "2.13.5") { # see issue #962 for discussion if ("cox" %in% family_names(x)) { stop_parameterization_changed("cox", "2.13.5") } } if (version < "2.13.8") { x$prior$source <- "" # ensure correct ordering of columns cols_prior <- intersect(all_cols_prior(), names(x$prior)) x$prior <- x$prior[, cols_prior] } if (version < "2.13.10") { # added support for threading x$threads <- threading() } if (version < "2.13.12") { # added more control over which parameters to save save_ranef <- isTRUE(attr(x$exclude, "save_ranef")) save_mevars <- isTRUE(attr(x$exclude, "save_mevars")) save_all_pars <- isTRUE(attr(x$exclude, "save_all_pars")) x$save_pars <- SW(validate_save_pars( save_pars(), save_ranef = save_ranef, save_mevars = save_mevars, save_all_pars = save_all_pars )) x$exclude <- NULL } if (version < "2.15.6") { # added support for OpenCL x$opencl <- opencl() } if (version < "2.16.1") { # problems with rstan::read_stan_csv as well as # non-unique variable names became apparent (#1218) x$fit <- repair_stanfit(x$fit) } if (version < "2.16.12") { # added full user control over parameter boundaries (#1324) # explicit bounds need to be added to old priors as a result x$prior$ub <- x$prior$lb <- NA for (i in which(nzchar(x$prior$bound))) { bounds <- convert_stan2bounds(x$prior$bound[i], default = c("", "")) x$prior[i, c("lb", "ub")] <- bounds } x$prior$bound <- NULL all_priors <- get_prior(x$formula, x$data, data2 = x$data2, internal = TRUE) all_priors$tag <- NULL # checking for lb is sufficient because both bounds are NA at the same time which_needs_bounds <- which(is.na(x$prior$lb) & !nzchar(x$prior$coef)) for (i in which_needs_bounds) { # take the corresponding bounds from the default prior prior_sub_i <- rbind(x$prior[i, ], all_priors) prior_sub_i <- prior_sub_i[duplicated(prior_sub_i), ] # should always have exactly one row but still check whether it has # any rows at all to prevent things from breaking accidentally if (NROW(prior_sub_i)) { x$prior[i, c("lb", "ub")] <- prior_sub_i[1, c("lb", "ub")] } else { x$prior[i, c("lb", "ub")] <- "" } } x$prior$lb[is.na(x$prior$lb)] <- x$prior$ub[is.na(x$prior$ub)] <- "" x$prior <- move2end(x$prior, "source") } if (version < "2.17.6") { # a slot was added that stores additional control arguments # that are directly passed to the Stan backends for later reuse (#1373) x$stan_args <- list() } if (version < "2.19.3") { # a slot was added to store parts of the Stan data computed at fitting time. # storing this is strictly required only for spline models but there it is # critical due to the machine-specific output of SVD (#1465) bframe <- brmsframe(x$formula, data = x$data) x$basis <- frame_basis(bframe, data = x$data) } if (version < "2.21.3") { # the class of random effects data.frames was changed # in the process of introducing brmsframe objects class(x$ranef) <- reframe_class() } if (version < "2.22.11") { # tag column was added to the prior (#1724) x$prior$tag <- "" } x } # restructure models fitted with brms 1.x restructure_v1 <- function(x) { version <- restructure_version(x) if (version < "1.0.0") { warning2( "Models fitted with brms < 1.0 are no longer offically ", "supported and post-processing them may fail. I recommend ", "refitting the model with the latest version of brms." ) } x$formula <- restructure_formula_v1(formula(x), x$nonlinear) x$formula <- SW(validate_formula( formula(x), data = model.frame(x), family = family(x), autocor = x$autocor, threshold = x$threshold )) x$nonlinear <- x$partial <- x$threshold <- NULL bterms <- brmsterms(formula(x)) x$data <- rm_attr(x$data, "brmsframe") x$data <- validate_data(x$data, bterms) x$ranef <- frame_re(bterms, model.frame(x)) if ("prior_frame" %in% class(x$prior)) { class(x$prior) <- c("brmsprior", "data.frame") } if (is(x$autocor, "cov_fixed")) { # deprecated as of brms 1.4.0 class(x$autocor) <- "cor_fixed" } if (version < "0.10.1") { if (length(bterms$dpars$mu$nlpars)) { # nlpar and group have changed positions change <- rename_old_re(x$ranef, variables(x), x$fit@sim$dims_oi) x <- do_renaming(x, change) } } if (version < "1.0.0") { # double underscores were added to group-level parameters change <- rename_old_re2(x$ranef, variables(x), x$fit@sim$dims_oi) x <- do_renaming(x, change) } if (version < "1.0.1.1") { # names of spline parameters had to be changed after # allowing for multiple covariates in one spline term change <- rename_old_sm( bterms, model.frame(x), variables(x), x$fit@sim$dims_oi ) x <- do_renaming(x, change) } if (version < "1.8.0.1") { att <- attributes(x$exclude) if (is.null(att$save_ranef)) { attr(x$exclude, "save_ranef") <- any(grepl("^r_", variables(x))) || !nrow(x$ranef) } if (is.null(att$save_mevars)) { attr(x$exclude, "save_mevars") <- any(grepl("^Xme_", variables(x))) } } if (version < "1.8.0.2") { x$prior$resp <- x$prior$dpar <- "" # ensure correct ordering of columns cols_prior <- intersect(all_cols_prior(), names(x$prior)) x$prior <- x$prior[, cols_prior] } if (version < "1.9.0.4") { # names of monotonic parameters had to be changed after # allowing for interactions in monotonic terms change <- rename_old_mo(bterms, x$data, pars = variables(x)) x <- do_renaming(x, change) } if (version >= "1.0.0" && version < "2.0.0") { change <- rename_old_categorical(bterms, x$data, pars = variables(x)) x <- do_renaming(x, change) } x } # get version with which a brmsfit object was restructured restructure_version <- function(x) { stopifnot(is.brmsfit(x)) out <- x$version$restructure if (!is.package_version(out)) { # models restructured with brms 2.11.1 store it as an attribute out <- attr(x, "restructured", exact = TRUE) } if (!is.package_version(out)) { out <- x$version$brms } out } # convert old model formulas to brmsformula objects restructure_formula_v1 <- function(formula, nonlinear = NULL) { if (is.brmsformula(formula) && is.formula(formula)) { # convert deprecated brmsformula objects back to formula class(formula) <- "formula" } if (is.brmsformula(formula)) { # already up to date return(formula) } old_nonlinear <- attr(formula, "nonlinear") nl <- length(nonlinear) > 0 if (is.logical(old_nonlinear)) { nl <- nl || old_nonlinear } else if (length(old_nonlinear)) { nonlinear <- c(nonlinear, old_nonlinear) nl <- TRUE } out <- structure(nlist(formula), class = "brmsformula") old_forms <- rmNULL(attributes(formula)[old_dpars()]) old_forms <- c(old_forms, nonlinear) out$pforms[names(old_forms)] <- old_forms bf(out, nl = nl) } # parameters to be restructured in old brmsformula objects old_dpars <- function() { c("mu", "sigma", "shape", "nu", "phi", "kappa", "beta", "xi", "zi", "hu", "zoi", "coi", "disc", "bs", "ndt", "bias", "quantile", "alpha", "theta") } # interchanges group and nlpar in names of group-level parameters # required for brms <= 0.10.0.9000 # @param ranef output of frame_re # @param pars names of all parameters in the model # @param dims dimension of parameters # @return a list whose elements can be interpreted by do_renaming rename_old_re <- function(ranef, pars, dims) { out <- list() for (id in unique(ranef$id)) { r <- subset2(ranef, id = id) g <- r$group[1] nlpar <- r$nlpar[1] stopifnot(nzchar(nlpar)) # rename sd-parameters old_sd_names <- paste0("sd_", nlpar, "_", g, "_", r$coef) new_sd_names <- paste0("sd_", g, "_", nlpar, "_", r$coef) for (i in seq_along(old_sd_names)) { lc(out) <- rename_simple( old_sd_names[i], new_sd_names[i], pars, dims ) } # rename cor-parameters new_cor_names <- get_cornames( paste0(nlpar, "_", r$coef), type = paste0("cor_", g), brackets = FALSE, sep = "_" ) old_cor_names <- get_cornames( r$coef, brackets = FALSE, sep = "_", type = paste0("cor_", nlpar, "_", g) ) for (i in seq_along(old_cor_names)) { lc(out) <- rename_simple( old_cor_names[i], new_cor_names[i], pars, dims ) } # rename r-parameters old_r_name <- paste0("r_", nlpar, "_", g) new_r_name <- paste0("r_", g, "_", nlpar) levels <- gsub("[ \t\r\n]", ".", attr(ranef, "levels")[[g]]) index_names <- make_index_names(levels, r$coef, dim = 2) new_r_names <- paste0(new_r_name, index_names) lc(out) <- rename_simple( old_r_name, new_r_names, pars, dims, pnames = new_r_name ) } out } # add double underscore in group-level parameters # required for brms < 1.0.0 # @note assumes that group and nlpar are correctly ordered already # @param ranef output of frame_re # @param pars names of all parameters in the model # @param dims dimension of parameters # @return a list whose elements can be interpreted by do_renaming rename_old_re2 <- function(ranef, pars, dims) { out <- list() for (id in unique(ranef$id)) { r <- subset2(ranef, id = id) g <- r$group[1] nlpars_usc <- usc(r$nlpar, "suffix") # rename sd-parameters old_sd_names <- paste0("sd_", g, "_", nlpars_usc, r$coef) new_sd_names <- paste0("sd_", g, "__", nlpars_usc, r$coef) for (i in seq_along(old_sd_names)) { lc(out) <- rename_simple(old_sd_names[i], new_sd_names[i], pars, dims) } # rename cor-parameters new_cor_names <- get_cornames( paste0(nlpars_usc, r$coef), type = paste0("cor_", g), brackets = FALSE ) old_cor_names <- get_cornames( paste0(nlpars_usc, r$coef), type = paste0("cor_", g), brackets = FALSE, sep = "_" ) for (i in seq_along(old_cor_names)) { lc(out) <- rename_simple(old_cor_names[i], new_cor_names[i], pars, dims) } # rename r-parameters for (nlpar in unique(r$nlpar)) { sub_r <- r[r$nlpar == nlpar, ] old_r_name <- paste0("r_", g, usc(nlpar)) new_r_name <- paste0("r_", g, usc(usc(nlpar))) levels <- gsub("[ \t\r\n]", ".", attr(ranef, "levels")[[g]]) index_names <- make_index_names(levels, sub_r$coef, dim = 2) new_r_names <- paste0(new_r_name, index_names) lc(out) <- rename_simple( old_r_name, new_r_names, pars, dims, pnames = new_r_name ) } } out } # change names of spline parameters fitted with brms <= 1.0.1 # this became necessary after allowing smooths with multiple covariates rename_old_sm <- function(bterms, data, pars, dims) { .rename_old_sm <- function(bt) { out <- list() smframe <- frame_sm(bt, data) if (nrow(smframe)) { p <- usc(combine_prefix(bt), "suffix") old_smooths <- rename(paste0(p, smframe$term)) new_smooths <- rename(paste0(p, smframe$label)) old_sds_pars <- paste0("sds_", old_smooths) new_sds_pars <- paste0("sds_", new_smooths, "_1") old_s_pars <- paste0("s_", old_smooths) new_s_pars <- paste0("s_", new_smooths, "_1") for (i in seq_along(old_smooths)) { lc(out) <- rename_simple(old_sds_pars[i], new_sds_pars[i], pars, dims) dim_s <- dims[[old_s_pars[i]]] if (!is.null(dim_s)) { new_s_par_indices <- paste0(new_s_pars[i], "[", seq_len(dim_s), "]") lc(out) <- rename_simple( old_s_pars[i], new_s_par_indices, pars, dims, pnames = new_s_pars[i] ) } } } return(out) } out <- list() if (is.mvbrmsterms(bterms)) { for (r in bterms$responses) { c(out) <- .rename_old_sm(bterms$terms[[r]]$dpars$mu) } } else if (is.brmsterms(bterms)) { for (dp in names(bterms$dpars)) { bt <- bterms$dpars[[dp]] if (length(bt$nlpars)) { for (nlp in names(bt$nlpars)) { c(out) <- .rename_old_sm(bt$nlpars[[nlp]]) } } else { c(out) <- .rename_old_sm(bt) } } } out } # change names of monotonic effects fitted with brms <= 1.9.0 # this became necessary after implementing monotonic interactions rename_old_mo <- function(bterms, data, pars) { .rename_old_mo <- function(bt) { out <- list() spframe <- frame_sp(bt, data) has_mo <- lengths(spframe$calls_mo) > 0 if (!any(has_mo)) { return(out) } spframe <- spframe[has_mo, ] p <- usc(combine_prefix(bt)) bmo_prefix <- paste0("bmo", p, "_") bmo_regex <- paste0("^", bmo_prefix, "[^_]+$") bmo_old <- pars[grepl(bmo_regex, pars)] bmo_new <- paste0(bmo_prefix, spframe$coef) if (length(bmo_old) != length(bmo_new)) { stop2("Restructuring failed. Please refit your ", "model with the latest version of brms.") } for (i in seq_along(bmo_old)) { pos <- grepl(paste0("^", bmo_old[i]), pars) lc(out) <- rlist(pos, fnames = bmo_new[i]) } simo_regex <- paste0("^simplex", p, "_[^_]+$") simo_old_all <- pars[grepl(simo_regex, pars)] simo_index <- get_matches("\\[[[:digit:]]+\\]$", simo_old_all) simo_old <- unique(sub("\\[[[:digit:]]+\\]$", "", simo_old_all)) simo_coef <- get_simo_labels(spframe) for (i in seq_along(simo_old)) { regex_pos <- paste0("^", simo_old[i]) pos <- grepl(regex_pos, pars) simo_new <- paste0("simo", p, "_", simo_coef[i]) simo_index_part <- simo_index[grepl(regex_pos, simo_old_all)] simo_new <- paste0(simo_new, simo_index_part) lc(out) <- rlist(pos, fnames = simo_new) } return(out) } out <- list() if (is.mvbrmsterms(bterms)) { for (r in bterms$responses) { c(out) <- .rename_old_mo(bterms$terms[[r]]$dpars$mu) } } else if (is.brmsterms(bterms)) { for (dp in names(bterms$dpars)) { bt <- bterms$dpars[[dp]] if (length(bt$nlpars)) { for (nlp in names(bt$nlpars)) { c(out) <- .rename_old_mo(bt$nlpars[[nlp]]) } } else { c(out) <- .rename_old_mo(bt) } } } out } # between version 1.0 and 2.0 categorical models used # the internal multivariate interface rename_old_categorical <- function(bterms, data, pars) { stopifnot(is.brmsterms(bterms)) if (!is_categorical(bterms$family)) { return(list()) } # compute the old category names respform <- bterms$respform old_dpars <- model.response(model.frame(respform, data = data)) old_dpars <- levels(factor(old_dpars)) old_dpars <- make.names(old_dpars[-1], unique = TRUE) old_dpars <- rename(old_dpars, ".", "x") new_dpars <- bterms$family$dpars stopifnot(length(old_dpars) == length(new_dpars)) pos <- rep(FALSE, length(pars)) new_pars <- pars for (i in seq_along(old_dpars)) { # not perfectly save but hopefully mostly correct regex <- paste0("(?<=_)", old_dpars[i], "(?=_|\\[)") pos <- pos | grepl(regex, pars, perl = TRUE) new_pars <- gsub(regex, new_dpars[i], new_pars, perl = TRUE) } list(nlist(pos, fnames = new_pars[pos])) } # as of brms 2.2 'mo' and 'me' terms are handled together rename_old_bsp <- function(pars) { pos <- grepl("^(bmo|bme)_", pars) if (!any(pos)) return(list()) fnames <- gsub("^(bmo|bme)_", "bsp_", pars[pos]) list(nlist(pos, fnames)) } # prepare for renaming of parameters in old models rename_simple <- function(oldname, fnames, pars, dims, pnames = fnames) { pos <- grepl(paste0("^", oldname), pars) if (any(pos)) { out <- nlist(pos, oldname, pnames, fnames, dims = dims[[oldname]]) class(out) <- c("rlist", "list") } else { out <- NULL } out } # rescale old 'b' coefficients of monotonic effects # to represent average instead of total differences rescale_old_mo <- function(x, ...) { UseMethod("rescale_old_mo") } #' @export rescale_old_mo.brmsfit <- function(x, ...) { bterms <- brmsterms(x$formula) rescale_old_mo(bterms, fit = x, ...) } #' @export rescale_old_mo.mvbrmsterms <- function(x, fit, ...) { for (resp in x$responses) { fit <- rescale_old_mo(x$terms[[resp]], fit = fit, ...) } fit } #' @export rescale_old_mo.brmsterms <- function(x, fit, ...) { for (dp in names(x$dpars)) { fit <- rescale_old_mo(x$dpars[[dp]], fit = fit, ...) } for (nlp in names(x$nlpars)) { fit <- rescale_old_mo(x$nlpars[[nlp]], fit = fit, ...) } fit } #' @export rescale_old_mo.btnl <- function(x, fit, ...) { fit } #' @export rescale_old_mo.btl <- function(x, fit, ...) { spframe <- frame_sp(x, fit$data) has_mo <- lengths(spframe$Imo) > 0L if (!any(has_mo)) { return(fit) } warning2( "The parameterization of monotonic effects has changed in brms 2.8.4 ", "so that corresponding 'b' coefficients now represent average instead ", "of total differences between categories. See vignette('brms_monotonic') ", "for more details. Parameters of old models are adjusted automatically." ) p <- combine_prefix(x) all_pars <- variables(fit) chains <- fit$fit@sim$chains for (i in which(has_mo)) { bsp_par <- paste0("bsp", p, "_", spframe$coef[i]) simo_regex <- paste0(spframe$coef[i], seq_along(spframe$Imo[[i]])) simo_regex <- paste0("simo", p, "_", simo_regex, "[") simo_regex <- paste0("^", escape_all(simo_regex)) # scaling factor by which to divide the old 'b' coefficients D <- prod(ulapply(simo_regex, function(r) sum(grepl(r, all_pars)))) for (j in seq_len(chains)) { fit$fit@sim$samples[[j]][[bsp_par]] <- fit$fit@sim$samples[[j]][[bsp_par]] / D } } fit } # update old families to work with the latest brms version update_old_family <- function(x, ...) { UseMethod("update_old_family") } #' @export update_old_family.default <- function(x, ...) { validate_family(x) } #' @export update_old_family.brmsfamily <- function(x, ...) { # new specials may have been added in new brms versions family_info <- get(paste0(".family_", x$family))() x$specials <- family_info$specials x } #' @export update_old_family.customfamily <- function(x, ...) { if (!is.null(x$predict)) { x$posterior_predict <- x$predict x$predict <- NULL } if (!is.null(x$fitted)) { x$posterior_epred <- x$fitted x$fitted <- NULL } x } #' @export update_old_family.mixfamily <- function(x, ...) { x$mix <- lapply(x$mix, update_old_family, ...) x } #' @export update_old_family.brmsformula <- function(x, ...) { x$family <- update_old_family(x$family, ...) x } #' @export update_old_family.mvbrmsformula <- function(x, ...) { x$forms <- lapply(x$forms, update_old_family, ...) x } stop_parameterization_changed <- function(family, version) { stop2( "The parameterization of '", family, "' models has changed in brms ", version, ". Please refit your model with the current version of brms." ) } check_old_nl_dpars <- function(bterms) { .check_nl_dpars <- function(x) { stopifnot(is.brmsterms(x)) non_mu_dpars <- x$dpars[names(x$dpars) != "mu"] if (any(ulapply(non_mu_dpars, is.btnl))) { stop2( "Non-linear parameters are global within univariate models ", "as of version 2.3.7. Please refit your model with the ", "latest version of brms." ) } return(TRUE) } if (is.mvbrmsterms(bterms)) { lapply(bterms$terms, .check_nl_dpars) } else { .check_nl_dpars(bterms) } TRUE } brms/R/priors.R0000644000176200001440000025763215057750012013100 0ustar liggesusers#' Prior Definitions for \pkg{brms} Models #' #' Define priors for specific parameters or classes of parameters. #' #' @aliases brmsprior brmsprior-class #' #' @param prior A character string defining a distribution in \pkg{Stan} language #' @param class The parameter class. Defaults to \code{"b"} #' (i.e. population-level effects). #' See 'Details' for other valid parameter classes. #' @param coef Name of the coefficient within the parameter class. #' @param group Grouping factor for group-level parameters. #' @param resp Name of the response variable. #' Only used in multivariate models. #' @param dpar Name of a distributional parameter. #' Only used in distributional models. #' @param nlpar Name of a non-linear parameter. #' Only used in non-linear models. #' @param lb Lower bound for parameter restriction. Currently only allowed #' for classes \code{"b"}. Defaults to \code{NULL}, that is no restriction. #' @param ub Upper bound for parameter restriction. Currently only allowed #' for classes \code{"b"}. Defaults to \code{NULL}, that is no restriction. #' @param tag Character to append to the \code{lprior} variable in the Stan code. #' Used for selectively checking sensitivity of priors in \code{priorsense}. #' @param check Logical; Indicates whether priors #' should be checked for validity (as far as possible). #' Defaults to \code{TRUE}. If \code{FALSE}, \code{prior} is passed #' to the Stan code as is, and all other arguments are ignored. #' @param ... Arguments passed to \code{set_prior}. #' #' @return An object of class \code{brmsprior} to be used in the \code{prior} #' argument of \code{\link{brm}}. #' #' @details #' \code{set_prior} is used to define prior distributions for parameters #' in \pkg{brms} models. The functions \code{prior}, \code{prior_}, and #' \code{prior_string} are aliases of \code{set_prior} each allowing #' for a different kind of argument specification. #' \code{prior} allows specifying arguments as expression without #' quotation marks using non-standard evaluation. #' \code{prior_} allows specifying arguments as one-sided formulas #' or wrapped in \code{quote}. #' \code{prior_string} allows specifying arguments as strings just #' as \code{set_prior} itself. #' #' Below, we explain its usage and list some common #' prior distributions for parameters. #' A complete overview on possible prior distributions is given #' in the Stan Reference Manual available at \url{https://mc-stan.org/}. #' #' To combine multiple priors, use \code{c(...)} or the \code{+} operator #' (see 'Examples'). \pkg{brms} does not check if the priors are written #' in correct \pkg{Stan} language. Instead, \pkg{Stan} will check their #' syntactical correctness when the model is parsed to \code{C++} and #' returns an error if they are not. #' This, however, does not imply that priors are always meaningful if they are #' accepted by \pkg{Stan}. Although \pkg{brms} trys to find common problems #' (e.g., setting bounded priors on unbounded parameters), there is no guarantee #' that the defined priors are reasonable for the model. #' Below, we list the types of parameters in \pkg{brms} models, #' for which the user can specify prior distributions. #' #' Below, we provide details for the individual parameter classes that you can #' set priors on. Often, it may not be immediately clear, which parameters are #' present in the model. To get a full list of parameters and parameter #' classes for which priors can be specified (depending on the model) use #' function \code{\link[brms:default_prior.default]{default_prior}}. #' #' 1. Population-level ('fixed') effects #' #' Every Population-level effect has its own regression parameter # These parameters are internally named as \code{b_}, where \code{} #' represents the name of the corresponding population-level effect. #' Suppose, for instance, that \code{y} is predicted by \code{x1} and \code{x2} #' (i.e., \code{y ~ x1 + x2} in formula syntax). #' Then, \code{x1} and \code{x2} have regression parameters #' \code{b_x1} and \code{b_x2} respectively. #' The default prior for population-level effects (including monotonic and #' category specific effects) is an improper flat prior over the reals. #' Other common options are normal priors or student-t priors. #' If we want to have a normal prior with mean 0 and #' standard deviation 5 for \code{x1}, and a unit student-t prior with 10 #' degrees of freedom for \code{x2}, we can specify this via #' \code{set_prior("normal(0,5)", class = "b", coef = "x1")} and \cr #' \code{set_prior("student_t(10, 0, 1)", class = "b", coef = "x2")}. #' To put the same prior on all population-level effects at once, #' we may write as a shortcut \code{set_prior("", class = "b")}. #' This also leads to faster sampling, because priors can be vectorized in this case. #' Both ways of defining priors can be combined using for instance #' \code{set_prior("normal(0, 2)", class = "b")} and \cr #' \code{set_prior("normal(0, 10)", class = "b", coef = "x1")} #' at the same time. This will set a \code{normal(0, 10)} prior on #' the effect of \code{x1} and a \code{normal(0, 2)} prior #' on all other population-level effects. #' However, this will break vectorization and #' may slow down the sampling procedure a bit. #' #' In case of the default intercept parameterization #' (discussed in the 'Details' section of \code{\link{brmsformula}}), #' general priors on class \code{"b"} will \emph{not} affect #' the intercept. Instead, the intercept has its own parameter class #' named \code{"Intercept"} and priors can thus be #' specified via \code{set_prior("", class = "Intercept")}. #' Setting a prior on the intercept will not break vectorization #' of the other population-level effects. #' Note that technically, this prior is set on an intercept that #' results when internally centering all population-level predictors #' around zero to improve sampling efficiency. On this centered #' intercept, specifying a prior is actually much easier and #' intuitive than on the original intercept, since the former #' represents the expected response value when all predictors #' are at their means. To treat the intercept as an ordinary #' population-level effect and avoid the centering parameterization, #' use \code{0 + Intercept} on the right-hand side of the model formula. #' #' In non-linear models, population-level effects are defined separately #' for each non-linear parameter. Accordingly, it is necessary to specify #' the non-linear parameter in \code{set_prior} so that priors #' we can be assigned correctly. #' If, for instance, \code{alpha} is the parameter and \code{x} the predictor #' for which we want to define the prior, we can write #' \code{set_prior("", coef = "x", nlpar = "alpha")}. #' As a shortcut we can use \code{set_prior("", nlpar = "alpha")} #' to set the same prior on all population-level effects of \code{alpha} at once. #' #' The same goes for specifying priors for specific distributional #' parameters in the context of distributional regression, for example, #' \code{set_prior("", coef = "x", dpar = "sigma")}. #' For most other parameter classes (see below), you need to indicate #' non-linear and distributional parameters in the same way as shown here. #' #' If desired, population-level effects can be restricted to fall only #' within a certain interval using the \code{lb} and \code{ub} arguments #' of \code{set_prior}. This is often required when defining priors #' that are not defined everywhere on the real line, such as uniform #' or gamma priors. When defining a \code{uniform(2,4)} prior, #' you should write \code{set_prior("uniform(2,4)", lb = 2, ub = 4)}. #' When using a prior that is defined on the positive reals only #' (such as a gamma prior) set \code{lb = 0}. #' In most situations, it is not useful to restrict population-level #' parameters through bounded priors #' (non-linear models are an important exception), #' but if you really want to this is the way to go. #' #' 2. Group-level ('random') effects #' #' Each group-level effect of each grouping factor has a standard deviation named #' \code{sd__}. Consider, for instance, the formula #' \code{y ~ x1 + x2 + (1 + x1 | g)}. #' We see that the intercept as well as \code{x1} are group-level effects #' nested in the grouping factor \code{g}. #' The corresponding standard deviation parameters are named as #' \code{sd_g_Intercept} and \code{sd_g_x1} respectively. #' These parameters are restricted to be non-negative and, by default, #' have a half student-t prior with 3 degrees of freedom and a #' scale parameter that depends on the standard deviation of the response #' after applying the link function. Minimally, the scale parameter is 2.5. #' This prior is used (a) to be only weakly informative in order to influence #' results as few as possible, while (b) providing at least some regularization #' to considerably improve convergence and sampling efficiency. #' To define a prior distribution only for standard deviations #' of a specific grouping factor, #' use \cr \code{set_prior("", class = "sd", group = "")}. #' To define a prior distribution only for a specific standard deviation #' of a specific grouping factor, you may write \cr #' \code{set_prior("", class = "sd", group = "", coef = "")}. #' #' If there is more than one group-level effect per grouping factor, #' the correlations between those effects have to be estimated. #' The prior \code{lkj_corr_cholesky(eta)} or in short #' \code{lkj(eta)} with \code{eta > 0} #' is essentially the only prior for (Cholesky factors) of correlation matrices. #' If \code{eta = 1} (the default) all correlations matrices #' are equally likely a priori. If \code{eta > 1}, extreme correlations #' become less likely, whereas \code{0 < eta < 1} results in #' higher probabilities for extreme correlations. #' Correlation matrix parameters in \code{brms} models are named as #' \code{cor_}, (e.g., \code{cor_g} if \code{g} is the grouping factor). #' To set the same prior on every correlation matrix, #' use for instance \code{set_prior("lkj(2)", class = "cor")}. #' Internally, the priors are transformed to be put on the Cholesky factors #' of the correlation matrices to improve efficiency and numerical stability. #' The corresponding parameter class of the Cholesky factors is \code{L}, #' but it is not recommended to specify priors for this parameter class directly. #' #' 4. Smoothing Splines #' #' Smoothing splines are implemented in \pkg{brms} using the 'random effects' #' formulation as explained in \code{\link[mgcv:gamm]{gamm}}). Thus, each #' spline has its corresponding standard deviations modeling the variability #' within this term. In \pkg{brms}, this parameter class is called \code{sds} #' and priors can be specified via #' \code{set_prior("", class = "sds", coef = "")}. #' The default prior is the same as for standard deviations of group-level effects. #' #' 5. Gaussian processes #' #' Gaussian processes as currently implemented in \pkg{brms} have two #' parameters, the standard deviation parameter \code{sdgp}, and #' characteristic length-scale parameter \code{lscale} (see \code{\link{gp}} #' for more details). The default prior of \code{sdgp} is the same as for #' standard deviations of group-level effects. The default prior of #' \code{lscale} is an informative inverse-gamma prior specifically tuned to #' the covariates of the Gaussian process (for more details see #' \url{https://betanalpha.github.io/assets/case_studies/gp_part3/part3.html}). #' This tuned prior may be overly informative in some cases, so please #' consider other priors as well to make sure inference is robust to the prior #' specification. If tuning fails, a half-normal prior is used instead. #' #' 6. Autocorrelation parameters #' #' The autocorrelation parameters currently implemented are named \code{ar} #' (autoregression), \code{ma} (moving average), \code{sderr} (standard #' deviation of latent residuals in latent ARMA models), \code{cosy} (compound #' symmetry correlation), \code{car} (spatial conditional autoregression), as #' well as \code{lagsar} and \code{errorsar} (spatial simultaneous #' autoregression). #' #' Priors can be defined by \code{set_prior("", class = "ar")} for #' \code{ar} and similar for other autocorrelation parameters. By default, #' \code{ar} and \code{ma} are bounded between \code{-1} and \code{1}; #' \code{cosy}, \code{car}, \code{lagsar}, and \code{errorsar} are bounded #' between \code{0} and \code{1}. The default priors are flat over the #' respective definition areas. #' #' 7. Parameters of measurement error terms #' #' Latent variables induced via measurement error \code{\link{me}} terms #' require both mean and standard deviation parameters, whose prior classes #' are named \code{"meanme"} and \code{"sdme"}, respectively. If multiple #' latent variables are induced this way, their correlation matrix will #' be modeled as well and corresponding priors can be specified via the #' \code{"corme"} class. All of the above parameters have flat priors over #' their respective definition spaces by default. #' #' 8. Distance parameters of monotonic effects #' #' As explained in the details section of \code{\link{brm}}, #' monotonic effects make use of a special parameter vector to #' estimate the 'normalized distances' between consecutive predictor #' categories. This is realized in \pkg{Stan} using the \code{simplex} #' parameter type. This class is named \code{"simo"} (short for #' simplex monotonic) in \pkg{brms}. #' The only valid prior for simplex parameters is the #' dirichlet prior, which accepts a vector of length \code{K - 1} #' (K = number of predictor categories) as input defining the #' 'concentration' of the distribution. Explaining the dirichlet prior #' is beyond the scope of this documentation, but we want to describe #' how to define this prior syntactically correct. #' If a predictor \code{x} with \code{K} categories is modeled as monotonic, #' we can define a prior on its corresponding simplex via \cr #' \code{prior(dirichlet(), class = simo, coef = mox1)}. #' The \code{1} in the end of \code{coef} indicates that this is the first #' simplex in this term. If interactions between multiple monotonic #' variables are modeled, multiple simplexes per term are required. #' For \code{}, we can put in any \code{R} expression #' defining a vector of length \code{K - 1}. The default is a uniform #' prior (i.e. \code{ = rep(1, K-1)}) over all simplexes #' of the respective dimension. #' #' 9. Parameters for specific families #' #' Some families need additional parameters to be estimated. #' Families \code{gaussian}, \code{student}, \code{skew_normal}, #' \code{lognormal}, and \code{gen_extreme_value} need the parameter #' \code{sigma} to account for the residual standard deviation. #' By default, \code{sigma} has a half student-t prior that scales #' in the same way as the group-level standard deviations. #' Further, family \code{student} needs the parameter #' \code{nu} representing the degrees of freedom of Student-t distribution. #' By default, \code{nu} has prior \code{gamma(2, 0.1)}, which is #' close to a penalized complexity prior (see Stan prior choice Wiki), #' and a fixed lower bound of \code{1}. #' Family \code{negbinomial} needs a \code{shape} parameter that has by #' default \code{inv_gamma(0.4, 0.3)} prior which is close to a #' penalized complexity prior (see Stan prior choice Wiki). #' Families \code{gamma}, \code{weibull}, and \code{inverse.gaussian}, #' need a \code{shape} parameter that has a \code{gamma(0.01, 0.01)} #' prior by default. #' For families \code{cumulative}, \code{cratio}, \code{sratio}, #' and \code{acat}, and only if \code{threshold = "equidistant"}, #' the parameter \code{delta} is used to model the distance between #' two adjacent thresholds. #' By default, \code{delta} has an improper flat prior over the reals. #' The \code{von_mises} family needs the parameter \code{kappa}, representing #' the concentration parameter. By default, \code{kappa} has prior #' \code{gamma(2, 0.01)}. #' #' Every family specific parameter has its own prior class, so that #' \code{set_prior("", class = "")} is the right way to go. #' All of these priors are chosen to be weakly informative, #' having only minimal influence on the estimations, #' while improving convergence and sampling efficiency. #' #' 10. Shrinkage priors #' #' To reduce the danger of overfitting in models with many predictor terms fit #' on comparably sparse data, brms supports special shrinkage priors, namely #' the (regularized) \code{\link{horseshoe}} and the \code{\link{R2D2}} prior. #' These priors can be applied on many parameter classes, either directly on #' the coefficient classes (e.g., class \code{b}), if directly setting priors #' on them is supported, or on the corresponding standard deviation #' hyperparameters (e.g., class \code{sd}) otherwise. Currently, the following #' classes support shrinkage priors: \code{b} (overall regression #' coefficients), \code{sds} (SDs of smoothing splines), \code{sdgp} (SDs of #' Gaussian processes), \code{ar} (autoregressive coefficients), \code{ma} #' (moving average coefficients), \code{sderr} (SD of latent residuals), #' \code{sdcar} (SD of spatial CAR structures), \code{sd} (SD of varying #' coefficients). #' #' 11. Fixing parameters to constants #' #' Fixing parameters to constants is possible by using the \code{constant} #' function, for example, \code{constant(1)} to fix a parameter to 1. #' Broadcasting to vectors and matrices is done automatically. #' #' @seealso \code{\link[brms:default_prior.default]{default_prior}} #' #' @examples #' ## use alias functions #' (prior1 <- prior(cauchy(0, 1), class = sd)) #' (prior2 <- prior_(~cauchy(0, 1), class = ~sd)) #' (prior3 <- prior_string("cauchy(0, 1)", class = "sd")) #' identical(prior1, prior2) #' identical(prior1, prior3) #' #' # check which parameters can have priors #' default_prior(rating ~ treat + period + carry + (1|subject), #' data = inhaler, family = cumulative()) #' #' # define some priors #' bprior <- c(prior_string("normal(0,10)", class = "b"), #' prior(normal(1,2), class = b, coef = treat), #' prior_(~cauchy(0,2), class = ~sd, #' group = ~subject, coef = ~Intercept)) #' #' # verify that the priors indeed found their way into Stan's model code #' stancode(rating ~ treat + period + carry + (1|subject), #' data = inhaler, family = cumulative(), #' prior = bprior) #' #' # use the horseshoe prior to model sparsity in regression coefficients #' stancode(count ~ zAge + zBase * Trt, #' data = epilepsy, family = poisson(), #' prior = set_prior("horseshoe(3)")) #' #' # fix certain priors to constants #' bprior <- prior(constant(1), class = "b") + #' prior(constant(2), class = "b", coef = "zBase") + #' prior(constant(0.5), class = "sd") #' stancode(count ~ zAge + zBase + (1 | patient), #' data = epilepsy, prior = bprior) #' #' # pass priors to Stan without checking #' prior <- prior_string("target += normal_lpdf(b[1] | 0, 1)", check = FALSE) #' stancode(count ~ Trt, data = epilepsy, prior = prior) #' #' # define priors in a vectorized manner #' # useful in particular for categorical or multivariate models #' set_prior("normal(0, 2)", dpar = c("muX", "muY", "muZ")) #' #' # specify tags for different priors for sensitivity analysis using priorsense #' # It is then possible to check the sensitivity when changing the priors with #' # the same tag while leaving others the same #' prior_cov <- prior(normal(0, 10), class = "b", tag = "covariates") #' prior_trt <- prior(normal(0, 1), class = "b", coef = "Trt1", tag = "treatment") #' stancode(count ~ Trt + zAge + zBase + (1 | patient), #' data = epilepsy, prior = c(prior_cov, prior_trt)) #' #' @export set_prior <- function(prior, class = "b", coef = "", group = "", resp = "", dpar = "", nlpar = "", lb = NA, ub = NA, tag = "", check = TRUE) { input <- nlist(prior, class, coef, group, resp, dpar, nlpar, lb, ub, tag, check) input <- try(as.data.frame(input), silent = TRUE) if (is_try_error(input)) { stop2("Processing arguments of 'set_prior' has failed:\n", input) } out <- vector("list", nrow(input)) for (i in seq_along(out)) { out[[i]] <- do_call(.set_prior, input[i, ]) } Reduce("+", out) } # validate arguments passed to 'set_prior' .set_prior <- function(prior, class, coef, group, resp, dpar, nlpar, lb, ub, tag, check) { prior <- as_one_character(prior) class <- as_one_character(class) group <- as_one_character(group) coef <- as_one_character(coef) resp <- as_one_character(resp) dpar <- as_one_character(dpar) nlpar <- as_one_character(nlpar) check <- as_one_logical(check) lb <- as_one_character(lb, allow_na = TRUE) ub <- as_one_character(ub, allow_na = TRUE) tag <- as_one_character(tag) if (dpar == "mu") { # distributional parameter 'mu' is currently implicit #1368 dpar <- "" } if (!check) { # prior will be added to the log-posterior as is class <- coef <- group <- resp <- dpar <- nlpar <- lb <- ub <- tag <- "" } source <- "user" out <- nlist(prior, source, class, coef, group, resp, dpar, nlpar, lb, ub, tag) do_call(brmsprior, out) } #' @describeIn set_prior Alias of \code{set_prior} allowing to #' specify arguments as expressions without quotation marks. #' @export prior <- function(prior, ...) { call <- as.list(match.call()[-1]) seval <- rmNULL(call[prior_seval_args()]) call[prior_seval_args()] <- NULL call <- lapply(call, deparse_no_string) do_call(set_prior, c(call, seval)) } #' @describeIn set_prior Alias of \code{set_prior} allowing to specify #' arguments as as one-sided formulas or wrapped in \code{quote}. #' @export prior_ <- function(prior, ...) { call <- nlist(prior, ...) seval <- rmNULL(call[prior_seval_args()]) call[prior_seval_args()] <- NULL as_string <- function(x) { if (is.formula(x) && length(x) == 2) { deparse_no_string(x[[2]]) } else if (is.call(x) || is.name(x) || is.atomic(x)) { deparse_no_string(x) } else { stop2("Arguments must be one-sided formula, call, name, or constant.") } } call <- lapply(call, as_string) do_call(set_prior, c(call, seval)) } # arguments for which to use standard evaluation prior_seval_args <- function() { c("check") } #' @describeIn set_prior Alias of \code{set_prior} allowing to #' specify arguments as strings. #' @export prior_string <- function(prior, ...) { set_prior(prior, ...) } #' Default priors for Bayesian models #' #' @description \code{default_prior} is a generic function that can be used to #' get default priors for Bayesian models. Its original use is #' within the \pkg{brms} package, but new methods for use #' with objects from other packages can be registered to the same generic. #' #' @param object An object whose class will determine which method will #' be used. A symbolic description of the model to be fitted. #' @param formula Synonym of \code{object} for use in \code{get_prior}. #' @param ... Further arguments passed to the specific method. #' #' @return Usually, a \code{brmsprior} object. See #' \code{\link{default_prior.default}} for more details. #' #' @details #' See \code{\link{default_prior.default}} for the default method applied for #' \pkg{brms} models. You can view the available methods by typing #' \code{methods(default_prior)}. #' #' @seealso #' \code{\link{set_prior}}, \code{\link{default_prior.default}} #' #' @examples #' ## get all parameters and parameters classes to define priors on #' (prior <- default_prior(count ~ zAge + zBase * Trt + (1|patient) + (1|obs), #' data = epilepsy, family = poisson())) #' #' @export default_prior <- function(object, ...) { UseMethod("default_prior") } #' @rdname default_prior #' @export get_prior <- function(formula, ...) { # became an alias of default_prior in 2.20.14. default_prior(formula, ...) } #' Default Priors for \pkg{brms} Models #' #' Get information on all parameters (and parameter classes) for which priors #' may be specified including default priors. #' #' @inheritParams brm #' @param object An object of class \code{\link[stats:formula]{formula}}, #' \code{\link{brmsformula}}, or \code{\link{mvbrmsformula}} (or one that can #' be coerced to that classes): A symbolic description of the model to be #' fitted. The details of model specification are explained in #' \code{\link{brmsformula}}. #' @param ... Other arguments for internal usage only. #' #' @return A \code{brmsprior} object. That is, a data.frame with specific #' columns including \code{prior}, \code{class}, \code{coef}, and \code{group} #' and several rows, each providing information on a parameter (or parameter #' class) on which priors can be specified. The prior column is empty except #' for internal default priors. #' #' @seealso \code{\link{default_prior}}, \code{\link{set_prior}} #' #' @examples #' # get all parameters and parameters classes to define priors on #' (prior <- default_prior(count ~ zAge + zBase * Trt + (1|patient) + (1|obs), #' data = epilepsy, family = poisson())) #' #' # define a prior on all population-level effects a once #' prior$prior[1] <- "normal(0,10)" #' #' # define a specific prior on the population-level effect of Trt #' prior$prior[5] <- "student_t(10, 0, 5)" #' #' # verify that the priors indeed found their way into Stan's model code #' stancode(count ~ zAge + zBase * Trt + (1|patient) + (1|obs), #' data = epilepsy, family = poisson(), #' prior = prior) #' #' @export default_prior.default <- function(object, data, family = gaussian(), autocor = NULL, data2 = NULL, knots = NULL, drop_unused_levels = TRUE, sparse = NULL, ...) { object <- validate_formula( object, data = data, family = family, autocor = autocor, sparse = sparse ) bterms <- brmsterms(object) data2 <- validate_data2( data2, bterms = bterms, get_data2_autocor(object) ) data <- validate_data( data, bterms = bterms, data2 = data2, knots = knots, drop_unused_levels = drop_unused_levels ) bframe <- brmsframe(bterms, data = data) .default_prior(bframe, ...) } #' @export default_prior.brmsfit <- function(object, ...) { object <- restructure(object) bterms <- brmsterms(object$formula) bframe <- brmsframe(bterms, data = object$data) .default_prior(bframe, ...) } # internal work function of 'default_prior' # @param internal return priors for internal use? # @return a brmsprior object .default_prior <- function(bframe, internal = FALSE, ...) { stopifnot(is.anybrmsframe(bframe)) # initialize output prior <- empty_prior() # priors for distributional parameters prior <- prior + prior_predictor(bframe, internal = internal) # priors of group-level parameters prior <- prior + prior_re(bframe, internal = internal) # priors for noise-free variables prior <- prior + prior_Xme(bframe, internal = internal) # explicitly label default priors as such prior$source <- "default" # apply 'unique' as the same prior may have been included multiple times to_order <- with(prior, order(resp, dpar, nlpar, class, group, coef, tag)) prior <- unique(prior[to_order, , drop = FALSE]) rownames(prior) <- NULL class(prior) <- c("brmsprior", "data.frame") prior } # generate priors for predictor terms # @return a 'brmsprior' object prior_predictor <- function(x, ...) { UseMethod("prior_predictor") } #' @export prior_predictor.default <- function(x, ...) { empty_prior() } #' @export prior_predictor.mvbrmsframe <- function(x, internal = FALSE, ...) { prior <- empty_prior() for (i in seq_along(x$terms)) { prior <- prior + prior_predictor(x$terms[[i]], internal = internal, ...) } if (x$rescor) { if (internal) { prior <- prior + brmsprior(class = "Lrescor", prior = "lkj_corr_cholesky(1)") } else { prior <- prior + brmsprior(class = "rescor", prior = "lkj(1)") } if (family_names(x)[1] %in% "student") { prior <- prior + brmsprior(class = "nu", prior = "gamma(2, 0.1)", lb = "1") } } prior } #' @export prior_predictor.brmsframe <- function(x, internal = FALSE, ...) { def_scale_prior <- def_scale_prior(x) valid_dpars <- valid_dpars(x) prior <- empty_prior() # priors for mixture models if (is.mixfamily(x$family)) { if (has_joint_theta(x)) { # individual theta parameters should not have a prior in this case theta_dpars <- str_subset(valid_dpars, "^theta[[:digit:]]+") valid_dpars <- setdiff(valid_dpars, theta_dpars) prior <- prior + brmsprior(prior = "dirichlet(1)", class = "theta", resp = x$resp) } if (fix_intercepts(x)) { # fixing thresholds across mixture components # requires a single set of priors at the top level stopifnot(is_ordinal(x)) prior <- prior + prior_thres(x, def_scale_prior = def_scale_prior) } } # priors for distributional parameters for (dp in valid_dpars) { def_dpar_prior <- def_dpar_prior(x, dp) if (!is.null(x$dpars[[dp]])) { # parameter is predicted dp_prior <- prior_predictor( x$dpars[[dp]], def_scale_prior = def_scale_prior, def_dpar_prior = def_dpar_prior, internal = internal ) } else if (!is.null(x$fdpars[[dp]])) { # parameter is fixed dp_prior <- empty_prior() } else { # parameter is estimated dp_bound <- dpar_bounds(dp, suffix = x$resp, family = x$family) dp_prior <- brmsprior( def_dpar_prior, class = dp, resp = x$resp, lb = dp_bound$lb, ub = dp_bound$ub ) } prior <- prior + dp_prior } # priors for non-linear parameters for (nlp in names(x$nlpars)) { nlp_prior <- prior_predictor( x$nlpars[[nlp]], def_scale_prior = def_scale_prior, internal = internal ) prior <- prior + nlp_prior } if (is_logistic_normal(x$family)) { if (internal) { prior <- prior + brmsprior("lkj_corr_cholesky(1)", class = "Llncor", resp = x$resp) } else { prior <- prior + brmsprior("lkj(1)", class = "lncor", resp = x$resp) } } prior } # prior for linear predictor termss #' @export prior_predictor.bframel <- function(x, ...) { prior_fe(x, ...) + prior_thres(x, ...) + prior_sp(x, ...) + prior_cs(x, ...) + prior_sm(x, ...) + prior_gp(x, ...) + prior_ac(x, ...) + prior_bhaz(x, ...) } # priors for non-linear predictor terms #' @export prior_predictor.bframenl <- function(x, ...) { # thresholds are required even in non-linear ordinal models prior_thres(x, ...) + prior_ac(x, ...) + prior_bhaz(x, ...) } # priors for population-level parameters prior_fe <- function(bframe, def_dpar_prior = "", ...) { stopifnot(is.bframel(bframe)) prior <- empty_prior() fixef <- bframe$frame$fe$vars_stan px <- check_prefix(bframe) center <- stan_center_X(bframe) if (center && !is_ordinal(bframe)) { # priors for ordinal thresholds are provided in 'prior_thres' prior <- prior + brmsprior(def_dpar_prior, class = "Intercept", ls = px) } if (length(fixef)) { prior <- prior + brmsprior(class = "b", coef = c("", fixef), ls = px) } prior } # priors for thresholds of ordinal models prior_thres <- function(bframe, def_scale_prior = "", ...) { prior <- empty_prior() if (!is_ordinal(bframe)) { # thresholds only exist in ordinal models return(prior) } if (fix_intercepts(bframe) && !is.mixfamily(bframe$family)) { # fixed thresholds cannot have separate priors return(prior) } # create priors for threshold per group .prior_thres <- function(thres, thres_prior = "", group = "") { prior <- empty_prior() if (has_equidistant_thres(bframe)) { # prior for the delta parameter for equidistant thresholds thres <- character(0) lb <- str_if(has_ordered_thres(bframe), "0") prior <- prior + brmsprior( class = "delta", group = group, lb = lb, ls = px ) } prior <- prior + brmsprior( prior = c(thres_prior, rep("", length(thres))), class = "Intercept", coef = c("", thres), group = group, ls = px ) } px <- check_prefix(bframe) groups <- get_thres_groups(bframe) if (any(nzchar(groups))) { # for models with multiple threshold vectors prior <- prior + .prior_thres(character(0), def_scale_prior) for (g in groups) { prior <- prior + .prior_thres(get_thres(bframe, group = g), group = g) } } else { # for models with a single threshold vector prior <- prior + .prior_thres(get_thres(bframe), def_scale_prior) } prior } # priors for coefficients of baseline hazards in the Cox model prior_bhaz <- function(bframe, ...) { prior <- empty_prior() if (!is_cox(bframe$family)) { return(prior) } px <- check_prefix(bframe) # the scale of sbhaz is not identified when an intercept is part of mu # thus a sum-to-one constraint ensures identification prior <- prior + brmsprior("dirichlet(1)", class = "sbhaz", ls = px) if (has_bhaz_groups(bframe)) { groups <- get_bhaz_groups(bframe) prior <- prior + brmsprior("", class = "sbhaz", ls = px, group = groups) } prior } # priors for special effects parameters prior_sp <- function(bframe, ...) { stopifnot(is.bframel(bframe)) prior <- empty_prior() spframe <- bframe$frame$sp if (has_rows(spframe)) { px <- check_prefix(bframe) prior <- prior + brmsprior( class = "b", coef = c("", spframe$coef), ls = px ) simo_coef <- get_simo_labels(spframe, use_id = TRUE) if (length(simo_coef)) { prior <- prior + brmsprior( prior = "dirichlet(1)", class = "simo", coef = simo_coef, ls = px ) } } prior } # priors for category spcific effects parameters prior_cs <- function(bframe, ...) { stopifnot(is.bframel(bframe)) prior <- empty_prior() csef <- bframe$frame$cs$vars if (length(csef)) { px <- check_prefix(bframe) prior <- prior + brmsprior(class = "b", coef = c("", csef), ls = px) } prior } # default priors for hyper-parameters of noise-free variables prior_Xme <- function(bframe, internal = FALSE, ...) { meframe <- bframe$frame$me stopifnot(is.meframe(meframe)) prior <- empty_prior() if (!has_rows(meframe)) { return(prior) } prior <- prior + brmsprior(class = "meanme") + brmsprior(class = "meanme", coef = meframe$coef) + brmsprior(class = "sdme", lb = "0") + brmsprior(class = "sdme", coef = meframe$coef) # priors for correlation parameters groups <- unique(meframe$grname) for (i in seq_along(groups)) { g <- groups[i] K <- which(meframe$grname %in% g) if (meframe$cor[K[1]] && length(K) > 1L) { if (internal) { prior <- prior + brmsprior("lkj_corr_cholesky(1)", class = "Lme") if (nzchar(g)) { prior <- prior + brmsprior(class = "Lme", group = g) } } else { prior <- prior + brmsprior("lkj(1)", class = "corme") if (nzchar(g)) { prior <- prior + brmsprior(class = "corme", group = g) } } } } prior } # default priors of gaussian processes # @param def_scale_prior: a character string defining # the default prior SD parameters prior_gp <- function(bframe, def_scale_prior, ...) { stopifnot(is.bframel(bframe)) prior <- empty_prior() gpframe <- bframe$frame$gp if (nrow(gpframe)) { px <- check_prefix(bframe) lscale_prior <- def_lscale_prior(bframe) prior <- prior + brmsprior(class = "sdgp", prior = def_scale_prior, ls = px, lb = "0") + brmsprior(class = "sdgp", coef = unlist(gpframe$sfx1), ls = px) + brmsprior(class = "lscale", ls = px, lb = "0") + brmsprior(class = "lscale", prior = lscale_prior, coef = names(lscale_prior), ls = px) } prior } # default priors for length-scale parameters of GPs # see https://betanalpha.github.io/assets/case_studies/gp_part3/part3.html # @param plb prior probability of being lower than minimum length-scale # @param pub prior probability of being higher than maximum length-scale def_lscale_prior <- function(bframe, plb = 0.01, pub = 0.01) { .opt_fun <- function(x, lb, ub) { # optimize parameters on the log-scale to make them positive only x <- exp(x) y1 <- pinvgamma(lb, x[1], x[2], log.p = TRUE) y2 <- pinvgamma(ub, x[1], x[2], lower.tail = FALSE, log.p = TRUE) c(y1 - log(plb), y2 - log(pub)) } .def_lscale_prior <- function(X) { dq <- diff_quad(X) ub <- sqrt(max(dq)) lb <- sqrt(min(dq[dq > 0])) # prevent extreme priors lb <- max(lb, 0.01 * ub) opt_res <- nleqslv::nleqslv( c(0, 0), .opt_fun, lb = lb, ub = ub, control = list(allowSingular = TRUE) ) prior <- "normal(0, 0.5)" if (opt_res$termcd %in% 1:2) { # use the inverse-gamma prior only in case of convergence pars <- exp(opt_res$x) prior <- paste0("inv_gamma(", sargs(round(pars, 6)), ")") } return(prior) } p <- usc(combine_prefix(bframe)) gpframe <- bframe$frame$gp data_gp <- bframe$sdata$gp out <- vector("list", NROW(gpframe)) for (i in seq_along(out)) { pi <- paste0(p, "_", i) iso <- gpframe$iso[i] cons <- gpframe$cons[[i]] if (length(cons) > 0L) { for (j in seq_along(cons)) { Xgp <- data_gp[[paste0("Xgp_prior", pi, "_", j)]] if (iso) { c(out[[i]]) <- .def_lscale_prior(Xgp) } else { c(out[[i]]) <- apply(Xgp, 2, .def_lscale_prior) } } } else { Xgp <- data_gp[[paste0("Xgp_prior", pi)]] if (iso) { out[[i]] <- .def_lscale_prior(Xgp) } else { out[[i]] <- apply(Xgp, 2, .def_lscale_prior) } } # transpose so that by-levels vary last names(out[[i]]) <- as.vector(t(gpframe$sfx2[[i]])) } unlist(out) } # priors for varying effects parameters # @param internal: see 'default_prior' prior_re <- function(bframe, internal = FALSE, ...) { prior <- empty_prior() reframe <- bframe$frame$re if (!has_rows(reframe)) { return(prior) } stopifnot(is.reframe(reframe)) # global sd class def_scale_prior <- def_scale_prior(bframe) px <- check_prefix(reframe) upx <- unique(px) if (length(def_scale_prior) > 1L) { def_scale_prior <- def_scale_prior[px$resp] } global_sd_prior <- brmsprior( class = "sd", prior = def_scale_prior, lb = "0", ls = px ) prior <- prior + global_sd_prior for (id in unique(reframe$id)) { r <- subset2(reframe, id = id) group <- r$group[1] rpx <- check_prefix(r) urpx <- unique(rpx) # include group-level standard deviations prior <- prior + # don't specify lb as we already have it above brmsprior(class = "sd", group = group, ls = urpx) + brmsprior(class = "sd", coef = r$coef, group = group, ls = rpx) # detect duplicated group-level effects J <- with(prior, class == "sd" & nzchar(coef)) dupli <- duplicated(prior[J, ]) if (any(dupli)) { stop2("Duplicated group-level effects detected for group ", group) } # include correlation parameters if (isTRUE(r$cor[1]) && nrow(r) > 1L) { if (internal) { prior <- prior + brmsprior( class = "L", group = c("", group), prior = c("lkj_corr_cholesky(1)", "") ) } else { prior <- prior + brmsprior( class = "cor", group = c("", group), prior = c("lkj(1)", "") ) } } } reframe_t <- subset_reframe_dist(reframe, "student") if (isTRUE(nrow(reframe_t) > 0L)) { prior <- prior + brmsprior("gamma(2, 0.1)", class = "df", group = reframe_t$group, lb = "1") } prior } # priors for smooth terms prior_sm <- function(bframe, def_scale_prior, ...) { stopifnot(is.bframel(bframe)) prior <- empty_prior() smframe <- bframe$frame$sm if (!has_rows(smframe)) { return(prior) } px <- check_prefix(bframe) # prior for the FE coefficients Xs_names <- attr(smframe, "Xs_names") if (length(Xs_names)) { prior <- prior + brmsprior( class = "b", coef = c("", Xs_names), ls = px ) } # prior for SD parameters of the RE coefficients smterms <- unique(smframe$term) prior <- prior + brmsprior(prior = def_scale_prior, class = "sds", lb = "0", ls = px) + brmsprior(class = "sds", coef = smterms, ls = px) prior } # priors for autocor parameters prior_ac <- function(bframe, def_scale_prior, internal = FALSE, ...) { prior <- empty_prior() acframe <- bframe$frame$ac stopifnot(is.acframe(acframe)) if (!NROW(acframe)) { return(prior) } px <- check_prefix(bframe) p <- combine_prefix(px) has_ac_latent_residuals <- has_ac_latent_residuals(bframe) if (has_ac_class(acframe, "arma")) { acframe_arma <- subset2(acframe, class = "arma") # no boundaries are required in the conditional formulation # when natural residuals automatically define the scale need_arma_bound <- acframe_arma$cov || has_ac_latent_residuals arma_lb <- str_if(need_arma_bound, "-1") arma_ub <- str_if(need_arma_bound, "1") if (acframe_arma$p > 0) { prior <- prior + brmsprior(class = "ar", ls = px, lb = arma_lb, ub = arma_ub) } if (acframe_arma$q > 0) { prior <- prior + brmsprior(class = "ma", ls = px, lb = arma_lb, ub = arma_ub) } } if (has_ac_class(acframe, "cosy")) { # cosy correlations may be negative in theory but # this causes problems with divergent transitions (#878) prior <- prior + brmsprior(class = "cosy", ls = px, lb = "0", ub = "1") } if (has_ac_class(acframe, "unstr")) { if (internal) { prior <- prior + brmsprior("lkj_corr_cholesky(1)", class = "Lcortime", ls = px) } else { prior <- prior + brmsprior("lkj(1)", class = "cortime", ls = px) } } if (has_ac_latent_residuals(bframe)) { prior <- prior + brmsprior(def_scale_prior, class = "sderr", ls = px, lb = "0") } if (has_ac_class(acframe, "sar")) { acframe_sar <- subset2(acframe, class = "sar") sar_lb <- glue("min_eigenMsar{p}") sar_ub <- glue("max_eigenMsar{p}") if (acframe_sar$type == "lag") { prior <- prior + brmsprior(class = "lagsar", lb = sar_lb, ub = sar_ub, ls = px) } if (acframe_sar$type == "error") { prior <- prior + brmsprior(class = "errorsar", lb = sar_lb, ub = sar_ub, ls = px) } } if (has_ac_class(acframe, "car")) { acframe_car <- subset2(acframe, class = "car") prior <- prior + brmsprior(def_scale_prior, class = "sdcar", lb = "0", ls = px) if (acframe_car$type %in% "escar") { prior <- prior + brmsprior(class = "car", lb = "0", ub = "1", ls = px) } else if (acframe_car$type %in% "bym2") { prior <- prior + brmsprior("beta(1, 1)", class = "rhocar", lb = "0", ub = "1", ls = px) } } prior } # default priors for distributional parameters def_dpar_prior <- function(x, dpar) { stopifnot(is.brmsterms(x)) dpar <- as_one_character(dpar) resp <- usc(x$resp) dpar_class <- dpar_class(dpar, family = x) link <- x$dpars[[dpar]]$family$link %||% "identity" if (is.function(x$family$prior)) { # use default priors stored in families #1614 # TODO: use this feature more generally? out <- x$family$prior(dpar_class, link = link) if (!is.null(out)) { return(out) } } # ensures reasonable scaling in def_scale_prior x$family$link <- link if (link == "identity") { # dpar is estimated or predicted on the linear scale out <- switch(dpar_class, "", mu = def_scale_prior(x, center = FALSE, dpar = dpar), sigma = def_scale_prior(x), shape = "gamma(0.01, 0.01)", nu = "gamma(2, 0.1)", phi = "gamma(0.01, 0.01)", kappa = "gamma(2, 0.01)", beta = "gamma(1, 0.1)", zi = "beta(1, 1)", hu = "beta(1, 1)", zoi = "beta(1, 1)", coi = "beta(1, 1)", bs = "gamma(1, 1)", ndt = glue("uniform(0, min_Y{resp})"), bias = "beta(1, 1)", quantile = "beta(1, 1)", xi = "normal(0, 2.5)", alpha = "normal(0, 4)", disc = "lognormal(0, 1)", theta = "logistic(0, 1)" ) } else { # except for 'mu' all parameters only support one link other than identity out <- switch(dpar_class, "", mu = def_scale_prior(x, center = FALSE, dpar = dpar), sigma = def_scale_prior(x), shape = "student_t(3, 0, 2.5)", nu = "normal(2.7, 0.8)", phi = "student_t(3, 0, 2.5)", kappa = "normal(5.0, 0.8)", beta = "normal(1.7, 1.3)", zi = "logistic(0, 1)", hu = "logistic(0, 1)", zoi = "logistic(0, 1)", coi = "logistic(0, 1)", bs = "normal(-0.6, 1.3)", bias = "logistic(0, 1)", quantile = "logistic(0, 1)", xi = "normal(0, 4)", alpha = "normal(0, 4)", disc = "normal(0, 1)" ) } out } # default priors for scale/SD parameters def_scale_prior <- function(x, ...) { UseMethod("def_scale_prior") } #' @export def_scale_prior.mvbrmsframe <- function(x, ...) { out <- ulapply(x$terms, def_scale_prior, ...) names(out) <- x$responses out } # @param center Should the prior be centered around zero? # If FALSE, the prior location is computed based on Y. #' @export def_scale_prior.brmsterms <- function(x, center = TRUE, df = 3, location = 0, scale = 2.5, dpar = NULL, ...) { y <- unname(x$frame$resp$values) link <- x$family$link if (has_logscale(x$family)) { link <- "log" } tlinks <- c("identity", "log", "inverse", "sqrt", "1/mu^2") if (link %in% tlinks && !is_like_factor(y) && !conv_cats_dpars(x)) { if (link %in% c("log", "inverse", "1/mu^2")) { # avoid Inf in link(y) y <- ifelse(y == 0, y + 0.1, y) } y_link <- SW(link(y, link = link)) scale_y <- round(mad(y_link), 1) if (is.finite(scale_y)) { scale <- max(scale, scale_y) } if (!center) { location_y <- round(median(y_link), 1) if (is.finite(location_y)) { location <- location_y } # offsets may render default intercept priors not sensible dpar <- as_one_character(dpar) offset <- unname(unlist(x$dpars[[dpar]]$sdata$offset)) if (length(offset)) { mean_offset <- mean(offset) if (is.finite(mean_offset)) { location <- location - mean_offset } } } } paste0("student_t(", sargs(df, location, scale), ")") } #' Validate Prior for \pkg{brms} Models #' #' Validate priors supplied by the user. Return a complete #' set of priors for the given model, including default priors. #' #' @inheritParams default_prior.default #' @inheritParams brm #' #' @return An object of class \code{brmsprior}. #' #' @seealso \code{\link[brms:default_prior.default]{default_prior}}, \code{\link{set_prior}}. #' #' @examples #' prior1 <- prior(normal(0,10), class = b) + #' prior(cauchy(0,2), class = sd) #' validate_prior(prior1, count ~ zAge + zBase * Trt + (1|patient), #' data = epilepsy, family = poisson()) #' #' @export validate_prior <- function(prior, formula, data, family = gaussian(), sample_prior = "no", data2 = NULL, knots = NULL, drop_unused_levels = TRUE, ...) { formula <- validate_formula(formula, data = data, family = family) bterms <- brmsterms(formula) data2 <- validate_data2(data2, bterms = bterms) data <- validate_data( data, bterms = bterms, data2 = data2, knots = knots, drop_unused_levels = drop_unused_levels ) bframe <- brmsframe(bterms, data) .validate_prior( prior, bframe = bframe, sample_prior = sample_prior, ... ) } # internal work function of 'validate_prior' .validate_prior <- function(prior, bframe, sample_prior, ...) { stopifnot(is.anybrmsframe(bframe)) sample_prior <- validate_sample_prior(sample_prior) all_priors <- .default_prior(bframe, internal = TRUE) if (is.null(prior)) { prior <- all_priors } else if (!is.brmsprior(prior)) { stop2("Argument 'prior' must be a 'brmsprior' object.") } if (!"tag" %in% names(prior)) { # the tag column was added in version 2.22.11 (#1724) # manually adding it retains compatibility with old brmsprior objects prior$tag <- "" } # when updating existing priors, invalid priors should be allowed allow_invalid_prior <- isTRUE(attr(prior, "allow_invalid_prior")) # temporarily exclude priors that should not be checked no_checks <- !nzchar(prior$class) prior_no_checks <- prior[no_checks, ] prior <- prior[!no_checks, ] # check for duplicated priors prior$class <- rename( prior$class, c("^cor$", "^rescor$", "^corme$", "^lncor$", "^cortime$"), c("L", "Lrescor", "Lme", "Llncor", "Lcortime"), fixed = FALSE ) if (any(duplicated(prior))) { stop2("Duplicated prior specifications are not allowed.") } # check for invalid priors # it is good to let the user know beforehand that some of their priors # were invalid in the model to avoid unnecessary refits if (nrow(prior)) { valid_ids <- which(duplicated(rbind(all_priors, prior))) invalid <- !seq_rows(prior) %in% (valid_ids - nrow(all_priors)) if (any(invalid) && !allow_invalid_prior) { stop2( "The following priors do not correspond ", "to any model parameter: \n", collapse(.print_prior(prior[invalid, ]), "\n"), "Function 'default_prior' might be helpful to you." ) } prior <- prior[!invalid, ] } prior$prior <- sub("^(lkj|lkj_corr)\\(", "lkj_corr_cholesky(", prior$prior) # include default parameter bounds; only new priors need bounds which_needs_lb <- which(is.na(prior$lb) & !nzchar(prior$coef)) for (i in which_needs_lb) { if (!is.na(prior$ub[i]) && nzchar(prior$ub[i])) { # if ub is specified lb should be specified in the same line as well prior$lb[i] <- stan_base_prior(all_priors, "lb", sel_prior = prior[i, ]) } else { # take the corresponding lb from the default prior prior_sub_i <- rbind(prior[i, ], all_priors) prior_sub_i <- prior_sub_i[duplicated(prior_sub_i), ] stopifnot(NROW(prior_sub_i) == 1L) prior$lb[i] <- prior_sub_i$lb } } which_needs_ub <- which(is.na(prior$ub) & !nzchar(prior$coef)) for (i in which_needs_ub) { if (!is.na(prior$lb[i]) && nzchar(prior$lb[i])) { # if lb is specified ub should be specified in the same line as well prior$ub[i] <- stan_base_prior(all_priors, "ub", sel_prior = prior[i, ]) } else { # take the corresponding lb from the default prior prior_sub_i <- rbind(prior[i, ], all_priors) prior_sub_i <- prior_sub_i[duplicated(prior_sub_i), ] stopifnot(NROW(prior_sub_i) == 1L) prior$ub[i] <- prior_sub_i$ub } } # the remaining NAs are in coef priors which cannot have bounds yet prior$lb[is.na(prior$lb)] <- prior$ub[is.na(prior$ub)] <- "" # boundaries on individual coefficients are not yet supported # TODO: enable bounds for coefficients as well? if (any((nzchar(prior$lb) | nzchar(prior$ub)) & nzchar(prior$coef))) { stop2("Prior argument 'coef' may not be specified when using boundaries.") } # merge user-specified priors with default priors prior$new <- rep(TRUE, nrow(prior)) all_priors$new <- rep(FALSE, nrow(all_priors)) prior <- c(all_priors, prior, replace = TRUE) check_prior_content(prior) prior <- validate_special_prior(prior, bframe = bframe, ...) prior <- prior[with(prior, order(class, group, resp, dpar, nlpar, coef)), ] # check and warn valid but unused priors for (i in which(nzchar(prior$prior) & !nzchar(prior$coef))) { ls <- prior[i, c("class", "group", "resp", "dpar", "nlpar")] class(ls) <- "data.frame" prior_sub_coef <- subset2(prior, ls = ls) prior_sub_coef <- prior_sub_coef[nzchar(prior_sub_coef$coef), ] if (nrow(prior_sub_coef) && all(nzchar(prior_sub_coef$prior))) { warning2( "The global prior '", prior$prior[i], "' of class '", prior$class[i], "' will not be used in the model as all related coefficients have ", "individual priors already. If you did not set those ", "priors yourself, then maybe brms has assigned default priors. ", "See ?set_prior and ?default_prior for more details." ) } } prior <- prior + prior_no_checks rownames(prior) <- NULL attr(prior, "sample_prior") <- sample_prior if (is_verbose()) { # show remaining default priors added to the model def_prior <- prepare_print_prior(prior) def_prior <- subset2(def_prior, source = "default") if (nrow(def_prior)) { message("The following priors were automatically added to the model:") print(def_prior, show_df = TRUE) } } prior } # try to check if prior distributions are reasonable # @param prior A brmsprior object check_prior_content <- function(prior) { if (!is.brmsprior(prior) || !NROW(prior)) { return(invisible(TRUE)) } lb_priors <- c( "lognormal", "chi_square", "inv_chi_square", "scaled_inv_chi_square", "exponential", "gamma", "inv_gamma", "weibull", "frechet", "rayleigh", "pareto", "pareto_type_2" ) lb_priors_regex <- paste0("^(", paste0(lb_priors, collapse = "|"), ")") ulb_priors <- c("beta", "uniform", "von_mises", "beta_proportion") ulb_priors_regex <- paste0("^(", paste0(ulb_priors, collapse = "|"), ")") cormat_pars <- c( "cor", "L", "rescor", "Lrescor", "corme", "Lme", "lncor", "Llncor", "cortime", "Lcortime" ) cormat_regex <- "^((lkj)|(constant))" simplex_pars <- c("simo", "theta", "sbhaz") simplex_regex <- "^((dirichlet)|(constant))\\(" lb_warning <- ub_warning <- "" for (i in seq_rows(prior)) { if (!nzchar(prior$prior[i]) || !prior$new[i]) { next } msg_prior <- .print_prior(prior[i, ]) has_lb_prior <- grepl(lb_priors_regex, prior$prior[i]) has_ulb_prior <- grepl(ulb_priors_regex, prior$prior[i]) base_bounds <- stan_base_prior(prior, c("lb", "ub"), sel_prior = prior[i, ]) has_lb <- nzchar(base_bounds[, "lb"]) has_ub <- nzchar(base_bounds[, "ub"]) if ((has_lb_prior || has_ulb_prior) && !has_lb) { lb_warning <- paste0(lb_warning, msg_prior, "\n") } if (has_ulb_prior && !has_ub) { ub_warning <- paste0(ub_warning, msg_prior, "\n") } if (prior$class[i] %in% cormat_pars && !grepl(cormat_regex, prior$prior[i])) { stop2( "The only supported prior for correlation matrices is ", "the 'lkj' prior. See help(set_prior) for more details." ) } if (prior$class[i] %in% simplex_pars && !grepl(simplex_regex, prior$prior[i])) { stop2( "Currently 'dirichlet' is the only valid prior for ", "simplex parameters. See help(set_prior) for more details." ) } } if (nzchar(lb_warning)) { warning2( "It appears as if you have specified a lower bounded ", "prior on a parameter that has no natural lower bound.", "\nIf this is really what you want, please specify ", "argument 'lb' of 'set_prior' appropriately.", "\nWarning occurred for prior \n", lb_warning ) } if (nzchar(ub_warning)) { warning2( "It appears as if you have specified an upper bounded ", "prior on a parameter that has no natural upper bound.", "\nIf this is really what you want, please specify ", "argument 'ub' of 'set_prior' appropriately.", "\nWarning occurred for prior \n", ub_warning ) } invisible(TRUE) } # prepare special priors for use in Stan # required for priors that are not natively supported by Stan validate_special_prior <- function(x, ...) { UseMethod("validate_special_prior") } #' @export validate_special_prior.default <- function(x, prior = empty_prior(), ...) { prior } #' @export validate_special_prior.brmsprior <- function(x, bframe, ...) { if (!NROW(x)) { return(x) } if (is.null(x$new)) { x$new <- TRUE } x$remove <- FALSE x <- validate_special_prior(bframe, prior = x, ...) x <- x[!x$remove, ] x$new <- x$remove <- NULL x } #' @export validate_special_prior.mvbrmsterms <- function(x, prior = NULL, ...) { for (i in seq_along(x$terms)) { prior <- validate_special_prior(x$terms[[i]], prior = prior, ...) } prior } #' @export validate_special_prior.brmsterms <- function(x, prior = NULL, ...) { if (is.null(prior)) { prior <- empty_prior() } simple_sigma <- simple_sigma(x) for (dp in names(x$dpars)) { allow_autoscale <- dp == "mu" && simple_sigma prior <- validate_special_prior( x$dpars[[dp]], prior = prior, allow_autoscale = allow_autoscale, ... ) } for (nlp in names(x$nlpars)) { prior <- validate_special_prior( x$nlpars[[nlp]], prior = prior, allow_autoscale = simple_sigma, ... ) } prior } #' @export validate_special_prior.btnl <- function(x, prior, ...) { prior } # prepare special priors that cannot be passed to Stan as is # @param allow_autoscale allow autoscaling by parameter sigma? # @return a possibly updated brmsprior object with additional attributes #' @export validate_special_prior.btl <- function(x, prior, allow_autoscale = TRUE, ...) { allow_autoscale <- as_one_logical(allow_autoscale) px <- check_prefix(x) # prepare special priors such as horseshoe special <- list() # the order of the classes doesn't matter but for consistency # it is still the same as the order in the Stan code special_classes <- c("b", "sds", "sdgp", "ar", "ma", "sderr", "sdcar", "sd") for (sc in special_classes) { index <- which(find_rows(prior, class = sc, coef = "", group = "", ls = px)) if (!length(index)) { next } stopifnot(length(index) <= 1L) sub_prior <- prior$prior[index] if (any(is_special_prior(sub_prior))) { # shrinkage priors have been specified if (sc %in% c("b", "ar", "ma")) { if (any(nzchar(prior[index, "lb"]) | nzchar(prior[index, "ub"]))) { stop2("Setting boundaries on coefficients is not ", "allowed when using special priors.") } # TODO: allow special priors also for 'cs' coefficients if (is.formula(x[["cs"]])) { stop2("Special priors are not yet allowed ", "in models with category-specific effects.") } } if (sc %in% c("sds", "sdgp", "sderr", "sdcar", "sd")) { if (any(prior[index, "lb"] != "0" | nzchar(prior[index, "ub"]))) { stop2("Setting custom boundaries on SD parameters is not ", "allowed when using special priors.") } } coef_indices <- which( find_rows(prior, class = sc, ls = px) & !find_rows(prior, class = sc, group = "", coef = "") ) if (any(nzchar(prior$prior[coef_indices]))) { stop2( "Defining separate priors for single coefficients or groups is not ", "allowed when using special priors for the whole class." ) } # the brms function may not be in the search path of formula env sub_prior <- paste0("brms::", sub_prior) tmp <- attributes(eval2(sub_prior, environment(x$formula))) tmp$autoscale <- isTRUE(tmp$autoscale) && allow_autoscale special[[sc]] <- tmp } } special_names <- unique(ufrom_list(special, "name")) if (length(special_names) > 1L) { stop2("Currently only one special prior per formula is allowed.") } prefix <- combine_prefix(px, keep_mu = TRUE) attributes(prior)$special[[prefix]] <- special prior } # validate argument 'sample_prior' validate_sample_prior <- function(sample_prior) { options <- c("no", "yes", "only") if (is.null(sample_prior)) { sample_prior <- "no" } if (!is.character(sample_prior)) { sample_prior <- as_one_logical(sample_prior) sample_prior <- if (sample_prior) "yes" else "no" } match.arg(sample_prior, options) } # get stored 'sample_prior' argument get_sample_prior <- function(prior) { validate_sample_prior(attr(prior, "sample_prior", TRUE)) } # create data.frames containing prior information brmsprior <- function(prior = "", class = "", coef = "", group = "", resp = "", dpar = "", nlpar = "", lb = "", ub = "", tag = "", source = "", ls = list()) { if (length(ls)) { if (is.null(names(ls))) { stop("Argument 'ls' must be named.") } names <- all_cols_prior() if (!all(names(ls) %in% names)) { stop("Names of 'ls' must some of ", collapse_comma(names)) } for (v in names(ls)) { assign(v, ls[[v]]) } } out <- data.frame( prior, class, coef, group, resp, dpar, nlpar, lb, ub, tag, source, stringsAsFactors = FALSE ) class(out) <- c("brmsprior", "data.frame") out } #' @describeIn set_prior Create an empty \code{brmsprior} object. #' @export empty_prior <- function() { char0 <- character(0) brmsprior( prior = char0, source = char0, class = char0, coef = char0, group = char0, resp = char0, dpar = char0, nlpar = char0, lb = char0, ub = char0, tag = char0 ) } # natural upper and lower bounds for priors # @param a named list with elements 'lb' and 'ub' prior_bounds <- function(prior) { switch(prior, lognormal = list(lb = 0, ub = Inf), chi_square = list(lb = 0, ub = Inf), inv_chi_square = list(lb = 0, ub = Inf), scaled_inv_chi_square = list(lb = 0, ub = Inf), exponential = list(lb = 0, ub = Inf), gamma = list(lb = 0, ub = Inf), inv_gamma = list(lb = 0, ub = Inf), weibull = list(lb = 0, ub = Inf), frechet = list(lb = 0, ub = Inf), rayleigh = list(lb = 0, ub = Inf), pareto = list(lb = 0, ub = Inf), pareto_type_2 = list(lb = 0, ub = Inf), beta = list(lb = 0, ub = 1), von_mises = list(lb = -pi, ub = pi), list(lb = -Inf, ub = Inf) ) } # all columns of brmsprior objects all_cols_prior <- function() { c("prior", "class", "coef", "group", "resp", "dpar", "nlpar", "lb", "ub", "tag", "source") } # relevant columns for duplication checks in brmsprior objects rcols_prior <- function() { c("class", "coef", "group", "resp", "dpar", "nlpar") } # default Stan definitions for distributional parameters # @param dpar name of a distributional parameter # @param suffix optional suffix of the parameter name # @param family optional brmsfamily object # @return a named list with numeric elements 'lb' and 'ub' dpar_bounds <- function(dpar, suffix = "", family = NULL) { dpar <- as_one_character(dpar) suffix <- usc(as_one_character(suffix)) if (is.mixfamily(family)) { if (dpar_class(dpar) == "theta") { return(list(lb = -Inf, ub = Inf)) } family <- family$mix[[as.numeric(dpar_id(dpar))]] } dpar_class <- dpar_class(dpar, family) if (is.customfamily(family)) { lb <- family$lb[[dpar_class]] ub <- family$ub[[dpar_class]] return(nlist(lb, ub)) } min_Y <- glue("min_Y{suffix}") out <- switch(dpar_class, sigma = list(lb = "0", ub = ""), shape = list(lb = "0", ub = ""), nu = list(lb = "1", ub = ""), phi = list(lb = "0", ub = ""), kappa = list(lb = "0", ub = ""), beta = list(lb = "0", ub = ""), zi = list(lb = "0", ub = "1"), hu = list(lb = "0", ub = "1"), zoi = list(lb = "0", ub = "1"), coi = list(lb = "0", ub = "1"), bs = list(lb = "0", ub = ""), ndt = list(lb = "0", ub = min_Y), bias = list(lb = "0", ub = "1"), disc = list(lb = "0", ub = ""), quantile = list(lb = "0", ub = "1"), xi = list(lb = "", ub = ""), alpha = list(lb = "", ub = "") ) out } # convert parameter bounds to Stan syntax # vectorized over both 'lb' and 'ub' vectors # @param bounds a named list with elements 'lb' and 'ub' # @param default default output if no proper bounds are specified convert_bounds2stan <- function(bounds, default = "") { lb <- as.character(bounds$lb) ub <- as.character(bounds$ub) stopifnot(length(lb) == length(ub)) default <- as_one_character(default, allow_na = TRUE) if (any(lb %in% "Inf")) { stop2("Lower boundaries cannot be positive infinite.") } if (any(ub %in% "-Inf")) { stop2("Upper boundaries cannot be negative infinite.") } lb <- ifelse( !is.na(lb) & !lb %in% c("NA", "-Inf", ""), paste0("lower=", lb), "" ) ub <- ifelse( !is.na(ub) & !ub %in% c("NA", "Inf", ""), paste0("upper=", ub), "" ) out <- ifelse( nzchar(lb) & nzchar(ub), glue("<{lb},{ub}>"), ifelse( nzchar(lb) & !nzchar(ub), glue("<{lb}>"), ifelse( !nzchar(lb) & nzchar(ub), glue("<{ub}>"), default ) ) ) out } # convert parameter bounds in Stan syntax # TODO: vectorize over a character vector of bounds? # complicated because of a mix of character and numeric values # to a named list with elements 'lb' and 'ub' convert_stan2bounds <- function(bound, default = c(-Inf, Inf)) { bound <- as_one_character(bound) stopifnot(length(default) == 2L) out <- list(lb = default[[1]], ub = default[[2]]) if (!is.na(bound) && isTRUE(nzchar(bound))) { lb <- get_matches("(<|,)lower=[^,>]+", bound) if (isTRUE(nzchar(lb))) { lb <- substr(lb, 8, nchar(lb)) lb_num <- SW(as.numeric(lb)) if (!is.na(lb_num)) { lb <- lb_num } out$lb <- lb } ub <- get_matches("(<|,)upper=[^,>]+", bound) if (isTRUE(nzchar(ub))) { ub <- substr(ub, 8, nchar(ub)) ub_num <- SW(as.numeric(ub)) if (!is.na(ub_num)) { ub <- ub_num } out$ub <- ub } } out } #' Priors of \code{brms} models #' #' Extract priors of models fitted with \pkg{brms}. #' #' @aliases prior_summary #' #' @param object An object of class \code{brmsfit}. #' @param all Logical; Show all parameters in the model which may have #' priors (\code{TRUE}) or only those with proper priors (\code{FALSE})? #' @param ... Further arguments passed to or from other methods. #' #' @return An \code{brmsprior} object. #' #' @examples #' \dontrun{ #' fit <- brm( #' count ~ zAge + zBase * Trt + (1|patient) + (1|obs), #' data = epilepsy, family = poisson(), #' prior = prior(student_t(5,0,10), class = b) + #' prior(cauchy(0,2), class = sd) #' ) #' #' prior_summary(fit) #' prior_summary(fit, all = FALSE) #' print(prior_summary(fit, all = FALSE), show_df = FALSE) #' } #' #' @method prior_summary brmsfit #' @export #' @export prior_summary #' @importFrom rstantools prior_summary #' @export prior_summary.brmsfit <- function(object, all = TRUE, ...) { object <- restructure(object) prior <- object$prior if (!all) { prior <- prior[nzchar(prior$prior), ] } prior } #' Checks if argument is a \code{brmsprior} object #' #' @param x An \R object #' #' @export is.brmsprior <- function(x) { inherits(x, "brmsprior") } #' Print method for \code{brmsprior} objects #' #' @param x An object of class \code{brmsprior}. #' @param show_df Logical; Print priors as a single #' \code{data.frame} (\code{TRUE}) or as a sequence of #' sampling statements (\code{FALSE})? #' @param ... Currently ignored. #' #' @export print.brmsprior <- function(x, show_df = NULL, ...) { if (is.null(show_df)) { show_df <- nrow(x) > 1L } show_df <- as_one_logical(show_df) y <- prepare_print_prior(x) if (show_df) { print.data.frame(y, row.names = FALSE, ...) } else { cat(collapse(.print_prior(y), "\n")) } invisible(x) } # prepare pretty printing of brmsprior objects prepare_print_prior <- function(x) { stopifnot(is.brmsprior(x)) if (is.null(x$source)) { x$source <- "" } x$source[!nzchar(x$source)] <- "(unknown)" # vectorize priors and bounds for pretty printing # TODO: improve efficiency of adding vectorization tags for (i in which(!nzchar(x$prior))) { base_prior <- stan_base_prior(x, sel_prior = x[i, ]) if (nzchar(base_prior)) { x$prior[i] <- base_prior x$source[i] <- "(vectorized)" } else { x$prior[i] <- "(flat)" } } for (i in which(!nzchar(x$tag))) { base_lprior_tag <- stan_base_prior(x, col = "tag", sel_prior = x[i, ]) if (nzchar(base_lprior_tag)) { x$tag[i] <- base_lprior_tag } } for (i in which(!nzchar(x$lb) & !nzchar(x$ub))) { base_bounds <- stan_base_prior(x, col = c("lb", "ub"), sel_prior = x[i, ]) x$lb[i] <- base_bounds[, "lb"] x$ub[i] <- base_bounds[, "ub"] } x } # prepare text for print.brmsprior .print_prior <- function(x) { group <- usc(x$group) resp <- usc(x$resp) dpar <- usc(x$dpar) nlpar <- usc(x$nlpar) coef <- usc(x$coef) if (any(nzchar(c(resp, dpar, nlpar, coef)))) { group <- usc(group, "suffix") } bound <- convert_bounds2stan(x[c("lb", "ub")]) bound <- ifelse(nzchar(bound), paste0(bound, " "), "") tilde <- ifelse(nzchar(x$class) | nzchar(group) | nzchar(coef), " ~ ", "") prior <- ifelse(nzchar(x$prior), x$prior, "(flat)") paste0(bound, x$class, group, resp, dpar, nlpar, coef, tilde, prior) } # combine multiple brmsprior objects into one brmsprior #' @export c.brmsprior <- function(x, ..., replace = FALSE) { dots <- list(...) if (all(sapply(dots, is.brmsprior))) { replace <- as_one_logical(replace) # don't use 'c()' here to avoid creating a recursion out <- do_call(rbind, list(x, ...)) if (replace) { # update duplicated priors out <- unique(out, fromLast = TRUE) } } else { if (length(dots)) { stop2("Cannot add '", class(dots[[1]])[1], "' objects to the prior.") } out <- c(as.data.frame(x)) } out } #' @export "+.brmsprior" <- function(e1, e2) { if (is.null(e2)) { return(e1) } if (!is.brmsprior(e2)) { stop2("Cannot add '", class(e2)[1], "' objects to the prior.") } c(e1, e2) } #' Transform into a brmsprior object #' #' Try to transform an object into a \code{brmsprior} object. #' #' @param x An object to be transformed. #' @return A \code{brmsprior} object if the transformation was possible. #' #' @export as.brmsprior <- function(x) { if (is.brmsprior(x)) { return(x) } x <- as.data.frame(x) if (!"prior" %in% names(x)) { stop2("Column 'prior' is required.") } x$prior <- as.character(x$prior) defaults <- c( class = "b", coef = "", group = "", resp = "", dpar = "", nlpar = "", lb = NA, ub = NA, tag = "" ) for (v in names(defaults)) { if (!v %in% names(x)) { x[[v]] <- defaults[v] } x[[v]] <- as.character(x[[v]]) } x$source <- "user" all_vars <- c("prior", names(defaults), "source") x <- x[, all_vars, drop = FALSE] class(x) <- c("brmsprior", "data.frame") x } #' @export duplicated.brmsprior <- function(x, incomparables = FALSE, ...) { # compare only specific columns of the brmsprior object duplicated.data.frame(x[, rcols_prior()], incomparables, ...) } # evaluate the dirichlet prior of simplex parameters # avoid name clashing with the dirichlet family # @param prior a character vector of the form 'dirichlet(...)' # @param len desired length of the prior concentration vector # @param env environment in which to search for data # @return a numeric vector of prior concentration values eval_dirichlet <- function(prior, len = NULL, env = NULL) { dirichlet <- function(...) { out <- try(as.numeric(c(...))) if (is_try_error(out)) { stop2("Something went wrong. Did you forget to store ", "auxiliary data in the 'data2' argument?") } if (anyNA(out) || any(out <= 0)) { stop2("The dirichlet prior expects positive values.") } if (!is.null(len)) { if (length(out) == 1L) { out <- rep(out, len) } if (length(out) != len) { stop2("Invalid Dirichlet prior. Expected input of length ", len, ".") } } return(out) } prior <- as_one_character(prior) if (!nzchar(prior)) { prior <- "dirichlet(1)" } eval2(prior, envir = env, enclos = environment()) } #' Regularized horseshoe priors in \pkg{brms} #' #' Function used to set up regularized horseshoe priors and related hierarchical #' shrinkage priors in \pkg{brms}. The function does not evaluate its arguments #' -- it exists purely to help set up the model. #' #' @param df Degrees of freedom of student-t prior of the #' local shrinkage parameters. Defaults to \code{1}. #' @param scale_global Scale of the student-t prior of the global shrinkage #' parameter. Defaults to \code{1}. #' In linear models, \code{scale_global} will internally be #' multiplied by the residual standard deviation parameter \code{sigma}. #' @param df_global Degrees of freedom of student-t prior of the #' global shrinkage parameter. Defaults to \code{1}. If \code{df_global} #' is greater \code{1}, the shape of the prior will no longer resemble #' a horseshoe and it may be more appropriately called an hierarchical #' shrinkage prior in this case. #' @param scale_slab Scale of the Student-t slab. Defaults to \code{2}. The #' original unregularized horseshoe prior is obtained by setting #' \code{scale_slab} to infinite, which we can approximate in practice by #' setting it to a very large real value. #' @param df_slab Degrees of freedom of the student-t slab. #' Defaults to \code{4}. #' @param par_ratio Ratio of the expected number of non-zero coefficients #' to the expected number of zero coefficients. If specified, #' \code{scale_global} is ignored and internally computed as #' \code{par_ratio / sqrt(N)}, where \code{N} is the total number #' of observations in the data. #' @param autoscale Logical; indicating whether the horseshoe #' prior should be scaled using the residual standard deviation #' \code{sigma} if possible and sensible (defaults to \code{TRUE}). #' Autoscaling is not applied for distributional parameters or #' when the model does not contain the parameter \code{sigma}. #' @param main Logical (defaults to \code{FALSE}); only relevant if the horseshoe #' prior spans multiple parameter classes. In this case, only arguments given #' in the single instance where \code{main} is \code{TRUE} will be used. #' Arguments given in other instances of the prior will be ignored. #' See the Examples section below. #' #' @return A character string obtained by \code{match.call()} with #' additional arguments. #' #' @details #' The horseshoe prior is a special shrinkage prior initially proposed by #' Carvalho et al. (2009). #' It is symmetric around zero with fat tails and an infinitely large spike #' at zero. This makes it ideal for sparse models that have #' many regression coefficients, although only a minority of them is non-zero. #' The horseshoe prior can be applied on all population-level effects at once #' (excluding the intercept) by using \code{set_prior("horseshoe(1)")}. #' The \code{1} implies that the student-t prior of the local shrinkage #' parameters has 1 degrees of freedom. This may, however, lead to an #' increased number of divergent transition in \pkg{Stan}. #' Accordingly, increasing the degrees of freedom to slightly higher values #' (e.g., \code{3}) may often be a better option, although the prior #' no longer resembles a horseshoe in this case. #' Further, the scale of the global shrinkage parameter plays an important role #' in amount of shrinkage applied. It defaults to \code{1}, #' but this may result in too few shrinkage (Piironen & Vehtari, 2016). #' It is thus possible to change the scale using argument \code{scale_global} #' of the horseshoe prior, for instance \code{horseshoe(1, scale_global = 0.5)}. #' In linear models, \code{scale_global} will internally be multiplied by the #' residual standard deviation parameter \code{sigma}. See Piironen and #' Vehtari (2016) for recommendations how to properly set the global scale. #' The degrees of freedom of the global shrinkage prior may also be #' adjusted via argument \code{df_global}. #' Piironen and Vehtari (2017) recommend to specifying the ratio of the #' expected number of non-zero coefficients to the expected number of zero #' coefficients \code{par_ratio} rather than \code{scale_global} directly. #' As proposed by Piironen and Vehtari (2017), an additional regularization #' is applied that only affects non-zero coefficients. The amount of #' regularization can be controlled via \code{scale_slab} and \code{df_slab}. #' To make sure that shrinkage can equally affect all coefficients, #' predictors should be one the same scale. #' Generally, models with horseshoe priors a more likely than other models #' to have divergent transitions so that increasing \code{adapt_delta} #' from \code{0.8} to values closer to \code{1} will often be necessary. #' See the documentation of \code{\link{brm}} for instructions #' on how to increase \code{adapt_delta}. #' #' The prior does not account for scale differences of the terms it is #' applied on. Accordingly, please make sure that all these terms have a #' comparable scale to ensure that shrinkage is applied properly. #' #' Currently, the following classes support the horseshoe prior: \code{b} #' (overall regression coefficients), \code{sds} (SDs of smoothing splines), #' \code{sdgp} (SDs of Gaussian processes), \code{ar} (autoregressive #' coefficients), \code{ma} (moving average coefficients), \code{sderr} (SD of #' latent residuals), \code{sdcar} (SD of spatial CAR structures), \code{sd} #' (SD of varying coefficients). #' #' @references #' Carvalho, C. M., Polson, N. G., & Scott, J. G. (2009). Handling sparsity via #' the horseshoe. Artificial Intelligence and Statistics. #' \url{http://proceedings.mlr.press/v5/carvalho09a} #' #' Piironen J. & Vehtari A. (2017). On the Hyperprior Choice for the Global #' Shrinkage Parameter in the Horseshoe Prior. Artificial Intelligence and #' Statistics. \url{https://arxiv.org/pdf/1610.05559v1} #' #' Piironen, J., and Vehtari, A. (2017). Sparsity information and regularization #' in the horseshoe and other shrinkage priors. Electronic Journal of #' Statistics. \url{https://arxiv.org/abs/1707.01694} #' #' @seealso \code{\link{set_prior}} #' #' @examples #' set_prior(horseshoe(df = 3, par_ratio = 0.1)) #' #' # specify the horseshoe prior across multiple parameter classes #' set_prior(horseshoe(df = 3, par_ratio = 0.1, main = TRUE), class = "b") + #' set_prior(horseshoe(), class = "sd") #' #' @export horseshoe <- function(df = 1, scale_global = 1, df_global = 1, scale_slab = 2, df_slab = 4, par_ratio = NULL, autoscale = TRUE, main = FALSE) { out <- deparse0(match.call()) name <- "horseshoe" df <- as.numeric(df) df_global <- as.numeric(df_global) df_slab <- as.numeric(df_slab) scale_global <- as.numeric(scale_global) scale_slab <- as.numeric(scale_slab) main <- as_one_logical(main) if (!isTRUE(df > 0)) { stop2("Invalid horseshoe prior: Degrees of freedom of ", "the local priors must be a single positive number.") } if (!isTRUE(df_global > 0)) { stop2("Invalid horseshoe prior: Degrees of freedom of ", "the global prior must be a single positive number.") } if (!isTRUE(scale_global > 0)) { stop2("Invalid horseshoe prior: Scale of the global ", "prior must be a single positive number.") } if (!isTRUE(df_slab > 0)) { stop2("Invalid horseshoe prior: Degrees of freedom of ", "the slab part must be a single positive number.") } if (!isTRUE(scale_slab > 0)) { stop2("Invalid horseshoe prior: Scale of the slab ", "part must be a single positive number.") } if (!is.null(par_ratio)) { par_ratio <- as.numeric(par_ratio) if (!isTRUE(par_ratio > 0)) { stop2("Argument 'par_ratio' must be greater 0.") } } autoscale <- as_one_logical(autoscale) att <- nlist( name, df, df_global, df_slab, scale_global, scale_slab, par_ratio, autoscale, main ) attributes(out)[names(att)] <- att out } #' R2D2 Priors in \pkg{brms} #' #' Function used to set up R2D2(M2) priors in \pkg{brms}. The function does #' not evaluate its arguments -- it exists purely to help set up the model. #' #' @param mean_R2 Mean of the Beta prior on the coefficient of determination R^2. #' @param prec_R2 Precision of the Beta prior on the coefficient of determination R^2. #' @param cons_D2 Concentration vector of the Dirichlet prior on the variance #' decomposition parameters. Lower values imply more shrinkage. #' @param autoscale Logical; indicating whether the R2D2 #' prior should be scaled using the residual standard deviation #' \code{sigma} if possible and sensible (defaults to \code{TRUE}). #' Autoscaling is not applied for distributional parameters or #' when the model does not contain the parameter \code{sigma}. #' @param main Logical (defaults to \code{FALSE}); only relevant if the R2D2 #' prior spans multiple parameter classes. In this case, only arguments given #' in the single instance where \code{main} is \code{TRUE} will be used. #' Arguments given in other instances of the prior will be ignored. #' See the Examples section below. #' #' @details #' The prior does not account for scale differences of the terms it is #' applied on. Accordingly, please make sure that all these terms have a #' comparable scale to ensure that shrinkage is applied properly. #' #' Currently, the following classes support the R2D2(M2) prior: \code{b} #' (overall regression coefficients), \code{sds} (SDs of smoothing splines), #' \code{sdgp} (SDs of Gaussian processes), \code{ar} (autoregressive #' coefficients), \code{ma} (moving average coefficients), \code{sderr} (SD of #' latent residuals), \code{sdcar} (SD of spatial CAR structures), \code{sd} #' (SD of varying coefficients). #' #' When the prior is only applied to parameter class \code{b}, it is equivalent #' to the original R2D2 prior (with Gaussian kernel). When the prior is also #' applied to other parameter classes, it is equivalent to the R2D2M2 prior. #' #' Even when the R2D2(M2) prior is applied to multiple parameter classes at once, #' the concentration vector (argument \code{cons_D2}) has to be provided #' jointly in the the one instance of the prior where \code{main = TRUE}. The #' order in which the elements of concentration vector correspond to the #' classes' coefficients is the same as the order of the classes provided #' above. #' #' @references #' Zhang, Y. D., Naughton, B. P., Bondell, H. D., & Reich, B. J. (2020). #' Bayesian regression using a prior on the model fit: The R2-D2 shrinkage #' prior. Journal of the American Statistical Association. #' \url{https://arxiv.org/pdf/1609.00046} #' #' Aguilar J. E. & Bürkner P. C. (2022). Intuitive Joint Priors for Bayesian #' Linear Multilevel Models: The R2D2M2 prior. ArXiv preprint. #' \url{https://arxiv.org/pdf/2208.07132} #' #' @seealso \code{\link{set_prior}} #' #' @examples #' set_prior(R2D2(mean_R2 = 0.8, prec_R2 = 10)) #' #' # specify the R2D2 prior across multiple parameter classes #' set_prior(R2D2(mean_R2 = 0.8, prec_R2 = 10, main = TRUE), class = "b") + #' set_prior(R2D2(), class = "sd") #' #' @export R2D2 <- function(mean_R2 = 0.5, prec_R2 = 2, cons_D2 = 0.5, autoscale = TRUE, main = FALSE) { out <- deparse0(match.call()) name <- "R2D2" mean_R2 <- as_one_numeric(mean_R2) prec_R2 <- as_one_numeric(prec_R2) cons_D2 <- as.numeric(cons_D2) main <- as_one_logical(main) if (!(mean_R2 > 0 && mean_R2 < 1)) { stop2("Invalid R2D2 prior: Mean of the R2 prior ", "must be a single number in (0, 1).") } if (prec_R2 <= 0) { stop2("Invalid R2D2 prior: Precision of the R2 prior ", "must be a single positive number.") } if (any(cons_D2 <= 0)) { stop2("Invalid R2D2 prior: Concentration of the D2 prior ", "must be a vector of positive numbers.") } autoscale <- as_one_logical(autoscale) att <- nlist(name, mean_R2, prec_R2, cons_D2, autoscale, main) attributes(out)[names(att)] <- att out } #' (Defunct) Set up a lasso prior in \pkg{brms} #' #' This functionality is no longer supported as of brms version 2.19.2. Please #' use the \code{\link{horseshoe}} or \code{\link{R2D2}} shrinkage priors instead. #' #' @param df Degrees of freedom of the chi-square prior of the inverse tuning #' parameter. Defaults to \code{1}. #' @param scale Scale of the lasso prior. Defaults to \code{1}. #' #' @return An error indicating that the lasso prior is no longer supported. #' #' @references #' Park, T., & Casella, G. (2008). The Bayesian Lasso. Journal of the American #' Statistical Association, 103(482), 681-686. #' #' @seealso \code{\link{set_prior}}, \code{\link{horseshoe}}, \code{\link{R2D2}} #' #' @export lasso <- function(df = 1, scale = 1) { stop2("The lasso prior is no longer supported as of brms version 2.19.2. ", "Please use the horseshoe or R2D2 shrinkage priors instead.") } # check for the usage of special priors # @param prior a character vector of priors # @param target optional special priors to search for # if NULL search for all special priors # @return a logical vector equal to the length of 'prior' is_special_prior <- function(prior, target = NULL) { stopifnot(is.character(prior)) if (is.null(target)) { target <- c("horseshoe", "R2D2", "lasso") } regex <- paste0("^", regex_or(target), "\\(") grepl(regex, prior) } # extract special prior information # @param prior a brmsprior object # @param class parameter class to be checked. the default ensures that #. the presence of any special prior is always detected # @param px object from which the prefix can be extract # @param type type of the special prior get_special_prior <- function(prior, px, class = NULL, main = FALSE) { out <- attr(prior, "special") prefix <- combine_prefix(px, keep_mu = TRUE) out <- out[[prefix]] if (!length(out)) { return(NULL) } if (main) { # get the main special prior to extract arguments from if (length(out) == 1L) { # only one class present which must then be main out <- out[[1]] } else { main <- which(ufrom_list(out, "main")) if (length(main) != 1L) { stop2("If special priors for multiple classes are given, ", "exactly one of them must be marked with 'main = TRUE'.") } out <- out[[main]] } } else if (!is.null(class)) { out <- out[[class]] } else { # just extract info on any class for example the first out <- out[[1]] } out } # is special prior information present? has_special_prior <- function(prior, px = NULL, class = NULL) { if (is.null(px)) { # is any special prior present? return(length(rmNULL(attr(prior, "special"))) > 0L) } .has_special_prior <- function(px) { !is.null(get_special_prior(prior, px = px, class = class)) } if (is.data.frame(px)) { # this case occurs for group-level parameters out <- FALSE for (i in seq_rows(px)) { out <- out || .has_special_prior(px[i, ]) } } else { out <- .has_special_prior(px) } out } #' Constant priors in \pkg{brms} #' #' Function used to set up constant priors in \pkg{brms}. #' The function does not evaluate its arguments -- it exists purely #' to help set up the model. #' #' @param const Numeric value, vector, matrix of values to which the parameters #' should be fixed to. Can also be a valid Stan variable in the model. #' @param broadcast Should \code{const} be automatically broadcasted to the #' correct size of the parameter? Defaults to \code{TRUE}. If you supply #' vectors or matrices in \code{const} or vector/matrix valued Stan variables, #' you need to set \code{broadcast} to \code{TRUE} (see Examples). #' #' @returns A named list with elements \code{const} and \code{broadcast}. #' #' @examples #' stancode(count ~ Base + Age, data = epilepsy, #' prior = prior(constant(1), class = "b")) #' #' # will fail parsing because brms will try to broadcast a vector into a vector #' stancode(count ~ Base + Age, data = epilepsy, #' prior = prior(constant(alpha), class = "b"), #' stanvars = stanvar(c(1, 0), name = "alpha")) #' #' stancode(count ~ Base + Age, data = epilepsy, #' prior = prior(constant(alpha, broadcast = FALSE), class = "b"), #' stanvars = stanvar(c(1, 0), name = "alpha")) #' #' @seealso \code{\link{set_prior}} #' #' @export constant <- function(const, broadcast = TRUE) { const <- deparse0(substitute(const)) const <- rename(const, c("\"", "'"), c("", "")) broadcast <- as_one_logical(broadcast) nlist(const, broadcast) } # check if parameters should be sampled only from the prior is_prior_only <- function(prior) { is_equal(get_sample_prior(prior), "only") } brms/R/brmsfit-class.R0000644000176200001440000001015615053072461014320 0ustar liggesusers#' Class \code{brmsfit} of models fitted with the \pkg{brms} package #' #' Models fitted with the \code{\link[brms:brms-package]{brms}} package are #' represented as a \code{brmsfit} object, which contains the posterior #' draws (samples), model formula, Stan code, relevant data, and other information. #' #' @name brmsfit-class #' @aliases brmsfit #' @docType class #' #' @details #' See \code{methods(class = "brmsfit")} for an overview of available methods. #' #' @slot formula A \code{\link{brmsformula}} object. #' @slot data A \code{data.frame} containing all variables used in the model. #' @slot data2 A \code{list} of data objects which cannot be passed #' via \code{data}. #' @slot prior A \code{\link{brmsprior}} object containing #' information on the priors used in the model. #' @slot stanvars A \code{\link{stanvars}} object. #' @slot model The model code in \pkg{Stan} language. #' @slot exclude The names of the parameters for which draws are not saved. #' @slot algorithm The name of the algorithm used to fit the model. #' @slot backend The name of the backend used to fit the model. #' @slot threads An object of class `brmsthreads` created by #' \code{\link{threading}}. #' @slot opencl An object of class `brmsopencl` created by \code{\link{opencl}}. #' @slot stan_args Named list of additional control arguments that were passed #' to the Stan backend directly. #' @slot fit An object of class \code{\link[rstan:stanfit-class]{stanfit}} #' among others containing the posterior draws. #' @slot basis An object that contains a small subset of the Stan data #' created at fitting time, which is needed to process new data correctly. #' @slot criteria An empty \code{list} for adding model fit criteria #' after estimation of the model. #' @slot file Optional name of a file in which the model object was stored in #' or loaded from. #' @slot version The versions of \pkg{brms} and \pkg{rstan} with #' which the model was fitted. #' @slot family (Deprecated) A \code{\link{brmsfamily}} object. #' @slot autocor (Deprecated) An \code{\link{cor_brms}} object containing #' the autocorrelation structure if specified. #' @slot ranef (Deprecated) A \code{data.frame} containing the group-level structure. #' @slot cov_ranef (Deprecated) A \code{list} of customized group-level #' covariance matrices. #' @slot stan_funs (Deprecated) A character string of length one or \code{NULL}. #' @slot data.name (Deprecated) The name of \code{data} as specified by the user. #' #' @seealso #' \code{\link{brms}}, #' \code{\link{brm}}, #' \code{\link{brmsformula}}, #' \code{\link{brmsfamily}} #' NULL # brmsfit class brmsfit <- function(formula = NULL, data = data.frame(), prior = empty_prior(), data2 = list(), stanvars = NULL, model = "", save_pars = NULL, algorithm = "sampling", backend = "rstan", threads = threading(), opencl = opencl(), stan_args = list(), fit = NULL, basis = NULL, criteria = list(), file = NULL, family = NULL, autocor = NULL, ranef = empty_reframe(), cov_ranef = NULL, stan_funs = NULL, data.name = "") { version <- list( brms = utils::packageVersion("brms"), rstan = utils::packageVersion("rstan"), stanHeaders = utils::packageVersion("StanHeaders") ) if (backend == "cmdstanr") { require_package("cmdstanr") version$cmdstanr <- utils::packageVersion("cmdstanr") version$cmdstan <- as.package_version(cmdstanr::cmdstan_version()) } x <- nlist( formula, data, prior, data2, stanvars, model, save_pars, algorithm, backend, threads, opencl, stan_args, fit, basis, criteria, file, version, family, autocor, ranef, cov_ranef, stan_funs, data.name ) class(x) <- "brmsfit" x } #' Checks if argument is a \code{brmsfit} object #' #' @param x An \R object #' #' @export is.brmsfit <- function(x) { inherits(x, "brmsfit") } #' Checks if argument is a \code{brmsfit_multiple} object #' #' @param x An \R object #' #' @export is.brmsfit_multiple <- function(x) { inherits(x, "brmsfit_multiple") } is.stanfit <- function(x) { inherits(x, "stanfit") } brms/R/pp_mixture.R0000644000176200001440000000710015053072461013736 0ustar liggesusers#' Posterior Probabilities of Mixture Component Memberships #' #' Compute the posterior probabilities of mixture component #' memberships for each observation including uncertainty #' estimates. #' #' @inheritParams predict.brmsfit #' @param x An \R object usually of class \code{brmsfit}. #' @param log Logical; Indicates whether to return #' probabilities on the log-scale. #' #' @return #' If \code{summary = TRUE}, an N x E x K array, #' where N is the number of observations, K is the number #' of mixture components, and E is equal to \code{length(probs) + 2}. #' If \code{summary = FALSE}, an S x N x K array, where #' S is the number of posterior draws. #' #' @details #' The returned probabilities can be written as #' \eqn{P(K_n = k | Y_n)}, that is the posterior probability #' that observation n originates from component k. #' They are computed using Bayes' Theorem #' \deqn{P(K_n = k | Y_n) = P(Y_n | K_n = k) P(K_n = k) / P(Y_n),} #' where \eqn{P(Y_n | K_n = k)} is the (posterior) likelihood #' of observation n for component k, \eqn{P(K_n = k)} is #' the (posterior) mixing probability of component k #' (i.e. parameter \code{theta}), and #' \deqn{P(Y_n) = \sum_{k=1,...,K} P(Y_n | K_n = k) P(K_n = k)} #' is a normalizing constant. #' #' @examples #' \dontrun{ #' ## simulate some data #' set.seed(1234) #' dat <- data.frame( #' y = c(rnorm(100), rnorm(50, 2)), #' x = rnorm(150) #' ) #' ## fit a simple normal mixture model #' mix <- mixture(gaussian, nmix = 2) #' prior <- c( #' prior(normal(0, 5), Intercept, nlpar = mu1), #' prior(normal(0, 5), Intercept, nlpar = mu2), #' prior(dirichlet(2, 2), theta) #' ) #' fit1 <- brm(bf(y ~ x), dat, family = mix, #' prior = prior, chains = 2, init = 0) #' summary(fit1) #' #' ## compute the membership probabilities #' ppm <- pp_mixture(fit1) #' str(ppm) #' #' ## extract point estimates for each observation #' head(ppm[, 1, ]) #' #' ## classify every observation according to #' ## the most likely component #' apply(ppm[, 1, ], 1, which.max) #' } #' #' @export pp_mixture.brmsfit <- function(x, newdata = NULL, re_formula = NULL, resp = NULL, ndraws = NULL, draw_ids = NULL, log = FALSE, summary = TRUE, robust = FALSE, probs = c(0.025, 0.975), ...) { log <- as_one_logical(log) contains_draws(x) x <- restructure(x) stopifnot_resp(x, resp) if (is_mv(x)) { resp <- validate_resp(resp, x$formula$responses, multiple = FALSE) family <- x$family[[resp]] } else { family <- x$family } if (!is.mixfamily(family)) { stop2("Method 'pp_mixture' can only be applied to mixture models.") } prep <- prepare_predictions( x, newdata = newdata, re_formula = re_formula, resp = resp, draw_ids = draw_ids, ndraws = ndraws, check_response = TRUE, ... ) stopifnot(is.brmsprep(prep)) prep$pp_mixture <- TRUE for (dp in names(prep$dpars)) { prep$dpars[[dp]] <- get_dpar(prep, dpar = dp) } N <- choose_N(prep) out <- lapply(seq_len(N), log_lik_mixture, prep = prep) out <- abind(out, along = 3) out <- aperm(out, c(1, 3, 2)) old_order <- prep$old_order sort <- isTRUE(ncol(out) != length(old_order)) out <- reorder_obs(out, old_order, sort = sort) if (!log) { out <- exp(out) } if (summary) { out <- posterior_summary(out, probs = probs, robust = robust) dimnames(out) <- list( seq_len(nrow(out)), colnames(out), paste0("P(K = ", seq_len(dim(out)[3]), " | Y)") ) } out } #' @rdname pp_mixture.brmsfit #' @export pp_mixture <- function(x, ...) { UseMethod("pp_mixture") } brms/R/formula-ac.R0000644000176200001440000005355715053072461013611 0ustar liggesusers#' Autocorrelation structures #' #' Specify autocorrelation terms in \pkg{brms} models. Currently supported terms #' are \code{\link{arma}}, \code{\link{ar}}, \code{\link{ma}}, #' \code{\link{cosy}}, \code{\link{unstr}}, \code{\link{sar}}, #' \code{\link{car}}, and \code{\link{fcor}}. Terms can be directly specified #' within the formula, or passed to the \code{autocor} argument of #' \code{\link{brmsformula}} in the form of a one-sided formula. For deprecated #' ways of specifying autocorrelation terms, see \code{\link{cor_brms}}. #' #' @name autocor-terms #' #' @details The autocor term functions are almost solely useful when called in #' formulas passed to the \pkg{brms} package. They do not evaluate its #' arguments -- but exist purely to help set up a model with autocorrelation #' terms. #' #' @seealso \code{\link{brmsformula}}, \code{\link{acformula}}, #' \code{\link{arma}}, \code{\link{ar}}, \code{\link{ma}}, #' \code{\link{cosy}}, \code{\link{unstr}}, \code{\link{sar}}, #' \code{\link{car}}, \code{\link{fcor}} #' #' @examples #' # specify autocor terms within the formula #' y ~ x + arma(p = 1, q = 1) + car(M) #' #' # specify autocor terms in the 'autocor' argument #' bf(y ~ x, autocor = ~ arma(p = 1, q = 1) + car(M)) #' #' # specify autocor terms via 'acformula' #' bf(y ~ x) + acformula(~ arma(p = 1, q = 1) + car(M)) NULL #' Set up ARMA(p,q) correlation structures #' #' Set up an autoregressive moving average (ARMA) term of order (p, q) in #' \pkg{brms}. The function does not evaluate its arguments -- it exists purely #' to help set up a model with ARMA terms. #' #' @param time An optional time variable specifying the time ordering #' of the observations. By default, the existing order of the observations #' in the data is used. #' @param gr An optional grouping variable. If specified, the correlation #' structure is assumed to apply only to observations within the same grouping #' level. #' @param p A non-negative integer specifying the autoregressive (AR) #' order of the ARMA structure. Default is \code{1}. #' @param q A non-negative integer specifying the moving average (MA) #' order of the ARMA structure. Default is \code{1}. #' @param cov A flag indicating whether ARMA effects should be estimated by #' means of residual covariance matrices. This is currently only possible for #' stationary ARMA effects of order 1. If the model family does not have #' natural residuals, latent residuals are added automatically. If #' \code{FALSE} (the default), a regression formulation is used that is #' considerably faster and allows for ARMA effects of order higher than 1 but #' is only available for \code{gaussian} models and some of its #' generalizations. #' #' @return An object of class \code{'arma_term'}, which is a list #' of arguments to be interpreted by the formula #' parsing functions of \pkg{brms}. #' #' @seealso \code{\link{autocor-terms}}, \code{\link{ar}}, \code{\link{ma}}, #' #' @examples #' \dontrun{ #' data("LakeHuron") #' LakeHuron <- as.data.frame(LakeHuron) #' fit <- brm(x ~ arma(p = 2, q = 1), data = LakeHuron) #' summary(fit) #' } #' #' @export arma <- function(time = NA, gr = NA, p = 1, q = 1, cov = FALSE) { label <- deparse0(match.call()) time <- deparse0(substitute(time)) gr <- deparse0(substitute(gr)) .arma(time = time, gr = gr, p = p, q = q, cov = cov, label = label) } #' Set up AR(p) correlation structures #' #' Set up an autoregressive (AR) term of order p in \pkg{brms}. The function #' does not evaluate its arguments -- it exists purely to help set up a model #' with AR terms. #' #' @inheritParams arma #' #' @return An object of class \code{'arma_term'}, which is a list #' of arguments to be interpreted by the formula #' parsing functions of \pkg{brms}. #' #' @seealso \code{\link{autocor-terms}}, \code{\link{arma}}, \code{\link{ma}} #' #' @examples #' \dontrun{ #' data("LakeHuron") #' LakeHuron <- as.data.frame(LakeHuron) #' fit <- brm(x ~ ar(p = 2), data = LakeHuron) #' summary(fit) #' } #' #' @export ar <- function(time = NA, gr = NA, p = 1, cov = FALSE) { label <- deparse0(match.call()) time <- deparse0(substitute(time)) gr <- deparse0(substitute(gr)) .arma(time = time, gr = gr, p = p, q = 0, cov = cov, label = label) } #' Set up MA(q) correlation structures #' #' Set up a moving average (MA) term of order q in \pkg{brms}. The function does #' not evaluate its arguments -- it exists purely to help set up a model with #' MA terms. #' #' @inheritParams arma #' #' @return An object of class \code{'arma_term'}, which is a list #' of arguments to be interpreted by the formula #' parsing functions of \pkg{brms}. #' #' @seealso \code{\link{autocor-terms}}, \code{\link{arma}}, \code{\link{ar}} #' #' @examples #' \dontrun{ #' data("LakeHuron") #' LakeHuron <- as.data.frame(LakeHuron) #' fit <- brm(x ~ ma(p = 2), data = LakeHuron) #' summary(fit) #' } #' #' @export ma <- function(time = NA, gr = NA, q = 1, cov = FALSE) { label <- deparse0(match.call()) time <- deparse0(substitute(time)) gr <- deparse0(substitute(gr)) .arma(time = time, gr = gr, p = 0, q = q, cov = cov, label = label) } # helper function to validate input to arma() .arma <- function(time, gr, p, q, cov, label) { time <- as_one_variable(time) gr <- as_one_character(gr) stopif_illegal_group(gr) p <- as_one_numeric(p) q <- as_one_numeric(q) if (!(p >= 0 && is_wholenumber(p))) { stop2("Autoregressive order must be a non-negative integer.") } if (!(q >= 0 && is_wholenumber(q))) { stop2("Moving-average order must be a non-negative integer.") } if (!sum(p, q)) { stop2("At least one of 'p' and 'q' should be greater zero.") } cov <- as_one_logical(cov) if (cov && (p > 1 || q > 1)) { stop2("Covariance formulation of ARMA structures is ", "only possible for effects of maximal order one.") } label <- as_one_character(label) out <- nlist(time, gr, p, q, cov, label) class(out) <- c("arma_term", "ac_term") out } #' Set up COSY correlation structures #' #' Set up a compounds symmetry (COSY) term in \pkg{brms}. The function does #' not evaluate its arguments -- it exists purely to help set up a model with #' COSY terms. #' #' @inheritParams arma #' #' @return An object of class \code{'cosy_term'}, which is a list #' of arguments to be interpreted by the formula #' parsing functions of \pkg{brms}. #' #' @seealso \code{\link{autocor-terms}} #' #' @examples #' \dontrun{ #' data("lh") #' lh <- as.data.frame(lh) #' fit <- brm(x ~ cosy(), data = lh) #' summary(fit) #' } #' #' @export cosy <- function(time = NA, gr = NA) { label <- deparse0(match.call()) time <- deparse0(substitute(time)) time <- as_one_variable(time) gr <- deparse0(substitute(gr)) stopif_illegal_group(gr) out <- nlist(time, gr, label) class(out) <- c("cosy_term", "ac_term") out } #' Set up UNSTR correlation structures #' #' Set up an unstructured (UNSTR) correlation term in \pkg{brms}. The function does #' not evaluate its arguments -- it exists purely to help set up a model with #' UNSTR terms. #' #' @inheritParams arma #' #' @return An object of class \code{'unstr_term'}, which is a list #' of arguments to be interpreted by the formula #' parsing functions of \pkg{brms}. #' #' @seealso \code{\link{autocor-terms}} #' #' @examples #' \dontrun{ #' # add an unstructured correlation matrix for visits within the same patient #' fit <- brm(count ~ Trt + unstr(visit, patient), data = epilepsy) #' summary(fit) #' } #' #' @export unstr <- function(time, gr) { label <- deparse0(match.call()) time <- deparse0(substitute(time)) time <- as_one_variable(time) gr <- deparse0(substitute(gr)) stopif_illegal_group(gr) out <- nlist(time, gr, label) class(out) <- c("unstr_term", "ac_term") out } #' Spatial simultaneous autoregressive (SAR) structures #' #' Set up an spatial simultaneous autoregressive (SAR) term in \pkg{brms}. The #' function does not evaluate its arguments -- it exists purely to help set up a #' model with SAR terms. #' #' @param M An object specifying the spatial weighting matrix. #' Can be either the spatial weight matrix itself or an #' object of class \code{listw} or \code{nb}, from which #' the spatial weighting matrix can be computed. #' @param type Type of the SAR structure. Either \code{"lag"} #' (for SAR of the response values) or \code{"error"} #' (for SAR of the residuals). More information is #' provided in the 'Details' section. #' #' @details The \code{lagsar} structure implements SAR of the response values: #' \deqn{y = \rho W y + \eta + e} #' The \code{errorsar} structure implements SAR of the residuals: #' \deqn{y = \eta + u, u = \rho W u + e} #' In the above equations, \eqn{\eta} is the predictor term and \eqn{e} are #' independent normally or t-distributed residuals. Currently, only families #' \code{gaussian} and \code{student} support SAR structures. #' #' @return An object of class \code{'sar_term'}, which is a list #' of arguments to be interpreted by the formula #' parsing functions of \pkg{brms}. #' #' @seealso \code{\link{autocor-terms}} #' #' @examples #' \dontrun{ #' data(oldcol, package = "spdep") #' fit1 <- brm(CRIME ~ INC + HOVAL + sar(COL.nb, type = "lag"), #' data = COL.OLD, data2 = list(COL.nb = COL.nb), #' chains = 2, cores = 2) #' summary(fit1) #' plot(fit1) #' #' fit2 <- brm(CRIME ~ INC + HOVAL + sar(COL.nb, type = "error"), #' data = COL.OLD, data2 = list(COL.nb = COL.nb), #' chains = 2, cores = 2) #' summary(fit2) #' plot(fit2) #' } #' #' @export sar <- function(M, type = "lag") { label <- deparse0(match.call()) if (missing(M)) { stop2("Argument 'M' is missing in sar().") } M <- deparse0(substitute(M)) M <- as_one_variable(M) options <- c("lag", "error") type <- match.arg(type, options) out <- nlist(M, type, label) class(out) <- c("sar_term", "ac_term") out } #' Spatial conditional autoregressive (CAR) structures #' #' Set up an spatial conditional autoregressive (CAR) term in \pkg{brms}. The #' function does not evaluate its arguments -- it exists purely to help set up a #' model with CAR terms. #' #' @param M Adjacency matrix of locations. All non-zero entries are treated as #' if the two locations are adjacent. If \code{gr} is specified, the row names #' of \code{M} have to match the levels of the grouping factor. #' @param gr An optional grouping factor mapping observations to spatial #' locations. If not specified, each observation is treated as a separate #' location. It is recommended to always specify a grouping factor to allow #' for handling of new data in post-processing methods. #' @param type Type of the CAR structure. Currently implemented are #' \code{"escar"} (exact sparse CAR), \code{"esicar"} (exact sparse intrinsic #' CAR), \code{"icar"} (intrinsic CAR), and \code{"bym2"}. More information is #' provided in the 'Details' section. #' #' @return An object of class \code{'car_term'}, which is a list #' of arguments to be interpreted by the formula #' parsing functions of \pkg{brms}. #' #' @seealso \code{\link{autocor-terms}} #' #' @details The \code{escar} and \code{esicar} types are #' implemented based on the case study of Max Joseph #' (\url{https://github.com/mbjoseph/CARstan}). The \code{icar} and #' \code{bym2} type is implemented based on the case study of Mitzi Morris #' (\url{https://mc-stan.org/users/documentation/case-studies/icar_stan.html}). #' #' @examples #' \dontrun{ #' # generate some spatial data #' east <- north <- 1:10 #' Grid <- expand.grid(east, north) #' K <- nrow(Grid) #' #' # set up distance and neighbourhood matrices #' distance <- as.matrix(dist(Grid)) #' W <- array(0, c(K, K)) #' W[distance == 1] <- 1 #' rownames(W) <- 1:nrow(W) #' #' # generate the covariates and response data #' x1 <- rnorm(K) #' x2 <- rnorm(K) #' theta <- rnorm(K, sd = 0.05) #' phi <- rmulti_normal( #' 1, mu = rep(0, K), Sigma = 0.4 * exp(-0.1 * distance) #' ) #' eta <- x1 + x2 + phi #' prob <- exp(eta) / (1 + exp(eta)) #' size <- rep(50, K) #' y <- rbinom(n = K, size = size, prob = prob) #' g <- 1:length(y) #' dat <- data.frame(y, size, x1, x2, g) #' #' # fit a CAR model #' fit <- brm(y | trials(size) ~ x1 + x2 + car(W, gr = g), #' data = dat, data2 = list(W = W), #' family = binomial()) #' summary(fit) #' } #' #' @export car <- function(M, gr = NA, type = "escar") { label <- deparse0(match.call()) if (missing(M)) { stop2("Argument 'M' is missing in car().") } M <- deparse0(substitute(M)) M <- as_one_variable(M) gr <- deparse0(substitute(gr)) stopif_illegal_group(gr) options <- c("escar", "esicar", "icar", "bym2") type <- match.arg(type, options) out <- nlist(M, gr, type, label) class(out) <- c("car_term", "ac_term") out } #' Fixed residual correlation (FCOR) structures #' #' Set up a fixed residual correlation (FCOR) term in \pkg{brms}. The function #' does not evaluate its arguments -- it exists purely to help set up a model #' with FCOR terms. #' #' @param M Known correlation/covariance matrix of the response variable. #' If a vector is passed, it will be used as diagonal entries #' (variances) and correlations/covariances will be set to zero. #' The actual covariance matrix used in the likelihood is obtained #' by multiplying \code{M} by the square of the residual standard #' deviation parameter \code{sigma} estimated as part of the model. #' #' @return An object of class \code{'fcor_term'}, which is a list #' of arguments to be interpreted by the formula #' parsing functions of \pkg{brms}. #' #' @seealso \code{\link{autocor-terms}} #' #' @examples #' \dontrun{ #' dat <- data.frame(y = rnorm(3)) #' V <- cbind(c(0.5, 0.3, 0.2), c(0.3, 1, 0.1), c(0.2, 0.1, 0.2)) #' fit <- brm(y ~ 1 + fcor(V), data = dat, data2 = list(V = V)) #' } #' #' @export fcor <- function(M) { label <- deparse0(match.call()) if (missing(M)) { stop2("Argument 'M' is missing in fcor().") } M <- deparse0(substitute(M)) M <- as_one_variable(M) out <- nlist(M, label) class(out) <- c("fcor_term", "ac_term") out } # validate 'autocor' argument validate_autocor <- function(autocor) { if (is.null(autocor) || is.cor_empty(autocor)) { return(NULL) } if (is.cor_brms(autocor)) { warning2("Using 'cor_brms' objects for 'autocor' is deprecated. ", "Please see ?cor_brms for details.") autocor <- as_formula_cor_brms(autocor) } if (is.null(autocor)) { return(NULL) } autocor <- as.formula(autocor) att <- attributes(autocor) autocor <- terms_ac(autocor) if (!is.null(autocor) && !is.formula(autocor)) { stop2("Argument 'autocor' must be coercible to a formula.") } attributes(autocor)[names(att)] <- att autocor } # gather information on autocor terms # @return a data.frame with one row per autocor term frame_ac <- function(x, ...) { UseMethod("frame_ac") } #' @export frame_ac.default <- function(x, ...) { x <- brmsterms(x, check_response = FALSE) frame_ac(x, ...) } #' @export frame_ac.mvbrmsterms <- function(x, ...) { out <- lapply(x$terms, frame_ac, ...) out <- do_call(rbind, out) structure(out, class = acframe_class()) } #' @export frame_ac.brmsterms <- function(x, ...) { out <- lapply(x$dpars, frame_ac, ...) out <- do_call(rbind, out) if (!NROW(out)) { return(empty_acframe()) } out <- structure(out, class = acframe_class()) if (has_ac_class(out, "sar")) { if (any(c("sigma", "nu") %in% names(x$dpars))) { stop2("SAR models are not implemented when predicting 'sigma' or 'nu'.") } } if (use_ac_cov(out)) { if (isTRUE(x$rescor)) { stop2("Explicit covariance terms cannot be modeled ", "when 'rescor' is estimated at the same time.") } } out } #' @export frame_ac.btl <- function(x, data = NULL, ...) { form <- x[["ac"]] if (!is.formula(form)) { return(empty_acframe()) } if (is.mixfamily(x$family)) { stop2("Autocorrelation terms cannot be applied in mixture models.") } px <- check_prefix(x) out <- data.frame(term = all_terms(form), stringsAsFactors = FALSE) nterms <- NROW(out) cnames <- c("class", "dim", "type", "time", "gr", "p", "q", "M") out[cnames] <- list(NA) out$cov <- out$nat_cov <- FALSE out$nat_res <- has_natural_residuals(x) out[names(px)] <- px for (i in seq_len(nterms)) { ac <- eval2(out$term[i]) if (is.arma_term(ac)) { out$class[i] <- "arma" out$dim[i] <- "time" out$time[i] <- ac$time out$gr[i] <- ac$gr out$p[i] <- ac$p out$q[i] <- ac$q out$cov[i] <- ac$cov } if (is.cosy_term(ac)) { out$class[i] <- "cosy" out$dim[i] <- "time" out$time[i] <- ac$time out$gr[i] <- ac$gr out$cov[i] <- TRUE } if (is.unstr_term(ac)) { out$class[i] <- "unstr" out$dim[i] <- "time" out$time[i] <- ac$time out$gr[i] <- ac$gr out$cov[i] <- TRUE } if (is.sar_term(ac)) { out$class[i] <- "sar" out$dim[i] <- "space" out$type[i] <- ac$type out$M[i] <- ac$M out$cov[i] <- TRUE } if (is.car_term(ac)) { out$class[i] <- "car" out$dim[i] <- "space" out$type[i] <- ac$type out$gr[i] <- ac$gr out$M[i] <- ac$M } if (is.fcor_term(ac)) { out$class[i] <- "fcor" out$M[i] <- ac$M out$cov[i] <- TRUE } } # covariance matrices of natural residuals will be handled # directly in the likelihood function while latent residuals will # be added to the linear predictor of the main parameter 'mu' out$nat_cov <- out$cov & out$nat_res class(out) <- acframe_class() # validate specified autocor terms if (any(duplicated(out$class))) { stop2("Can only model one term per autocorrelation class.") } if (NROW(subset2(out, dim = "time")) > 1) { stop2("Can only model one time-series term.") } if (NROW(subset2(out, dim = "space")) > 1) { stop2("Can only model one spatial term.") } if (NROW(subset2(out, nat_cov = TRUE)) > 1) { stop2("Can only model one covariance matrix of natural residuals.") } if (use_ac_cov(out) || has_ac_class(out, "arma")) { if (any(!out$dpar %in% c("", "mu") | nzchar(out$nlpar))) { stop2("Explicit covariance terms can only be specified on 'mu'.") } } if (!is.null(data)) { # optional such that this function can be applied # without data before brmsframe is being created time <- get_ac_vars(out, "time", dim = "time") if (length(time)) { attr(out, "times") <- extract_levels(get(time, data)) } } out } #' @export frame_ac.btnl <- function(x, ... ) { frame_ac.btl(x, ...) } #' @export frame_ac.acframe <- function(x, ...) { x } #' @export frame_ac.NULL <- function(x, ...) { empty_acframe() } empty_acframe <- function() { structure(empty_data_frame(), class = acframe_class()) } acframe_class <- function() { c("acframe", "data.frame") } is.acframe <- function(x) { inherits(x, "acframe") } # get names of certain autocor variables get_ac_vars <- function(x, var, ...) { var <- match.arg(var, c("time", "gr", "M")) acframe <- subset2(frame_ac(x), ...) out <- unique(acframe[[var]]) setdiff(na.omit(out), "NA") } # get names of grouping variables from ac terms get_ac_group_vars <- function(x, ...) { get_ac_vars(x, "gr", ...) } # is certain subset of autocor terms is present? has_ac_subset <- function(x, ...) { NROW(subset2(frame_ac(x), ...)) > 0L } # is a certain autocorrelation class present? has_ac_class <- function(x, class) { has_ac_subset(x, class = class) } # use explicit residual covariance structure? use_ac_cov <- function(x) { has_ac_subset(x, cov = TRUE) } # use explicit residual covariance structure for time-series? use_ac_cov_time <- function(x) { has_ac_subset(x, cov = TRUE, dim = "time") } # check if the family has natural residuals has_ac_natural_residuals <- function(x) { has_ac_subset(x, nat_res = TRUE) } # does the model need latent residuals for autocor structures? has_ac_latent_residuals <- function(x) { x <- frame_ac(x) !has_ac_natural_residuals(x) && (use_ac_cov(x) || has_ac_class(x, "arma")) } # validate SAR matrices validate_sar_matrix <- function(M) { if (is(M, "listw")) { require_package("spdep") M <- spdep::listw2mat(M) } else if (is(M, "nb")) { require_package("spdep") M <- spdep::nb2mat(M) } if (length(dim(M)) != 2L) { stop2("'M' for SAR terms must be of class 'matrix', 'listw', or 'nb'.") } M <- Matrix::Matrix(M, sparse = TRUE) M } # validate CAR matrices validate_car_matrix <- function(M) { if (length(dim(M)) != 2L) { stop2("'M' for CAR terms must be a matrix.") } M <- Matrix::Matrix(M, sparse = TRUE) if (!Matrix::isSymmetric(M, check.attributes = FALSE)) { stop2("'M' for CAR terms must be symmetric.") } colnames(M) <- rownames(M) not_binary <- M@x != 1 if (any(not_binary)) { message("Converting all non-zero values in 'M' to 1.") M@x[not_binary] <- 1 } M } # validate FCOR matrices validate_fcor_matrix <- function(M) { if (length(dim(M)) <= 1L) { M <- diag(as.vector(M), length(M)) } if (length(dim(M)) != 2L) { stop2("'M' for FCOR terms must be a matrix.") } M <- as.matrix(M) if (!isSymmetric(M, check.attributes = FALSE)) { stop2("'M' for FCOR terms must be symmetric.") } if (min(eigen(M)$values <= 0)) { stop2("'M' for FCOR terms must be positive definite.") } M } # regex to extract all parameter names of autocorrelation structures regex_autocor_pars <- function() { # cortime is ignored here to allow custom renaming in summary.brmsfit p <- c("ar", "ma", "sderr", "cosy", "lagsar", "errorsar", "car", "sdcar", "rhocar") p <- paste0("(", p, ")", collapse = "|") paste0("^(", p, ")(\\[|_|$)") } is.ac_term <- function(x) { inherits(x, "ac_term") } is.arma_term <- function(x) { inherits(x, "arma_term") } is.cosy_term <- function(x) { inherits(x, "cosy_term") } is.unstr_term <- function(x) { inherits(x, "unstr_term") } is.sar_term <- function(x) { inherits(x, "sar_term") } is.car_term <- function(x) { inherits(x, "car_term") } is.fcor_term <- function(x) { inherits(x, "fcor_term") } brms/R/rename_pars.R0000644000176200001440000005354715053305627014061 0ustar liggesusers#' Rename parameters in brmsfit objects #' #' Rename parameters within the \code{stanfit} object #' after model fitting to ensure reasonable parameter names. This function is #' usually called automatically by \code{\link{brm}} and users will rarely be #' required to call it themselves. #' #' @param x A \code{brmsfit} object. #' @return A \code{brmsfit} object with adjusted parameter names. #' #' @details #' Function \code{rename_pars} is a deprecated alias of \code{rename_pars}. #' #' @examples #' \dontrun{ #' # fit a model manually via rstan #' scode <- stancode(count ~ Trt, data = epilepsy) #' sdata <- standata(count ~ Trt, data = epilepsy) #' stanfit <- rstan::stan(model_code = scode, data = sdata) #' #' # feed the Stan model back into brms #' fit <- brm(count ~ Trt, data = epilepsy, empty = TRUE) #' fit$fit <- stanfit #' fit <- rename_pars(fit) #' summary(fit) #' } #' #' @export rename_pars <- function(x) { if (!length(x$fit@sim)) { return(x) } bframe <- brmsframe(x$formula, x$data) pars <- variables(x) # find positions of parameters and define new names to_rename <- c( rename_predictor(bframe, pars = pars, prior = x$prior), rename_re(bframe, pars = pars), rename_Xme(bframe, pars = pars) ) # perform the actual renaming in x$fit@sim x <- save_old_par_order(x) x <- do_renaming(x, to_rename) x$fit <- repair_stanfit(x$fit) x <- compute_quantities(x) x <- reorder_pars(x) x } # helps in renaming parameters after model fitting # @return a list whose elements can be interpreted by do_renaming rename_predictor <- function(x, ...) { UseMethod("rename_predictor") } #' @export rename_predictor.default <- function(x, ...) { NULL } #' @export rename_predictor.mvbrmsterms <- function(x, pars, ...) { out <- list() for (i in seq_along(x$terms)) { c(out) <- rename_predictor(x$terms[[i]], pars = pars, ...) } if (x$rescor) { rescor_names <- get_cornames( x$responses, type = "rescor", brackets = FALSE ) lc(out) <- rlist(grepl("^rescor\\[", pars), rescor_names) } out } #' @export rename_predictor.brmsterms <- function(x, ...) { out <- list() for (dp in names(x$dpars)) { c(out) <- rename_predictor(x$dpars[[dp]], ...) } for (nlp in names(x$nlpars)) { c(out) <- rename_predictor(x$nlpars[[nlp]], ...) } if (is.formula(x$adforms$mi)) { c(out) <- rename_Ymi(x, ...) } c(out) <- rename_thres(x, ...) c(out) <- rename_bhaz(x, ...) c(out) <- rename_family_cor_pars(x, ...) out } # helps in renaming parameters of additive predictor terms # @param pars vector of all parameter names #' @export rename_predictor.bframel <- function(x, ...) { c(rename_fe(x, ...), rename_sm(x, ...), rename_cs(x, ...), rename_sp(x, ...), rename_gp(x, ...), rename_ac(x, ...)) } # helps in renaming fixed effects parameters rename_fe <- function(bframe, pars, prior, ...) { stopifnot(is.bframel(bframe)) out <- list() fixef <- bframe$frame$fe$vars_stan if (!length(fixef)) { return(out) } px <- check_prefix(bframe) p <- usc(combine_prefix(px)) b <- paste0("b", p) pos <- grepl(paste0("^", b, "\\["), pars) bnames <- paste0(b, "_", fixef) lc(out) <- rlist(pos, bnames) c(out) <- rename_prior(b, pars, names = fixef) if (has_special_prior(prior, bframe, class = "b")) { sdb <- paste0("sdb", p) pos <- grepl(paste0("^", sdb, "\\["), pars) sdb_names <- paste0(sdb, "_", fixef) lc(out) <- rlist(pos, sdb_names) } out } # helps in renaming special effects parameters rename_sp <- function(bframe, pars, prior, ...) { stopifnot(is.bframel(bframe)) out <- list() spframe <- bframe$frame$sp if (!nrow(spframe)) { return(out) } p <- usc(combine_prefix(bframe)) bsp <- paste0("bsp", p) pos <- grepl(paste0("^", bsp, "\\["), pars) newnames <- paste0("bsp", p, "_", spframe$coef) lc(out) <- rlist(pos, newnames) c(out) <- rename_prior(bsp, pars, names = spframe$coef) simo_coef <- get_simo_labels(spframe) for (i in seq_along(simo_coef)) { simo_old <- paste0("simo", p, "_", i) simo_new <- paste0("simo", p, "_", simo_coef[i]) pos <- grepl(paste0("^", simo_old, "\\["), pars) simo_names <- paste0(simo_new, "[", seq_len(sum(pos)), "]") lc(out) <- rlist(pos, simo_names) c(out) <- rename_prior( simo_old, pars, new_class = simo_new, is_vector = TRUE ) } if (has_special_prior(prior, bframe, class = "b")) { sdbsp <- paste0("sdbsp", p) pos <- grepl(paste0("^", sdbsp, "\\["), pars) sdbsp_names <- paste0(sdbsp, "_", spframe$coef) lc(out) <- rlist(pos, sdbsp_names) } out } # helps in renaming category specific effects parameters rename_cs <- function(bframe, pars, ...) { stopifnot(is.bframel(bframe)) out <- list() csef <- bframe$frame$cs$vars if (length(csef)) { p <- usc(combine_prefix(bframe)) bcsp <- paste0("bcs", p) ncs <- length(csef) thres <- sum(grepl(paste0("^b", p, "_Intercept\\["), pars)) csenames <- t(outer(csef, paste0("[", 1:thres, "]"), FUN = paste0)) csenames <- paste0(bcsp, "_", csenames) sort_cse <- ulapply(seq_len(ncs), seq, to = thres * ncs, by = ncs) lc(out) <- rlist( grepl(paste0("^", bcsp, "\\["), pars), csenames, sort = sort_cse ) c(out) <- rename_prior(bcsp, pars, names = csef) } out } # rename threshold parameters in ordinal models rename_thres <- function(bframe, pars, ...) { out <- list() # renaming is only required if multiple threshold were estimated if (!has_thres_groups(bframe)) { return(out) } px <- check_prefix(bframe) p <- usc(combine_prefix(px)) int <- paste0("b", p, "_Intercept") groups <- get_thres_groups(bframe) for (i in seq_along(groups)) { thres <- get_thres(bframe, groups[i]) pos <- grepl(glue("^{int}_{i}\\["), pars) int_names <- glue("{int}[{groups[i]},{thres}]") lc(out) <- rlist(pos, int_names) } out } # rename baseline hazard parameters in cox models rename_bhaz <- function(bframe, pars, ...) { out <- list() # renaming is only required if multiple threshold were estimated if (!has_bhaz_groups(bframe)) { return(out) } px <- check_prefix(bframe) p <- usc(combine_prefix(px)) groups <- get_bhaz_groups(bframe) for (k in seq_along(groups)) { pos <- grepl(glue("^sbhaz{p}\\[{k},"), pars) funs <- seq_len(sum(pos)) bhaz_names <- glue("sbhaz{p}[{groups[k]},{funs}]") lc(out) <- rlist(pos, bhaz_names) } out } # helps in renaming global noise free variables # @param meframe data.frame returned by 'frame_me' rename_Xme <- function(bframe, pars, ...) { meframe <- bframe$frame$me stopifnot(is.meframe(meframe)) out <- list() levels <- attr(meframe, "levels") groups <- unique(meframe$grname) for (i in seq_along(groups)) { g <- groups[i] K <- which(meframe$grname %in% g) # rename mean and sd parameters for (par in c("meanme", "sdme")) { hpar <- paste0(par, "_", i) pos <- grepl(paste0("^", hpar, "\\["), pars) hpar_new <- paste0(par, "_", meframe$coef[K]) lc(out) <- rlist(pos, hpar_new) c(out) <- rename_prior(hpar, pars, names = hpar_new) } # rename latent variable parameters for (k in K) { if (any(grepl("^Xme_", pars))) { Xme <- paste0("Xme_", k) pos <- grepl(paste0("^", Xme, "\\["), pars) Xme_new <- paste0("Xme_", meframe$coef[k]) if (nzchar(g)) { indices <- gsub("[ \t\r\n]", ".", levels[[g]]) } else { indices <- seq_len(sum(pos)) } fnames <- paste0(Xme_new, "[", indices, "]") lc(out) <- rlist(pos, fnames) } } # rename correlation parameters if (meframe$cor[K[1]] && length(K) > 1L) { cor_type <- paste0("corme", usc(g)) cor_names <- get_cornames(meframe$coef[K], cor_type, brackets = FALSE) cor_regex <- paste0("^corme_", i, "(\\[|$)") cor_pos <- grepl(cor_regex, pars) lc(out) <- rlist(cor_pos, cor_names) c(out) <- rename_prior( paste0("corme_", i), pars, new_class = paste0("corme", usc(g)) ) } } out } # helps in renaming estimated missing values rename_Ymi <- function(bframe, pars, ...) { stopifnot(is.brmsframe(bframe)) out <- list() if (is.formula(bframe$adforms$mi)) { resp <- usc(combine_prefix(bframe)) Ymi <- paste0("Ymi", resp) pos <- grepl(paste0("^", Ymi, "\\["), pars) if (any(pos)) { Jmi <- bframe$frame$resp$Jmi fnames <- paste0(Ymi, "[", Jmi, "]") lc(out) <- rlist(pos, fnames) } } out } # helps in renaming parameters of gaussian processes rename_gp <- function(bframe, pars, ...) { stopifnot(is.bframel(bframe)) out <- list() p <- usc(combine_prefix(bframe), "prefix") gpframe <- bframe$frame$gp for (i in seq_rows(gpframe)) { # rename GP hyperparameters sfx1 <- gpframe$sfx1[[i]] sfx2 <- as.vector(gpframe$sfx2[[i]]) sdgp <- paste0("sdgp", p) sdgp_old <- paste0(sdgp, "_", i) sdgp_pos <- grepl(paste0("^", sdgp_old, "\\["), pars) sdgp_names <- paste0(sdgp, "_", sfx1) lc(out) <- rlist(sdgp_pos, sdgp_names) c(out) <- rename_prior(sdgp_old, pars, names = sfx1, new_class = sdgp) lscale <- paste0("lscale", p) lscale_old <- paste0(lscale, "_", i) lscale_pos <- grepl(paste0("^", lscale_old, "\\["), pars) lscale_names <- paste0(lscale, "_", sfx2) lc(out) <- rlist(lscale_pos, lscale_names) c(out) <- rename_prior(lscale_old, pars, names = sfx2, new_class = lscale) zgp <- paste0("zgp", p) zgp_old <- paste0(zgp, "_", i) if (length(sfx1) > 1L) { # categorical 'by' variable for (j in seq_along(sfx1)) { zgp_old_sub <- paste0(zgp_old, "_", j) zgp_pos <- grepl(paste0("^", zgp_old_sub, "\\["), pars) if (any(zgp_pos)) { zgp_new <- paste0(zgp, "_", sfx1[j]) fnames <- paste0(zgp_new, "[", seq_len(sum(zgp_pos)), "]") lc(out) <- rlist(zgp_pos, fnames) } } } else { zgp_pos <- grepl(paste0("^", zgp_old, "\\["), pars) if (any(zgp_pos)) { zgp_new <- paste0(zgp, "_", sfx1) fnames <- paste0(zgp_new, "[", seq_len(sum(zgp_pos)), "]") lc(out) <- rlist(zgp_pos, fnames) } } } out } # helps in renaming smoothing term parameters rename_sm <- function(bframe, pars, prior, ...) { stopifnot(is.bframel(bframe)) out <- list() smframe <- bframe$frame$sm if (!has_rows(smframe)) { return(out) } p <- usc(combine_prefix(bframe)) Xs_names <- attr(smframe, "Xs_names") if (length(Xs_names)) { bs <- paste0("bs", p) pos <- grepl(paste0("^", bs, "\\["), pars) bsnames <- paste0(bs, "_", Xs_names) lc(out) <- rlist(pos, bsnames) c(out) <- rename_prior(bs, pars, names = Xs_names) } if (has_special_prior(prior, bframe, class = "b")) { sdbs <- paste0("sdbs", p) pos <- grepl(paste0("^", sdbs, "\\["), pars) sdbs_names <- paste0(sdbs, "_", Xs_names) lc(out) <- rlist(pos, sdbs_names) } sds <- paste0("sds", p) sds_names <- paste0(sds, "_", smframe$label) s <- paste0("s", p) snames <- paste0(s, "_", smframe$label) for (i in seq_rows(smframe)) { nbases <- smframe$nbases[i] sds_pos <- grepl(paste0("^", sds, "_", i), pars) sds_names_nb <- paste0(sds_names[i], "_", seq_len(nbases)) lc(out) <- rlist(sds_pos, sds_names_nb) new_class <- paste0(sds, "_", smframe$label[i]) c(out) <- rename_prior(paste0(sds, "_", i), pars, new_class = new_class) for (j in seq_len(nbases)) { spos <- grepl(paste0("^", s, "_", i, "_", j), pars) sfnames <- paste0(snames[i], "_", j, "[", seq_len(sum(spos)), "]") lc(out) <- rlist(spos, sfnames) } } out } # helps in renaming autocorrelation parameters rename_ac <- function(bframe, pars, ...) { out <- list() acframe <- bframe$frame$ac stopifnot(is.acframe(acframe)) resp <- usc(bframe$resp) if (has_ac_class(acframe, "unstr")) { times <- attr(acframe, "times") corname <- paste0("cortime", resp) regex <- paste0("^", corname, "\\[") cortime_names <- get_cornames(times, type = corname, brackets = FALSE) lc(out) <- rlist(grepl(regex, pars), cortime_names) } out } # helps in renaming group-level parameters rename_re <- function(bframe, pars, ...) { out <- list() reframe <- bframe$frame$re if (!has_rows(reframe)) { return(out) } stopifnot(is.reframe(reframe)) for (id in unique(reframe$id)) { r <- subset2(reframe, id = id) g <- r$group[1] rnames <- get_rnames(r) sd_names <- paste0("sd_", g, "__", as.vector(rnames)) sd_pos <- grepl(paste0("^sd_", id, "(\\[|$)"), pars) lc(out) <- rlist(sd_pos, sd_names) c(out) <- rename_prior( paste0("sd_", id), pars, new_class = paste0("sd_", g), names = paste0("_", as.vector(rnames)) ) # rename group-level correlations if (nrow(r) > 1L && isTRUE(r$cor[1])) { type <- paste0("cor_", g) if (isTRUE(nzchar(r$by[1]))) { cor_names <- named_list(r$bylevels[[1]]) for (j in seq_along(cor_names)) { cor_names[[j]] <- get_cornames( rnames[, j], type, brackets = FALSE ) } cor_names <- unlist(cor_names) } else { cor_names <- get_cornames(rnames, type, brackets = FALSE) } cor_regex <- paste0("^cor_", id, "(_[[:digit:]]+)?(\\[|$)") cor_pos <- grepl(cor_regex, pars) lc(out) <- rlist(cor_pos, cor_names) c(out) <- rename_prior( paste0("cor_", id), pars, new_class = paste0("cor_", g) ) } } if (any(grepl("^r_", pars))) { c(out) <- rename_re_levels(bframe, pars = pars) } reframe_t <- subset_reframe_dist(reframe, "student") for (i in seq_rows(reframe_t)) { df_pos <- grepl(paste0("^df_", reframe_t$ggn[i], "$"), pars) df_name <- paste0("df_", reframe_t$group[i]) lc(out) <- rlist(df_pos, df_name) } out } # helps in renaming varying effects parameters per level rename_re_levels <- function(bframe, pars, ...) { out <- list() reframe <- bframe$frame$re stopifnot(is.reframe(reframe)) for (i in seq_rows(reframe)) { r <- reframe[i, ] p <- usc(combine_prefix(r)) r_parnames <- paste0("r_", r$id, p, "_", r$cn) r_regex <- paste0("^", r_parnames, "(\\[|$)") r_new_parname <- paste0("r_", r$group, usc(p)) # rstan doesn't like whitespaces in parameter names levels <- gsub("[ \t\r\n]", ".", attr(reframe, "levels")[[r$group]]) index_names <- make_index_names(levels, r$coef, dim = 2) fnames <- paste0(r_new_parname, index_names) lc(out) <- rlist(grepl(r_regex, pars), fnames) } out } # helps to rename correlation parameters of likelihoods rename_family_cor_pars <- function(x, pars, ...) { stopifnot(is.brmsterms(x)) out <- list() if (is_logistic_normal(x$family)) { predcats <- get_predcats(x$family) lncor_names <- get_cornames( predcats, type = "lncor", brackets = FALSE ) lc(out) <- rlist(grepl("^lncor\\[", pars), lncor_names) } out } # helps in renaming prior parameters # @param class the class of the parameters # @param pars names of all parameters in the model # @param names names to replace digits at the end of parameter names # @param new_class optional replacement of the orginal class name # @param is_vector indicate if the prior parameter is a vector rename_prior <- function(class, pars, names = NULL, new_class = class, is_vector = FALSE) { out <- list() # 'stan_rngprior' adds '__' before the digits to disambiguate regex <- paste0("^prior_", class, "(__[[:digit:]]+|$|\\[)") pos_priors <- which(grepl(regex, pars)) if (length(pos_priors)) { priors <- gsub( paste0("^prior_", class), paste0("prior_", new_class), pars[pos_priors] ) if (is_vector) { if (!is.null(names)) { .names <- paste0("_", names) for (i in seq_along(priors)) { priors[i] <- gsub("\\[[[:digit:]]+\\]$", .names[i], priors[i]) } } lc(out) <- rlist(pos_priors, priors) } else { digits <- sapply(priors, function(prior) { d <- regmatches(prior, gregexpr("__[[:digit:]]+$", prior))[[1]] if (length(d)) as.numeric(substr(d, 3, nchar(d))) else 0 }) for (i in seq_along(priors)) { if (digits[i] && !is.null(names)) { priors[i] <- gsub("_[[:digit:]]+$", names[digits[i]], priors[i]) } if (pars[pos_priors[i]] != priors[i]) { lc(out) <- rlist(pos_priors[i], priors[i]) } } } } out } # helper for rename_* functions rlist <- function(pos, fnames, ...) { structure(nlist(pos, fnames, ...), class = c("rlist", "list")) } is.rlist <- function(x) { inherits(x, "rlist") } # compute index names in square brackets for indexing stan parameters # @param rownames a vector of row names # @param colnames a vector of columns # @param dim the number of output dimensions # @return all index pairs of rows and cols make_index_names <- function(rownames, colnames = NULL, dim = 1) { if (!dim %in% c(1, 2)) stop("dim must be 1 or 2") if (dim == 1) { index_names <- paste0("[", rownames, "]") } else { tmp <- outer(rownames, colnames, FUN = paste, sep = ",") index_names <- paste0("[", tmp, "]") } index_names } # save original order of the parameters in the stanfit object save_old_par_order <- function(x, x2 = NULL) { stopifnot(is.brmsfit(x)) if (is.null(x2)) { # used in rename_pars() to store the old order x$fit@sim$pars_oi_old <- x$fit@sim$pars_oi x$fit@sim$dims_oi_old <- x$fit@sim$dims_oi x$fit@sim$fnames_oi_old <- x$fit@sim$fnames_oi } else { # used in combine_models() to take the old order from another model stopifnot(is.brmsfit(x2)) x$fit@sim$pars_oi_old <- x2$fit@sim$pars_oi_old x$fit@sim$dims_oi_old <- x2$fit@sim$dims_oi_old x$fit@sim$fnames_oi_old <- x2$fit@sim$fnames_oi_old } x } # perform actual renaming of Stan parameters # @param x a brmsfit object # @param y a list of lists each element allowing # to rename certain parameters # @return a brmsfit object with updated parameter names do_renaming <- function(x, y) { .do_renaming <- function(x, y) { stopifnot(is.rlist(y)) x$fit@sim$fnames_oi[y$pos] <- y$fnames for (i in seq_len(chains)) { names(x$fit@sim$samples[[i]])[y$pos] <- y$fnames if (!is.null(y$sort)) { x$fit@sim$samples[[i]][y$pos] <- x$fit@sim$samples[[i]][y$pos][y$sort] } } return(x) } chains <- length(x$fit@sim$samples) for (i in seq_along(y)) { x <- .do_renaming(x, y[[i]]) } x } # order parameter draws after parameter class # @param x brmsfit object reorder_pars <- function(x) { all_classes <- unique(c( "b", "bs", "bsp", "bcs", "ar", "ma", "sderr", "lagsar", "errorsar", "car", "rhocar", "sdcar", "cosy", "cortime", "sd", "cor", "df", "sds", "sdgp", "lscale", valid_dpars(x), "hs", "R2D2", "sdb", "sdbsp", "sdbs", "sdar", "sdma", "lncor", "Intercept", "tmp", "rescor", "delta", "simo", "r", "s", "zgp", "rcar", "sbhaz", "Ymi", "Yl", "meanme", "sdme", "corme", "Xme", "prior", "lprior", "lp" )) # reorder parameter classes class <- get_matches("^[^_]+", x$fit@sim$pars_oi) new_order <- order( factor(class, levels = all_classes), !grepl("_Intercept(_[[:digit:]]+)?$", x$fit@sim$pars_oi) ) x$fit@sim$dims_oi <- x$fit@sim$dims_oi[new_order] x$fit@sim$pars_oi <- names(x$fit@sim$dims_oi) # reorder single parameter names nsubpars <- ulapply(x$fit@sim$dims_oi, prod) has_subpars <- nsubpars > 0 new_order <- new_order[has_subpars] nsubpars <- nsubpars[has_subpars] num <- lapply(seq_along(new_order), function(x) as.numeric(paste0(x, ".", sprintf("%010d", seq_len(nsubpars[x])))) ) new_order <- order(unlist(num[order(new_order)])) x$fit@sim$fnames_oi <- x$fit@sim$fnames_oi[new_order] chains <- length(x$fit@sim$samples) for (i in seq_len(chains)) { # attributes of samples must be kept x$fit@sim$samples[[i]] <- subset_keep_attr(x$fit@sim$samples[[i]], new_order) } x } # wrapper function to compute and store quantities in the stanfit # object which were not computed / stored by Stan itself # @param x a brmsfit object # @return a brmsfit object compute_quantities <- function(x) { stopifnot(is.brmsfit(x)) x <- compute_xi(x) x } # helper function to compute parameter xi, which is currently # defined in the Stan model block and thus not being stored # @param x a brmsfit object # @return a brmsfit object compute_xi <- function(x, ...) { UseMethod("compute_xi") } #' @export compute_xi.brmsfit <- function(x, ...) { if (!any(grepl("^tmp_xi(_|$)", variables(x)))) { return(x) } prep <- try(prepare_predictions(x)) if (is_try_error(prep)) { warning2("Trying to compute 'xi' was unsuccessful. ", "Some S3 methods may not work as expected.") return(x) } compute_xi(prep, fit = x, ...) } #' @export compute_xi.mvbrmsprep <- function(x, fit, ...) { stopifnot(is.brmsfit(fit)) for (resp in names(x$resps)) { fit <- compute_xi(x$resps[[resp]], fit = fit, ...) } fit } #' @export compute_xi.brmsprep <- function(x, fit, ...) { stopifnot(is.brmsfit(fit)) resp <- usc(x$resp) tmp_xi_name <- paste0("tmp_xi", resp) if (!tmp_xi_name %in% variables(fit)) { return(fit) } mu <- get_dpar(x, "mu") sigma <- get_dpar(x, "sigma") y <- matrix(x$data$Y, dim(mu)[1], dim(mu)[2], byrow = TRUE) bs <- -1 / matrixStats::rowRanges((y - mu) / sigma) bs <- matrixStats::rowRanges(bs) tmp_xi <- as.vector(as.matrix(fit, variable = tmp_xi_name)) xi <- inv_logit(tmp_xi) * (bs[, 2] - bs[, 1]) + bs[, 1] # write xi into stanfit object xi_name <- paste0("xi", resp) samp_chain <- length(xi) / fit$fit@sim$chains for (i in seq_len(fit$fit@sim$chains)) { xi_part <- xi[((i - 1) * samp_chain + 1):(i * samp_chain)] # add warmup draws not used anyway xi_part <- c(rep(0, fit$fit@sim$warmup2[1]), xi_part) fit$fit@sim$samples[[i]][[xi_name]] <- xi_part } fit$fit@sim$pars_oi <- c(fit$fit@sim$pars_oi, xi_name) fit$fit@sim$dims_oi[[xi_name]] <- numeric(0) fit$fit@sim$fnames_oi <- c(fit$fit@sim$fnames_oi, xi_name) fit$fit@sim$n_flatnames <- fit$fit@sim$n_flatnames + 1 fit } brms/R/loo.R0000644000176200001440000010531115053072461012336 0ustar liggesusers#' Efficient approximate leave-one-out cross-validation (LOO) #' #' Perform approximate leave-one-out cross-validation based #' on the posterior likelihood using the \pkg{loo} package. #' For more details see \code{\link[loo:loo]{loo}}. #' #' @aliases loo LOO LOO.brmsfit #' #' @param x A \code{brmsfit} object. #' @param ... More \code{brmsfit} objects or further arguments #' passed to the underlying post-processing functions. #' In particular, see \code{\link{prepare_predictions}} for further #' supported arguments. #' @param compare A flag indicating if the information criteria #' of the models should be compared to each other #' via \code{\link{loo_compare}}. #' @param pointwise A flag indicating whether to compute the full #' log-likelihood matrix at once or separately for each observation. #' The latter approach is usually considerably slower but #' requires much less working memory. Accordingly, if one runs #' into memory issues, \code{pointwise = TRUE} is the way to go. #' @param moment_match Logical; Indicate whether \code{\link{loo_moment_match}} #' should be applied on problematic observations. Defaults to \code{FALSE}. #' For most models, moment matching will only work if you have set #' \code{save_pars = save_pars(all = TRUE)} when fitting the model with #' \code{\link{brm}}. See \code{\link{loo_moment_match.brmsfit}} for more #' details. #' @param reloo Logical; Indicate whether \code{\link{reloo}} #' should be applied on problematic observations. Defaults to \code{FALSE}. #' @param k_threshold The Pareto \eqn{k} threshold for which observations #' \code{\link{loo_moment_match}} or \code{\link{reloo}} is applied if #' argument \code{moment_match} or \code{reloo} is \code{TRUE}. #' Defaults to \code{0.7}. #' See \code{\link[loo:pareto-k-diagnostic]{pareto_k_ids}} for more details. #' @param save_psis Should the \code{"psis"} object created internally be saved #' in the returned object? For more details see \code{\link[loo:loo]{loo}}. #' @param moment_match_args Optional named \code{list} of additional arguments #' passed to \code{\link{loo_moment_match}}. #' @param reloo_args Optional named \code{list} of additional arguments passed to #' \code{\link{reloo}}. This can be useful, among others, to control #' how many chains, iterations, etc. to use for the fitted sub-models. #' @param model_names If \code{NULL} (the default) will use model names #' derived from deparsing the call. Otherwise will use the passed #' values as model names. #' @inheritParams predict.brmsfit #' #' @details See \code{\link{loo_compare}} for details on model comparisons. #' For \code{brmsfit} objects, \code{LOO} is an alias of \code{loo}. #' Use method \code{\link{add_criterion}} to store #' information criteria in the fitted model object for later usage. #' #' @return If just one object is provided, an object of class \code{loo}. #' If multiple objects are provided, an object of class \code{loolist}. #' #' @examples #' \dontrun{ #' # model with population-level effects only #' fit1 <- brm(rating ~ treat + period + carry, #' data = inhaler) #' (loo1 <- loo(fit1)) #' #' # model with an additional varying intercept for subjects #' fit2 <- brm(rating ~ treat + period + carry + (1|subject), #' data = inhaler) #' (loo2 <- loo(fit2)) #' #' # compare both models #' loo_compare(loo1, loo2) #' } #' #' @references #' Vehtari, A., Gelman, A., & Gabry J. (2016). Practical Bayesian model #' evaluation using leave-one-out cross-validation and WAIC. In Statistics #' and Computing, doi:10.1007/s11222-016-9696-4. arXiv preprint arXiv:1507.04544. #' #' Gelman, A., Hwang, J., & Vehtari, A. (2014). #' Understanding predictive information criteria for Bayesian models. #' Statistics and Computing, 24, 997-1016. #' #' Watanabe, S. (2010). Asymptotic equivalence of Bayes cross validation #' and widely applicable information criterion in singular learning theory. #' The Journal of Machine Learning Research, 11, 3571-3594. #' #' @importFrom loo loo is.loo #' @export loo #' @export loo.brmsfit <- function(x, ..., compare = TRUE, resp = NULL, pointwise = FALSE, moment_match = FALSE, reloo = FALSE, k_threshold = 0.7, save_psis = FALSE, moment_match_args = list(), reloo_args = list(), model_names = NULL) { args <- split_dots(x, ..., model_names = model_names) if (!"use_stored" %in% names(args)) { further_arg_names <- c( "resp", "moment_match", "reloo", "k_threshold", "save_psis", "moment_match_args", "reloo_args" ) args$use_stored <- all(names(args) %in% "models") && !any(further_arg_names %in% names(match.call())) } c(args) <- nlist( criterion = "loo", pointwise, compare, resp, k_threshold, save_psis, moment_match, reloo, moment_match_args, reloo_args ) do_call(compute_loolist, args) } #' @export LOO.brmsfit <- function(x, ..., compare = TRUE, resp = NULL, pointwise = FALSE, moment_match = FALSE, reloo = FALSE, k_threshold = 0.7, save_psis = FALSE, moment_match_args = list(), reloo_args = list(), model_names = NULL) { cl <- match.call() cl[[1]] <- quote(loo) eval(cl, parent.frame()) } #' @export LOO <- function(x, ...) { UseMethod("LOO") } #' Widely Applicable Information Criterion (WAIC) #' #' Compute the widely applicable information criterion (WAIC) #' based on the posterior likelihood using the \pkg{loo} package. #' For more details see \code{\link[loo:waic]{waic}}. #' #' @aliases waic WAIC WAIC.brmsfit #' #' @inheritParams loo.brmsfit #' #' @details See \code{\link{loo_compare}} for details on model comparisons. #' For \code{brmsfit} objects, \code{WAIC} is an alias of \code{waic}. #' Use method \code{\link[brms:add_criterion]{add_criterion}} to store #' information criteria in the fitted model object for later usage. #' #' @return If just one object is provided, an object of class \code{loo}. #' If multiple objects are provided, an object of class \code{loolist}. #' #' @examples #' \dontrun{ #' # model with population-level effects only #' fit1 <- brm(rating ~ treat + period + carry, #' data = inhaler) #' (waic1 <- waic(fit1)) #' #' # model with an additional varying intercept for subjects #' fit2 <- brm(rating ~ treat + period + carry + (1|subject), #' data = inhaler) #' (waic2 <- waic(fit2)) #' #' # compare both models #' loo_compare(waic1, waic2) #' } #' #' @references #' Vehtari, A., Gelman, A., & Gabry J. (2016). Practical Bayesian model #' evaluation using leave-one-out cross-validation and WAIC. In Statistics #' and Computing, doi:10.1007/s11222-016-9696-4. arXiv preprint arXiv:1507.04544. #' #' Gelman, A., Hwang, J., & Vehtari, A. (2014). #' Understanding predictive information criteria for Bayesian models. #' Statistics and Computing, 24, 997-1016. #' #' Watanabe, S. (2010). Asymptotic equivalence of Bayes cross validation #' and widely applicable information criterion in singular learning theory. #' The Journal of Machine Learning Research, 11, 3571-3594. #' #' @importFrom loo waic #' @export waic #' @export waic.brmsfit <- function(x, ..., compare = TRUE, resp = NULL, pointwise = FALSE, model_names = NULL) { args <- split_dots(x, ..., model_names = model_names) if (!"use_stored" %in% names(args)) { further_arg_names <- c("resp") args$use_stored <- all(names(args) %in% "models") && !any(further_arg_names %in% names(match.call())) } c(args) <- nlist(criterion = "waic", pointwise, compare, resp) do_call(compute_loolist, args) } #' @export WAIC.brmsfit <- function(x, ..., compare = TRUE, resp = NULL, pointwise = FALSE, model_names = NULL) { cl <- match.call() cl[[1]] <- quote(waic) eval(cl, parent.frame()) } #' @export WAIC <- function(x, ...) { UseMethod("WAIC") } # helper function used to create (lists of) 'loo' objects # @param models list of brmsfit objects # @param criterion name of the criterion to compute # @param use_stored use precomputed criterion objects if possible? # @param compare compare models using 'loo_compare'? # @param ... more arguments passed to compute_loo # @return If length(models) > 1 an object of class 'loolist' # If length(models) == 1 an object of class 'loo' compute_loolist <- function(models, criterion, use_stored = TRUE, compare = TRUE, ...) { criterion <- match.arg(criterion, loo_criteria()) args <- nlist(criterion, ...) for (i in seq_along(models)) { models[[i]] <- restructure(models[[i]]) } if (length(models) > 1L) { if (!match_nobs(models)) { stop2("Models have different number of observations.") } if (length(use_stored) == 1L) { use_stored <- rep(use_stored, length(models)) } out <- list(loos = named_list(names(models))) for (i in seq_along(models)) { args$x <- models[[i]] args$model_name <- names(models)[i] args$use_stored <- use_stored[i] out$loos[[i]] <- do_call(compute_loo, args) } compare <- as_one_logical(compare) if (compare) { out$diffs <- loo_compare(out$loos) # for backwards compatibility; remove in brms 3.0 out$ic_diffs__ <- SW(compare_ic(x = out$loos))$ic_diffs__ } class(out) <- "loolist" } else { args$x <- models[[1]] args$model_name <- names(models) args$use_stored <- use_stored out <- do_call(compute_loo, args) } out } # compute model fit criteria using the 'loo' package # @param x an object of class brmsfit # @param criterion the criterion to be computed # @param newdata optional data.frame of new data # @param resp optional names of the predicted response variables # @param model_name original variable name of object 'x' # @param use_stored use precomputed criterion objects if possible? # @param ... passed to the individual methods # @return an object of class 'loo' compute_loo <- function(x, criterion, newdata = NULL, resp = NULL, model_name = "", use_stored = TRUE, ...) { criterion <- match.arg(criterion, loo_criteria()) model_name <- as_one_character(model_name) use_stored <- as_one_logical(use_stored) out <- get_criterion(x, criterion) if (is.loo(out) && !use_stored) { message("Recomputing '", criterion, "' for model '", model_name, "'") } if (!is.loo(out) || !use_stored) { args <- nlist(x, newdata, resp, model_name, ...) out <- do_call(paste0(".", criterion), args) attr(out, "yhash") <- hash_response(x, newdata = newdata, resp = resp) } attr(out, "model_name") <- model_name out } # possible criteria to evaluate via the loo package loo_criteria <- function() { c("loo", "waic", "psis", "kfold", "loo_subsample") } # compute 'loo' criterion using the 'loo' package .loo <- function(x, pointwise, k_threshold, moment_match, reloo, moment_match_args, reloo_args, newdata, resp, model_name, save_psis, ...) { loo_args <- prepare_loo_args( x, newdata = newdata, resp = resp, pointwise = pointwise, save_psis = save_psis, ... ) out <- SW(do_call("loo", loo_args, pkg = "loo")) if (moment_match) { c(moment_match_args) <- nlist( x, loo = out, newdata, resp, k_threshold, check = FALSE, ... ) out <- do_call("loo_moment_match", moment_match_args) } if (reloo) { c(reloo_args) <- nlist( x, loo = out, newdata, resp, k_threshold, check = FALSE, ... ) out <- do_call("reloo", reloo_args) } recommend_loo_options(out, k_threshold, moment_match, model_name) out } # compute 'waic' criterion using the 'loo' package # @param model_name ignored but included to avoid being passed to '...' .waic <- function(x, pointwise, newdata, resp, model_name, ...) { loo_args <- prepare_loo_args( x, newdata = newdata, resp = resp, pointwise = pointwise, ... ) do_call("waic", loo_args, pkg = "loo") } # alias of psis for convenient use in compute_loo() .psis <- function(x, newdata, resp, model_name, ...) { psis(x, newdata = newdata, resp = resp, model_name = model_name, ...) } #' @inherit loo::psis return title description details references #' #' @aliases psis psis.brmsfit #' #' @param log_ratios A fitted model object of class \code{brmsfit}. #' Argument is named "log_ratios" to match the argument name of the #' \code{\link[loo:psis]{loo::psis}} generic function. #' @param model_name Currently ignored. #' @param ... Further arguments passed to \code{\link{log_lik}} and #' \code{\link[loo:psis]{loo::psis}}. #' @inheritParams log_lik.brmsfit #' #' @examples #' \dontrun{ #' fit <- brm(rating ~ treat + period + carry, data = inhaler) #' psis(fit) #'} #' @importFrom loo psis #' @export psis #' @export psis.brmsfit <- function(log_ratios, newdata = NULL, resp = NULL, model_name = NULL, ...) { loo_args <- prepare_loo_args( log_ratios, newdata = newdata, resp = resp, pointwise = FALSE, ... ) loo_args$log_ratios <- -loo_args$x loo_args$x <- NULL do_call("psis", loo_args, pkg = "loo") } # prepare arguments passed to the methods of the `loo` package prepare_loo_args <- function(x, newdata, resp, pointwise, ...) { pointwise <- as_one_logical(pointwise) loo_args <- list(...) ll_args <- nlist(object = x, newdata, resp, pointwise, ...) loo_args$x <- do_call(log_lik, ll_args) if (pointwise) { loo_args$draws <- attr(loo_args$x, "draws") loo_args$data <- attr(loo_args$x, "data") } # compute pointwise relative efficiencies r_eff_args <- loo_args r_eff_args$fit <- x loo_args$r_eff <- do_call(r_eff_log_lik, r_eff_args) loo_args } #' Model comparison with the \pkg{loo} package #' #' For more details see \code{\link[loo:loo_compare]{loo_compare}}. #' #' @aliases loo_compare #' #' @inheritParams loo.brmsfit #' @param ... More \code{brmsfit} objects. #' @param criterion The name of the criterion to be extracted #' from \code{brmsfit} objects. #' #' @details All \code{brmsfit} objects should contain precomputed #' criterion objects. See \code{\link{add_criterion}} for more help. #' #' @return An object of class "\code{compare.loo}". #' #' @examples #' \dontrun{ #' # model with population-level effects only #' fit1 <- brm(rating ~ treat + period + carry, #' data = inhaler) #' fit1 <- add_criterion(fit1, "waic") #' #' # model with an additional varying intercept for subjects #' fit2 <- brm(rating ~ treat + period + carry + (1|subject), #' data = inhaler) #' fit2 <- add_criterion(fit2, "waic") #' #' # compare both models #' loo_compare(fit1, fit2, criterion = "waic") #' } #' #' @importFrom loo loo_compare #' @export loo_compare #' @export loo_compare.brmsfit <- function(x, ..., criterion = c("loo", "waic", "kfold"), model_names = NULL) { criterion <- match.arg(criterion) models <- split_dots(x, ..., model_names = model_names, other = FALSE) loos <- named_list(names(models)) for (i in seq_along(models)) { models[[i]] <- restructure(models[[i]]) loo_i <- get_criterion(models[[i]], criterion) if (is.null(loo_i)) { stop2( "Model '", names(models)[i], "' does not contain a precomputed '", criterion, "' criterion. See ?loo_compare.brmsfit for help." ) } # only assign object to list after checking if non-null # otherwise the index may be out of bounds in the error check loos[[i]] <- loo_i } loo_compare(loos) } #' Model averaging via stacking or pseudo-BMA weighting. #' #' Compute model weights for \code{brmsfit} objects via stacking #' or pseudo-BMA weighting. For more details, see #' \code{\link[loo:loo_model_weights]{loo::loo_model_weights}}. #' #' @aliases loo_model_weights #' #' @inheritParams loo.brmsfit #' #' @return A named vector of model weights. #' #' @examples #' \dontrun{ #' # model with population-level effects only #' fit1 <- brm(rating ~ treat + period + carry, #' data = inhaler, family = "gaussian") #' # model with an additional varying intercept for subjects #' fit2 <- brm(rating ~ treat + period + carry + (1|subject), #' data = inhaler, family = "gaussian") #' loo_model_weights(fit1, fit2) #' } #' #' @method loo_model_weights brmsfit #' @importFrom loo loo_model_weights #' @export loo_model_weights #' @export loo_model_weights.brmsfit <- function(x, ..., model_names = NULL) { args <- split_dots(x, ..., model_names = model_names) models <- args$models args$models <- NULL log_lik_list <- lapply(models, function(x) do_call(log_lik, c(list(x), args)) ) args$x <- log_lik_list args$r_eff_list <- mapply( r_eff_log_lik, log_lik_list, fit = models, SIMPLIFY = FALSE ) out <- do_call(loo::loo_model_weights, args) names(out) <- names(models) out } #' Add model fit criteria to model objects #' #' @param x An \R object typically of class \code{brmsfit}. #' @param criterion Names of model fit criteria #' to compute. Currently supported are \code{"loo"}, #' \code{"waic"}, \code{"kfold"}, \code{"loo_subsample"}, #' \code{"bayes_R2"} (Bayesian R-squared), #' \code{"loo_R2"} (LOO-adjusted R-squared), and #' \code{"marglik"} (log marginal likelihood). #' @param model_name Optional name of the model. If \code{NULL} #' (the default) the name is taken from the call to \code{x}. #' @param overwrite Logical; Indicates if already stored fit #' indices should be overwritten. Defaults to \code{FALSE}. #' Setting it to \code{TRUE} is useful for example when changing #' additional arguments of an already stored criterion. #' @param file Either \code{NULL} or a character string. In the latter case, the #' fitted model object including the newly added criterion values is saved via #' \code{\link{saveRDS}} in a file named after the string supplied in #' \code{file}. The \code{.rds} extension is added automatically. If \code{x} #' was already stored in a file before, the file name will be reused #' automatically (with a message) unless overwritten by \code{file}. In any #' case, \code{file} only applies if new criteria were actually added via #' \code{add_criterion} or if \code{force_save} was set to \code{TRUE}. #' @param force_save Logical; only relevant if \code{file} is specified and #' ignored otherwise. If \code{TRUE}, the fitted model object will be saved #' regardless of whether new criteria were added via \code{add_criterion}. #' @param ... Further arguments passed to the underlying #' functions computing the model fit criteria. If you are recomputing #' an already stored criterion with other \code{...} arguments, make #' sure to set \code{overwrite = TRUE}. #' #' @return An object of the same class as \code{x}, but #' with model fit criteria added for later usage. #' #' @details Functions \code{add_loo} and \code{add_waic} are aliases of #' \code{add_criterion} with fixed values for the \code{criterion} argument. #' #' @examples #' \dontrun{ #' fit <- brm(count ~ Trt, data = epilepsy) #' # add both LOO and WAIC at once #' fit <- add_criterion(fit, c("loo", "waic")) #' print(fit$criteria$loo) #' print(fit$criteria$waic) #' } #' #' @export add_criterion <- function(x, ...) { UseMethod("add_criterion") } #' @rdname add_criterion #' @export add_criterion.brmsfit <- function(x, criterion, model_name = NULL, overwrite = FALSE, file = NULL, force_save = FALSE, ...) { if (!is.null(model_name)) { model_name <- as_one_character(model_name) } else { model_name <- deparse0(substitute(x)) } criterion <- unique(as.character(criterion)) if (any(criterion == "R2")) { # deprecated as of version 2.10.4 warning2("Criterion 'R2' is deprecated. Please use 'bayes_R2' instead.") criterion[criterion == "R2"] <- "bayes_R2" } loo_options <- c("loo", "waic", "kfold", "loo_subsample") options <- c(loo_options, "bayes_R2", "loo_R2", "marglik") if (!length(criterion) || !all(criterion %in% options)) { stop2("Argument 'criterion' should be a subset of ", collapse_comma(options)) } auto_save <- FALSE if (!is.null(file)) { file <- paste0(as_one_character(file), ".rds") } else { file <- x$file if (!is.null(file)) auto_save <- TRUE } force_save <- as_one_logical(force_save) overwrite <- as_one_logical(overwrite) if (overwrite) { # recompute all criteria new_criteria <- criterion } else { # only computed criteria not already stored new_criteria <- criterion[ulapply(x$criteria[criterion], is.null)] } # remove all criteria that are to be recomputed x$criteria[new_criteria] <- NULL args <- list(x, ...) for (fun in intersect(new_criteria, loo_options)) { args$model_names <- model_name x$criteria[[fun]] <- do_call(fun, args) } if ("bayes_R2" %in% new_criteria) { args$summary <- FALSE x$criteria$bayes_R2 <- do_call(bayes_R2, args) } if ("loo_R2" %in% new_criteria) { args$summary <- FALSE x$criteria$loo_R2 <- do_call(loo_R2, args) } if ("marglik" %in% new_criteria) { x$criteria$marglik <- do_call(bridge_sampler, args) } if (!is.null(file) && (force_save || length(new_criteria))) { if (auto_save) { message("Automatically saving the model object in '", file, "'") } x$file <- file saveRDS(x, file = file) } x } # extract a recomputed model fit criterion get_criterion <- function(x, criterion) { stopifnot(is.brmsfit(x)) criterion <- as_one_character(criterion) x$criteria[[criterion]] } # create a hash based on the response of a model hash_response <- function(x, newdata = NULL, resp = NULL, ...) { require_package("digest") stopifnot(is.brmsfit(x)) sdata <- standata( x, newdata = newdata, re_formula = NA, internal = TRUE, check_response = TRUE, only_response = TRUE ) add_funs <- lsp("brms", what = "exports", pattern = "^resp_") regex <- c("Y", sub("^resp_", "", add_funs)) regex <- outer(regex, escape_all(usc(resp)), FUN = paste0) regex <- paste0("(", as.vector(regex), ")", collapse = "|") regex <- paste0("^(", regex, ")(_|$)") out <- sdata[grepl(regex, names(sdata))] out <- as.matrix(as.data.frame(rmNULL(out))) out <- p(out, attr(sdata, "old_order")) # see issue #642 attributes(out) <- NULL digest::sha1(x = out, ...) } # compare the response parts of multiple brmsfit objects # @param models A list of brmsfit objects # @param ... passed to hash_response # @return TRUE if the response parts of all models match and FALSE otherwise match_response <- function(models, ...) { if (length(models) <= 1L) { out <- TRUE } else { yhash <- lapply(models, hash_response, ...) yhash_check <- ulapply(yhash, is_equal, yhash[[1]]) if (all(yhash_check)) { out <- TRUE } else { out <- FALSE } } out } # compare number of observations of multipe models # @param models A list of brmsfit objects # @param ... currently ignored # @return TRUE if the number of rows match match_nobs <- function(models, ...) { if (length(models) <= 1L) { out <- TRUE } else { nobs <- lapply(models, nobs) nobs_check <- ulapply(nobs, is_equal, nobs[[1]]) if (all(nobs_check)) { out <- TRUE } else { out <- FALSE } } out } # validate models passed to loo and related methods # @param models list of fitted model objects # @param model_names names specified by the user # @param sub_names names inferred by substitute() validate_models <- function(models, model_names, sub_names) { stopifnot(is.list(models)) model_names <- as.character(model_names) if (!length(model_names)) { model_names <- as.character(sub_names) } if (length(model_names) != length(models)) { stop2("Number of model names is not equal to the number of models.") } names(models) <- model_names for (i in seq_along(models)) { if (!is.brmsfit(models[[i]])) { stop2("Object '", names(models)[i], "' is not of class 'brmsfit'.") } } models } # recommend options if approximate loo fails for some observations # @param moment_match has moment matching already been performed? recommend_loo_options <- function(loo, k_threshold = 0.7, moment_match = FALSE, model_name = "") { if (isTRUE(nzchar(model_name))) { model_name <- paste0(" in model '", model_name, "'") } else { model_name <- "" } ndraws <- dim(loo)[1] %||% Inf n <- n2 <- length(loo::pareto_k_ids(loo, threshold = k_threshold)) # for small number of draws the threshold may be smaller than 0.7 k_threshold2 <- ps_khat_threshold(ndraws) if (k_threshold2 < k_threshold) { n2 <- length(loo::pareto_k_ids(loo, threshold = k_threshold2)) } if (n2 > n && k_threshold2 <= 0.7) { warning2( "Found ", n2, " observations with a pareto_k > ", round(k_threshold2, 2), model_name, ". We recommend to run more iterations to get at least ", "about 2200 posterior draws to improve LOO-CV approximation accuracy." ) out <- "loo_more_draws" } else if (n > 0 && !moment_match) { warning2( "Found ", n, " observations with a pareto_k > ", k_threshold, model_name, ". We recommend to set 'moment_match = TRUE' in order ", "to perform moment matching for problematic observations. " ) out <- "loo_moment_match" } else if (n > 0 && n <= 10) { warning2( "Found ", n, " observations with a pareto_k > ", k_threshold, model_name, ". We recommend to set 'reloo = TRUE' in order to ", "calculate the ELPD without the assumption that these observations " , "are negligible. This will refit the model ", n, " times to compute ", "the ELPDs for the problematic observations directly." ) out <- "reloo" } else if (n > 10) { warning2( "Found ", n, " observations with a pareto_k > ", k_threshold, model_name, ". With this many problematic observations, it may be more ", "appropriate to use 'kfold' with argument 'K = 10' to perform ", "10-fold cross-validation rather than LOO." ) out <- "kfold" } else { out <- "loo" } invisible(out) } # subset observations in a psis object # this is a bit cumbersome because of how psis stores information # @param subset vector with which to subset #' @export subset.psis <- function(x, subset, ...) { stopifnot(is.vector(subset)) x$log_weights <- x$log_weights[, subset, drop = FALSE] for (d in names(x$diagnostics)) { x$diagnostics[[d]] <- x$diagnostics[[d]][subset] } attr_names <- c("norm_const_log", "tail_len", "r_eff") for (a in attr_names) { attr(x, a) <- attr(x, a)[subset] } attr(x, "dims") <- dim(x$log_weights) x } # helper function to compute relative efficiences # @param x matrix of posterior draws # @param fit a brmsfit object to extract metadata from # @param allow_na allow NA values in the output? # @return a numeric vector of length NCOL(x) r_eff_helper <- function(x, chain_id, allow_na = TRUE, ...) { out <- loo::relative_eff(x, chain_id = chain_id, ...) if (!allow_na && anyNA(out)) { # avoid error in loo if some but not all r_effs are NA out <- rep(1, length(out)) warning2( "Ignoring relative efficiencies as some were NA. ", "See argument 'r_eff' in ?loo::loo for more details." ) } out } # wrapper around r_eff_helper to compute efficiency # of likelihood draws based on log-likelihood draws r_eff_log_lik <- function(x, ...) { UseMethod("r_eff_log_lik") } #' @export r_eff_log_lik.matrix <- function(x, fit, allow_na = FALSE, ...) { if (is.brmsfit_multiple(fit)) { # due to stacking of chains from multiple models # efficiency computations will likely be incorrect # assume relative efficiency of 1 for now return(rep(1, ncol(x))) } chain_id <- get_chain_id(nrow(x), fit) r_eff_helper(exp(x), chain_id = chain_id, allow_na = allow_na, ...) } #' @export r_eff_log_lik.function <- function(x, fit, draws, allow_na = FALSE, ...) { if (is.brmsfit_multiple(fit)) { # due to stacking of chains from multiple models # efficiency computations will likely be incorrect # assume relative efficiency of 1 for now return(rep(1, draws$nobs)) } lik_fun <- function(data_i, draws, ...) { exp(x(data_i, draws, ...)) } chain_id <- get_chain_id(draws$ndraws, fit) r_eff_helper( lik_fun, chain_id = chain_id, draws = draws, allow_na = allow_na, ... ) } # get chain IDs per posterior draw get_chain_id <- function(ndraws, fit) { if (ndraws != ndraws(fit)) { # don't know the chain IDs of a subset of draws chain_id <- rep(1L, ndraws) } else { nchains <- fit$fit@sim$chains chain_id <- rep(seq_len(nchains), each = ndraws / nchains) } chain_id } # print the output of a list of loo objects #' @export print.loolist <- function(x, digits = 1, ...) { model_names <- loo::find_model_names(x$loos) for (i in seq_along(x$loos)) { cat(paste0("Output of model '", model_names[i], "':\n")) print(x$loos[[i]], digits = digits, ...) cat("\n") } if (!is.null(x$diffs)) { cat("Model comparisons:\n") print(x$diffs, digits = digits, ...) } invisible(x) } # ---------- deprecated functions ---------- #' @rdname add_ic #' @export add_loo <- function(x, model_name = NULL, ...) { warning2("'add_loo' is deprecated. Please use 'add_criterion' instead.") if (!is.null(model_name)) { model_name <- as_one_character(model_name) } else { model_name <- deparse0(substitute(x)) } add_criterion(x, criterion = "loo", model_name = model_name, ...) } #' @rdname add_ic #' @export add_waic <- function(x, model_name = NULL, ...) { warning2("'add_waic' is deprecated. Please use 'add_criterion' instead.") if (!is.null(model_name)) { model_name <- as_one_character(model_name) } else { model_name <- deparse0(substitute(x)) } add_criterion(x, criterion = "waic", model_name = model_name, ...) } #' Add model fit criteria to model objects #' #' Deprecated aliases of \code{\link{add_criterion}}. #' #' @inheritParams add_criterion #' @param ic,value Names of model fit criteria #' to compute. Currently supported are \code{"loo"}, #' \code{"waic"}, \code{"kfold"}, \code{"R2"} (R-squared), and #' \code{"marglik"} (log marginal likelihood). #' #' @return An object of the same class as \code{x}, but #' with model fit criteria added for later usage. #' Previously computed criterion objects will be overwritten. #' #' @export add_ic <- function(x, ...) { UseMethod("add_ic") } #' @rdname add_ic #' @export add_ic.brmsfit <- function(x, ic = "loo", model_name = NULL, ...) { warning2("'add_ic' is deprecated. Please use 'add_criterion' instead.") if (!is.null(model_name)) { model_name <- as_one_character(model_name) } else { model_name <- deparse0(substitute(x)) } add_criterion(x, criterion = ic, model_name = model_name, ...) } #' @rdname add_ic #' @export 'add_ic<-' <- function(x, ..., value) { add_ic(x, ic = value, ...) } #' Compare Information Criteria of Different Models #' #' Compare information criteria of different models fitted #' with \code{\link{waic}} or \code{\link{loo}}. #' Deprecated and will be removed in the future. Please use #' \code{\link{loo_compare}} instead. #' #' @param ... At least two objects returned by #' \code{\link{waic}} or \code{\link{loo}}. #' Alternatively, \code{brmsfit} objects with information #' criteria precomputed via \code{\link{add_ic}} #' may be passed, as well. #' @param x A \code{list} containing the same types of objects as #' can be passed via \code{...}. #' @param ic The name of the information criterion to be extracted #' from \code{brmsfit} objects. Ignored if information #' criterion objects are only passed directly. #' #' @return An object of class \code{iclist}. #' #' @details See \code{\link{loo_compare}} for the recommended way #' of comparing models with the \pkg{loo} package. #' #' @seealso #' \code{\link{loo}}, #' \code{\link{loo_compare}} #' \code{\link{add_criterion}} #' #' @examples #' \dontrun{ #' # model with population-level effects only #' fit1 <- brm(rating ~ treat + period + carry, #' data = inhaler) #' waic1 <- waic(fit1) #' #' # model with an additional varying intercept for subjects #' fit2 <- brm(rating ~ treat + period + carry + (1|subject), #' data = inhaler) #' waic2 <- waic(fit2) #' #' # compare both models #' compare_ic(waic1, waic2) #' } #' #' @export compare_ic <- function(..., x = NULL, ic = c("loo", "waic", "kfold")) { # will be removed in brms 3.0 warning2( "'compare_ic' is deprecated and will be removed ", "in the future. Please use 'loo_compare' instead." ) ic <- match.arg(ic) if (!(is.null(x) || is.list(x))) { stop2("Argument 'x' should be a list.") } x$ic_diffs__ <- NULL x <- c(list(...), x) for (i in seq_along(x)) { # extract precomputed values from brmsfit objects if (is.brmsfit(x[[i]]) && !is.null(x[[i]][[ic]])) { x[[i]] <- x[[i]][[ic]] } } if (!all(sapply(x, inherits, "loo"))) { stop2("All inputs should have class 'loo' ", "or contain precomputed 'loo' objects.") } if (length(x) < 2L) { stop2("Expecting at least two objects.") } ics <- unname(sapply(x, function(y) rownames(y$estimates)[3])) if (!all(ics %in% ics[1])) { stop2("All inputs should be from the same criterion.") } yhash <- lapply(x, attr, which = "yhash") yhash_check <- ulapply(yhash, is_equal, yhash[[1]]) if (!all(yhash_check)) { warning2( "Model comparisons are likely invalid as the response ", "values of at least two models do not match." ) } names(x) <- loo::find_model_names(x) n_models <- length(x) ic_diffs <- matrix(0, nrow = n_models * (n_models - 1) / 2, ncol = 2) rnames <- rep("", nrow(ic_diffs)) # pairwise comparision to get differences in ICs and their SEs n <- 1 for (i in seq_len(n_models - 1)) { for (j in (i + 1):n_models) { tmp <- SW(loo::compare(x[[j]], x[[i]])) ic_diffs[n, ] <- c(-2 * tmp[["elpd_diff"]], 2 * tmp[["se"]]) rnames[n] <- paste(names(x)[i], "-", names(x)[j]) n <- n + 1 } } rownames(ic_diffs) <- rnames colnames(ic_diffs) <- c(toupper(ics[1]), "SE") x$ic_diffs__ <- ic_diffs class(x) <- "iclist" x } # print the output of LOO and WAIC with multiple models # deprecated as of brms > 2.5.0 and will be removed in brms 3.0 #' @export print.iclist <- function(x, digits = 2, ...) { m <- x m$ic_diffs__ <- NULL if (length(m)) { ic <- rownames(m[[1]]$estimates)[3] mat <- matrix(0, nrow = length(m), ncol = 2) dimnames(mat) <- list(names(m), c(toupper(ic), "SE")) for (i in seq_along(m)) { mat[i, ] <- m[[i]]$estimates[3, ] } } else { mat <- ic <- NULL } ic_diffs <- x$ic_diffs__ if (is.matrix(attr(x, "compare"))) { # deprecated as of brms 1.4.0 ic_diffs <- attr(x, "compare") } if (is.matrix(ic_diffs)) { # models were compared using the compare_ic function mat <- rbind(mat, ic_diffs) } print(round(mat, digits = digits), na.print = "") invisible(x) } # Pareto-smoothing k-hat threshold # not yet exported by loo so copied over here for now ps_khat_threshold <- function(S, ...) { 1 - 1 / log10(S) } brms/R/exclude_terms.R0000644000176200001440000000271314527413457014423 0ustar liggesusers# exclude predictor terms from being evaluated exclude_terms <- function(x, ...) { UseMethod("exclude_terms") } #' @export exclude_terms.brmsfit <- function(x, ...) { x$formula <- exclude_terms(x$formula, ...) x } #' @export exclude_terms.mvbrmsformula <- function(x, ...) { for (i in seq_along(x$forms)) { x$forms[[i]] <- exclude_terms(x$forms[[i]], ...) } x } #' @export exclude_terms.brmsformula <- function( x, excl_term_types = NULL, incl_autocor = TRUE, smooths_only = FALSE, offset = TRUE, ... ) { excl_term_types <- as.character(excl_term_types) # TODO: deprecate the three arguments below? incl_autocor <- as_one_logical(incl_autocor) smooths_only <- as_one_logical(smooths_only) offset <- as_one_logical(offset) if (!incl_autocor) { c(excl_term_types) <- "ac" } if (!offset) { c(excl_term_types) <- "offset" } if (smooths_only) { excl_term_types <- setdiff(all_term_types(), "sm") } if (!length(excl_term_types)) { return(x) } invalid_types <- setdiff(excl_term_types, all_term_types()) if (length(invalid_types)) { stop2("The following term types are invalid: ", collapse_comma(invalid_types)) } attr(x$formula, "excl_term_types") <- excl_term_types for (i in seq_along(x$pforms)) { attr(x$pforms[[i]], "excl_term_types") <- excl_term_types } x } # extract names of excluded term types excluded_term_types <- function(x) { as.character(attr(x, "excl_term_types", TRUE)) } brms/R/stan-response.R0000644000176200001440000005307715053305627014364 0ustar liggesusers# unless otherwise specifiedm functions return a named list # of Stan code snippets to be pasted together later on # Stan code for the response variables stan_response <- function(bframe, threads, normalize, ...) { stopifnot(is.brmsframe(bframe)) lpdf <- stan_lpdf_name(normalize) family <- bframe$family rtype <- str_if(use_int(family), "int", "real") multicol <- has_multicol(family) px <- check_prefix(bframe) resp <- usc(combine_prefix(px)) out <- list(resp_type = rtype) if (nzchar(resp)) { # global N is defined elsewhere str_add(out$data) <- glue( " int N{resp}; // number of observations\n" ) str_add(out$pll_def) <- glue( " int N{resp} = end - start + 1;\n" ) } if (has_cat(family)) { str_add(out$data) <- glue( " int ncat{resp}; // number of categories\n" ) str_add(out$pll_args) <- glue(", data int ncat{resp}") } if (has_multicol(family)) { if (rtype == "real") { str_add(out$data) <- glue( " array[N{resp}] vector[ncat{resp}] Y{resp}; // response array\n" ) str_add(out$pll_args) <- glue(", data array[] vector Y{resp}") } else if (rtype == "int") { str_add(out$data) <- glue( " array[N{resp}, ncat{resp}] int Y{resp}; // response array\n" ) str_add(out$pll_args) <- glue(", data array[,] int Y{resp}") } } else { if (rtype == "real") { # type vector (instead of array real) is required by some PDFs str_add(out$data) <- glue( " vector[N{resp}] Y{resp}; // response variable\n" ) str_add(out$pll_args) <- glue(", data vector Y{resp}") } else if (rtype == "int") { str_add(out$data) <- glue( " array[N{resp}] int Y{resp}; // response variable\n" ) str_add(out$pll_args) <- glue(", data array[] int Y{resp}") } } if (has_ndt(family)) { str_add(out$tdata_def) <- glue( " real min_Y{resp} = min(Y{resp});\n" ) } if (has_trials(family) || is.formula(bframe$adforms$trials)) { str_add(out$data) <- glue( " array[N{resp}] int trials{resp}; // number of trials\n" ) str_add(out$pll_args) <- glue(", data array[] int trials{resp}") } if (is.formula(bframe$adforms$weights)) { str_add(out$data) <- glue( " vector[N{resp}] weights{resp}; // model weights\n" ) str_add(out$pll_args) <- glue(", data vector weights{resp}") } if (has_thres(family)) { groups <- get_thres_groups(family) if (any(nzchar(groups))) { str_add(out$data) <- glue( " int ngrthres{resp}; // number of threshold groups\n", " array[ngrthres{resp}] int nthres{resp}; // number of thresholds\n", " array[N{resp}, 2] int Jthres{resp}; // threshold indices\n" ) str_add(out$tdata_def) <- glue( " int nmthres{resp} = sum(nthres{resp});", " // total number of thresholds\n", " array[ngrthres{resp}] int Kthres_start{resp};", " // start index per threshold group\n", " array[ngrthres{resp}] int Kthres_end{resp};", " // end index per threshold group\n" ) str_add(out$tdata_comp) <- glue( " Kthres_start{resp}[1] = 1;\n", " Kthres_end{resp}[1] = nthres{resp}[1];\n", " for (i in 2:ngrthres{resp}) {{\n", " Kthres_start{resp}[i] = Kthres_end{resp}[i-1] + 1;\n", " Kthres_end{resp}[i] = Kthres_end{resp}[i-1] + nthres{resp}[i];\n", " }}\n" ) str_add(out$pll_args) <- glue( ", data array[] int nthres{resp}, data array[,] int Jthres{resp}" ) } else { str_add(out$data) <- glue( " int nthres{resp}; // number of thresholds\n" ) str_add(out$pll_args) <- glue(", data int nthres{resp}") } } if (is.formula(bframe$adforms$se)) { str_add(out$data) <- glue( " vector[N{resp}] se{resp}; // known sampling error\n" ) str_add(out$tdata_def) <- glue( " vector[N{resp}] se2{resp} = square(se{resp});\n" ) str_add(out$pll_args) <- glue( ", data vector se{resp}, data vector se2{resp}" ) } if (is.formula(bframe$adforms$dec)) { str_add(out$data) <- glue( " array[N{resp}] int dec{resp}; // decisions\n" ) str_add(out$pll_args) <- glue(", data array[] int dec{resp}") } if (is.formula(bframe$adforms$rate)) { str_add(out$data) <- glue( " vector[N{resp}] denom{resp};", " // response denominator\n" ) str_add(out$tdata_def) <- glue( " // log response denominator\n", " vector[N{resp}] log_denom{resp} = log(denom{resp});\n" ) str_add(out$pll_args) <- glue( ", data vector denom{resp}, data vector log_denom{resp}" ) } if (is.formula(bframe$adforms$cens)) { str_add(out$data) <- glue( " // censoring indicator: 0 = event, 1 = right, -1 = left, 2 = interval censored\n", " array[N{resp}] int cens{resp};\n" ) str_add(out$pll_args) <- glue(", data array[] int cens{resp}") if (has_interval_cens(bframe)) { # some observations may be interval censored str_add(out$data) <- " // right censor points for interval censoring\n" if (rtype == "int") { str_add(out$data) <- glue( " array[N{resp}] int rcens{resp};\n" ) str_add(out$pll_args) <- glue(", data array[] int rcens{resp}") } else { str_add(out$data) <- glue( " vector[N{resp}] rcens{resp};\n" ) str_add(out$pll_args) <- glue(", data vector rcens{resp}") } } else { # cannot yet vectorize over interval censored observations # hence there is no need to collect the indices in that case cens_indicators_def <- glue( " // indices of censored data\n", " int Nevent{resp} = 0;\n", " int Nrcens{resp} = 0;\n", " int Nlcens{resp} = 0;\n", " array[N{resp}] int Jevent{resp};\n", " array[N{resp}] int Jrcens{resp};\n", " array[N{resp}] int Jlcens{resp};\n" ) n <- stan_nn(threads) cens_indicators_comp <- glue( " // collect indices of censored data\n", " for (n in 1:N{resp}) {{\n", stan_nn_def(threads), " if (cens{resp}{n} == 0) {{\n", " Nevent{resp} += 1;\n", " Jevent{resp}[Nevent{resp}] = n;\n", " }} else if (cens{resp}{n} == 1) {{\n", " Nrcens{resp} += 1;\n", " Jrcens{resp}[Nrcens{resp}] = n;\n", " }} else if (cens{resp}{n} == -1) {{\n", " Nlcens{resp} += 1;\n", " Jlcens{resp}[Nlcens{resp}] = n;\n", " }}\n", " }}\n" ) if (use_threading(threads)) { # in threaded Stan code, gathering the indices has to be done on the fly # inside the reduce_sum call since the indices are dependent on the slice # of observations whose log likelihood is being evaluated str_add(out$fun) <- " #include 'fun_add_int.stan'\n" str_add(out$pll_def) <- cens_indicators_def str_add(out$model_comp_basic) <- cens_indicators_comp } else { str_add(out$tdata_def) <- cens_indicators_def str_add(out$tdata_comp) <- cens_indicators_comp } } } bounds <- bframe$frame$resp$bounds if (any(bounds$lb > -Inf)) { str_add(out$data) <- glue( " array[N{resp}] {rtype} lb{resp}; // lower truncation bounds;\n" ) str_add(out$pll_args) <- glue(", data array[] {rtype} lb{resp}") } if (any(bounds$ub < Inf)) { str_add(out$data) <- glue( " array[N{resp}] {rtype} ub{resp}; // upper truncation bounds\n" ) str_add(out$pll_args) <- glue(", data array[] {rtype} ub{resp}") } if (is.formula(bframe$adforms$mi)) { # TODO: pass 'Ybounds' via 'standata' instead of hardcoding them Ybounds <- bframe$frame$resp$Ybounds mi <- eval_rhs(bframe$adforms$mi) if (mi$vars$sdy == "NA") { # response is modeled without measurement error str_add(out$data) <- glue( " int Nmi{resp}; // number of missings\n", " array[Nmi{resp}] int Jmi{resp}; // positions of missings\n" ) str_add(out$par) <- glue( " vector{Ybounds}[Nmi{resp}] Ymi{resp}; // estimated missings\n" ) str_add(out$model_no_pll_def) <- glue( " // vector combining observed and missing responses\n", " vector[N{resp}] Yl{resp} = Y{resp};\n" ) str_add(out$model_no_pll_comp_basic) <- glue( " Yl{resp}[Jmi{resp}] = Ymi{resp};\n" ) str_add(out$pll_args) <- glue(", vector Yl{resp}") } else { # measurement error present str_add(out$data) <- glue( " // data for measurement-error in the response\n", " vector[N{resp}] noise{resp};\n", " // information about non-missings\n", " int Nme{resp};\n", " array[Nme{resp}] int Jme{resp};\n" ) str_add(out$par) <- glue( " vector{Ybounds}[N{resp}] Yl{resp}; // latent variable\n" ) str_add(out$model_prior) <- glue( " target += normal_{lpdf}(Y{resp}[Jme{resp}]", " | Yl{resp}[Jme{resp}], noise{resp}[Jme{resp}]);\n" ) str_add(out$pll_args) <- glue(", vector Yl{resp}") } } if (is.formula(bframe$adforms$vreal)) { # vectors of real values for use in custom families vreal <- eval_rhs(bframe$adforms$vreal) k <- length(vreal$vars) str_add(out$data) <- cglue( " // data for custom real vectors\n", " array[N{resp}] real vreal{seq_len(k)}{resp};\n" ) str_add(out$pll_args) <- cglue(", data array[] real vreal{seq_len(k)}{resp}") } if (is.formula(bframe$adforms$vint)) { # vectors of integer values for use in custom families vint <- eval_rhs(bframe$adforms$vint) k <- length(vint$vars) str_add(out$data) <- cglue( " // data for custom integer vectors\n", " array[N{resp}] int vint{seq_len(k)}{resp};\n" ) str_add(out$pll_args) <- cglue(", data array[] int vint{seq_len(k)}{resp}") } out } # Stan code for ordinal thresholds # intercepts in ordinal models require special treatment # and must be present even when using non-linear predictors # thus the relevant Stan code cannot be part of 'stan_fe' stan_thres <- function(bterms, prior, normalize, ...) { stopifnot(is.btl(bterms) || is.btnl(bterms)) out <- list() if (!is_ordinal(bterms)) { return(out) } px <- check_prefix(bterms) p <- usc(combine_prefix(px)) resp <- usc(px$resp) type <- str_if(has_ordered_thres(bterms), "ordered", "vector") coef_type <- str_if(has_ordered_thres(bterms), "", "real") gr <- grb <- "" groups <- get_thres_groups(bterms) if (has_thres_groups(bterms)) { # include one threshold vector per group gr <- usc(seq_along(groups)) grb <- paste0("[", seq_along(groups), "]") } family <- bterms$family$family link <- bterms$family$link if (has_extra_cat(bterms)) { str_add(out$fun) <- glue( " #includeR `stan_hurdle_ordinal_lpmf('{family}', '{link}')`\n" ) } else { str_add(out$fun) <- glue( " #includeR `stan_ordinal_lpmf('{family}', '{link}')`\n" ) } if (fix_intercepts(bterms)) { # identify ordinal mixtures by fixing their thresholds to the same values if (has_equidistant_thres(bterms)) { stop2("Cannot use equidistant and fixed thresholds at the same time.") } # separate definition from computation to support fixed parameters str_add(out$tpar_def) <- " // ordinal thresholds\n" str_add(out$tpar_def) <- cglue( " {type}[nthres{resp}{grb}] Intercept{p}{gr};\n" ) str_add(out$tpar_comp) <- " // fix thresholds across ordinal mixture components\n" str_add(out$tpar_comp) <- cglue( " Intercept{p}{gr} = fixed_Intercept{resp}{gr};\n" ) } else { if (has_equidistant_thres(bterms)) { bound <- subset2(prior, class = "delta", group = "", ls = px)$bound for (i in seq_along(groups)) { str_add_list(out) <- stan_prior( prior, class = "Intercept", group = groups[i], prefix = "first_", suffix = glue("{p}{gr[i]}"), px = px, comment = "first threshold", normalize = normalize ) str_add_list(out) <- stan_prior( prior, class = "delta", group = groups[i], px = px, suffix = gr[i], comment = "distance between thresholds", normalize = normalize ) } str_add(out$tpar_def) <- " // temporary thresholds for centered predictors\n" str_add(out$tpar_def) <- cglue( " {type}[nthres{resp}{grb}] Intercept{p}{gr};\n" ) str_add(out$tpar_comp) <- " // compute equidistant thresholds\n" str_add(out$tpar_comp) <- cglue( " for (k in 1:(nthres{resp}{grb})) {{\n", " Intercept{p}{gr}[k] = first_Intercept{p}{gr}", " + (k - 1.0) * delta{p}{gr};\n", " }}\n" ) } else { for (i in seq_along(groups)) { str_add_list(out) <- stan_prior( prior, class = "Intercept", group = groups[i], coef = get_thres(bterms, group = groups[i]), type = glue("{type}[nthres{resp}{grb[i]}]"), coef_type = coef_type, px = px, suffix = glue("{p}{gr[i]}"), comment = "temporary thresholds for centered predictors", normalize = normalize ) } } } stz <- "" if (has_sum_to_zero_thres(bterms)) { stz <- "_stz" str_add(out$tpar_def) <- cglue( " vector[nthres{resp}{grb}] Intercept{p}_stz{gr};", " // sum-to-zero constraint thresholds\n" ) str_add(out$tpar_comp) <- " // compute sum-to-zero constraint thresholds\n" str_add(out$tpar_comp) <- cglue( " Intercept{p}_stz{gr} = Intercept{p}{gr} - mean(Intercept{p}{gr});\n" ) } if (has_thres_groups(bterms)) { # merge all group specific thresholds into one vector str_add(out$tpar_def) <- glue( " vector[nmthres{resp}] merged_Intercept{p}{stz}; // merged thresholds\n" ) str_add(out$tpar_comp) <- " // merge thresholds\n" grj <- seq_along(groups) grj <- glue("Kthres_start{resp}[{grj}]:Kthres_end{resp}[{grj}]") str_add(out$tpar_comp) <- cglue( " merged_Intercept{p}{stz}[{grj}] = Intercept{p}{stz}{gr};\n" ) str_add(out$pll_args) <- cglue(", vector merged_Intercept{p}{stz}") } else { str_add(out$pll_args) <- glue(", vector Intercept{p}{stz}") } sub_X_means <- "" if (stan_center_X(bterms) && length(all_terms(bterms$fe))) { # centering of the design matrix improves convergence # ordinal families either use thres - mu or mu - thres # both implies adding to the temporary intercept sub_X_means <- glue(" + dot_product(means_X{p}, b{p})") } str_add(out$gen_def) <- " // compute actual thresholds\n" str_add(out$gen_def) <- cglue( " vector[nthres{resp}{grb}] b{p}_Intercept{gr}", " = Intercept{p}{stz}{gr}{sub_X_means};\n" ) out } # Stan code for the baseline functions of the Cox model stan_bhaz <- function(bterms, prior, threads, normalize, ...) { stopifnot(is.btl(bterms) || is.btnl(bterms)) out <- list() if (!is_cox(bterms$family)) { return(out) } lpdf <- stan_lpdf_name(normalize) px <- check_prefix(bterms) p <- usc(combine_prefix(px)) resp <- usc(px$resp) n <- stan_nn(threads) slice <- stan_slice(threads) str_add(out$data) <- glue( " // data for flexible baseline functions\n", " int Kbhaz{resp}; // number of basis functions\n", " // design matrix of the baseline function\n", " matrix[N{resp}, Kbhaz{resp}] Zbhaz{resp};\n", " // design matrix of the cumulative baseline function\n", " matrix[N{resp}, Kbhaz{resp}] Zcbhaz{resp};\n" ) str_add(out$pll_args) <- glue( ", data matrix Zbhaz{resp}, data matrix Zcbhaz{resp}" ) if (has_bhaz_groups(bterms)) { # stratified baseline hazards with separate functions per group str_add(out$data) <- glue( " // data for stratification of baseline hazards\n", " int ngrbhaz{resp}; // number of groups\n", " array[N{resp}] int Jgrbhaz{resp}; // group indices per observation\n", " // a-priori concentration vector of baseline coefficients\n", " array[ngrbhaz{resp}] vector[Kbhaz{resp}] con_sbhaz{resp};\n" ) str_add(out$pll_args) <- glue( ", data array[] int Jgrbhaz{resp}" ) str_add(out$par) <- glue( " // stratified baseline hazard coefficients\n", " array[ngrbhaz{resp}] simplex[Kbhaz{resp}] sbhaz{resp};\n" ) str_add(out$tpar_prior) <- glue( " for (k in 1:ngrbhaz{resp}) {{\n", " lprior += dirichlet_{lpdf}(sbhaz{resp}[k] | con_sbhaz{resp}[k]);\n", " }}\n" ) str_add(out$model_def) <- glue( " // stratified baseline hazard functions\n", " vector[N{resp}] bhaz{resp};\n", " vector[N{resp}] cbhaz{resp};\n" ) str_add(out$model_comp_basic) <- glue( " // compute values of stratified baseline hazard functions\n", " for (n in 1:N{resp}) {{\n", stan_nn_def(threads), " bhaz{resp}{n} = Zbhaz{resp}{n} * sbhaz{resp}[Jgrbhaz{resp}{n}];\n", " cbhaz{resp}{n} = Zcbhaz{resp}{n} * sbhaz{resp}[Jgrbhaz{resp}{n}];\n", " }}\n" ) str_add(out$pll_args) <- glue(", array[] vector sbhaz{resp}") } else { # a single baseline hazard function str_add(out$data) <- glue( " // a-priori concentration vector of baseline coefficients\n", " vector[Kbhaz{resp}] con_sbhaz{resp};\n" ) str_add(out$par) <- glue( " // baseline hazard coefficients\n", " simplex[Kbhaz{resp}] sbhaz{resp};\n" ) str_add(out$tpar_prior) <- glue( " lprior += dirichlet_{lpdf}(sbhaz{resp} | con_sbhaz{resp});\n" ) str_add(out$model_def) <- glue( " // compute values of baseline function\n", " vector[N{resp}] bhaz{resp} = Zbhaz{resp}{slice} * sbhaz{resp};\n", " // compute values of cumulative baseline function\n", " vector[N{resp}] cbhaz{resp} = Zcbhaz{resp}{slice} * sbhaz{resp};\n" ) str_add(out$pll_args) <- glue(", vector sbhaz{resp}") } out } # Stan code specific to mixture families stan_mixture <- function(bterms, prior, threads, normalize, ...) { out <- list() if (!is.mixfamily(bterms$family)) { return(out) } lpdf <- stan_lpdf_name(normalize) px <- check_prefix(bterms) p <- usc(combine_prefix(px)) nmix <- length(bterms$family$mix) theta_pred <- grepl("^theta", names(bterms$dpars)) theta_pred <- bterms$dpars[theta_pred] theta_fix <- grepl("^theta", names(bterms$fdpars)) theta_fix <- bterms$fdpars[theta_fix] def_thetas <- cglue( " real theta{1:nmix}{p}; // mixing proportion\n" ) if (length(theta_pred)) { if (length(theta_pred) != nmix - 1) { stop2("Can only predict all but one mixing proportion.") } missing_id <- setdiff(1:nmix, dpar_id(names(theta_pred))) str_add(out$model_def) <- glue( " vector[N{p}] theta{missing_id}{p} = rep_vector(0.0, N{p});\n", " real log_sum_exp_theta{p};\n" ) sum_exp_theta <- glue("exp(theta{1:nmix}{p}[n])", collapse = " + ") str_add(out$model_comp_mix) <- glue( " for (n in 1:N{p}) {{\n", " // scale theta to become a probability vector\n", " log_sum_exp_theta{p} = log({sum_exp_theta});\n" ) str_add(out$model_comp_mix) <- cglue( " theta{1:nmix}{p}[n] = theta{1:nmix}{p}[n] - log_sum_exp_theta{p};\n" ) str_add(out$model_comp_mix) <- " }\n" } else if (length(theta_fix)) { # fix mixture proportions if (length(theta_fix) != nmix) { stop2("Can only fix no or all mixing proportions.") } str_add(out$data) <- " // mixing proportions\n" str_add(out$data) <- cglue( " real theta{1:nmix}{p};\n" ) str_add(out$pll_args) <- cglue(", real theta{1:nmix}{p}") } else { # estimate mixture proportions str_add(out$data) <- glue( " vector[{nmix}] con_theta{p}; // prior concentration\n" ) str_add(out$par) <- glue( " simplex[{nmix}] theta{p}; // mixing proportions\n" ) str_add(out$tpar_prior) <- glue( " lprior += dirichlet_{lpdf}(theta{p} | con_theta{p});\n" ) # separate definition from computation to support fixed parameters str_add(out$tpar_def) <- " // mixing proportions\n" str_add(out$tpar_def) <- cglue( " real theta{1:nmix}{p};\n" ) str_add(out$tpar_comp) <- cglue( " theta{1:nmix}{p} = theta{p}[{1:nmix}];\n" ) str_add(out$pll_args) <- cglue(", real theta{1:nmix}{p}") } if (order_intercepts(bterms)) { # identify mixtures by ordering the intercepts of their components str_add(out$par) <- glue( " ordered[{nmix}] ordered_Intercept{p}; // to identify mixtures\n" ) } if (fix_intercepts(bterms)) { # identify ordinal mixtures by fixing their thresholds to the same values stopifnot(is_ordinal(bterms)) gr <- grb <- "" groups <- get_thres_groups(bterms) if (has_thres_groups(bterms)) { # include one threshold vector per group gr <- usc(seq_along(groups)) grb <- paste0("[", seq_along(groups), "]") } type <- str_if(has_ordered_thres(bterms), "ordered", "vector") coef_type <- str_if(has_ordered_thres(bterms), "", "real") for (i in seq_along(groups)) { str_add_list(out) <- stan_prior( prior, class = "Intercept", coef = get_thres(bterms, group = groups[i]), type = glue("{type}[nthres{p}{grb[i]}]"), coef_type = coef_type, px = px, prefix = "fixed_", suffix = glue("{p}{gr[i]}"), comment = "thresholds fixed over mixture components", normalize = normalize ) } } out } brms/R/backends.R0000644000176200001440000010563515053072461013330 0ustar liggesusers# parse Stan model code # @param model Stan model code # @return validated Stan model code parse_model <- function(model, backend, ...) { backend <- as_one_character(backend) .parse_model <- get(paste0(".parse_model_", backend), mode = "function") .parse_model(model, ...) } # parse Stan model code with rstan # @param model Stan model code # @return validated Stan model code .parse_model_rstan <- function(model, silent = 1, ...) { out <- eval_silent( rstan::stanc(model_code = model, ...), type = "message", try = TRUE, silent = silent ) out$model_code } # parse Stan model code with cmdstanr # @param model Stan model code # @return validated Stan model code .parse_model_cmdstanr <- function(model, silent = 1, ...) { require_package("cmdstanr") temp_file <- cmdstanr::write_stan_file(model) # if (cmdstanr::cmdstan_version() >= "2.29.0") { # .canonicalize_stan_model(temp_file, overwrite_file = TRUE) # } out <- eval_silent( cmdstanr::cmdstan_model(temp_file, compile = FALSE, ...), type = "message", try = TRUE, silent = silent ) out$check_syntax(quiet = TRUE) collapse(out$code(), "\n") } # parse model with a mock backend for testing .parse_model_mock <- function(model, silent = TRUE, parse_error = NULL, parse_check = "rstan", ...) { if (!is.null(parse_error)) { stop2(parse_error) } else if (parse_check == "rstan") { out <- .parse_model_rstan(model, silent = silent, ...) } else if (parse_check == "cmdstanr") { out <- .parse_model_cmdstanr(model, silent = silent, ...) } else if (is.null(parse_check)) { out <- "mock_code" } else { stop2("Unknown 'parse_check' value.") } out } # compile Stan model # @param model Stan model code # @return validated Stan model code compile_model <- function(model, backend, ...) { backend <- as_one_character(backend) .compile_model <- get(paste0(".compile_model_", backend), mode = "function") .compile_model(model, ...) } # compile Stan model with rstan # @param model Stan model code # @return model compiled with rstan .compile_model_rstan <- function(model, threads, opencl, silent = 1, ...) { args <- list(...) args$model_code <- model if (silent < 2) { message("Compiling Stan program...") } if (use_threading(threads, force = TRUE)) { if (utils::packageVersion("rstan") >= "2.26") { threads_per_chain_def <- rstan::rstan_options("threads_per_chain") on.exit(rstan::rstan_options(threads_per_chain = threads_per_chain_def)) rstan::rstan_options(threads_per_chain = threads$threads) } else { stop2("Threading is not supported by backend 'rstan' version ", utils::packageVersion("rstan"), ".") } } if (use_opencl(opencl)) { stop2("OpenCL is not supported by backend 'rstan' version ", utils::packageVersion("rstan"), ".") } eval_silent( do_call(rstan::stan_model, args), type = "message", try = TRUE, silent = silent >= 2 ) } # compile Stan model with cmdstanr # @param model Stan model code # @return model compiled with cmdstanr .compile_model_cmdstanr <- function(model, threads, opencl, silent = 1, ...) { require_package("cmdstanr") args <- list(...) args$stan_file <- cmdstanr::write_stan_file(model) # if (cmdstanr::cmdstan_version() >= "2.29.0") { # .canonicalize_stan_model(args$stan_file, overwrite_file = TRUE) # } if (use_threading(threads, force = TRUE)) { args$cpp_options$stan_threads <- TRUE } if (use_opencl(opencl)) { args$cpp_options$stan_opencl <- TRUE } eval_silent( do_call(cmdstanr::cmdstan_model, args), type = "message", try = TRUE, silent = silent >= 2 ) } # compile model with a mock backend for testing .compile_model_mock <- function(model, threads, opencl, compile_check = "rstan", compile_error = NULL, silent = 1, ...) { if (!is.null(compile_error)) { stop2(compile_error) } else if (compile_check == "rstan") { out <- .parse_model_rstan(model, silent = silent, ...) } else if (compile_check == "cmdstanr") { out <- .parse_model_cmdstanr(model, silent = silent, ...) } else if (is.null(compile_check)) { out <- list() } else { stop2("Unknown 'compile_check' value.") } out } # fit Stan model # @param model Stan model code # @return validated Stan model code fit_model <- function(model, backend, ...) { backend <- as_one_character(backend) .fit_model <- get(paste0(".fit_model_", backend), mode = "function") .fit_model(model, ...) } # fit Stan model with rstan # @param model a compiled Stan model # @param sdata named list to be passed to Stan as data # @return a fitted Stan model .fit_model_rstan <- function(model, sdata, algorithm, iter, warmup, thin, chains, cores, threads, opencl, init, exclude, seed, control, silent, future, ...) { # some input checks and housekeeping if (use_threading(threads, force = TRUE)) { if (utils::packageVersion("rstan") >= "2.26") { threads_per_chain_def <- rstan::rstan_options("threads_per_chain") on.exit(rstan::rstan_options(threads_per_chain = threads_per_chain_def)) rstan::rstan_options(threads_per_chain = threads$threads) } else { stop2("Threading is not supported by backend 'rstan' version ", utils::packageVersion("rstan"), ".") } } if (use_opencl(opencl)) { stop2("OpenCL is not supported by backend 'rstan' version ", utils::packageVersion("rstan"), ".") } if (is.null(init)) { init <- "random" } else if (is.character(init) && !init %in% c("random", "0")) { init <- get(init, mode = "function", envir = parent.frame()) } future <- future && algorithm %in% "sampling" args <- nlist( object = model, data = sdata, iter, seed, init = init, pars = exclude, include = FALSE ) dots <- list(...) args[names(dots)] <- dots # do the actual sampling if (silent < 2) { message("Start sampling") } if (algorithm %in% c("sampling", "fixed_param")) { c(args) <- nlist(warmup, thin, control, show_messages = !silent) if (algorithm == "fixed_param") { args$algorithm <- "Fixed_param" } if (future) { if (cores > 1L) { warning2("Argument 'cores' is ignored when using 'future'.") } args$chains <- 1L out <- futures <- vector("list", chains) for (i in seq_len(chains)) { args$chain_id <- i if (is.list(init)) { args$init <- init[i] } futures[[i]] <- future::future( brms::do_call(rstan::sampling, args), packages = "rstan", seed = TRUE ) } for (i in seq_len(chains)) { out[[i]] <- future::value(futures[[i]]) } out <- rstan::sflist2stanfit(out) rm(futures) } else { c(args) <- nlist(chains, cores) out <- do_call(rstan::sampling, args) } } else if (algorithm %in% c("fullrank", "meanfield")) { # vb does not support parallel execution c(args) <- nlist(algorithm) out <- do_call(rstan::vb, args) } else { stop2("Algorithm '", algorithm, "' is not supported.") } # TODO: add support for pathfinder and laplace out <- repair_stanfit(out) out } # fit Stan model with cmdstanr # @param model a compiled Stan model # @param sdata named list to be passed to Stan as data # @return a fitted Stan model .fit_model_cmdstanr <- function(model, sdata, algorithm, iter, warmup, thin, chains, cores, threads, opencl, init, exclude, seed, control, silent, future, ...) { require_package("cmdstanr") # some input checks and housekeeping class(sdata) <- "list" if (isNA(seed)) { seed <- NULL } if (is_equal(init, "random")) { init <- NULL } else if (is_equal(init, "0")) { init <- 0 } future <- future && algorithm %in% "sampling" args <- nlist(data = sdata, seed, init) if (use_opencl(opencl)) { args$opencl_ids <- opencl$ids } dots <- list(...) args[names(dots)] <- dots args[names(control)] <- control chains <- as_one_numeric(chains) empty_model <- chains <= 0 if (empty_model) { # fit the model with minimal amount of draws # TODO: replace with a better solution chains <- 1 iter <- 2 warmup <- 1 thin <- 1 cores <- 1 } # do the actual sampling if (silent < 2) { message("Start sampling") } use_threading <- use_threading(threads, force = TRUE) if (algorithm %in% c("sampling", "fixed_param")) { c(args) <- list( iter_sampling = iter - warmup, iter_warmup = warmup, chains = chains, thin = thin, parallel_chains = cores, show_messages = silent < 2, show_exceptions = silent == 0, fixed_param = algorithm == "fixed_param" ) if (use_threading) { args$threads_per_chain <- threads$threads } if (future) { if (cores > 1L) { warning2("Argument 'cores' is ignored when using 'future'.") } args$chains <- 1L out <- futures <- vector("list", chains) for (i in seq_len(chains)) { args$chain_ids <- i if (is.list(init)) { args$init <- init[i] } futures[[i]] <- future::future( brms::do_call(model$sample, args), packages = "cmdstanr", seed = TRUE ) } for (i in seq_len(chains)) { out[[i]] <- future::value(futures[[i]]) } rm(futures) } else { out <- do_call(model$sample, args) } } else if (algorithm %in% c("fullrank", "meanfield")) { c(args) <- nlist(iter, algorithm) if (use_threading) { args$threads <- threads$threads } out <- do_call(model$variational, args) } else if (algorithm %in% c("pathfinder")) { c(args) <- list(num_paths = chains) if (use_threading) { args$num_threads <- threads$threads } out <- do_call(model$pathfinder, args) } else if (algorithm %in% c("laplace")) { if (use_threading) { args$threads <- threads$threads } out <- do_call(model$laplace, args) } else { stop2("Algorithm '", algorithm, "' is not supported.") } if (future) { # 'out' is a list of fitted models output_files <- ulapply(out, function(x) x$output_files()) stan_variables <- out[[1]]$metadata()$stan_variables } else { # 'out' is a single fitted model output_files <- out$output_files() stan_variables <- out$metadata()$stan_variables } out <- read_csv_as_stanfit( output_files, variables = stan_variables, model = model, exclude = exclude, algorithm = algorithm ) if (empty_model) { # allow correct updating of an 'empty' model out@sim <- list() } out } # fit model with a mock backend for testing .fit_model_mock <- function(model, sdata, algorithm, iter, warmup, thin, chains, cores, threads, opencl, init, exclude, seed, control, silent, future, mock_fit, ...) { if (is.function(mock_fit)) { out <- mock_fit() } else { out <- mock_fit } out } # extract the compiled stan model # @param x brmsfit object compiled_model <- function(x) { stopifnot(is.brmsfit(x)) backend <- x$backend %||% "rstan" if (backend == "rstan") { out <- rstan::get_stanmodel(x$fit) } else if (backend == "cmdstanr") { out <- attributes(x$fit)$CmdStanModel } else if (backend == "mock") { stop2("'compiled_model' is not supported in the mock backend.") } out } # Does the model need recompilation before being able to sample again? needs_recompilation <- function(x) { stopifnot(is.brmsfit(x)) backend <- x$backend %||% "rstan" if (backend == "rstan") { # TODO: figure out when rstan requires recompilation out <- FALSE } else if (backend == "cmdstanr") { exe_file <- attributes(x$fit)$CmdStanModel$exe_file() out <- !is.character(exe_file) || !file.exists(exe_file) } else if (backend == "mock") { out <- FALSE } out } #' Recompile Stan models in \code{brmsfit} objects #' #' Recompile the Stan model inside a \code{brmsfit} object, if necessary. #' This does not change the model, it simply recreates the executable #' so that sampling is possible again. #' #' @param x An object of class \code{brmsfit}. #' @param recompile Logical, indicating whether the Stan model should be #' recompiled. If \code{NULL} (the default), \code{recompile_model} tries #' to figure out internally, if recompilation is necessary. Setting it to #' \code{FALSE} will cause \code{recompile_model} to always return the #' \code{brmsfit} object unchanged. #' #' @return A (possibly updated) \code{brmsfit} object. #' #' @export recompile_model <- function(x, recompile = NULL) { stopifnot(is.brmsfit(x)) if (is.null(recompile)) { recompile <- needs_recompilation(x) } recompile <- as_one_logical(recompile) if (!recompile) { return(x) } message("Recompiling the Stan model") backend <- x$backend %||% "rstan" new_model <- compile_model( stancode(x), backend = backend, threads = x$threads, opencl = x$opencl, silent = 2 ) if (backend == "rstan") { x$fit@stanmodel <- new_model } else if (backend == "cmdstanr") { attributes(x)$CmdStanModel <- new_model } else if (backend == "mock") { stop2("'recompile_model' is not supported in the mock backend.") } x } # extract the elapsed time during model fitting # @param x brmsfit object elapsed_time <- function(x) { stopifnot(is.brmsfit(x)) backend <- x$backend %||% "rstan" if (backend == "rstan") { out <- rstan::get_elapsed_time(x$fit) out <- data.frame( chain_id = seq_len(nrow(out)), warmup = out[, "warmup"], sampling = out[, "sample"] ) out$total <- out$warmup + out$sampling rownames(out) <- NULL } else if (backend == "cmdstanr") { out <- attributes(x$fit)$metadata$time$chains } else if (backend == "mock") { stop2("'elapsed_time' not supported in the mock backend.") } out } # supported Stan backends backend_choices <- function() { c("rstan", "cmdstanr", "mock") } # supported Stan algorithms algorithm_choices <- function() { c("sampling", "meanfield", "fullrank", "pathfinder", "laplace", "fixed_param") } # check if the model was fit the the required backend require_backend <- function(backend, x) { stopifnot(is.brmsfit(x)) backend <- match.arg(backend, backend_choices()) if (isTRUE(x$backend != backend)) { stop2("Backend '", backend, "' is required for this method.") } invisible(TRUE) } #' Threading in Stan #' #' Use threads for within-chain parallelization in \pkg{Stan} via the \pkg{brms} #' interface. Within-chain parallelization is experimental! We recommend its use #' only if you are experienced with Stan's \code{reduce_sum} function and have a #' slow running model that cannot be sped up by any other means. #' #' @param threads Number of threads to use in within-chain parallelization. #' @param grainsize Number of observations evaluated together in one chunk on #' one of the CPUs used for threading. If \code{NULL} (the default), #' \code{grainsize} is currently chosen as \code{max(100, N / (2 * #' threads))}, where \code{N} is the number of observations in the data. This #' default is experimental and may change in the future without prior notice. #' @param static Logical. Apply the static (non-adaptive) version of #' \code{reduce_sum}? Defaults to \code{FALSE}. Setting it to \code{TRUE} #' is required to achieve exact reproducibility of the model results #' (if the random seed is set as well). #' @param force Logical. Defaults to \code{FALSE}. If \code{TRUE}, this will #' force the Stan model to compile with threading enabled without altering the #' Stan code generated by brms. This can be useful if your own custom Stan #' functions use threading internally. #' #' @return A \code{brmsthreads} object which can be passed to the #' \code{threads} argument of \code{brm} and related functions. #' #' @details The adaptive scheduling procedure used by \code{reduce_sum} will #' prevent the results to be exactly reproducible even if you set the random #' seed. If you need exact reproducibility, you have to set argument #' \code{static = TRUE} which may reduce efficiency a bit. #' #' To ensure that chunks (whose size is defined by \code{grainsize}) require #' roughly the same amount of computing time, we recommend storing #' observations in random order in the data. At least, please avoid sorting #' observations after the response values. This is because the latter often #' cause variations in the computing time of the pointwise log-likelihood, #' which makes up a big part of the parallelized code. #' #' @examples #' \dontrun{ #' # this model just serves as an illustration #' # threading may not actually speed things up here #' fit <- brm(count ~ zAge + zBase * Trt + (1|patient), #' data = epilepsy, family = negbinomial(), #' chains = 1, threads = threading(2, grainsize = 100), #' backend = "cmdstanr") #' summary(fit) #' } #' #' @export threading <- function(threads = NULL, grainsize = NULL, static = FALSE, force = FALSE) { out <- list(threads = NULL, grainsize = NULL) class(out) <- "brmsthreads" if (!is.null(threads)) { threads <- as_one_numeric(threads) if (!is_wholenumber(threads) || threads < 1) { stop2("Number of threads needs to be positive.") } out$threads <- threads } if (!is.null(grainsize)) { grainsize <- as_one_numeric(grainsize) if (!is_wholenumber(grainsize) || grainsize < 1) { stop2("The grainsize needs to be positive.") } out$grainsize <- grainsize } out$static <- as_one_logical(static) out$force <- as_one_logical(force) out } is.brmsthreads <- function(x) { inherits(x, "brmsthreads") } # validate 'thread' argument validate_threads <- function(threads) { if (is.null(threads)) { threads <- threading() } else if (is.numeric(threads)) { threads <- as_one_numeric(threads) threads <- threading(threads) } else if (!is.brmsthreads(threads)) { stop2("Argument 'threads' needs to be numeric or ", "specified via the 'threading' function.") } threads } # is threading activated? use_threading <- function(threads, force = FALSE) { threads <- validate_threads(threads) out <- isTRUE(threads$threads > 0) if (!force) { # Stan code will only be altered in non-forced mode out <- out && !isTRUE(threads$force) } out } #' GPU support in Stan via OpenCL #' #' Use OpenCL for GPU support in \pkg{Stan} via the \pkg{brms} interface. Only #' some \pkg{Stan} functions can be run on a GPU at this point and so #' a lot of \pkg{brms} models won't benefit from OpenCL for now. #' #' @param ids (integer vector of length 2) The platform and device IDs of the #' OpenCL device to use for fitting. If you don't know the IDs of your OpenCL #' device, \code{c(0,0)} is most likely what you need. #' #' @return A \code{brmsopencl} object which can be passed to the #' \code{opencl} argument of \code{brm} and related functions. #' #' @details For more details on OpenCL in \pkg{Stan}, check out #' \url{https://mc-stan.org/docs/2_26/cmdstan-guide/parallelization.html#opencl} #' as well as \url{https://mc-stan.org/docs/2_26/stan-users-guide/opencl.html}. #' #' @examples #' \dontrun{ #' # this model just serves as an illustration #' # OpenCL may not actually speed things up here #' fit <- brm(count ~ zAge + zBase * Trt + (1|patient), #' data = epilepsy, family = poisson(), #' chains = 2, cores = 2, opencl = opencl(c(0, 0)), #' backend = "cmdstanr") #' summary(fit) #' } #' #' @export opencl <- function(ids = NULL) { out <- list(ids = NULL) class(out) <- "brmsopencl" if (!is.null(ids)) { ids <- as.integer(ids) if (!length(ids) == 2L) { stop2("OpenCl 'ids' needs to be an integer vector of length 2.") } out$ids <- ids } out } is.brmsopencl <- function(x) { inherits(x, "brmsopencl") } # validate the 'opencl' argument validate_opencl <- function(opencl) { if (is.null(opencl)) { opencl <- opencl() } else if (is.numeric(opencl)) { opencl <- opencl(opencl) } else if (!is.brmsopencl(opencl)) { stop2("Argument 'opencl' needs to an integer vector or ", "specified via the 'opencl' function.") } opencl } # is OpenCL activated? use_opencl <- function(opencl) { !is.null(validate_opencl(opencl)$ids) } # validate the 'silent' argument validate_silent <- function(silent) { silent <- as_one_integer(silent) if (silent < 0 || silent > 2) { stop2("'silent' must be between 0 and 2.") } silent } # ensure that variable dimensions at the end are correctly written # convert names like b.1.1 to b[1,1] repair_variable_names <- function(x) { x <- sub("\\.", "[", x) x <- gsub("\\.", ",", x) x[grep("\\[", x)] <- paste0(x[grep("\\[", x)], "]") x } # repair parameter names of stanfit objects repair_stanfit <- function(x) { stopifnot(is.stanfit(x)) if (!length(x@sim$fnames_oi)) { # nothing to rename return(x) } # the posterior package cannot deal with non-unique parameter names # this case happens rarely but might happen when sample_prior = "yes" x@sim$fnames_oi <- make.unique(as.character(x@sim$fnames_oi), "__") for (i in seq_along(x@sim$samples)) { # stanfit may have renamed dimension suffixes (#1218) if (length(x@sim$samples[[i]]) == length(x@sim$fnames_oi)) { names(x@sim$samples[[i]]) <- x@sim$fnames_oi } } x } # possible options for argument 'file_refit' file_refit_options <- function() { c("never", "always", "on_change") } # canonicalize Stan model file in accordance with the current Stan version # this function may no longer be needed due to rstan 2.26+ now being on CRAN # for more details see https://github.com/paul-buerkner/brms/issues/1544 # .canonicalize_stan_model <- function(stan_file, overwrite_file = TRUE) { # cmdstan_mod <- cmdstanr::cmdstan_model(stan_file, compile = FALSE) # out <- utils::capture.output( # cmdstan_mod$format( # canonicalize = list("deprecations", "braces", "parentheses"), # overwrite_file = overwrite_file, backup = FALSE # ) # ) # paste0(out, collapse = "\n") # } #' Read CmdStan CSV files as a brms-formatted stanfit object #' #' \code{read_csv_as_stanfit} is used internally to read CmdStan CSV files into a #' \code{stanfit} object that is consistent with the structure of the fit slot of a #' brmsfit object. #' #' @param files Character vector of CSV files names where draws are stored. #' @param variables Character vector of variables to extract from the CSV files. #' @param sampler_diagnostics Character vector of sampler diagnostics to extract. #' @param model A compiled cmdstanr model object (optional). Provide this argument #' if you want to allow updating the model without recompilation. #' @param exclude Character vector of variables to exclude from the stanfit. Only #' used when \code{variables} is also specified. #' @param algorithm The algorithm with which the model was fitted. #' See \code{\link{brm}} for details. #' #' @return A stanfit object consistent with the structure of the \code{fit} #' slot of a brmsfit object. #' #' @examples #' \dontrun{ #' # fit a model manually via cmdstanr #' scode <- stancode(count ~ Trt, data = epilepsy) #' sdata <- standata(count ~ Trt, data = epilepsy) #' mod <- cmdstanr::cmdstan_model(cmdstanr::write_stan_file(scode)) #' stanfit <- mod$sample(data = sdata) #' #' # feed the Stan model back into brms #' fit <- brm(count ~ Trt, data = epilepsy, empty = TRUE, backend = 'cmdstanr') #' fit$fit <- read_csv_as_stanfit(stanfit$output_files(), model = mod) #' fit <- rename_pars(fit) #' summary(fit) #' } #' #' @export read_csv_as_stanfit <- function(files, variables = NULL, sampler_diagnostics = NULL, model = NULL, exclude = "", algorithm = "sampling") { require_package("cmdstanr") if (!is.null(variables)) { # ensure that only relevant variables are read from CSV variables <- repair_variable_names(variables) variables <- unique(sub("\\[.+", "", variables)) variables <- setdiff(variables, exclude) # temp fix for cmdstanr not recognizing the variable names it produces #1473 if (algorithm %in% c("meanfield", "fullrank")) { variables <- ifelse(variables == "lp_approx__", "log_g__", variables) } else if (algorithm %in% "pathfinder") { variables <- setdiff(variables, "lp_approx__") } else if (algorithm %in% "laplace") { variables <- setdiff(variables, c("lp__", "lp_approx__")) } } csfit <- cmdstanr::read_cmdstan_csv( files = files, variables = variables, sampler_diagnostics = sampler_diagnostics, format = NULL ) # @model_name model_name <- gsub(".csv", "", basename(files[[1]])) # @model_pars model_pars <- csfit$metadata$stan_variables if (!is.null(variables)) { model_pars <- intersect(model_pars, variables) } # special variables will be added back later on special_vars <- c("lp__", "lp_approx__") model_pars <- setdiff(model_pars, special_vars) # @par_dims par_dims <- vector("list", length(model_pars)) names(par_dims) <- model_pars par_dims <- lapply(par_dims, function(x) integer(0)) pdims_num <- ulapply(model_pars, function(x) sum(grepl(paste0("^", x, "\\[.*\\]$"), csfit$metadata$model_params)) ) par_dims[pdims_num != 0] <- csfit$metadata$stan_variable_sizes[model_pars][pdims_num != 0] # @mode mode <- 0L # @sim rstan_diagn_order <- c("accept_stat__", "treedepth__", "stepsize__", "divergent__", "n_leapfrog__", "energy__") if (!is.null(sampler_diagnostics)) { rstan_diagn_order <- rstan_diagn_order[rstan_diagn_order %in% sampler_diagnostics] } res_vars <- c(".chain", ".iteration", ".draw") if ("post_warmup_draws" %in% names(csfit)) { # for MCMC samplers n_chains <- max( nchains(csfit$warmup_draws), nchains(csfit$post_warmup_draws) ) n_iter_warmup <- niterations(csfit$warmup_draws) n_iter_sample <- niterations(csfit$post_warmup_draws) if (n_iter_warmup > 0) { csfit$warmup_draws <- as_draws_df(csfit$warmup_draws) csfit$warmup_sampler_diagnostics <- as_draws_df(csfit$warmup_sampler_diagnostics) } if (n_iter_sample > 0) { csfit$post_warmup_draws <- as_draws_df(csfit$post_warmup_draws) csfit$post_warmup_sampler_diagnostics <- as_draws_df(csfit$post_warmup_sampler_diagnostics) } # called 'samples' for consistency with rstan samples <- rbind(csfit$warmup_draws, csfit$post_warmup_draws) # manage memory csfit$warmup_draws <- NULL csfit$post_warmup_draws <- NULL # prepare sampler diagnostics diagnostics <- rbind( csfit$warmup_sampler_diagnostics, csfit$post_warmup_sampler_diagnostics ) # manage memory csfit$warmup_sampler_diagnostics <- NULL csfit$post_warmup_sampler_diagnostics <- NULL # convert to regular data.frame diagnostics <- as.data.frame(diagnostics) diag_chain_ids <- diagnostics$.chain diagnostics[res_vars] <- NULL } else if ("draws" %in% names(csfit)) { # for variational inference "samplers" n_chains <- 1 n_iter_warmup <- 0 n_iter_sample <- niterations(csfit$draws) if (n_iter_sample > 0) { csfit$draws <- as_draws_df(csfit$draws) } # called 'samples' for consistency with rstan samples <- csfit$draws # manage memory csfit$draws <- NULL # VI has no sampler diagnostics diag_chain_ids <- rep(1L, nrow(samples)) diagnostics <- as.data.frame(matrix(nrow = nrow(samples), ncol = 0)) } # some diagnostics may be missing in the output depending on the algorithm rstan_diagn_order <- intersect(rstan_diagn_order, names(diagnostics)) # convert to regular data.frame samples <- as.data.frame(samples) chain_ids <- samples$.chain samples[res_vars] <- NULL # only add special variables to dims if there are present in samples # this ensures that dims_oi, pars_oi, and fnames_oi match with samples for (p in special_vars) { if (p %in% colnames(samples)) { samples <- move2end(samples, p) par_dims[[p]] <- integer(0) } } model_pars <- names(par_dims) fnames_oi <- colnames(samples) # split samples into chains samples <- split(samples, chain_ids) names(samples) <- NULL # split diagnostics into chains diagnostics <- split(diagnostics, diag_chain_ids) names(diagnostics) <- NULL # @sim$sample: largely 113-130 from rstan::read_stan_csv values <- list() values$algorithm <- csfit$metadata$algorithm values$engine <- csfit$metadata$engine values$metric <- csfit$metadata$metric sampler_t <- NULL if (!is.null(values$algorithm)) { if (values$algorithm == "rwm" || values$algorithm == "Metropolis") { sampler_t <- "Metropolis" } else if (values$algorithm == "hmc") { if (values$engine == "static") { sampler_t <- "HMC" } else { if (values$metric == "unit_e") { sampler_t <- "NUTS(unit_e)" } else if (values$metric == "diag_e") { sampler_t <- "NUTS(diag_e)" } else if (values$metric == "dense_e") { sampler_t <- "NUTS(dense_e)" } } } } adapt_info <- vector("list", 4) idx_samples <- (n_iter_warmup + 1):(n_iter_warmup + n_iter_sample) for (i in seq_along(samples)) { m <- colMeans(samples[[i]][idx_samples, , drop = FALSE]) rownames(samples[[i]]) <- seq_rows(samples[[i]]) attr(samples[[i]], "sampler_params") <- diagnostics[[i]][rstan_diagn_order] rownames(attr(samples[[i]], "sampler_params")) <- seq_rows(diagnostics[[i]]) # reformat back to text if (length(csfit$inv_metric)) { if (is_equal(sampler_t, "NUTS(dense_e)")) { mmatrix_txt <- "\n# Elements of inverse mass matrix:\n# " mmat <- paste0(apply(csfit$inv_metric[[i]], 1, paste0, collapse = ", "), collapse = "\n# ") } else { mmatrix_txt <- "\n# Diagonal elements of inverse mass matrix:\n# " mmat <- paste0(csfit$inv_metric[[i]], collapse = ", ") } adapt_info[[i]] <- paste0("# Step size = ", csfit$step_size[[i]], mmatrix_txt, mmat, "\n# ") attr(samples[[i]], "adaptation_info") <- adapt_info[[i]] } else { attr(samples[[i]], "adaptation_info") <- character(0) } attr(samples[[i]], "args") <- list(sampler_t = sampler_t, chain_id = i) if (NROW(csfit$metadata$time)) { time_i <- as.double(csfit$metadata$time[i, c("warmup", "sampling")]) names(time_i) <- c("warmup", "sample") attr(samples[[i]], "elapsed_time") <- time_i } attr(samples[[i]], "mean_pars") <- m[-length(m)] attr(samples[[i]], "mean_lp__") <- m["lp__"] } perm_lst <- lapply(seq_len(n_chains), function(id) sample.int(n_iter_sample)) # @sim sim <- list( samples = samples, iter = csfit$metadata$iter_sampling + csfit$metadata$iter_warmup, thin = csfit$metadata$thin, warmup = csfit$metadata$iter_warmup, chains = n_chains, n_save = rep(n_iter_sample + n_iter_warmup, n_chains), warmup2 = rep(n_iter_warmup, n_chains), permutation = perm_lst, pars_oi = model_pars, dims_oi = par_dims, fnames_oi = fnames_oi, n_flatnames = length(fnames_oi) ) # @stan_args sargs <- list( stan_version_major = as.character(csfit$metadata$stan_version_major), stan_version_minor = as.character(csfit$metadata$stan_version_minor), stan_version_patch = as.character(csfit$metadata$stan_version_patch), model = csfit$metadata$model_name, start_datetime = gsub(" ", "", csfit$metadata$start_datetime), method = csfit$metadata$method, iter = csfit$metadata$iter_sampling + csfit$metadata$iter_warmup, warmup = csfit$metadata$iter_warmup, save_warmup = csfit$metadata$save_warmup, thin = csfit$metadata$thin, engaged = as.character(csfit$metadata$adapt_engaged), gamma = csfit$metadata$gamma, delta = csfit$metadata$adapt_delta, kappa = csfit$metadata$kappa, t0 = csfit$metadata$t0, init_buffer = as.character(csfit$metadata$init_buffer), term_buffer = as.character(csfit$metadata$term_buffer), window = as.character(csfit$metadata$window), algorithm = csfit$metadata$algorithm, engine = csfit$metadata$engine, max_depth = csfit$metadata$max_treedepth, metric = csfit$metadata$metric, metric_file = character(0), # not stored in metadata stepsize = NA, # add in loop stepsize_jitter = csfit$metadata$stepsize_jitter, num_chains = as.character(csfit$metadata$num_chains), chain_id = NA, # add in loop file = character(0), # not stored in metadata init = NA, # add in loop seed = as.character(csfit$metadata$seed), file = NA, # add in loop diagnostic_file = character(0), # not stored in metadata refresh = as.character(csfit$metadata$refresh), sig_figs = as.character(csfit$metadata$sig_figs), profile_file = csfit$metadata$profile_file, num_threads = as.character(csfit$metadata$threads_per_chain), stanc_version = gsub(" ", "", csfit$metadata$stanc_version), stancflags = character(0), # not stored in metadata adaptation_info = NA, # add in loop has_time = is.numeric(csfit$metadata$time$total), time_info = NA, # add in loop sampler_t = sampler_t, # rstan looks in @stan_args$control for some metadata control = list( adapt_delta = csfit$metadata$adapt_delta, max_treedepth = csfit$metadata$max_treedepth ) ) sargs_rep <- replicate(n_chains, sargs, simplify = FALSE) for (i in seq_along(sargs_rep)) { sargs_rep[[i]]$chain_id <- i sargs_rep[[i]]$stepsize <- csfit$metadata$step_size[i] sargs_rep[[i]]$init <- as.character(csfit$metadata$init[i]) # two 'file' elements: select the second file_idx <- which(names(sargs_rep[[i]]) == "file") sargs_rep[[i]][[file_idx[2]]] <- files[[i]] sargs_rep[[i]]$adaptation_info <- adapt_info[[i]] if (NROW(csfit$metadata$time)) { sargs_rep[[i]]$time_info <- paste0( c("# Elapsed Time: ", "# ", "# ", "# "), c(csfit$metadata$time[i, c("warmup", "sampling", "total")], ""), c(" seconds (Warm-up)", " seconds (Sampling)", " seconds (Total)", "") ) } } # @stanmodel cxxdso_class <- "cxxdso" attr(cxxdso_class, "package") <- "rstan" null_dso <- new( cxxdso_class, sig = list(character(0)), dso_saved = FALSE, dso_filename = character(0), modulename = character(0), system = R.version$system, cxxflags = character(0), .CXXDSOMISC = new.env(parent = emptyenv()) ) null_sm <- new( "stanmodel", model_name = model_name, model_code = character(0), model_cpp = list(), dso = null_dso ) # @date sdate <- do.call(max, lapply(files, function(csv) file.info(csv)$mtime)) sdate <- format(sdate, "%a %b %d %X %Y") out <- new( "stanfit", model_name = model_name, model_pars = model_pars, par_dims = par_dims, mode = mode, sim = sim, inits = list(), stan_args = sargs_rep, stanmodel = null_sm, date = sdate, # not the time of sampling .MISC = new.env(parent = emptyenv()) ) attributes(out)$metadata <- csfit attributes(out)$CmdStanModel <- model out } brms/R/predictor.R0000644000176200001440000004175015053305627013551 0ustar liggesusers# compute predictor terms predictor <- function(prep, ...) { UseMethod("predictor") } # compute linear/additive predictor terms # @param prep a list generated by prepare_predictions containing # all required data and posterior draws # @param i An optional vector indicating the observation(s) # for which to compute eta. If NULL, eta is computed # for all all observations at once. # @param fprep Optional full brmsprep object of the model. # Currently only needed in non-linear models or for # predicting new data in models with autocorrelation. # @return Usually an S x N matrix where S is the number of draws # and N is the number of observations or length of i if specified. #' @export predictor.bprepl <- function(prep, i = NULL, fprep = NULL, ...) { nobs <- ifelse(!is.null(i), length(i), prep$nobs) eta <- matrix(0, nrow = prep$ndraws, ncol = nobs) + predictor_fe(prep, i) + predictor_re(prep, i) + predictor_sp(prep, i) + predictor_sm(prep, i) + predictor_gp(prep, i) + predictor_offset(prep, i, nobs) # some autocorrelation structures depend on eta eta <- predictor_ac(eta, prep, i, fprep = fprep) # intentionally last as it may return 3D arrays eta <- predictor_cs(eta, prep, i) unname(eta) } # compute non-linear predictor terms # @param prep a list generated by prepare_predictions containing # all required data and posterior draws # @param i An optional vector indicating the observation(s) # for which to compute eta. If NULL, eta is computed # for all all observations at once. # @param ... further arguments passed to predictor.bprepl # @return Usually an S x N matrix where S is the number of draws # and N is the number of observations or length of i if specified. #' @export predictor.bprepnl <- function(prep, i = NULL, fprep = NULL, ...) { # TODO: add the brms namespace to the search path of the eval calls below stopifnot(!is.null(fprep)) nlpars <- prep$used_nlpars covars <- names(prep$C) args <- named_list(c(nlpars, covars)) for (nlp in nlpars) { args[[nlp]] <- get_nlpar(fprep, nlpar = nlp, i = i, ...) } for (cov in covars) { args[[cov]] <- p(prep$C[[cov]], i, row = FALSE) } dim_eta <- dim(rmNULL(args)[[1]]) # evaluate non-linear predictor if (!prep$loop) { # cannot reasonably vectorize over posterior draws # when 'nlform' must be evaluated jointly across observations # and hence 'loop' had been set to FALSE for (i in seq_along(args)) { old_dim <- dim(args[[i]]) args[[i]] <- split(args[[i]], slice.index(args[[i]], 1)) if (length(old_dim) > 2L) { # split drops array dimensions which need to be restored args[[i]] <- lapply(args[[i]], "dim<-", old_dim[-1]) } } .fun <- function(...) { eval(prep$nlform, list(...), enclos = prep$env) } eta <- try( t(do_call(mapply, c(list(FUN = .fun, SIMPLIFY = "array"), args))), silent = TRUE ) } else { # assumes fully vectorized version of 'nlform' eta <- try( eval(prep$nlform, args, enclos = prep$env), silent = TRUE ) } if (is_try_error(eta)) { if (grepl("could not find function", eta)) { eta <- rename(eta, "Error in eval(expr, envir, enclos) : ", "") vectorize <- str_if(prep$loop, ", vectorize = TRUE") message( eta, " Most likely this is because you used a Stan ", "function in the non-linear model formula that ", "is not defined in R. If this is a user-defined function, ", "please run 'expose_functions(.", vectorize, ")' ", "on your fitted model and try again." ) } else { eta <- rename(eta, "^Error :", "", fixed = FALSE) stop2(eta) } } dim(eta) <- dim_eta unname(eta) } # compute eta for overall effects predictor_fe <- function(prep, i) { fe <- prep[["fe"]] if (!isTRUE(ncol(fe[["X"]]) > 0)) { return(0) } eta <- try(.predictor_fe(X = p(fe[["X"]], i), b = fe[["b"]])) if (is_try_error(eta)) { stop2( "Something went wrong (see the error message above). ", "Perhaps you transformed numeric variables ", "to factors or vice versa within the model formula? ", "If yes, please convert your variables beforehand. ", "Or did you set a predictor variable to NA?" ) } eta } # workhorse function of predictor_fe # @param X fixed effects design matrix # @param b draws of fixed effects coeffients .predictor_fe <- function(X, b) { stopifnot(is.matrix(X)) stopifnot(is.matrix(b)) tcrossprod(b, X) } # compute eta for varying effects predictor_re <- function(prep, i) { eta <- 0 re <- prep[["re"]] group <- names(re[["r"]]) for (g in group) { eta_g <- try(.predictor_re(Z = p(re[["Z"]][[g]], i), r = re[["r"]][[g]])) if (is_try_error(eta_g)) { stop2( "Something went wrong (see the error message above). ", "Perhaps you transformed numeric variables ", "to factors or vice versa within the model formula? ", "If yes, please convert your variables beforehand. ", "Or did you use a grouping factor also for a different purpose? ", "If yes, please make sure that its factor levels are correct ", "also in the new data you may have provided." ) } eta <- eta + eta_g } eta } # workhorse function of predictor_re # @param Z sparse random effects design matrix # @param r random effects draws # @return linear predictor for random effects .predictor_re <- function(Z, r) { Matrix::as.matrix(Matrix::tcrossprod(r, Z)) } # compute eta for special effects terms predictor_sp <- function(prep, i) { eta <- 0 sp <- prep[["sp"]] if (!length(sp)) { return(eta) } eval_list <- list() for (j in seq_along(sp[["simo"]])) { eval_list[[paste0("Xmo_", j)]] <- p(sp[["Xmo"]][[j]], i) eval_list[[paste0("simo_", j)]] <- sp[["simo"]][[j]] } for (j in seq_along(sp[["Xme"]])) { eval_list[[paste0("Xme_", j)]] <- p(sp[["Xme"]][[j]], i, row = FALSE) } for (j in seq_along(sp[["Yl"]])) { eval_list[[names(sp[["Yl"]])[j]]] <- p(sp[["Yl"]][[j]], i, row = FALSE) } for (j in seq_along(sp[["idxl"]])) { eval_list[[names(sp[["idxl"]])[j]]] <- p(sp[["idxl"]][[j]], i, row = FALSE) } for (j in seq_along(sp[["Csp"]])) { eval_list[[paste0("Csp_", j)]] <- p(sp[["Csp"]][[j]], i, row = FALSE) } re <- prep[["re"]] coef <- colnames(sp[["bsp"]]) for (j in seq_along(coef)) { # prepare special group-level effects rsp <- named_list(names(re[["rsp"]][[coef[j]]])) for (g in names(rsp)) { rsp[[g]] <- .predictor_re( Z = p(re[["Zsp"]][[g]], i), r = re[["rsp"]][[coef[j]]][[g]] ) } eta <- eta + .predictor_sp( eval_list, call = sp[["calls"]][[j]], b = sp[["bsp"]][, j], r = Reduce("+", rsp) ) } eta } # workhorse function of predictor_sp # @param call expression for evaluation of special effects # @param eval_list list containing variables for 'call' # @param b special effects coefficients draws # @param r matrix with special effects group-level draws .predictor_sp <- function(eval_list, call, b, r = NULL) { b <- as.vector(b) if (is.null(r)) r <- 0 (b + r) * eval(call, eval_list) } # R implementation of the user defined Stan function 'mo' # @param simplex posterior draws of a simplex parameter vector # @param X variable modeled as monotonic .mo <- function(simplex, X) { stopifnot(is.matrix(simplex), is.atomic(X)) D <- NCOL(simplex) simplex <- cbind(0, simplex) for (i in seq_cols(simplex)[-1]) { # compute the cumulative representation of the simplex simplex[, i] <- simplex[, i] + simplex[, i - 1] } D * simplex[, X + 1] } # compute eta for smooth terms predictor_sm <- function(prep, i) { eta <- 0 if (!length(prep[["sm"]])) { return(eta) } fe <- prep[["sm"]]$fe if (length(fe)) { eta <- eta + .predictor_fe(X = p(fe$Xs, i), b = fe$bs) } re <- prep[["sm"]]$re for (k in seq_along(re)) { for (j in seq_along(re[[k]]$s)) { Zs <- p(re[[k]]$Zs[[j]], i) s <- re[[k]]$s[[j]] eta <- eta + .predictor_fe(X = Zs, b = s) } } eta } # compute eta for Gaussian processes predictor_gp <- function(prep, i) { if (!length(prep[["gp"]])) { return(0) } if (!is.null(i)) { stop2("Pointwise evaluation is not supported for Gaussian processes.") } eta <- matrix(0, nrow = prep$ndraws, ncol = prep$nobs) for (k in seq_along(prep[["gp"]])) { gp <- prep[["gp"]][[k]] if (isTRUE(attr(gp, "byfac"))) { # categorical 'by' variable for (j in seq_along(gp)) { if (length(gp[[j]][["Igp"]])) { eta[, gp[[j]][["Igp"]]] <- .predictor_gp(gp[[j]]) } } } else { eta <- eta + .predictor_gp(gp) } } eta } # workhorse function of predictor_gp # @param gp a list returned by '.prepare_predictions_gp' # @return A S x N matrix to be added to the linear predictor # @note does not work with pointwise evaluation .predictor_gp <- function(gp) { if (is.null(gp[["slambda"]])) { # predictions for exact GPs ndraws <- length(gp[["sdgp"]]) eta <- as.list(rep(NA, ndraws)) if (!is.null(gp[["x_new"]])) { for (i in seq_along(eta)) { eta[[i]] <- with(gp, .predictor_gp_new( x_new = x_new, yL = yL[i, ], x = x, sdgp = sdgp[i], lscale = lscale[i, ], cov = cov, nug = nug )) } } else { for (i in seq_along(eta)) { eta[[i]] <- with(gp, .predictor_gp_old( x = x, sdgp = sdgp[i], lscale = lscale[i, ], zgp = zgp[i, ], cov = cov, nug = nug )) } } eta <- do_call(rbind, eta) } else { # predictions for approximate GPs eta <- with(gp, .predictor_gpa( x = x, sdgp = sdgp, lscale = lscale, zgp = zgp, slambda = slambda, cov = cov )) } if (!is.null(gp[["Jgp"]])) { eta <- eta[, gp[["Jgp"]], drop = FALSE] } if (!is.null(gp[["Cgp"]])) { eta <- eta * data2draws(gp[["Cgp"]], dim = dim(eta)) } eta } # make exact GP predictions for old data points # vectorized over posterior draws # @param x old predictor values # @param sdgp sample of parameter sdgp # @param lscale sample of parameter lscale # @param zgp draws of parameter vector zgp # @param nug very small positive value to ensure numerical stability .predictor_gp_old <- function(x, sdgp, lscale, zgp, cov, nug) { Sigma <- cov_gp(x, sdgp = sdgp, lscale = lscale, cov = cov) lx <- nrow(x) Sigma <- Sigma + diag(rep(nug, lx), lx, lx) L_Sigma <- try_nug(t(chol(Sigma)), nug = nug) as.numeric(L_Sigma %*% zgp) } # make exact GP predictions for new data points # vectorized over posterior draws # @param x_new new predictor values # @param yL linear predictor of the old data # @param x old predictor values # @param sdgp sample of parameter sdgp # @param lscale sample of parameter lscale # @param nug very small positive value to ensure numerical stability .predictor_gp_new <- function(x_new, yL, x, sdgp, lscale, cov, nug) { Sigma <- cov_gp(x, sdgp = sdgp, lscale = lscale, cov = cov) lx <- nrow(x) lx_new <- nrow(x_new) Sigma <- Sigma + diag(rep(nug, lx), lx, lx) L_Sigma <- try_nug(t(chol(Sigma)), nug = nug) L_Sigma_inverse <- solve(L_Sigma) K_div_yL <- L_Sigma_inverse %*% yL K_div_yL <- t(t(K_div_yL) %*% L_Sigma_inverse) k_x_x_new <- cov_gp(x, x_new, sdgp = sdgp, lscale = lscale, cov = cov) mu_yL_new <- as.numeric(t(k_x_x_new) %*% K_div_yL) v_new <- L_Sigma_inverse %*% k_x_x_new cov_yL_new <- cov_gp(x_new, sdgp = sdgp, lscale = lscale, cov = cov) - t(v_new) %*% v_new + diag(rep(nug, lx_new), lx_new, lx_new) yL_new <- try_nug( rmulti_normal(1, mu = mu_yL_new, Sigma = cov_yL_new), nug = nug ) return(yL_new) } # make predictions for approximate GPs # vectorized over posterior draws # @param x matrix of evaluated eigenfunctions of the cov matrix # @param sdgp sample of parameter sdgp # @param lscale sample of parameter lscale # @param zgp draws of parameter vector zgp # @param slambda vector of eigenvalues of the cov matrix # @note no need to differentiate between old and new data points .predictor_gpa <- function(x, sdgp, lscale, zgp, slambda, cov) { spd <- sqrt(spd_gp(slambda, sdgp = sdgp, lscale = lscale, cov = cov)) (spd * zgp) %*% t(x) } # compute eta for category specific effects # @param predictor matrix of other additive terms # @return 3D predictor array in the presence of 'cs' effects # otherwise return 'eta' unchanged predictor_cs <- function(eta, prep, i) { cs <- prep[["cs"]] re <- prep[["re"]] if (!length(cs[["bcs"]]) && !length(re[["rcs"]])) { return(eta) } nthres <- cs[["nthres"]] rcs <- NULL if (!is.null(re[["rcs"]])) { groups <- names(re[["rcs"]]) rcs <- vector("list", nthres) for (k in seq_along(rcs)) { rcs[[k]] <- named_list(groups) for (g in groups) { rcs[[k]][[g]] <- .predictor_re( Z = p(re[["Zcs"]][[g]], i), r = re[["rcs"]][[g]][[k]] ) } rcs[[k]] <- Reduce("+", rcs[[k]]) } } .predictor_cs( eta, X = p(cs[["Xcs"]], i), b = cs[["bcs"]], nthres = nthres, r = rcs ) } # workhorse function of predictor_cs # @param X category specific design matrix # @param b category specific effects draws # @param nthres number of thresholds # @param eta linear predictor matrix # @param r list of draws of cs group-level effects # @return 3D predictor array including category specific effects .predictor_cs <- function(eta, X, b, nthres, r = NULL) { stopifnot(is.null(X) && is.null(b) || is.matrix(X) && is.matrix(b)) nthres <- max(nthres) eta <- predictor_expand(eta, nthres) if (!is.null(X)) { I <- seq(1, (nthres) * ncol(X), nthres) - 1 X <- t(X) } for (k in seq_len(nthres)) { if (!is.null(X)) { eta[, , k] <- eta[, , k] + b[, I + k, drop = FALSE] %*% X } if (!is.null(r[[k]])) { eta[, , k] <- eta[, , k] + r[[k]] } } eta } # expand dimension of the predictor matrix to a 3D array predictor_expand <- function(eta, nthres) { if (length(dim(eta)) == 2L) { eta <- array(eta, dim = c(dim(eta), nthres)) } eta } predictor_offset <- function(prep, i, nobs) { if (is.null(prep$offset)) { return(0) } eta <- rep(p(prep$offset, i), prep$ndraws) matrix(eta, ncol = nobs, byrow = TRUE) } # compute eta for autocorrelation structures # @note eta has to be passed to this function in # order for ARMA structures to work correctly predictor_ac <- function(eta, prep, i, fprep = NULL) { if (!is.null(prep$ac[["err"]])) { # auto-correlations via latent residuals eta <- eta + p(prep$ac$err, i, row = FALSE) } else if (has_ac_class(prep$ac$acframe, "arma")) { # ARMA correlations via explicit natural residuals if (!is.null(i)) { stop2("Pointwise evaluation is not possible for ARMA models.") } eta <- .predictor_arma( eta, ar = prep$ac$ar, ma = prep$ac$ma, Y = prep$ac$Y, J_lag = prep$ac$J_lag, fprep = fprep ) } if (has_ac_class(prep$ac$acframe, "car")) { eta <- eta + .predictor_re(Z = p(prep$ac$Zcar, i), r = prep$ac$rcar) } eta } # add ARMA effects to a predictor matrix # @param eta linear predictor matrix # @param ar optional autoregressive draws # @param ma optional moving average draws # @param Y vector of response values # @param J_lag autocorrelation lag for each observation # @return linear predictor matrix updated by ARMA effects .predictor_arma <- function(eta, ar = NULL, ma = NULL, Y = NULL, J_lag = NULL, fprep = NULL) { if (is.null(ar) && is.null(ma)) { return(eta) } if (anyNA(Y)) { # predicting Y will be necessary at some point stopifnot(is.brmsprep(fprep) || is.mvbrmsprep(fprep)) pp_fun <- paste0("posterior_predict_", fprep$family$fun) pp_fun <- get(pp_fun, asNamespace("brms")) } S <- nrow(eta) N <- length(Y) max_lag <- max(J_lag, 1) Kar <- ifelse(is.null(ar), 0, ncol(ar)) Kma <- ifelse(is.null(ma), 0, ncol(ma)) # relevant if time-series are shorter than the ARMA orders take_ar <- seq_len(min(Kar, max_lag)) take_ma <- seq_len(min(Kma, max_lag)) ar <- ar[, take_ar, drop = FALSE] ma <- ma[, take_ma, drop = FALSE] Err <- array(0, dim = c(S, max_lag, max_lag + 1)) err <- zero_mat <- matrix(0, nrow = S, ncol = max_lag) zero_vec <- rep(0, S) for (n in seq_len(N)) { if (Kma) { eta[, n] <- eta[, n] + rowSums(ma * Err[, take_ma, max_lag]) } eta_before_ar <- eta[, n] if (Kar) { eta[, n] <- eta[, n] + rowSums(ar * Err[, take_ar, max_lag]) } # AR terms need to be included in the predictions of y if missing # the prediction code thus differs from the structure of the Stan code y <- Y[n] if (is.na(y)) { # y was not observed and has to be predicted fprep$dpars$mu <- eta y <- pp_fun(n, fprep) } # errors in AR models need to be computed before adding AR terms err[, max_lag] <- y - eta_before_ar if (J_lag[n] > 0) { # store residuals of former observations I <- seq_len(J_lag[n]) Err[, I, max_lag + 1] <- err[, max_lag + 1 - I] } # keep the size of 'err' and 'Err' as small as possible Err <- abind(Err[, , -1, drop = FALSE], zero_mat) err <- cbind(err[, -1, drop = FALSE], zero_vec) } eta } brms/R/bridgesampling.R0000644000176200001440000002160114527413457014544 0ustar liggesusers#' Log Marginal Likelihood via Bridge Sampling #' #' Computes log marginal likelihood via bridge sampling, #' which can be used in the computation of bayes factors #' and posterior model probabilities. #' The \code{brmsfit} method is just a thin wrapper around #' the corresponding method for \code{stanfit} objects. #' #' @aliases bridge_sampler #' #' @param samples A \code{brmsfit} object. #' @param recompile Logical, indicating whether the Stan model should be #' recompiled. This may be necessary if you are running bridge sampling on #' another machine than the one used to fit the model. No recompilation #' is done by default. #' @param ... Additional arguments passed to #' \code{\link[bridgesampling:bridge_sampler]{bridge_sampler.stanfit}}. #' #' @details Computing the marginal likelihood requires samples of all variables #' defined in Stan's \code{parameters} block to be saved. Otherwise #' \code{bridge_sampler} cannot be computed. Thus, please set \code{save_pars #' = save_pars(all = TRUE)} in the call to \code{brm}, if you are planning to #' apply \code{bridge_sampler} to your models. #' #' The computation of marginal likelihoods based on bridge sampling requires #' a lot more posterior draws than usual. A good conservative #' rule of thump is perhaps 10-fold more draws (read: the default of 4000 #' draws may not be enough in many cases). If not enough posterior #' draws are provided, the bridge sampling algorithm tends to be #' unstable leading to considerably different results each time it is run. #' We thus recommend running \code{bridge_sampler} #' multiple times to check the stability of the results. #' #' More details are provided under #' \code{\link[bridgesampling:bridge_sampler]{bridgesampling::bridge_sampler}}. #' #' @seealso \code{ #' \link[brms:bayes_factor.brmsfit]{bayes_factor}, #' \link[brms:post_prob.brmsfit]{post_prob} #' } #' #' @examples #' \dontrun{ #' # model with the treatment effect #' fit1 <- brm( #' count ~ zAge + zBase + Trt, #' data = epilepsy, family = negbinomial(), #' prior = prior(normal(0, 1), class = b), #' save_pars = save_pars(all = TRUE) #' ) #' summary(fit1) #' bridge_sampler(fit1) #' #' # model without the treatment effect #' fit2 <- brm( #' count ~ zAge + zBase, #' data = epilepsy, family = negbinomial(), #' prior = prior(normal(0, 1), class = b), #' save_pars = save_pars(all = TRUE) #' ) #' summary(fit2) #' bridge_sampler(fit2) #' } #' #' @method bridge_sampler brmsfit #' @importFrom bridgesampling bridge_sampler #' @export bridge_sampler #' @export bridge_sampler.brmsfit <- function(samples, recompile = FALSE, ...) { out <- get_criterion(samples, "marglik") if (inherits(out, "bridge") && !is.na(out$logml)) { # return precomputed criterion return(out) } samples <- restructure(samples) if (samples$version$brms <= "1.8.0") { stop2( "Models fitted with brms 1.8.0 or lower are not ", "usable in method 'bridge_sampler'." ) } if (!is_normalized(samples$model)) { stop2( "The Stan model has to be normalized to be ", "usable in method 'bridge_sampler'." ) } # otherwise bridge_sampler may fail in a new R session or on another machine samples <- update_misc_env(samples, recompile = recompile) out <- try(bridge_sampler(samples$fit, ...)) if (is_try_error(out)) { stop2( "Bridgesampling failed. Perhaps you did not set ", "'save_pars = save_pars(all = TRUE)' when fitting your model? ", "If you are running bridge sampling on another machine than the one ", "used to fit the model, you may need to set recompile = TRUE." ) } out } #' Bayes Factors from Marginal Likelihoods #' #' Compute Bayes factors from marginal likelihoods. #' #' @aliases bayes_factor #' #' @param x1 A \code{brmsfit} object #' @param x2 Another \code{brmsfit} object based on the same responses. #' @param log Report Bayes factors on the log-scale? #' @param ... Additional arguments passed to #' \code{\link[brms:bridge_sampler.brmsfit]{bridge_sampler}}. #' #' @details Computing the marginal likelihood requires samples #' of all variables defined in Stan's \code{parameters} block #' to be saved. Otherwise \code{bayes_factor} cannot be computed. #' Thus, please set \code{save_all_pars = TRUE} in the call to \code{brm}, #' if you are planning to apply \code{bayes_factor} to your models. #' #' The computation of Bayes factors based on bridge sampling requires #' a lot more posterior samples than usual. A good conservative #' rule of thumb is perhaps 10-fold more samples (read: the default of 4000 #' samples may not be enough in many cases). If not enough posterior #' samples are provided, the bridge sampling algorithm tends to be unstable, #' leading to considerably different results each time it is run. #' We thus recommend running \code{bayes_factor} #' multiple times to check the stability of the results. #' #' More details are provided under #' \code{\link[bridgesampling:bf]{bridgesampling::bayes_factor}}. #' #' @seealso \code{ #' \link[brms:bridge_sampler.brmsfit]{bridge_sampler}, #' \link[brms:post_prob.brmsfit]{post_prob} #' } #' #' @examples #' \dontrun{ #' # model with the treatment effect #' fit1 <- brm( #' count ~ zAge + zBase + Trt, #' data = epilepsy, family = negbinomial(), #' prior = prior(normal(0, 1), class = b), #' save_all_pars = TRUE #' ) #' summary(fit1) #' #' # model without the treatment effect #' fit2 <- brm( #' count ~ zAge + zBase, #' data = epilepsy, family = negbinomial(), #' prior = prior(normal(0, 1), class = b), #' save_all_pars = TRUE #' ) #' summary(fit2) #' #' # compute the bayes factor #' bayes_factor(fit1, fit2) #' } #' #' @method bayes_factor brmsfit #' @importFrom bridgesampling bayes_factor #' @export bayes_factor #' @export bayes_factor.brmsfit <- function(x1, x2, log = FALSE, ...) { model_name_1 <- deparse0(substitute(x1)) model_name_2 <- deparse0(substitute(x2)) match_response(list(x1, x2)) bridge1 <- bridge_sampler(x1, ...) bridge2 <- bridge_sampler(x2, ...) out <- bayes_factor(bridge1, bridge2, log = log) attr(out, "model_names") <- c(model_name_1, model_name_2) out } #' Posterior Model Probabilities from Marginal Likelihoods #' #' Compute posterior model probabilities from marginal likelihoods. #' The \code{brmsfit} method is just a thin wrapper around #' the corresponding method for \code{bridge} objects. #' #' @aliases post_prob #' #' @inheritParams loo.brmsfit #' @param prior_prob Numeric vector with prior model probabilities. #' If omitted, a uniform prior is used (i.e., all models are equally #' likely a priori). The default \code{NULL} corresponds to equal #' prior model weights. #' #' @details Computing the marginal likelihood requires samples #' of all variables defined in Stan's \code{parameters} block #' to be saved. Otherwise \code{post_prob} cannot be computed. #' Thus, please set \code{save_all_pars = TRUE} in the call to \code{brm}, #' if you are planning to apply \code{post_prob} to your models. #' #' The computation of model probabilities based on bridge sampling requires #' a lot more posterior samples than usual. A good conservative #' rule of thump is perhaps 10-fold more samples (read: the default of 4000 #' samples may not be enough in many cases). If not enough posterior #' samples are provided, the bridge sampling algorithm tends to be #' unstable leading to considerably different results each time it is run. #' We thus recommend running \code{post_prob} #' multiple times to check the stability of the results. #' #' More details are provided under #' \code{\link[bridgesampling:post_prob]{bridgesampling::post_prob}}. #' #' @seealso \code{ #' \link[brms:bridge_sampler.brmsfit]{bridge_sampler}, #' \link[brms:bayes_factor.brmsfit]{bayes_factor} #' } #' #' @examples #' \dontrun{ #' # model with the treatment effect #' fit1 <- brm( #' count ~ zAge + zBase + Trt, #' data = epilepsy, family = negbinomial(), #' prior = prior(normal(0, 1), class = b), #' save_all_pars = TRUE #' ) #' summary(fit1) #' #' # model without the treatent effect #' fit2 <- brm( #' count ~ zAge + zBase, #' data = epilepsy, family = negbinomial(), #' prior = prior(normal(0, 1), class = b), #' save_all_pars = TRUE #' ) #' summary(fit2) #' #' # compute the posterior model probabilities #' post_prob(fit1, fit2) #' #' # specify prior model probabilities #' post_prob(fit1, fit2, prior_prob = c(0.8, 0.2)) #' } #' #' @method post_prob brmsfit #' @importFrom bridgesampling post_prob #' @export post_prob #' @export post_prob.brmsfit <- function(x, ..., prior_prob = NULL, model_names = NULL) { args <- split_dots(x, ..., model_names = model_names) models <- args$models args$models <- NULL bs <- vector("list", length(models)) for (i in seq_along(models)) { bs[[i]] <- do_call(bridge_sampler, c(list(models[[i]]), args)) } model_names <- names(models) do_call(post_prob, c(bs, nlist(prior_prob, model_names))) } brms/R/loo_moment_match.R0000644000176200001440000002000615053072461015066 0ustar liggesusers#' Moment matching for efficient approximate leave-one-out cross-validation #' #' Moment matching for efficient approximate leave-one-out cross-validation #' (LOO-CV). See \code{\link[loo:loo_moment_match]{loo_moment_match}} #' for more details. #' #' @aliases loo_moment_match #' #' @inheritParams predict.brmsfit #' @param x An \R object of class \code{brmsfit} or \code{loo} depending #' on the method. #' @param loo An \R object of class \code{loo}. If \code{NULL}, #' brms will try to extract a precomputed \code{loo} object #' from the fitted model, added there via \code{\link{add_criterion}}. #' @param fit An \R object of class \code{brmsfit}. #' @param k_threshold The Pareto \eqn{k} threshold for which observations #' moment matching is applied. Defaults to \code{0.7}. #' See \code{\link[loo:pareto-k-diagnostic]{pareto_k_ids}} #' for more details. #' @param check Logical; If \code{TRUE} (the default), some checks #' check are performed if the \code{loo} object was generated #' from the \code{brmsfit} object passed to argument \code{fit}. #' @param recompile Logical, indicating whether the Stan model should be #' recompiled. This may be necessary if you are running moment matching on #' another machine than the one used to fit the model. No recompilation #' is done by default. #' @param ... Further arguments passed to the underlying methods. #' Additional arguments initially passed to \code{\link{loo}}, #' for example, \code{newdata} or \code{resp} need to be passed #' again to \code{loo_moment_match} in order for the latter #' to work correctly. #' @return An updated object of class \code{loo}. #' #' @details The moment matching algorithm requires draws of all variables #' defined in Stan's \code{parameters} block to be saved. Otherwise #' \code{loo_moment_match} cannot be computed. Thus, please set #' \code{save_pars = save_pars(all = TRUE)} in the call to \code{\link{brm}}, #' if you are planning to apply \code{loo_moment_match} to your models. #' #' @references #' Paananen, T., Piironen, J., Buerkner, P.-C., Vehtari, A. (2021). #' Implicitly Adaptive Importance Sampling. Statistics and Computing. #' #' @examples #' \dontrun{ #' fit1 <- brm(count ~ zAge + zBase * Trt + (1|patient), #' data = epilepsy, family = poisson(), #' save_pars = save_pars(all = TRUE)) #' #' # throws warning about some pareto k estimates being too high #' (loo1 <- loo(fit1)) #' #' # no more warnings after moment matching #' (mmloo1 <- loo_moment_match(fit1, loo = loo1)) #' } #' #' @importFrom loo loo_moment_match #' @export loo_moment_match #' @export loo_moment_match.brmsfit <- function(x, loo = NULL, k_threshold = 0.7, newdata = NULL, resp = NULL, check = TRUE, recompile = FALSE, ...) { stopifnot(is.brmsfit(x)) loo <- loo %||% x$criteria[["loo"]] if (is.null(loo)) { stop2("No 'loo' object was provided and none is stored within the model.") } else if (!is.loo(loo)) { stop2("Inputs to the 'loo' argument must be of class 'loo'.") } if (is.null(newdata)) { newdata <- model.frame(x) } else { newdata <- as.data.frame(newdata) } check <- as_one_logical(check) if (check) { yhash_loo <- attr(loo, "yhash") yhash_fit <- hash_response(x, newdata = newdata) if (!is_equal(yhash_loo, yhash_fit)) { stop2( "Response values used in 'loo' and 'x' do not match. ", "If this is a false positive, please set 'check' to FALSE." ) } } # otherwise loo_moment_match may fail in a new R session or on another machine x <- update_misc_env(x, recompile = recompile) out <- try(loo::loo_moment_match.default( x, loo = loo, post_draws = as.matrix, log_lik_i = .log_lik_i, unconstrain_pars = .unconstrain_pars, log_prob_upars = .log_prob_upars, log_lik_i_upars = .log_lik_i_upars, k_threshold = k_threshold, newdata = newdata, resp = resp, ... )) if (is_try_error(out)) { stop2( "Moment matching failed. Perhaps you did not set ", "'save_pars = save_pars(all = TRUE)' when fitting your model? ", "If you are running moment matching on another machine than the one ", "used to fit the model, you may need to set recompile = TRUE." ) } out } #' @rdname loo_moment_match.brmsfit #' @export loo_moment_match.loo <- function(x, fit, ...) { loo_moment_match(fit, loo = x, ...) } # compute a vector of log-likelihood values for the ith observation .log_lik_i <- function(x, i, newdata, ...) { as.vector(log_lik(x, newdata = newdata[i, , drop = FALSE], ...)) } # transform parameters to the unconstrained space .unconstrain_pars <- function(x, pars, ...) { unconstrain_pars_stanfit(x$fit, pars = pars, ...) } # compute log_prob for each posterior draws on the unconstrained space .log_prob_upars <- function(x, upars, ...) { x <- update_misc_env(x, only_windows = TRUE) log_prob_upars_stanfit(x$fit, upars = upars, ...) } # transform parameters to the constraint space .update_pars <- function(x, upars, ...) { # list with one element per posterior draw pars <- apply(upars, 1, .constrain_pars, x = x) # select required parameters only pars <- lapply(pars, "[", x$fit@sim$pars_oi_old) # transform draws ndraws <- length(pars) pars <- unlist(pars) npars <- length(pars) / ndraws dim(pars) <- c(npars, ndraws) # add dummy 'lp__' draws pars <- rbind(pars, rep(0, ndraws)) # bring draws into the right structure new_draws <- named_list(x$fit@sim$fnames_oi_old, list(numeric(ndraws))) if (length(new_draws) != nrow(pars)) { stop2("Updating parameters in `loo_moment_match.brmsfit' failed. ", "Please report a bug at https://github.com/paul-buerkner/brms.") } for (i in seq_len(npars)) { new_draws[[i]] <- pars[i, ] } # create new sim object to overwrite x$fit@sim x$fit@sim <- list( samples = list(new_draws), iter = ndraws, thin = 1, warmup = 0, chains = 1, n_save = ndraws, warmup2 = 0, permutation = list(seq_len(ndraws)), pars_oi = x$fit@sim$pars_oi_old, dims_oi = x$fit@sim$dims_oi_old, fnames_oi = x$fit@sim$fnames_oi_old, n_flatnames = length(x$fit@sim$fnames_oi_old) ) x$fit@stan_args <- list( list(chain_id = 1, iter = ndraws, thin = 1, warmup = 0) ) rename_pars(x) } # wrapper around rstan::constrain_pars # ensures that the right posterior draws are excluded .constrain_pars <- function(upars, x) { out <- rstan::constrain_pars(upars, object = x$fit) out[x$exclude] <- NULL out } # compute log_lik values based on the unconstrained parameters .log_lik_i_upars <- function(x, upars, i, ndraws = NULL, draw_ids = NULL, ...) { # do not pass draw_ids or ndraws further to avoid subsetting twice x <- update_misc_env(x, only_windows = TRUE) x <- .update_pars(x, upars = upars, ...) .log_lik_i(x, i = i, ...) } # -------- will be imported from rstan at some point ------- # transform parameters to the unconstraint space unconstrain_pars_stanfit <- function(x, pars, ...) { skeleton <- .create_skeleton(x@sim$pars_oi, x@par_dims[x@sim$pars_oi]) upars <- apply(pars, 1, FUN = function(theta) { rstan::unconstrain_pars(x, pars = .rstan_relist(theta, skeleton)) }) # for one parameter models if (is.null(dim(upars))) { dim(upars) <- c(1, length(upars)) } t(upars) } # compute log_prob for each posterior draws on the unconstrained space log_prob_upars_stanfit <- function(x, upars, ...) { apply(upars, 1, rstan::log_prob, object = x, adjust_transform = TRUE, gradient = FALSE) } # create a named list of draws for use with rstan methods .rstan_relist <- function (x, skeleton) { out <- utils::relist(x, skeleton) for (i in seq_along(skeleton)) { dim(out[[i]]) <- dim(skeleton[[i]]) } out } # rstan helper function to get dims of parameters right .create_skeleton <- function (pars, dims) { out <- lapply(seq_along(pars), function(i) { len_dims <- length(dims[[i]]) if (len_dims < 1) return(0) return(array(0, dim = dims[[i]])) }) names(out) <- pars out } brms/R/emmeans.R0000644000176200001440000002107714527413457013211 0ustar liggesusers#' Support Functions for \pkg{emmeans} #' #' Functions required for compatibility of \pkg{brms} with \pkg{emmeans}. #' Users are not required to call these functions themselves. Instead, #' they will be called automatically by the \code{emmeans} function #' of the \pkg{emmeans} package. #' #' @name emmeans-brms-helpers #' #' @inheritParams posterior_epred.brmsfit #' @param re_formula Optional formula containing group-level effects to be #' considered in the prediction. If \code{NULL}, include all group-level #' effects; if \code{NA} (default), include no group-level effects. #' @param epred Logical. If \code{TRUE} compute predictions of #' the posterior predictive distribution's mean #' (see \code{\link{posterior_epred.brmsfit}}) while ignoring #' arguments \code{dpar} and \code{nlpar}. Defaults to \code{FALSE}. #' If you have specified a response transformation within the formula, #' you need to set \code{epred} to \code{TRUE} for \pkg{emmeans} to #' detect this transformation. #' @param data,trms,xlev,grid,vcov. Arguments required by \pkg{emmeans}. #' @param ... Additional arguments passed to \pkg{emmeans}. #' #' @details #' In order to ensure compatibility of most \pkg{brms} models with #' \pkg{emmeans}, predictions are not generated 'manually' via a design matrix #' and coefficient vector, but rather via \code{\link{posterior_linpred.brmsfit}}. #' This appears to generally work well, but note that it produces an `.@linfct` #' slot that contains the computed predictions as columns instead of the #' coefficients. #' #' @examples #' \dontrun{ #' fit1 <- brm(time | cens(censored) ~ age * sex + disease + (1|patient), #' data = kidney, family = lognormal()) #' summary(fit1) #' #' # summarize via 'emmeans' #' library(emmeans) #' rg <- ref_grid(fit1) #' em <- emmeans(rg, "disease") #' summary(em, point.est = mean) #' #' # obtain estimates for the posterior predictive distribution's mean #' epred <- emmeans(fit1, "disease", epred = TRUE) #' summary(epred, point.est = mean) #' #' #' # model with transformed response variable #' fit2 <- brm(log(mpg) ~ factor(cyl), data = mtcars) #' summary(fit2) #' #' # results will be on the log scale by default #' emmeans(fit2, ~ cyl) #' # log transform is detected and can be adjusted automatically #' emmeans(fit2, ~ cyl, epred = TRUE, type = "response") #' } NULL # recover the variables used in the model predictions # @param data only added to prevent it from being passed further via ... #' @rdname emmeans-brms-helpers recover_data.brmsfit <- function(object, data, resp = NULL, dpar = NULL, nlpar = NULL, re_formula = NA, epred = FALSE, ...) { bterms <- .extract_par_terms( object, resp = resp, dpar = dpar, nlpar = nlpar, re_formula = re_formula, epred = epred ) data <- rm_attr(object$data, "terms") # use of model.frame fixes issue #1531 mf <- model.frame(bterms$allvars, data = data) trms <- attr(mf, "terms") # brms has no call component so the call is just a dummy for the most part cl <- call("brms") if (epred) { # fixes issue #1360 for in-formula response transformations cl$formula <- bterms$respform } emmeans::recover_data(cl, trms, "na.omit", data = data, ...) } # Calculate the basis for making predictions. In some sense, this is # similar to the fitted() function with new data on the link scale. # Transforming to response scale, if desired, is handled by emmeans. #' @rdname emmeans-brms-helpers emm_basis.brmsfit <- function(object, trms, xlev, grid, vcov., resp = NULL, dpar = NULL, nlpar = NULL, re_formula = NA, epred = FALSE, ...) { if (is_equal(dpar, "mean")) { # deprecated as of version 2.15.9 warning2("dpar = 'mean' is deprecated. Please use epred = TRUE instead.") epred <- TRUE dpar <- NULL } epred <- as_one_logical(epred) bterms <- .extract_par_terms( object, resp = resp, dpar = dpar, nlpar = nlpar, re_formula = re_formula, epred = epred ) if (epred) { post.beta <- posterior_epred( object, newdata = grid, re_formula = re_formula, resp = resp, incl_autocor = FALSE, ... ) } else { req_vars <- all_vars(bterms$allvars) post.beta <- posterior_linpred( object, newdata = grid, re_formula = re_formula, resp = resp, dpar = dpar, nlpar = nlpar, incl_autocor = FALSE, req_vars = req_vars, # offsets are handled by emmeans (#1096) transform = FALSE, offset = FALSE, ... ) } if (anyNA(post.beta)) { stop2("emm_basis.brmsfit created NAs. Please check your reference grid.") } misc <- bterms$.misc if (length(dim(post.beta)) == 3L) { # reshape to a 2D matrix, for example, in multivariate models ynames <- dimnames(post.beta)[[3]] if (is.null(ynames)) { ynames <- as.character(seq_len(dim(post.beta)[3])) } dims <- dim(post.beta) post.beta <- matrix(post.beta, ncol = prod(dims[2:3])) misc$ylevs = list(rep.meas = ynames) } attr(post.beta, "n.chains") <- object$fit@sim$chains X <- diag(ncol(post.beta)) bhat <- apply(post.beta, 2, mean) V <- cov(post.beta) nbasis <- matrix(NA) dfargs <- list() dffun <- function(k, dfargs) Inf environment(dffun) <- baseenv() nlist(X, bhat, nbasis, V, dffun, dfargs, misc, post.beta) } # extract terms of specific predicted parameter(s) in the model # currently, the only slots that matter in the returned object are # allvars: formula with all required variables on the right-hand side # .misc: a named list with additional info to be interpreted by emmeans .extract_par_terms <- function(x, ...) { UseMethod(".extract_par_terms") } #' @export .extract_par_terms.brmsfit <- function(x, resp = NULL, re_formula = NA, dpar = NULL, epred = FALSE, ...) { if (is_equal(dpar, "mean")) { # deprecation warning already provided in emm_basis.brmsfit epred <- TRUE dpar <- NULL } resp <- validate_resp(resp, x) new_formula <- update_re_terms(formula(x), re_formula) # autocorrelation terms are always excluded for emmeans predictions (#1424) new_formula <- exclude_terms(new_formula, incl_autocor = FALSE) bterms <- brmsterms(new_formula, resp_rhs_all = FALSE) if (is_ordinal(bterms)) { warning2("brms' emmeans support for ordinal models is experimental ", "and currently ignores the threshold parameters.") } .extract_par_terms(bterms, resp = resp, dpar = dpar, epred = epred, ...) } #' @export .extract_par_terms.mvbrmsterms <- function(x, resp, epred, ...) { stopifnot(is.character(resp)) epred <- as_one_logical(epred) out <- x # only use selected univariate models out$terms <- out$terms[resp] if (epred) { out$allvars <- allvars_formula(lapply(out$terms, get_allvars)) out$.misc <- list() return(out) } for (i in seq_along(out$terms)) { out$terms[[i]] <- .extract_par_terms(out$terms[[i]], epred = epred, ...) } out$allvars <- allvars_formula(lapply(out$terms, get_allvars)) misc_list <- unique(from_list(out$terms, ".misc")) if (length(misc_list) > 1L){ stop2("brms' emmeans support for multivariate models is limited ", "to cases where all univariate models have the same family.") } out$.misc <- misc_list[[1]] out } #' @export .extract_par_terms.brmsterms <- function(x, dpar, nlpar, epred, ...) { epred <- as_one_logical(epred) all_dpars <- names(x$dpars) all_nlpars <- names(x$nlpars) out <- x if (epred) { out$.misc <- list() return(out) } if (!is.null(nlpar)) { if (!is.null(dpar)) { stop2("'dpar' and 'nlpar' cannot be specified at the same time.") } nlpar <- as_one_character(nlpar) if (!nlpar %in% all_nlpars) { stop2( "Non-linear parameter '", nlpar, "' is not part of the model.", "\nSupported parameters are: ", collapse_comma(all_nlpars) ) } out <- x$nlpars[[nlpar]] } else if (!is.null(dpar)) { dpar <- as_one_character(dpar) if (!dpar %in% all_dpars) { stop2( "Distributional parameter '", dpar, "' is not part of the model.", "\nSupported parameters are: ", collapse_comma(all_dpars) ) } out <- x$dpars[[dpar]] } else { # extract 'mu' parameter by default if (!"mu" %in% names(x$dpars)) { # concerns categorical-like and mixture models stop2("emmeans is not yet supported for this brms model.") } out <- x$dpars[["mu"]] } if (!is.null(out$offset)) { # ensure that offsets are detected by emmeans (#1096) out$allvars <- allvars_formula(out$allvars, out$offset) } out$.misc <- emmeans::.std.link.labels(out$family, list()) out } brms/R/brms-package.R0000644000176200001440000000765514576305566014133 0ustar liggesusers#' Bayesian Regression Models using 'Stan' #' #' @name brms-package #' @aliases brms #' #' @description #' \if{html}{ #' \figure{stanlogo.png}{options: width="50" alt="https://mc-stan.org/about/logo/"} #' \emph{Stan Development Team} #' } #' #' The \pkg{brms} package provides an interface to fit Bayesian generalized #' multivariate (non-)linear multilevel models using \pkg{Stan}, which is a C++ #' package for obtaining full Bayesian inference (see #' \url{https://mc-stan.org/}). The formula syntax is an extended version of the #' syntax applied in the \pkg{lme4} package to provide a familiar and simple #' interface for performing regression analyses. #' #' @details #' The main function of \pkg{brms} is \code{\link{brm}}, which uses #' formula syntax to specify a wide range of complex Bayesian models #' (see \code{\link{brmsformula}} for details). Based on the supplied #' formulas, data, and additional information, it writes the Stan code #' on the fly via \code{\link[brms:stancode.default]{stancode}}, prepares the data via #' \code{\link[brms:standata.default]{standata}} and fits the model using #' \pkg{\link[rstan:rstan]{Stan}}. #' #' Subsequently, a large number of post-processing methods can be applied: #' To get an overview on the estimated parameters, #' \code{\link[brms:summary.brmsfit]{summary}} or #' \code{\link[brms:conditional_effects.brmsfit]{conditional_effects}} #' are perfectly suited. Detailed visual analyses can be performed by applying #' the \code{\link{pp_check}} and \code{\link{stanplot}} methods, which both #' rely on the \pkg{\link[bayesplot:bayesplot-package]{bayesplot}} package. #' Model comparisons can be done via \code{\link{loo}} and \code{\link{waic}}, #' which make use of the \pkg{\link[loo:loo-package]{loo}} package as well as #' via \code{\link{bayes_factor}} which relies on the \pkg{bridgesampling} package. #' For a full list of methods to apply, type \code{methods(class = "brmsfit")}. #' #' Because \pkg{brms} is based on \pkg{Stan}, a C++ compiler is required. The #' program Rtools (available on #' \url{https://cran.r-project.org/bin/windows/Rtools/}) comes with a C++ #' compiler for Windows. On Mac, you should use Xcode. For further instructions #' on how to get the compilers running, see the prerequisites section at the #' \href{https://github.com/stan-dev/rstan/wiki/RStan-Getting-Started}{RStan-Getting-Started} #' page. #' #' When comparing other packages fitting multilevel models to \pkg{brms}, keep #' in mind that the latter needs to compile models before actually fitting them, #' which will require between 20 and 40 seconds depending on your machine, #' operating system and overall model complexity. #' #' Thus, fitting smaller models may be relatively slow as compilation time makes #' up the majority of the whole running time. For larger / more complex #' models however, fitting my take several minutes or even hours, so that the #' compilation time won't make much of a difference for these models. #' #' See \code{vignette("brms_overview")} and \code{vignette("brms_multilevel")} #' for a general introduction and overview of \pkg{brms}. For a full list of #' available vignettes, type \code{vignette(package = "brms")}. #' #' @references #' Paul-Christian Buerkner (2017). brms: An R Package for Bayesian Multilevel #' Models Using Stan. \emph{Journal of Statistical Software}, 80(1), 1-28. #' \code{doi:10.18637/jss.v080.i01} #' #' Paul-Christian Buerkner (2018). Advanced Bayesian Multilevel Modeling #' with the R Package brms. \emph{The R Journal}. 10(1), 395–411. #' \code{doi:10.32614/RJ-2018-017} #' #' The Stan Development Team. \emph{Stan Modeling Language User's Guide and #' Reference Manual}. \url{https://mc-stan.org/users/documentation/}. #' #' Stan Development Team (2020). RStan: the R interface to Stan. R package #' version 2.21.2. \url{https://mc-stan.org/} #' #' @seealso #' \code{\link{brm}}, #' \code{\link{brmsformula}}, #' \code{\link{brmsfamily}}, #' \code{\link{brmsfit}} #' "_PACKAGE" brms/R/reloo.R0000644000176200001440000001567715057533545012715 0ustar liggesusers#' Compute exact cross-validation for problematic observations #' #' Compute exact cross-validation for problematic observations for which #' approximate leave-one-out cross-validation may return incorrect results. #' Models for problematic observations can be run in parallel using the #' \pkg{future} package. #' #' @inheritParams predict.brmsfit #' @param x An \R object of class \code{brmsfit} or \code{loo} depending #' on the method. #' @param loo An \R object of class \code{loo}. If \code{NULL}, #' brms will try to extract a precomputed \code{loo} object #' from the fitted model, added there via \code{\link{add_criterion}}. #' @param fit An \R object of class \code{brmsfit}. #' @param k_threshold The threshold at which Pareto \eqn{k} #' estimates are treated as problematic. Defaults to \code{0.7}. #' See \code{\link[loo:pareto-k-diagnostic]{pareto_k_ids}} #' for more details. #' @param check Logical; If \code{TRUE} (the default), some checks #' check are performed if the \code{loo} object was generated #' from the \code{brmsfit} object passed to argument \code{fit}. #' @param recompile Logical, indicating whether the Stan model should be #' recompiled. This may be necessary if you are running \code{reloo} on #' another machine than the one used to fit the model. #' @param future_args A list of further arguments passed to #' \code{\link[future:future]{future}} for additional control over parallel #' execution if activated. #' @param ... Further arguments passed to #' \code{\link{update.brmsfit}} and \code{\link{log_lik.brmsfit}}. #' #' @return An object of the class \code{loo}. #' #' @details #' Warnings about Pareto \eqn{k} estimates indicate observations #' for which the approximation to LOO is problematic (this is described in #' detail in Vehtari, Gelman, and Gabry (2017) and the #' \pkg{\link[loo:loo-package]{loo}} package documentation). #' If there are \eqn{J} observations with \eqn{k} estimates above #' \code{k_threshold}, then \code{reloo} will refit the original model #' \eqn{J} times, each time leaving out one of the \eqn{J} #' problematic observations. The pointwise contributions of these observations #' to the total ELPD are then computed directly and substituted for the #' previous estimates from these \eqn{J} observations that are stored in the #' original \code{loo} object. #' #' @template details-sample_new_levels_gaussian #' @template parallelization #' #' @seealso \code{\link{loo}}, \code{\link{kfold}} #' #' @examples #' \dontrun{ #' fit1 <- brm(count ~ zAge + zBase * Trt + (1|patient), #' data = epilepsy, family = poisson()) #' #' # throws warning about some pareto k estimates being too high #' (loo1 <- loo(fit1)) #' #' # no more warnings after reloo #' (reloo1 <- reloo(fit1, loo = loo1, chains = 1)) #' } #' #' @export reloo.brmsfit <- function(x, loo = NULL, k_threshold = 0.7, newdata = NULL, resp = NULL, check = TRUE, recompile = NULL, future_args = list(), ...) { stopifnot(is.brmsfit(x), is.list(future_args)) if (is.brmsfit_multiple(x)) { warn_brmsfit_multiple(x) class(x) <- "brmsfit" } loo <- loo %||% x$criteria[["loo"]] if (is.null(loo)) { stop2("No 'loo' object was provided and none is stored within the model.") } else if (!is.loo(loo)) { stop2("Inputs to the 'loo' argument must be of class 'loo'.") } if (is.null(newdata)) { mf <- model.frame(x) } else { mf <- as.data.frame(newdata) } mf <- rm_attr(mf, c("terms", "brmsframe")) if (NROW(mf) != NROW(loo$pointwise)) { stop2("Number of observations in 'loo' and 'x' do not match.") } check <- as_one_logical(check) if (check) { yhash_loo <- attr(loo, "yhash") yhash_fit <- hash_response(x, newdata = newdata) if (!is_equal(yhash_loo, yhash_fit)) { stop2( "Response values used in 'loo' and 'x' do not match. ", "If this is a false positive, please set 'check' to FALSE." ) } } if (is.null(loo$diagnostics$pareto_k)) { stop2("No Pareto k estimates found in the 'loo' object.") } obs <- loo::pareto_k_ids(loo, k_threshold) J <- length(obs) if (J == 0L) { message( "No problematic observations found. ", "Returning the original 'loo' object." ) return(loo) } # ensure that the model can be run in the current R session x <- recompile_model(x, recompile = recompile) # split dots for use in log_lik and update dots <- list(...) ll_arg_names <- arg_names("log_lik") ll_arg_names <- intersect(names(dots), ll_arg_names) ll_args <- dots[ll_arg_names] ll_args$allow_new_levels <- TRUE ll_args$sample_new_levels <- first_not_null(ll_args$sample_new_levels, "gaussian") ll_args$resp <- resp ll_args$combine <- TRUE # cores is used in both log_lik and update up_arg_names <- setdiff(names(dots), setdiff(ll_arg_names, "cores")) up_args <- dots[up_arg_names] up_args$object <- x up_args$refresh <- 0 .reloo <- function(j) { message( "\nFitting model ", j, " out of ", J, " (leaving out observation ", obs[j], ")" ) omitted <- obs[j] mf_omitted <- mf[-omitted, , drop = FALSE] up_args$newdata <- mf_omitted up_args$data2 <- subset_data2(x$data2, -omitted) fit_j <- SW(do_call(update, up_args)) ll_args$object <- fit_j ll_args$newdata <- mf[omitted, , drop = FALSE] ll_args$newdata2 <- subset_data2(x$data2, omitted) return(do_call(log_lik, ll_args)) } message( J, " problematic observation(s) found.", "\nThe model will be refit ", J, " times." ) # TODO: separate parallel and non-parallel code to enable better printing? future_args$X <- seq_len(J) future_args$FUN <- .reloo future_args$future.seed <- TRUE lls <- do_call("future_lapply", future_args, pkg = "future.apply") # most of the following code is taken from rstanarm:::reloo # compute elpd_{loo,j} for each of the held out observations elpd_loo <- ulapply(lls, log_mean_exp) # compute \hat{lpd}_j for each of the held out observations (using log-lik # matrix from full posterior, not the leave-one-out posteriors) mf_obs <- mf[obs, , drop = FALSE] data2_obs <- subset_data2(x$data2, obs) ll_x <- log_lik(x, newdata = mf_obs, newdata2 = data2_obs) hat_lpd <- apply(ll_x, 2, log_mean_exp) # compute effective number of parameters p_loo <- hat_lpd - elpd_loo # replace parts of the loo object with these computed quantities sel <- c("elpd_loo", "p_loo", "looic") loo$pointwise[obs, sel] <- cbind(elpd_loo, p_loo, -2 * elpd_loo) new_pw <- loo$pointwise[, sel, drop = FALSE] loo$estimates[, 1] <- colSums(new_pw) loo$estimates[, 2] <- sqrt(nrow(loo$pointwise) * apply(new_pw, 2, var)) # what should we do about pareto-k? for now setting them to 0 loo$diagnostics$pareto_k[obs] <- 0 loo } #' @rdname reloo.brmsfit #' @export reloo.loo <- function(x, fit, ...) { reloo(fit, loo = x, ...) } # the generic will eventually be moved to 'loo' #' @rdname reloo.brmsfit #' @export reloo <- function(x, ...) { UseMethod("reloo") } brms/R/brmsfit-helpers.R0000644000176200001440000010573015053072461014660 0ustar liggesuserscontains_draws <- function(x) { if (!(is.brmsfit(x) && length(x$fit@sim))) { stop2("The model does not contain posterior draws.") } invisible(TRUE) } is_mv <- function(x) { stopifnot(is.brmsfit(x)) is.mvbrmsformula(x$formula) } stopifnot_resp <- function(x, resp = NULL) { # TODO: merge into validate_resp? if (is_mv(x) && length(resp) != 1L) { stop2("Argument 'resp' must be a single variable name ", "when applying this method to a multivariate model.") } invisible(NULL) } # apply a link function # @param x an array of arbitrary dimension # @param link character string defining the link link <- function(x, link) { switch(link, identity = x, log = log(x), logm1 = logm1(x), log1p = log1p(x), inverse = 1 / x, sqrt = sqrt(x), "1/mu^2" = 1 / x^2, tan_half = tan(x / 2), logit = logit(x), probit = qnorm(x), cauchit = qcauchy(x), cloglog = cloglog(x), probit_approx = qnorm(x), softplus = log_expm1(x), squareplus = (x^2 - 1) / x, softit = softit(x), stop2("Link '", link, "' is not supported.") ) } # apply an inverse link function # @param x an array of arbitrary dimension # @param link a character string defining the link inv_link <- function(x, link) { switch(link, identity = x, log = exp(x), logm1 = expp1(x), log1p = expm1(x), inverse = 1 / x, sqrt = x^2, "1/mu^2" = 1 / sqrt(x), tan_half = 2 * atan(x), logit = inv_logit(x), probit = pnorm(x), cauchit = pcauchy(x), cloglog = inv_cloglog(x), probit_approx = pnorm(x), softplus = log1p_exp(x), squareplus = (x + sqrt(x^2 + 4)) / 2, softit = inv_softit(x), stop2("Link '", link, "' is not supported.") ) } # log CDF for unit interval link functions # @param x an array of arbitrary dimension # @param link a character string defining the link log_cdf <- function(x, link) { switch(link, logit = log_inv_logit(x), probit = pnorm(x, log.p = TRUE), cauchit = pcauchy(x, log.p = TRUE), cloglog = log1m_exp(-exp(x)), probit_approx = pnorm(x, log.p = TRUE), softit = log_inv_softit(x), stop2("Link '", link, "' is not supported.") ) } # log CCDF for unit interval link functions # @param x an array of arbitrary dimension # @param link a character string defining the link log_ccdf <- function(x, link) { switch(link, logit = log1m_inv_logit(x), probit = pnorm(x, log.p = TRUE, lower.tail = FALSE), cauchit = pcauchy(x, log.p = TRUE, lower.tail = FALSE), cloglog = -exp(x), probit_approx = pnorm(x, log.p = TRUE, lower.tail = FALSE), softit = log1m_inv_softit(x), stop2("Link '", link, "' is not supported.") ) } # validate integers indicating which draws to subset validate_draw_ids <- function(x, draw_ids = NULL, ndraws = NULL) { ndraws_total <- ndraws(x) if (is.null(draw_ids) && !is.null(ndraws)) { ndraws <- as_one_integer(ndraws) if (ndraws < 1 || ndraws > ndraws_total) { stop2("Argument 'ndraws' should be between 1 and ", "the maximum number of draws (", ndraws_total, ").") } draw_ids <- sample(seq_len(ndraws_total), ndraws) } if (!is.null(draw_ids)) { draw_ids <- as.integer(draw_ids) if (any(draw_ids < 1L) || any(draw_ids > ndraws_total)) { stop2("Some 'draw_ids' indices are out of range.") } } draw_ids } # get correlation names as combinations of variable names # @param names the variable names # @param type character string to be put in front of the returned strings # @param brackets should the correlation names contain brackets # or underscores as seperators? # @param sep character string to separate names; only used if !brackets # @return a vector of character strings get_cornames <- function(names, type = "cor", brackets = TRUE, sep = "__") { cornames <- NULL if (length(names) > 1) { for (i in seq_along(names)[-1]) { for (j in seq_len(i - 1)) { if (brackets) { c(cornames) <- paste0(type, "(", names[j], "," , names[i], ")") } else { c(cornames) <- paste0(type, sep, names[j], sep, names[i]) } } } } cornames } # extract names of categorical variables in the model get_cat_vars <- function(x) { stopifnot(is.brmsfit(x)) like_factor <- sapply(model.frame(x), is_like_factor) valid_groups <- c( names(model.frame(x))[like_factor], get_group_vars(x) ) unique(valid_groups[nzchar(valid_groups)]) } # covariance matrices based on correlation and SD draws # @param sd matrix of draws of standard deviations # @param cor matrix of draws of correlations get_cov_matrix <- function(sd, cor = NULL) { sd <- as.matrix(sd) stopifnot(all(sd >= 0)) ndraws <- nrow(sd) size <- ncol(sd) out <- array(diag(1, size), dim = c(size, size, ndraws)) out <- aperm(out, perm = c(3, 1, 2)) for (i in seq_len(size)) { out[, i, i] <- sd[, i]^2 } if (length(cor)) { cor <- as.matrix(cor) stopifnot(nrow(sd) == nrow(cor)) stopifnot(min(cor) >= -1, max(cor) <= 1) stopifnot(ncol(cor) == size * (size - 1) / 2) k <- 0 for (i in seq_len(size)[-1]) { for (j in seq_len(i - 1)) { k = k + 1 out[, j, i] <- out[, i, j] <- cor[, k] * sd[, i] * sd[, j] } } } out } # correlation matrices based on correlation draws # @param cor draws of correlations # @param size optional size of the desired correlation matrix; # ignored is 'cor' is specified # @param ndraws optional number of posterior draws; # ignored is 'cor' is specified get_cor_matrix <- function(cor, size = NULL, ndraws = NULL) { if (length(cor)) { cor <- as.matrix(cor) size <- -1 / 2 + sqrt(1 / 4 + 2 * ncol(cor)) + 1 ndraws <- nrow(cor) } size <- as_one_numeric(size) ndraws <- as_one_numeric(ndraws) stopifnot(is_wholenumber(size) && size > 0) stopifnot(is_wholenumber(ndraws) && ndraws > 0) out <- array(diag(1, size), dim = c(size, size, ndraws)) out <- aperm(out, perm = c(3, 1, 2)) if (length(cor)) { k <- 0 for (i in seq_len(size)[-1]) { for (j in seq_len(i - 1)) { k = k + 1 out[, j, i] <- out[, i, j] <- cor[, k] } } } out } # compute covariance matrices of autocor structures # @param prep a brmsprep object # @param obs observations for which to compute the covariance matrix # @param Jtime vector indicating to which time points obs belong # @param latent compute covariance matrix for latent residuals? get_cov_matrix_ac <- function(prep, obs = NULL, Jtime = NULL, latent = FALSE) { if (is.null(obs)) { obs <- seq_len(prep$nobs) } nobs <- length(obs) ndraws <- prep$ndraws acframe <- prep$ac$acframe # prepare correlations if (has_ac_class(acframe, "arma")) { ar <- as.numeric(prep$ac$ar) ma <- as.numeric(prep$ac$ma) if (length(ar) && !length(ma)) { cor <- get_cor_matrix_ar1(ar, nobs) } else if (!length(ar) && length(ma)) { cor <- get_cor_matrix_ma1(ma, nobs) } else if (length(ar) && length(ma)) { cor <- get_cor_matrix_arma1(ar, ma, nobs) } else { stop2("Neither 'ar' nor 'ma' were supplied. Please report a bug.") } } else if (has_ac_class(acframe, "cosy")) { cosy <- as.numeric(prep$ac$cosy) cor <- get_cor_matrix_cosy(cosy, nobs) } else if (has_ac_class(acframe, "unstr")) { cortime <- prep$ac$cortime cor <- get_cor_matrix_unstr(cortime, Jtime) } else if (has_ac_class(acframe, "fcor")) { cor <- get_cor_matrix_fcor(prep$ac$Mfcor, ndraws) } else { cor <- get_cor_matrix_ident(ndraws, nobs) } # prepare known standard errors if (!is.null(prep$data$se)) { se2 <- prep$data$se[obs]^2 se2 <- array(diag(se2, nobs), dim = c(nobs, nobs, ndraws)) se2 <- aperm(se2, perm = c(3, 1, 2)) # make sure not to add 'se' twice prep$data$se <- NULL } else { se2 <- rep(0, nobs) } # prepare residual standard deviations if (latent) { sigma2 <- as.numeric(prep$ac$sderr)^2 } else { sigma <- get_dpar(prep, "sigma", i = obs) if (NCOL(sigma) > 1L) { # sigma varies across observations sigma2 <- array(dim = c(ndraws, nobs, nobs)) for (s in seq_rows(sigma2)) { sigma2[s, , ] <- outer(sigma[s, ], sigma[s, ]) } } else { sigma2 <- as.numeric(sigma)^2 } } sigma2 * cor + se2 } # compute AR1 correlation matrices # @param ar AR1 autocorrelation draws # @param nobs number of rows of the covariance matrix # @return a numeric 'ndraws' x 'nobs' x 'nobs' array get_cor_matrix_ar1 <- function(ar, nobs) { out <- array(0, dim = c(NROW(ar), nobs, nobs)) fac <- 1 / (1 - ar^2) pow_ar <- as.list(rep(1, nobs + 1)) for (i in seq_len(nobs)) { pow_ar[[i + 1]] <- ar^i out[, i, i] <- fac for (j in seq_len(i - 1)) { out[, i, j] <- fac * pow_ar[[i - j + 1]] out[, j, i] <- out[, i, j] } } out } # compute MA1 correlation matrices # @param ma MA1 autocorrelation draws # @param nobs number of rows of the covariance matrix # @return a numeric 'ndraws' x 'nobs' x 'nobs' array get_cor_matrix_ma1 <- function(ma, nobs) { out <- array(0, dim = c(NROW(ma), nobs, nobs)) gamma0 <- 1 + ma^2 for (i in seq_len(nobs)) { out[, i, i] <- gamma0 if (i > 1) { out[, i, i - 1] <- ma } if (i < nobs) { out[, i, i + 1] <- ma } } out } # compute ARMA1 correlation matrices # @param ar AR1 autocorrelation draws # @param ma MA1 autocorrelation draws # @param nobs number of rows of the covariance matrix # @return a numeric 'ndraws' x 'nobs' x 'nobs' array get_cor_matrix_arma1 <- function(ar, ma, nobs) { out <- array(0, dim = c(NROW(ar), nobs, nobs)) fac <- 1 / (1 - ar^2) gamma0 <- 1 + ma^2 + 2 * ar * ma gamma <- as.list(rep(NA, nobs)) gamma[[1]] <- (1 + ar * ma) * (ar + ma) for (i in seq_len(nobs)) { out[, i, i] <- fac * gamma0 gamma[[i]] <- gamma[[1]] * ar^(i - 1) for (j in seq_len(i - 1)) { out[, i, j] <- fac * gamma[[i - j]] out[, j, i] <- out[, i, j] } } out } # compute compound symmetry correlation matrices # @param cosy compund symmetry correlation draws # @param nobs number of rows of the covariance matrix # @return a numeric 'ndraws' x 'nobs' x 'nobs' array get_cor_matrix_cosy <- function(cosy, nobs) { out <- array(0, dim = c(NROW(cosy), nobs, nobs)) for (i in seq_len(nobs)) { out[, i, i] <- 1 for (j in seq_len(i - 1)) { out[, i, j] <- cosy out[, j, i] <- out[, i, j] } } out } # compute unstructured time correlation matrices # @param cortime time correlation draws # @param Jtime indictor of rows/cols to consider in cortime # @return a numeric 'ndraws' x 'nobs' x 'nobs' array # where nobs = length(Jtime[Jtime > 0]) get_cor_matrix_unstr <- function(cortime, Jtime) { stopifnot(length(Jtime) > 0L) Jtime <- Jtime[Jtime > 0] get_cor_matrix(cortime)[, Jtime, Jtime, drop = FALSE] } # prepare a fixed correlation matrix # @param Mfcor correlation matrix to be prepared # @param ndraws number of posterior draws # @return a numeric 'ndraws' x 'nobs' x 'nobs' array get_cor_matrix_fcor <- function(Mfcor, ndraws) { out <- array(Mfcor, dim = c(dim(Mfcor), ndraws)) aperm(out, c(3, 1, 2)) } # compute an identity correlation matrix # @param ndraws number of posterior draws # @param nobs number of rows of the covariance matrix # @return a numeric 'ndraws' x 'nobs' x 'nobs' array get_cor_matrix_ident <- function(ndraws, nobs) { out <- array(0, dim = c(ndraws, nobs, nobs)) for (i in seq_len(nobs)) { out[, i, i] <- 1 } out } #' Draws of a Distributional Parameter #' #' Get draws of a distributional parameter from a \code{brmsprep} or #' \code{mvbrmsprep} object. This function is primarily useful when developing #' custom families or packages depending on \pkg{brms}. #' This function lets callers easily handle both the case when the #' distributional parameter is predicted directly, via a (non-)linear #' predictor or fixed to a constant. See the vignette #' \code{vignette("brms_customfamilies")} for an example use case. #' #' @param prep A 'brmsprep' or 'mvbrmsprep' object created by #' \code{\link[brms:prepare_predictions.brmsfit]{prepare_predictions}}. #' @param dpar Name of the distributional parameter. #' @param i The observation numbers for which predictions shall be extracted. #' If \code{NULL} (the default), all observation will be extracted. #' Ignored if \code{dpar} is not predicted. #' @param inv_link Should the inverse link function be applied? #' If \code{NULL} (the default), the value is chosen internally. #' In particular, \code{inv_link} is \code{TRUE} by default for custom #' families. #' @return #' If the parameter is predicted and \code{i} is \code{NULL} or #' \code{length(i) > 1}, an \code{S x N} matrix. If the parameter it not #' predicted or \code{length(i) == 1}, a vector of length \code{S}. Here #' \code{S} is the number of draws and \code{N} is the number of #' observations or length of \code{i} if specified. #' #' @examples #' \dontrun{ #' posterior_predict_my_dist <- function(i, prep, ...) { #' mu <- brms::get_dpar(prep, "mu", i = i) #' mypar <- brms::get_dpar(prep, "mypar", i = i) #' my_rng(mu, mypar) #' } #' } #' #' @export get_dpar <- function(prep, dpar, i = NULL, inv_link = NULL) { stopifnot(is.brmsprep(prep) || is.mvbrmsprep(prep)) dpar <- as_one_character(dpar) x <- prep$dpars[[dpar]] stopifnot(!is.null(x)) if (is.list(x)) { # compute draws of a predicted parameter out <- predictor(x, i = i, fprep = prep) if (is.null(inv_link)) { inv_link <- apply_dpar_inv_link(dpar, family = prep$family) } else { inv_link <- as_one_logical(inv_link) } if (inv_link) { out <- inv_link(out, x$family$link) } if (length(i) == 1L) { out <- slice_col(out, 1) } } else if (!is.null(i) && !is.null(dim(x))) { out <- slice_col(x, i) } else { out <- x } out } # get draws of a non-linear parameter # @param x object to extract posterior draws from # @param nlpar name of the non-linear parameter # @param i the current observation number # @return # If i is NULL or length(i) > 1: an S x N matrix # If length(i) == 1: a vector of length S get_nlpar <- function(prep, nlpar, i = NULL) { stopifnot(is.brmsprep(prep) || is.mvbrmsprep(prep)) x <- prep$nlpars[[nlpar]] stopifnot(!is.null(x)) if (is.list(x)) { # compute draws of a predicted parameter out <- predictor(x, i = i, fprep = prep) if (length(i) == 1L) { out <- slice_col(out, 1) } } else if (!is.null(i) && !is.null(dim(x))) { out <- slice_col(x, i) } else { out <- x } out } # get the mixing proportions of mixture models get_theta <- function(prep, i = NULL) { stopifnot(is.brmsprep(prep)) if ("theta" %in% names(prep$dpars)) { # theta was not predicted; no need to call get_dpar theta <- prep$dpars$theta } else { # theta was predicted; apply softmax mix_family <- prep$family families <- family_names(mix_family) theta <- vector("list", length(families)) for (j in seq_along(families)) { prep$family <- mix_family$mix[[j]] theta[[j]] <- as.matrix(get_dpar(prep, paste0("theta", j), i = i)) } theta <- abind(theta, along = 3) for (n in seq_len(dim(theta)[2])) { theta[, n, ] <- softmax(slice(theta, 2, n)) } if (length(i) == 1L) { dim(theta) <- dim(theta)[c(1, 3)] } } theta } # get posterior draws of multivariate mean vectors # only used in multivariate models with 'rescor' # and in univariate models with multiple 'mu' pars such as logistic_normal get_Mu <- function(prep, i = NULL) { is_mv <- is.mvbrmsprep(prep) if (is_mv) { Mu <- prep$mvpars$Mu } else { stopifnot(is.brmsprep(prep)) Mu <- prep$dpars$Mu } if (!is.null(Mu)) { stopifnot(!is.null(i)) Mu <- slice_col(Mu, i) return(Mu) } if (is_mv) { Mu <- lapply(prep$resps, get_dpar, "mu", i = i) } else { mu_dpars <- str_subset(names(prep$dpars), "^mu") Mu <- lapply(mu_dpars, get_dpar, prep = prep, i = i) } if (length(i) == 1L) { Mu <- do_call(cbind, Mu) } else { # keep correct dimension even if data has only 1 row Mu <- lapply(Mu, as.matrix) Mu <- abind::abind(Mu, along = 3) } Mu } # get posterior draws of residual covariance matrices # only used in multivariate models with 'rescor' # and in univariate models with multiple 'mu' pars such as logistic_normal get_Sigma <- function(prep, i = NULL, cor_name = NULL) { is_mv <- is.mvbrmsprep(prep) if (is_mv) { cor_name <- "rescor" Sigma <- prep$mvpars$Sigma } else { stopifnot(is.brmsprep(prep)) cor_name <- as_one_character(cor_name) Sigma <- prep$dpars$Sigma } if (!is.null(Sigma)) { # already computed before stopifnot(!is.null(i)) ldim <- length(dim(Sigma)) stopifnot(ldim %in% 3:4) if (ldim == 4L) { Sigma <- slice_col(Sigma, i) } return(Sigma) } if (is_mv) { cors <- prep$mvpars[[cor_name]] sigma <- named_list(names(prep$resps)) for (j in seq_along(sigma)) { sigma[[j]] <- get_dpar(prep$resps[[j]], "sigma", i = i) sigma[[j]] <- add_sigma_se(sigma[[j]], prep$resps[[j]], i = i) } } else { cors <- prep$dpars[[cor_name]] sigma_names <- str_subset(names(prep$dpars), "^sigma") sigma <- named_list(sigma_names) for (j in seq_along(sigma)) { sigma[[j]] <- get_dpar(prep, sigma_names[j], i = i) sigma[[j]] <- add_sigma_se(sigma[[j]], prep, i = i) } } is_matrix <- ulapply(sigma, is.matrix) if (!any(is_matrix)) { # happens if length(i) == 1 or if no sigma was predicted sigma <- do_call(cbind, sigma) Sigma <- get_cov_matrix(sigma, cors) } else { for (j in seq_along(sigma)) { # bring all sigmas to the same dimension if (!is_matrix[j]) { sigma[[j]] <- array(sigma[[j]], dim = dim_mu(prep)) } } nsigma <- length(sigma) sigma <- abind(sigma, along = 3) Sigma <- array(dim = c(dim_mu(prep), nsigma, nsigma)) for (n in seq_len(ncol(Sigma))) { Sigma[, n, , ] <- get_cov_matrix(slice(sigma, 2, n), cors) } } Sigma } # extract user-defined standard errors get_se <- function(prep, i = NULL) { stopifnot(is.brmsprep(prep)) se <- as.vector(prep$data[["se"]]) if (!is.null(se)) { if (!is.null(i)) { se <- se[i] } if (length(se) > 1L) { dim <- c(prep$ndraws, length(se)) se <- data2draws(se, dim = dim) } } else { se <- 0 } se } # add user defined standard errors to 'sigma' # @param sigma draws of the 'sigma' parameter add_sigma_se <- function(sigma, prep, i = NULL) { if ("se" %in% names(prep$data)) { se <- get_se(prep, i = i) sigma <- sqrt(se^2 + sigma^2) } sigma } # extract user-defined rate denominators get_rate_denom <- function(prep, i = NULL) { stopifnot(is.brmsprep(prep)) denom <- as.vector(prep$data[["denom"]]) if (!is.null(denom)) { if (!is.null(i)) { denom <- denom[i] } if (length(denom) > 1L) { dim <- c(prep$ndraws, length(denom)) denom <- data2draws(denom, dim = dim) } } else { denom <- 1 } denom } # multiply a parameter with the 'rate' denominator # @param dpar draws of the distributional parameter multiply_dpar_rate_denom <- function(dpar, prep, i = NULL) { if ("denom" %in% names(prep$data)) { denom <- get_rate_denom(prep, i = i) dpar <- dpar * denom } dpar } # return draws of ordinal thresholds for observation i # @param prep a bprepl or bprepnl object # @param i observation number subset_thres <- function(prep, i) { thres <- prep$thres$thres Jthres <- prep$thres$Jthres if (!is.null(Jthres)) { thres <- thres[, Jthres[i, 1]:Jthres[i, 2], drop = FALSE] } thres } # helper function of 'get_dpar' to decide if # the link function should be applied directly apply_dpar_inv_link <- function(dpar, family) { !(has_joint_link(family) && dpar_class(dpar, family) == "mu") } # insert zeros for the predictor term of the reference category # in categorical-like models using the softmax response function insert_refcat <- function(eta, refcat = 1) { stopifnot(is.array(eta)) refcat <- as_one_integer(refcat, allow_na = TRUE) if (isNA(refcat)) { # no reference category used return(eta) } # need to add zeros for the reference category ndim <- length(dim(eta)) dim_noncat <- dim(eta)[-ndim] zeros_arr <- array(0, dim = c(dim_noncat, 1)) before <- seq_len(refcat - 1) after <- setdiff(seq_dim(eta, ndim), before) abind::abind( slice(eta, ndim, before, drop = FALSE), zeros_arr, slice(eta, ndim, after, drop = FALSE) ) } # validate the 'resp' argument of 'predict' and related methods # @param resp response names to be validated # @param x valid response names or brmsfit object to extract names from # @param multiple allow multiple response variables? # @return names of validated response variables validate_resp <- function(resp, x, multiple = TRUE) { if (is.brmsfit(x)) { x <- brmsterms(x$formula)$responses } x <- as.character(x) if (!length(x)) { # resp is unused in univariate models return(NULL) } if (length(resp)) { resp <- as.character(resp) if (!all(resp %in% x)) { stop2("Invalid argument 'resp'. Valid response ", "variables are: ", collapse_comma(x)) } if (!multiple) { resp <- as_one_character(resp) } } else { resp <- x } resp } # split '...' into a list of model objects and other arguments # takes its argument names from parent.frame() # @param .... objects to split into model and non-model objects # @param x object treated in the same way as '...'. Adding it is # necessary for substitute() to catch the name of the first # argument passed to S3 methods. # @param model_names optional names of the model objects # @param other: allow non-model arguments in '...'? # @return # A list of arguments. All brmsfit objects are stored # as a list in element 'models' unless 'other' is FALSE. # In the latter case just returns a list of models split_dots <- function(x, ..., model_names = NULL, other = TRUE) { other <- as_one_logical(other) dots <- list(x, ...) names <- substitute(list(x, ...), env = parent.frame())[-1] names <- ulapply(names, deparse0) if (length(names)) { if (!length(names(dots))) { names(dots) <- names } else { has_no_name <- !nzchar(names(dots)) names(dots)[has_no_name] <- names[has_no_name] } } is_brmsfit <- unlist(lapply(dots, is.brmsfit)) models <- dots[is_brmsfit] models <- validate_models(models, model_names, names(models)) out <- dots[!is_brmsfit] if (other) { out$models <- models } else { if (length(out)) { stop2("Only model objects can be passed to '...' for this method.") } out <- models } out } # reorder observations to be in the initial user-defined order # currently only relevant for autocorrelation models # @param eta 'ndraws' x 'nobs' matrix or array # @param old_order optional vector to retrieve the initial data order # @param sort keep the new order as defined by the time-series? # @return the 'eta' matrix with possibly reordered columns reorder_obs <- function(eta, old_order = NULL, sort = FALSE) { stopifnot(length(dim(eta)) %in% c(2L, 3L)) if (!length(old_order) || sort) { return(eta) } stopifnot(length(old_order) == NCOL(eta)) p(eta, old_order, row = FALSE) } # update .MISC environment of the stanfit object # allows to call log_prob and other C++ using methods # on objects not created in the current R session # or objects created via another backend update_misc_env <- function(x, recompile = FALSE, only_windows = FALSE) { stopifnot(is.brmsfit(x)) recompile <- as_one_logical(recompile) only_windows <- as_one_logical(only_windows) if (recompile || !has_rstan_model(x)) { x <- add_rstan_model(x, overwrite = TRUE) } else if (os_is_windows() || !only_windows) { # TODO: detect when updating .MISC is not required # TODO: find a more efficient way to update .MISC old_backend <- x$backend x$backend <- "rstan" x$fit@.MISC <- suppressMessages(brm(fit = x, chains = 0))$fit@.MISC x$backend <- old_backend } x } #' Add compiled \pkg{rstan} models to \code{brmsfit} objects #' #' Compile a \code{\link[rstan:stanmodel-class]{stanmodel}} and add #' it to a \code{brmsfit} object. This enables some advanced functionality #' of \pkg{rstan}, most notably \code{\link[rstan:log_prob]{log_prob}} #' and friends, to be used with brms models fitted with other Stan backends. #' #' @param x A \code{brmsfit} object to be updated. #' @param overwrite Logical. If \code{TRUE}, overwrite any existing #' \code{\link[rstan:stanmodel-class]{stanmodel}}. Defaults to \code{FALSE}. #' #' @return A (possibly updated) \code{brmsfit} object. #' #' @export add_rstan_model <- function(x, overwrite = FALSE) { stopifnot(is.brmsfit(x)) overwrite <- as_one_logical(overwrite) if (!has_rstan_model(x) || overwrite) { message("Recompiling the model with 'rstan'") # threading is not yet supported by rstan and needs to be deactivated stanfit <- suppressMessages(rstan::stan( model_code = stancode(x, threads = threading(), backend = "rstan"), data = standata(x), chains = 0 )) x$fit@stanmodel <- stanfit@stanmodel x$fit@.MISC <- stanfit@.MISC message("Recompilation done") } x } # does the model have a non-empty rstan 'stanmodel' # that can be used for 'log_prob' and friends? has_rstan_model <- function(x) { stopifnot(is.brmsfit(x)) isTRUE(nzchar(x$fit@stanmodel@model_cpp$model_cppname)) && length(ls(pos = x$fit@.MISC)) > 0 } # extract argument names of a post-processing method arg_names <- function(method) { opts <- c("posterior_predict", "posterior_epred", "log_lik") method <- match.arg(method, opts) out <- names(formals(paste0(method, ".brmsfit"))) c(out) <- names(formals(prepare_predictions.brmsfit)) c(out) <- names(formals(validate_newdata)) out <- unique(out) out <- setdiff(out, c("object", "x", "...")) out } # validate 'cores' argument for use in post-processing functions validate_cores_post_processing <- function(cores, use_mc_cores = FALSE) { if (is.null(cores)) { if (os_is_windows() || !use_mc_cores) { # multi cores often leads to a slowdown on windows # in post-processing functions as discussed in #1129 # multi cores may also lead to zombie workers # on unix systems as discussed in #1658 cores <- 1L } else { cores <- getOption("mc.cores", 1L) } } cores <- as_one_integer(cores) if (cores < 1L) { cores <- 1L } cores } #' Check if cached fit can be used. #' #' Checks whether a given cached fit can be used without refitting when #' \code{file_refit = "on_change"} is used. #' This function is internal and exposed only to facilitate debugging problems #' with cached fits. The function may change or be removed in future versions #' and scripts should not use it. #' #' @param fit Old \code{brmsfit} object (e.g., loaded from file). #' @param sdata New Stan data (result of a call to \code{\link[brms:standata.default]{standata}}). #' Pass \code{NULL} to avoid this data check. #' @param scode New Stan code (result of a call to \code{\link[brms:stancode.default]{stancode}}). #' Pass \code{NULL} to avoid this code check. #' @param data New data to check consistency of factor level names. #' Pass \code{NULL} to avoid this data check. #' @param algorithm New algorithm. Pass \code{NULL} to avoid algorithm check. #' @param silent Logical. If \code{TRUE}, no messages will be given. #' @param verbose Logical. If \code{TRUE} detailed report of the differences #' is printed to the console. #' @return A boolean indicating whether a refit is needed. #' #' @details #' Use with \code{verbose = TRUE} to get additional info on how the stored #' fit differs from the given data and code. #' #' @export #' @keywords internal brmsfit_needs_refit <- function(fit, sdata = NULL, scode = NULL, data = NULL, algorithm = NULL, silent = FALSE, verbose = FALSE) { stopifnot(is.brmsfit(fit)) silent <- as_one_logical(silent) verbose <- as_one_logical(verbose) if (!is.null(scode)) { scode <- as_one_character(scode) cached_scode <- stancode(fit) } if (!is.null(sdata)) { stopifnot(is.list(sdata)) cached_sdata <- standata(fit) } if (!is.null(data)) { stopifnot(is.data.frame(data)) cached_data <- fit$data } if (!is.null(algorithm)) { algorithm <- as_one_character(algorithm) stopifnot(!is.null(fit$algorithm)) } refit <- FALSE if (!is.null(scode)) { if (normalize_stancode(scode) != normalize_stancode(cached_scode)) { if (!silent) { message("Stan code has changed beyond whitespace/comments.") if (verbose) { require_package("diffobj") print(diffobj::diffChr(scode, cached_scode, format = "ansi8")) } } refit <- TRUE } } if (!is.null(sdata)) { sdata_equality <- all.equal(sdata, cached_sdata, check.attributes = FALSE) if (!isTRUE(sdata_equality)) { if (!silent) { message("The processed data for Stan has changed.") if (verbose) { print(sdata_equality) } } refit <- TRUE } } if (!is.null(data)) { # check consistency of factor names # as they are only stored as attributes in sdata (#1128) factor_level_message <- FALSE for (var in names(cached_data)) { if (is_like_factor(cached_data[[var]])) { cached_levels <- levels(factor(cached_data[[var]])) new_levels <- levels(factor(data[[var]])) if (!is_equal(cached_levels, new_levels)) { if (!silent) { factor_level_message <- TRUE if (verbose) { cat(paste0( "Names of factor levels have changed for variable '", var, "' ", "with cached levels (", collapse_comma(cached_levels), ") ", "but new levels (", collapse_comma(new_levels), ").\n" )) } } refit <- TRUE if (!verbose) { # no need to check all variables if we trigger a refit anyway break } } } } if (factor_level_message) { message("Names of factor levels have changed.") } } if (!is.null(algorithm)) { if (algorithm != fit$algorithm) { if (!silent) { message("Algorithm has changed from '", fit$algorithm, "' to '", algorithm, "'.\n") } refit <- TRUE } } refit } # Determine Cache Folder for brms # # Checks if the provided file path includes a directory. If so, returns that directory. # Otherwise, looks for a user‐defined `brms_cache_folder` option. If the option is not set, # defaults to the current directory ("."). # # @param file A file path (string) that may include a directory component. # @return A string indicating which folder to use for caching. get_cache_folder <- function(file) { dir <- dirname(file) # If the file path already contains a directory, use it if (dir != ".") { return(dir) } # Otherwise, check for a user‐defined cache folder option cache_folder <- getOption("brms.cache_folder", default = ".") cache_folder } # Check that a directory exists # @param folder A character string specifying a directory path. # @return NULL (invisibly) if the directory exists; otherwise throws an error. check_folder <- function(folder) { if (!dir.exists(folder)) { stop2( "The directory '", folder, "' does not exist. Please choose an ", "existing directory where the model can be saved after fitting." ) } invisible(NULL) } # Split a file path into cache folder and file components # @param file A character string specifying a file path or file name. # @return A list with two elements: # \item{folder}{The directory returned by get_cache_folder(file).} # \item{file}{The original file argument (unchanged).} split_folder_and_file <- function(file) { cache_folder <- get_cache_folder(file) file <- basename(file) list(folder = cache_folder, file = file) } # read a brmsfit object from a file # @param file path to an rds file # @return a brmsfit object or NULL read_brmsfit <- function(file) { file <- check_brmsfit_file(file) x <- suppressWarnings(try(readRDS(file), silent = TRUE)) if (!is_try_error(x)) { if (!is.brmsfit(x)) { stop2("Object loaded via 'file' is not of class 'brmsfit'.") } x$file <- file } else { x <- NULL } x } # write a brmsfit object to a file # @param x a brmsfit object # @param file path to an rds file # @param compress compression format supported by saveRDS # @return NULL write_brmsfit <- function(x, file, compress = TRUE) { stopifnot(is.brmsfit(x)) file <- check_brmsfit_file(file) x$file <- file saveRDS(x, file = file, compress = compress) invisible(x) } # Helper function to ensure a valid filename for saving a brmsfit object # # Appends a `.rds` extension to the filename if not already present. # # @param file A character string specifying a file path or base filename. # @return A character string with a valid `.rds` file name. check_brmsfit_file_name <- function(file) { file <- as_one_character(file) file_ending <- tolower(get_matches("\\.[^\\.]+$", file)) if (!isTRUE(file_ending == ".rds")) { file <- paste0(file, ".rds") } file } # Validate and prepare a file path for storing a brmsfit object # # Splits the provided file path into folder and file components, # checks that the folder exists (if enabled), ensures the file name ends with `.rds`, # and then returns the full normalized file path. # # @param file A character string specifying a file path or base filename. # @param .check_folder Logical; if TRUE (default), validates that the folder # exists using `check_folder()`. # If FALSE, the folder check is skipped. Mainly used in test scenarios. # @return A fully qualified file path (character string) with the `.rds` extension. check_brmsfit_file <- function(file, .check_folder = TRUE) { flist <- split_folder_and_file(file) if (.check_folder) { check_folder(flist$folder) } file_name <- check_brmsfit_file_name(flist$file) full_name <- file.path(flist$folder, file_name) full_name } # check if a function requires an old default setting # only used to ensure backwards compatibility # @param version brms version in which the change to the default was made # @return TRUE or FALSE require_old_default <- function(version) { version <- as.package_version(version) brmsfit_version <- getOption(".brmsfit_version") isTRUE(brmsfit_version < version) } # add dummy draws to a brmsfit object for use in unit tests # @param x a brmsfit object # @param newpar name of the new parameter to add # @param dim dimension of the new parameter # @param dist name of the distribution from which to sample # @param ... further arguments passed to r # @return a brmsfit object including dummy draws of the new parameter add_dummy_draws <- function(x, newpar, dim = numeric(0), dist = "norm", ...) { stopifnot(is.brmsfit(x)) stopifnot(identical(dim, numeric(0))) newpar <- as_one_character(newpar) for (i in seq_along(x$fit@sim$samples)) { x$fit@sim$samples[[i]][[newpar]] <- do_call(paste0("r", dist), list(x$fit@sim$iter, ...)) } x$fit@sim$fnames_oi <- c(x$fit@sim$fnames_oi, newpar) x$fit@sim$dims_oi[[newpar]] <- dim x$fit@sim$pars_oi <- names(x$fit@sim$dims_oi) x } brms/R/data-helpers.R0000644000176200001440000005645415057503614014136 0ustar liggesusers# update data for use in brms functions # @param data the data passed by the user # @param bterms object of class brmsterms # @param na_action function defining how to treat NAs # @param drop_unused_levels should unused factor levels be removed? # @param attr_terms a list of attributes of the terms object of # the original model.frame; only used with newdata; # this ensures that (1) calls to 'poly' work correctly # and (2) that the number of variables matches the number # of variable names; fixes issue #73 # @param knots: a list of knot values for GAMMs # @param data_name: optional name of the data frame as passed by the user # @return model.frame for use in brms functions validate_data <- function(data, bterms, data2 = list(), knots = NULL, na_action = na_omit, drop_unused_levels = TRUE, attr_terms = NULL, data_name = "") { if (missing(data)) { stop2("Data must be specified using the 'data' argument.") } if (is.null(knots)) { knots <- get_knots(data) } data <- try(as.data.frame(data), silent = TRUE) if (is_try_error(data)) { stop2("Argument 'data' must be coercible to a data.frame.") } if (!isTRUE(nrow(data) > 0L)) { stop2("Argument 'data' does not contain observations.") } data <- data_rsv_intercept(data, bterms = bterms) all_vars_formula <- bterms$allvars missing_vars <- setdiff(all_vars(all_vars_formula), names(data)) if (length(missing_vars)) { missing_vars2 <- setdiff(missing_vars, names(data2)) if (length(missing_vars2)) { stop2("The following variables can neither be found in ", "'data' nor in 'data2':\n", collapse_comma(missing_vars2)) } # all initially missing variables can be found in 'data2' # they are not necessarily of the length required for 'data' # so need to be excluded from the evaluation of 'model.frame' missing_vars_formula <- paste0(". ~ . ", collapse(" - ", missing_vars)) all_vars_formula <- update(all_vars_formula, missing_vars_formula) } all_vars_terms <- terms(all_vars_formula) # ensure that 'data2' comes first in the search path # during the evaluation of model.frame terms_env <- environment(all_vars_terms) environment(all_vars_terms) <- as.environment(as.list(data2)) parent.env(environment(all_vars_terms)) <- terms_env attributes(all_vars_terms)[names(attr_terms)] <- attr_terms # 'terms' prevents correct validation in 'model.frame' attr(data, "terms") <- NULL # ensures that na_action can be passed to model.frame na_action_bterms <- function(object, ...) { na_action(object, bterms = bterms, ...) } data <- model.frame( all_vars_terms, data, na.action = na_action_bterms, drop.unused.levels = drop_unused_levels ) if (any(grepl("__|_$", colnames(data)))) { stop2("Variable names may not contain double underscores ", "or underscores at the end.") } if (!isTRUE(nrow(data) > 0L)) { stop2("All observations in the data were removed ", "presumably because of NA values.") } if (any(ulapply(data, is.infinite))) { warning2("Found infinite values in the data, ", "which may cause issues for Stan.") } groups <- get_group_vars(bterms) data <- combine_groups(data, groups) data <- fix_factor_contrasts(data, ignore = groups) data <- order_data(data, bterms = bterms) attr(data, "knots") <- knots attr(data, "drop_unused_levels") <- drop_unused_levels attr(data, "data_name") <- data_name data } # validate the 'data2' argument # @param data2 a named list of data objects # @param bterms object returned by 'brmsterms' # @param ... more named list to pass objects to data2 from other sources # only required for backwards compatibility with deprecated arguments # @return a validated named list of data objects validate_data2 <- function(data2, bterms, ...) { # TODO: specify spline-related matrices in 'data2' # this requires adding another parser layer with bterms and data as input if (is.null(data2)) { data2 <- list() } if (!is.list(data2)) { stop2("'data2' must be a list.") } if (length(data2) && !is_named(data2)) { stop2("All elements of 'data2' must be named.") } dots <- list(...) for (i in seq_along(dots)) { if (length(dots[[i]])) { stopifnot(is.list(dots[[i]]), is_named(dots[[i]])) data2[names(dots[[i]])] <- dots[[i]] } } # validate autocorrelation matrices acframe <- frame_ac(bterms) sar_M_names <- get_ac_vars(acframe, "M", class = "sar") for (M in sar_M_names) { data2[[M]] <- validate_sar_matrix(get_from_data2(M, data2)) attr(data2[[M]], "obs_based_matrix") <- TRUE } car_M_names <- get_ac_vars(acframe, "M", class = "car") for (M in car_M_names) { data2[[M]] <- validate_car_matrix(get_from_data2(M, data2)) # observation based CAR matrices are deprecated and # there is no need to label them as observation based } fcor_M_names <- get_ac_vars(acframe, "M", class = "fcor") for (M in fcor_M_names) { data2[[M]] <- validate_fcor_matrix(get_from_data2(M, data2)) attr(data2[[M]], "obs_based_matrix") <- TRUE } # validate within-group covariance matrices cov_names <- ufrom_list(get_re(bterms)$gcall, "cov") cov_names <- cov_names[nzchar(cov_names)] for (cov in cov_names) { data2[[cov]] <- validate_recov_matrix(get_from_data2(cov, data2)) } data2 } # get an object from the 'data2' argument get_from_data2 <- function(x, data2) { if (!x %in% names(data2)) { stop2("Object '", x, "' was not found in 'data2'.") } get(x, data2) } # index observation based elements in 'data2' # @param data2 a named list of objects # @param i observation based indices # @return data2 with potentially indexed elements subset_data2 <- function(data2, i) { if (!length(data2)) { return(data2) } stopifnot(is.list(data2), is_named(data2)) for (var in names(data2)) { if (isTRUE(attr(data2[[var]], "obs_based_matrix"))) { # matrices with dimensions equal to the number of observations data2[[var]] <- data2[[var]][i, i, drop = FALSE] attr(data2[[var]], "obs_based_matrix") <- TRUE } } data2 } # add the reserved intercept variables to the data data_rsv_intercept <- function(data, bterms) { fe_forms <- get_effect(bterms, "fe") if (any(ulapply(fe_forms, no_int))) { if ("intercept" %in% ulapply(fe_forms, all_vars)) { warning2("Reserved variable name 'intercept' is deprecated. ", "Please use 'Intercept' instead.") } if (any(data[["intercept"]] != 1)) { stop2("Variable name 'intercept' is reserved in models ", "without a population-level intercept.") } if (any(data[["Intercept"]] != 1)) { stop2("Variable name 'Intercept' is reserved in models ", "without a population-level intercept.") } data$intercept <- data$Intercept <- rep(1, length(data[[1]])) } data } # combine grouping factors to form new variables # @param data data.frame to be updated # @param ... the grouping factors to be combined # @return 'data' including the new combined grouping factors combine_groups <- function(data, ...) { group <- c(...) for (i in seq_along(group)) { sgroup <- unlist(strsplit(group[[i]], ":")) if (length(sgroup) > 1L && !group[[i]] %in% names(data)) { new_var <- get(sgroup[1], data) for (j in 2:length(sgroup)) { new_var <- paste0(new_var, "_", get(sgroup[j], data)) } data[[group[[i]]]] <- new_var } } data } # hard code factor contrasts to be independent of the global "contrasts" option # @param data data.frame to be updated # @param olddata: optional data.frame from which contrasts are taken if present # @param ignore: names of variables for which not to fix contrasts # @return 'data' with amended contrasts attributes fix_factor_contrasts <- function(data, olddata = NULL, ignore = NULL) { stopifnot(is(data, "data.frame")) stopifnot(is.null(olddata) || is.list(olddata)) olddata <- as.data.frame(olddata) # fixes issue #105 for (i in seq_along(data)) { needs_contrast <- is.factor(data[[i]]) && !names(data)[i] %in% ignore if (needs_contrast && is.null(attr(data[[i]], "contrasts"))) { old_contrasts <- attr(olddata[[names(data)[i]]], "contrasts") if (!is.null(old_contrasts)) { # take contrasts from olddata contrasts(data[[i]]) <- old_contrasts } else if (length(unique(data[[i]])) > 1L) { # avoid error when supplying only a single level # hard code current global "contrasts" option contrasts(data[[i]]) <- contrasts(data[[i]]) } } } data } # order data for use in time-series models # @param data data.frame to be ordered # @param bterms brmsterms of mvbrmsterms object # @return 'data' potentially ordered differently order_data <- function(data, bterms) { # ordering does only matter for time-series models time <- get_ac_vars(bterms, "time", dim = "time") gr <- get_ac_vars(bterms, "gr", dim = "time") if (length(time) > 1L || length(gr) > 1L) { stop2("All time-series structures must have the same ", "'time' and 'gr' variables.") } if (length(time) || length(gr)) { if (length(gr)) { gv <- data[[gr]] } else { gv <- rep(1L, nrow(data)) } if (length(time)) { tv <- data[[time]] } else { tv <- seq_rows(data) } if (any(duplicated(data.frame(gv, tv)))) { stop2("Time points within groups must be unique.") } new_order <- do_call(order, list(gv, tv)) data <- data[new_order, , drop = FALSE] # old_order will allow to retrieve the initial order of the data attr(data, "old_order") <- order(new_order) } data } # subset data according to addition argument 'subset' subset_data <- function(data, bterms) { if (has_subset(bterms)) { # only evaluate a subset of the data subset <- as.logical(get_ad_values(bterms, "subset", "subset", data)) if (length(subset) != nrow(data)) { stop2("Length of 'subset' does not match the rows of 'data'.") } if (anyNA(subset)) { stop2("Subset variables may not contain NAs.") } # cross-formula indexing is no longer trivial for subsetted models check_cross_formula_indexing(bterms) data <- data[subset, , drop = FALSE] attr(data, "subset") <- subset } if (!NROW(data)) { stop2( "All rows of 'data' were removed via 'subset'. ", "Please make sure that variables do not contain NAs ", "for observations in which they are supposed to be used. ", "Please also make sure that each subset variable is ", "TRUE for at least one observation." ) } data } # like stats:::na.omit.data.frame but allows to certain NA values na_omit <- function(object, bterms, ...) { stopifnot(is.data.frame(object)) nobs <- nrow(object) if (is.mvbrmsterms(bterms)) { responses <- names(bterms$terms) subsets <- lapply(bterms$terms, get_ad_values, "subset", "subset", object) vars_sub <- lapply(bterms$terms, function(x) all_vars(x$allvars)) } vars_keep_na <- vars_keep_na(bterms) omit <- logical(nobs) for (v in names(object)) { x <- object[[v]] vars_v <- all_vars(v) keep_all_na <- all(vars_v %in% vars_keep_na) if (!is.atomic(x) || keep_all_na) { next } if (!is.mvbrmsterms(bterms)) { # remove all NAs in this variable keep_na <- rep(FALSE, nobs) } else { # allow to retain NAs in subsetted variables keep_na <- rep(TRUE, nobs) for (r in responses) { if (any(vars_v %in% vars_sub[[r]])) { if (!is.null(subsets[[r]])) { # keep NAs ignored because of 'subset' keep_na <- keep_na & !subsets[[r]] } else { # remove all NAs in this variable keep_na <- keep_na & FALSE } } } } is_na <- is.na(x) d <- dim(is_na) if (is.null(d) || length(d) != 2L) { omit <- omit | (is_na & !keep_na) } else { for (ii in seq_len(d[2L])) { omit <- omit | (is_na[, ii] & !keep_na) } } } if (any(omit > 0L)) { out <- object[!omit, , drop = FALSE] temp <- setNames(seq(omit)[omit], attr(object, "row.names")[omit]) attr(temp, "class") <- "omit" attr(out, "na.action") <- temp warning2("Rows containing NAs were excluded from the model.") } else { out <- object } out } # get a single value per group # @param x vector of values to extract one value per group # @param gr vector of grouping values # @return a vector of the same length as unique(group) get_one_value_per_group <- function(x, gr) { stopifnot(length(x) == length(gr)) not_dupl_gr <- !duplicated(gr) gr_unique <- gr[not_dupl_gr] to_order <- order(gr_unique) gr_unique <- gr_unique[to_order] out <- x[not_dupl_gr][to_order] names(out) <- gr_unique out } # extract knots values for use in spline terms get_knots <- function(data) { attr(data, "knots", TRUE) } get_drop_unused_levels <- function(data) { out <- attr(data, "drop_unused_levels", TRUE) %||% TRUE } # extract name of the data as originally passed by the user get_data_name <- function(data) { out <- attr(data, "data_name", TRUE) if (is.null(out)) { out <- "NULL" } out } #' Validate New Data #' #' Validate new data passed to post-processing methods of \pkg{brms}. Unless you #' are a package developer, you will rarely need to call \code{validate_newdata} #' directly. #' #' @inheritParams prepare_predictions #' @param newdata A \code{data.frame} containing new data to be validated. #' @param object A \code{brmsfit} object. #' @param check_response Logical; Indicates if response variables should #' be checked as well. Defaults to \code{TRUE}. #' @param group_vars Optional names of grouping variables to be validated. #' Defaults to all grouping variables in the model. #' @param req_vars Optional names of variables required in \code{newdata}. #' If \code{NULL} (the default), all variables in the original data #' are required (unless ignored for some other reason). #' @param ... Currently ignored. #' #' @return A validated \code{'data.frame'} based on \code{newdata}. #' #' @export validate_newdata <- function( newdata, object, re_formula = NULL, allow_new_levels = FALSE, newdata2 = NULL, resp = NULL, check_response = TRUE, incl_autocor = TRUE, group_vars = NULL, req_vars = NULL, ... ) { newdata <- try(as.data.frame(newdata), silent = TRUE) if (is_try_error(newdata)) { stop2("Argument 'newdata' must be coercible to a data.frame.") } object <- restructure(object) object <- exclude_terms(object, incl_autocor = incl_autocor) resp <- validate_resp(resp, object) new_formula <- update_re_terms(formula(object), re_formula) bterms <- brmsterms(new_formula, resp_rhs_all = FALSE) # fill values of not required variables all_vars <- all.vars(bterms$allvars) if (is.null(req_vars)) { req_vars <- all_vars } else { req_vars <- as.character(req_vars) req_vars <- intersect(req_vars, all_vars) } if (is.mvbrmsterms(bterms) && !is.null(resp)) { # variables not used in the included model parts # do not need to be specified in newdata resp <- validate_resp(resp, bterms$responses) form_req_vars <- from_list(bterms$terms[resp], "allvars") form_req_vars <- allvars_formula(form_req_vars) req_vars <- intersect(req_vars, all.vars(form_req_vars)) } not_req_vars <- setdiff(all_vars, req_vars) not_req_vars <- setdiff(not_req_vars, names(newdata)) newdata <- fill_newdata(newdata, not_req_vars, object$data) # check response and addition variables only_resp <- all.vars(bterms$respform) only_resp <- setdiff(only_resp, all.vars(rhs(bterms$allvars))) # always require 'dec' variables to be specified dec_vars <- get_ad_vars(bterms, "dec") missing_resp <- setdiff(c(only_resp, dec_vars), names(newdata)) if (length(missing_resp)) { if (check_response) { stop2("Response variables must be specified in 'newdata'.\n", "Missing variables: ", collapse_comma(missing_resp)) } else { newdata <- fill_newdata(newdata, missing_resp) } } # censoring and weighting vars are unused in post-processing methods cens_vars <- get_ad_vars(bterms, "cens") for (v in setdiff(cens_vars, names(newdata))) { newdata[[v]] <- 0 } weights_vars <- get_ad_vars(bterms, "weights") for (v in setdiff(weights_vars, names(newdata))) { newdata[[v]] <- 1 } mf <- model.frame(object) for (i in seq_along(mf)) { if (is_like_factor(mf[[i]])) { mf[[i]] <- as.factor(mf[[i]]) } } pw_vars <- ufrom_list(get_re(bterms)$gcall, "pw") for (v in setdiff(pw_vars, names(newdata))) { newdata[[v]] <- 1 } # fixes issue #279 newdata <- data_rsv_intercept(newdata, bterms) new_group_vars <- get_group_vars(bterms) if (allow_new_levels && length(new_group_vars)) { # grouping factors do not need to be specified # by the user if new levels are allowed mis_group_vars <- new_group_vars[!grepl(":", new_group_vars)] mis_group_vars <- setdiff(mis_group_vars, names(newdata)) newdata <- fill_newdata(newdata, mis_group_vars) } newdata <- combine_groups(newdata, new_group_vars) # validate factor levels in newdata if (is.null(group_vars)) { group_vars <- get_group_vars(object) } do_check <- union(get_pred_vars(bterms), get_int_vars(bterms)) # do not check variables from the 'unused' argument #1238 unused_arg_vars <- get_unused_arg_vars(bterms) dont_check <- unique(c(group_vars, cens_vars, unused_arg_vars)) dont_check <- setdiff(dont_check, do_check) dont_check <- names(mf) %in% dont_check is_factor <- ulapply(mf, is.factor) factors <- mf[is_factor & !dont_check] if (length(factors)) { factor_names <- names(factors) for (i in seq_along(factors)) { new_factor <- newdata[[factor_names[i]]] if (!is.null(new_factor)) { if (!is.factor(new_factor)) { new_factor <- factor(new_factor) } old_levels <- levels(factors[[i]]) if (length(old_levels) <= 1L) { # contrasts are not defined for factors with 1 or fewer levels next } new_levels <- levels(new_factor) old_contrasts <- contrasts(factors[[i]]) old_ordered <- is.ordered(factors[[i]]) to_zero <- is.na(new_factor) | new_factor %in% "zero__" # don't add the 'zero__' level to response variables is_resp <- factor_names[i] %in% all.vars(bterms$respform) if (!is_resp && any(to_zero)) { levels(new_factor) <- c(new_levels, "zero__") new_factor[to_zero] <- "zero__" old_levels <- c(old_levels, "zero__") old_contrasts <- rbind(old_contrasts, zero__ = 0) } if (any(!new_levels %in% old_levels)) { stop2( "New factor levels are not allowed.", "\nLevels allowed: ", collapse_comma(old_levels), "\nLevels found: ", collapse_comma(new_levels) ) } newdata[[factor_names[i]]] <- factor(new_factor, old_levels, ordered = old_ordered) # don't use contrasts(.) here to avoid dimension checks attr(newdata[[factor_names[i]]], "contrasts") <- old_contrasts } } } # check if originally numeric variables are still numeric num_names <- names(mf)[!is_factor] num_names <- setdiff(num_names, group_vars) for (nm in intersect(num_names, names(newdata))) { if (!anyNA(newdata[[nm]]) && !is.numeric(newdata[[nm]])) { stop2("Variable '", nm, "' was originally ", "numeric but is not in 'newdata'.") } } # validate monotonic variables mo_vars <- get_sp_vars(bterms, "mo") if (length(mo_vars)) { # factors have already been checked num_mo_vars <- names(mf)[!is_factor & names(mf) %in% mo_vars] for (v in num_mo_vars) { new_values <- get(v, newdata) min_value <- min(mf[[v]]) invalid <- new_values < min_value | new_values > max(mf[[v]]) invalid <- invalid | !is_wholenumber(new_values) if (sum(invalid)) { stop2("Invalid values in variable '", v, "': ", collapse_comma(new_values[invalid])) } attr(newdata[[v]], "min") <- min_value } } # update_data expects all original variables to be present used_vars <- c(names(newdata), all.vars(bterms$allvars)) used_vars <- union(used_vars, rsv_vars(bterms)) all_vars <- all.vars(str2formula(names(mf))) unused_vars <- setdiff(all_vars, used_vars) newdata <- fill_newdata(newdata, unused_vars) # validate grouping factors old_levels <- get_levels(bterms, data = mf) if (!allow_new_levels) { new_levels <- get_levels(bterms, data = newdata) for (g in names(old_levels)) { unknown_levels <- setdiff(new_levels[[g]], old_levels[[g]]) # NA is not found by get_levels but still behaves like a new level (#1652) if (anyNA(newdata[[g]])) { c(unknown_levels) <- NA } if (length(unknown_levels)) { unknown_levels <- collapse_comma(unknown_levels) stop2( "Levels ", unknown_levels, " of grouping factor '", g, "' ", "cannot be found in the fitted model. ", "Consider setting argument 'allow_new_levels' to TRUE." ) } } } # ensure correct handling of functions like 'poly' or 'scale' old_terms <- attr(object$data, "terms") attr_terms <- c("variables", "predvars") attr_terms <- attributes(old_terms)[attr_terms] newdata <- validate_data( newdata, bterms = bterms, na_action = na.pass, drop_unused_levels = FALSE, attr_terms = attr_terms, data2 = current_data2(object, newdata2), knots = get_knots(object$data) ) newdata } # fill newdata with values for not required variables # @param newdata data.frame to be filled # @param vars character vector of not required variables # @param olddata optional data.frame to take values from # @param n row number of olddata to extract values from fill_newdata <- function(newdata, vars, olddata = NULL, n = 1L) { stopifnot(is.data.frame(newdata), is.character(vars)) vars <- setdiff(vars, names(newdata)) if (is.null(olddata)) { if (length(vars)) { newdata[, vars] <- NA } return(newdata) } stopifnot(is.data.frame(olddata), length(n) == 1L) for (v in vars) { # using NA for variables is not safe in all cases # for example when processing splines using mgcv # hence it is safer to use existing data values cval <- olddata[n, v] %||% NA if (length(dim(cval)) == 2L) { # matrix columns don't have automatic broadcasting apparently cval <- matrix(cval, nrow(newdata), ncol(cval), byrow = TRUE) } newdata[[v]] <- cval } newdata } # validate new data2 validate_newdata2 <- function(newdata2, object, ...) { stopifnot(is.brmsfit(object)) bterms <- brmsterms(object$formula) validate_data2(newdata2, bterms = bterms, ...) } # extract the current data current_data <- function(object, newdata = NULL, skip_validation = FALSE, ...) { stopifnot(is.brmsfit(object)) skip_validation <- as_one_logical(skip_validation) if (is.null(newdata)) { data <- object$data } else if (skip_validation) { data <- newdata } else { data <- validate_newdata(newdata, object = object, ...) } data } # extract the current data2 current_data2 <- function(object, newdata2 = NULL, skip_validation = FALSE, ...) { stopifnot(is.brmsfit(object)) skip_validation <- as_one_logical(skip_validation) if (is.null(newdata2)) { data2 <- object$data2 } else if (skip_validation) { data2 <- newdata2 } else { data2 <- validate_newdata2(newdata2, object = object, ...) } data2 } brms/R/posterior_smooths.R0000644000176200001440000001017015053072461015345 0ustar liggesusers#' Posterior Predictions of Smooth Terms #' #' Compute posterior predictions of smooth \code{s} and \code{t2} terms of #' models fitted with \pkg{brms}. #' #' @inheritParams posterior_epred.brmsfit #' @param smooth Name of a single smooth term for which predictions should #' be computed. #' @param newdata An optional \code{data.frame} for which to evaluate #' predictions. If \code{NULL} (default), the original data of the model is #' used. Only those variables appearing in the chosen \code{smooth} term are #' required. #' @param ... Currently ignored. #' #' @return An S x N matrix, where S is the number of #' posterior draws and N is the number of observations. #' #' @examples #' \dontrun{ #' set.seed(0) #' dat <- mgcv::gamSim(1, n = 200, scale = 2) #' fit <- brm(y ~ s(x0) + s(x1) + s(x2) + s(x3), data = dat) #' summary(fit) #' #' newdata <- data.frame(x2 = seq(0, 1, 10)) #' str(posterior_smooths(fit, smooth = "s(x2)", newdata = newdata)) #' } #' #' @export posterior_smooths.brmsfit <- function(object, smooth, newdata = NULL, resp = NULL, dpar = NULL, nlpar = NULL, ndraws = NULL, draw_ids = NULL, ...) { resp <- validate_resp(resp, object, multiple = FALSE) bterms <- brmsterms(exclude_terms(object$formula, smooths_only = TRUE)) if (!is.null(resp)) { stopifnot(is.mvbrmsterms(bterms)) bterms <- bterms$terms[[resp]] } if (!is.null(nlpar)) { if (length(dpar)) { stop2("Cannot use 'dpar' and 'nlpar' at the same time.") } nlpar <- as_one_character(nlpar) nlpars <- names(bterms$nlpars) if (!nlpar %in% nlpars) { stop2("Invalid argument 'nlpar'. Valid non-linear ", "parameters are: ", collapse_comma(nlpars)) } bterms <- bterms$nlpars[[nlpar]] } else { dpar <- dpar %||% "mu" dpar <- as_one_character(dpar) dpars <- names(bterms$dpars) if (!dpar %in% dpars) { stop2("Invalid argument 'dpar'. Valid distributional ", "parameters are: ", collapse_comma(dpars)) } bterms <- bterms$dpars[[dpar]] } posterior_smooths( bterms, fit = object, smooth = smooth, newdata = newdata, ndraws = ndraws, draw_ids = draw_ids, ... ) } #' @export posterior_smooths.btl <- function(object, fit, smooth, newdata = NULL, ndraws = NULL, draw_ids = NULL, nsamples = NULL, subset = NULL, ...) { smooth <- rm_wsp(as_one_character(smooth)) ndraws <- use_alias(ndraws, nsamples) draw_ids <- use_alias(draw_ids, subset) object$frame$sm <- frame_sm(object, fit$data) class(object) <- c("bframel", class(object)) smframe <- object$frame$sm smframe$term <- rm_wsp(smframe$term) smterms <- unique(smframe$term) if (!smooth %in% smterms) { stop2("Term '", smooth, "' cannot be found. Available ", "smooth terms are: ", collapse_comma(smterms)) } # find relevant variables sub_smframe <- subset2(smframe, term = smooth) covars <- all_vars(sub_smframe$covars[[1]]) byvars <- all_vars(sub_smframe$byvars[[1]]) req_vars <- c(covars, byvars) # prepare predictions for splines sdata <- standata( fit, newdata, re_formula = NA, internal = TRUE, check_response = FALSE, req_vars = req_vars ) draw_ids <- validate_draw_ids(fit, draw_ids, ndraws) draws <- as_draws_matrix(fit) draws <- suppressMessages(subset_draws(draws, draw = draw_ids)) prep_args <- nlist(x = object, draws, sdata, data = fit$data) prep <- do_call(prepare_predictions, prep_args) # select subset of smooth parameters and design matrices i <- which(smterms %in% smooth)[1] J <- which(smframe$termnum == i) scs <- unlist(attr(prep$sm$fe$Xs, "smcols")[J]) prep$sm$fe$Xs <- prep$sm$fe$Xs[, scs, drop = FALSE] prep$sm$fe$bs <- prep$sm$fe$bs[, scs, drop = FALSE] prep$sm$re <- prep$sm$re[J] prep$family <- brmsfamily("gaussian") predictor(prep, i = NULL) } #' @export posterior_smooths.btnl <- function(object, ...) { stop2("Non-linear formulas do not contain smooth terms.") } #' @rdname posterior_smooths.brmsfit #' @export posterior_smooths <- function(object, ...) { UseMethod("posterior_smooths") } brms/R/stanvars.R0000644000176200001440000002213615053072461013411 0ustar liggesusers#' User-defined variables passed to Stan #' #' Prepare user-defined variables to be passed to one of Stan's #' program blocks. This is primarily useful for defining more complex #' priors, for refitting models without recompilation despite #' changing priors, or for defining custom Stan functions. #' #' @aliases stanvars #' #' @param x An \R object containing data to be passed to Stan. #' Only required if \code{block = 'data'} and ignored otherwise. #' @param name Optional character string providing the desired variable #' name of the object in \code{x}. If \code{NULL} (the default) #' the variable name is directly inferred from \code{x}. #' @param scode Line of Stan code to define the variable #' in Stan language. If \code{block = 'data'}, the #' Stan code is inferred based on the class of \code{x} by default. #' @param block Name of one of Stan's program blocks in #' which the variable should be defined. Can be \code{'data'}, #' \code{'tdata'} (transformed data), \code{'parameters'}, #' \code{'tparameters'} (transformed parameters), \code{'model'}, #' \code{'likelihood'} (part of the model block where the likelihood is given), #' \code{'genquant'} (generated quantities) or \code{'functions'}. #' @param position Name of the position within the block where the #' Stan code should be placed. Currently allowed are \code{'start'} #' (the default) and \code{'end'} of the block. #' @param pll_args Optional Stan code to be put into the header #' of \code{partial_log_lik} functions. This ensures that the variables #' specified in \code{scode} can be used in the likelihood even when #' within-chain parallelization is activated via \code{\link{threading}}. #' #' @return An object of class \code{stanvars}. #' #' @details #' The \code{stanvar} function is not vectorized. Instead, multiple #' \code{stanvars} objects can be added together via \code{+} (see Examples). #' #' Special attention is necessary when using \code{stanvars} to inject #' code into the \code{'likelihood'} block while having \code{\link{threading}} #' activated. In this case, your custom Stan code may need adjustments to ensure #' correct observation indexing. Please investigate the generated Stan code via #' \code{\link[brms:stancode.default]{stancode}} to see which adjustments are necessary in your case. #' #' @examples #' bprior <- prior(normal(mean_intercept, 10), class = "Intercept") #' stanvars <- stanvar(5, name = "mean_intercept") #' stancode(count ~ Trt, epilepsy, prior = bprior, #' stanvars = stanvars) #' #' # define a multi-normal prior with known covariance matrix #' bprior <- prior(multi_normal(M, V), class = "b") #' stanvars <- stanvar(rep(0, 2), "M", scode = " vector[K] M;") + #' stanvar(diag(2), "V", scode = " matrix[K, K] V;") #' stancode(count ~ Trt + zBase, epilepsy, #' prior = bprior, stanvars = stanvars) #' #' # define a hierachical prior on the regression coefficients #' bprior <- set_prior("normal(0, tau)", class = "b") + #' set_prior("target += normal_lpdf(tau | 0, 10)", check = FALSE) #' stanvars <- stanvar(scode = "real tau;", #' block = "parameters") #' stancode(count ~ Trt + zBase, epilepsy, #' prior = bprior, stanvars = stanvars) #' #' # ensure that 'tau' is passed to the likelihood of a threaded model #' # not necessary for this example but may be necessary in other cases #' stanvars <- stanvar(scode = "real tau;", #' block = "parameters", pll_args = "real tau") #' stancode(count ~ Trt + zBase, epilepsy, #' stanvars = stanvars, threads = threading(2)) #' #' @export stanvar <- function(x = NULL, name = NULL, scode = NULL, block = "data", position = "start", pll_args = NULL) { vblocks <- c( "data", "tdata", "parameters", "tparameters", "model", "genquant", "functions", "likelihood" ) block <- match.arg(block, vblocks) vpositions <- c("start", "end") position <- match.arg(position, vpositions) if (block == "data") { if (is.null(x)) { stop2("Argument 'x' is required if block = 'data'.") } if (is.null(name)) { name <- deparse0(substitute(x)) } name <- as_one_character(name) if (!is_equal(name, make.names(name)) || grepl("\\.", name)) { stop2("'", limit_chars(name, 30), "' is not ", "a valid variable name in Stan.") } if (is.null(scode)) { # infer scode from x if (is.integer(x)) { if (length(x) == 1L) { scode <- paste0("int ", name) } else { scode <- paste0("array[", length(x), "] int ", name) } } else if (is.vector(x)) { if (length(x) == 1L) { scode <- paste0("real ", name) } else { scode <- paste0("vector[", length(x), "] ", name) } } else if (is.array(x)) { if (length(dim(x)) == 1L) { scode <- paste0("vector[", length(x), "] ", name) } else if (is.matrix(x)) { scode <- paste0("matrix[", nrow(x), ", ", ncol(x), "] ", name) } } if (is.null(scode)) { stop2( "'stanvar' could not infer the Stan code for an object ", "of class '", class(x), "'. Please specify the Stan code ", "manually via argument 'scode'." ) } scode <- paste0(scode, ";") } if (is.null(pll_args)) { # infer pll_args from x pll_type <- str_if(block %in% c("data", "tdata"), "data ") if (is.integer(x)) { if (length(x) == 1L) { pll_type <- paste0(pll_type, "int") } else { pll_type <- paste0(pll_type, "array[] int") } } else if (is.vector(x)) { if (length(x) == 1L) { pll_type <- paste0(pll_type, "real") } else { pll_type <- paste0(pll_type, "vector") } } else if (is.array(x)) { if (length(dim(x)) == 1L) { pll_type <- paste0(pll_type, "vector") } else if (is.matrix(x)) { pll_type <- paste0(pll_type, "matrix") } } if (!is.null(pll_type)) { pll_args <- paste0(pll_type, " ", name) } else { # don't throw an error because most people will not use threading pll_args <- character(0) } } } else { x <- NULL if (is.null(name)) { name <- "" } name <- as_one_character(name) if (is.null(scode)) { stop2("Argument 'scode' is required if block is not 'data'.") } scode <- as.character(scode) pll_args <- as.character(pll_args) } if (position == "end" && block %in% c("functions", "data")) { stop2("Position '", position, "' is not sensible for block '", block, "'.") } out <- nlist(name, sdata = x, scode, block, position, pll_args) structure(setNames(list(out), name), class = "stanvars") } # take a subset of a stanvars object # @param x a stanvars object # @param ... conditions defining the desired subset subset_stanvars <- function(x, ...) { x <- validate_stanvars(x) structure_not_null(x[find_elements(x, ...)], class = "stanvars") } # collapse Stan code provided in a stanvars object collapse_stanvars <- function(x, block = NULL, position = NULL) { x <- validate_stanvars(x) if (!length(x)) { return(character(0)) } if (!is.null(block)) { x <- subset_stanvars(x, block = block) } if (!is.null(position)) { x <- subset_stanvars(x, position = position) } if (!length(x)) { return("") } collapse(wsp(nsp = 2), ufrom_list(x, "scode"), "\n") } # collapse partial log-lik code provided in a stanvars object collapse_stanvars_pll_args <- function(x) { x <- validate_stanvars(x) if (!length(x)) { return(character(0)) } out <- ufrom_list(x, "pll_args") if (!length(out)) { return("") } collapse(", ", out) } # validate 'stanvars' objects validate_stanvars <- function(x, stan_funs = NULL) { if (is.null(x)) { x <- empty_stanvars() } if (!is.stanvars(x)) { stop2("Argument 'stanvars' is invalid. See ?stanvar for help.") } if (length(stan_funs) > 0) { warning2("Argument 'stan_funs' is deprecated. Please use argument ", "'stanvars' instead. See ?stanvar for more help.") stan_funs <- as_one_character(stan_funs) x <- x + stanvar(scode = stan_funs, block = "functions") } x } # add new data to stanvars # @param x a 'stanvars' object # @param newdata2 a list with new 'data2' objects # @return a 'stanvars' object add_newdata_stanvars <- function(x, newdata2) { stopifnot(is.stanvars(x)) stanvars_data <- subset_stanvars(x, block = "data") for (name in names(stanvars_data)) { if (name %in% names(newdata2)) { x[[name]]$sdata <- newdata2[[name]] } } x } #' @export c.stanvars <- function(x, ...) { dots <- lapply(list(...), validate_stanvars) class(x) <- "list" out <- unlist(c(list(x), dots), recursive = FALSE) svnames <- names(out)[nzchar(names(out))] if (any(duplicated(svnames))) { stop2("Duplicated names in 'stanvars' are not allowed.") } structure(out, class = "stanvars") } #' @export "+.stanvars" <- function(e1, e2) { c(e1, e2) } is.stanvars <- function(x) { inherits(x, "stanvars") } empty_stanvars <- function() { structure(list(), class = "stanvars") } brms/R/formula-gp.R0000644000176200001440000004243115057501172013621 0ustar liggesusers# R helper functions for Gaussian Processes #' Set up Gaussian process terms in \pkg{brms} #' #' Set up a Gaussian process (GP) term in \pkg{brms}. The function does not #' evaluate its arguments -- it exists purely to help set up a model with #' GP terms. #' #' @param ... One or more predictors for the GP. #' @param by A numeric or factor variable of the same length as #' each predictor. In the numeric vector case, the elements multiply #' the values returned by the GP. In the factor variable #' case, a separate GP is fitted for each factor level. #' @param k Optional number of basis functions for computing Hilbert-space #' approximate GPs. If \code{NA} (the default), exact GPs are computed. #' @param cov Name of the covariance kernel. Currently supported are #' \code{"exp_quad"} (exponentiated-quadratic kernel; default), #' \code{"matern32"} (Matern 3/2 kernel), \code{"matern52"} (Matern 5/2 kernel), #' and \code{"exponential"} (exponential kernel; alias: \code{"matern12"}). #' @param iso A flag to indicate whether an isotropic (\code{TRUE}; the #' default) or a non-isotropic GP should be used. #' In the former case, the same amount of smoothing is applied to all #' predictors. In the latter case, predictors may have different smoothing. #' Ignored if only a single predictor is supplied. #' @param gr Logical; Indicates if auto-grouping should be used (defaults #' to \code{TRUE}). If enabled, observations sharing the same #' predictor values will be represented by the same latent variable #' in the GP. This will improve sampling efficiency #' drastically if the number of unique predictor combinations is small #' relative to the number of observations. #' @param cmc Logical; Only relevant if \code{by} is a factor. If \code{TRUE} #' (the default), cell-mean coding is used for the \code{by}-factor, that is #' one GP per level is estimated. If \code{FALSE}, contrast GPs are estimated #' according to the contrasts set for the \code{by}-factor. #' @param scale Logical; If \code{TRUE} (the default), predictors are #' scaled so that the maximum Euclidean distance between two points #' is 1. This often improves sampling speed and convergence. #' Scaling also affects the estimated length-scale parameters #' in that they resemble those of scaled predictors (not of the original #' predictors) if \code{scale} is \code{TRUE}. #' @param c Numeric value only used in approximate GPs. Defines the #' multiplicative constant of the predictors' range over which #' predictions should be computed. A good default could be \code{c = 5/4} #' but we are still working on providing better recommendations. #' #' @details A GP is a stochastic process, which #' describes the relation between one or more predictors #' \eqn{x = (x_1, ..., x_d)} and a response \eqn{f(x)}, where #' \eqn{d} is the number of predictors. A GP is the #' generalization of the multivariate normal distribution #' to an infinite number of dimensions. Thus, it can be #' interpreted as a prior over functions. The values of \eqn{f( )} #' at any finite set of locations are jointly multivariate #' normal, with a covariance matrix defined by the covariance #' kernel \eqn{k_p(x_i, x_j)}, where \eqn{p} is the vector of parameters #' of the GP: #' \deqn{(f(x_1), \ldots f(x_n) \sim MVN(0, (k_p(x_i, x_j))_{i,j=1}^n) .} #' The smoothness and general behavior of the function \eqn{f} #' depends only on the choice of covariance kernel. #' For a more detailed introduction to Gaussian processes, #' see \url{https://en.wikipedia.org/wiki/Gaussian_process}. #' #' For mathematical details on the supported kernels, please see the Stan manual: #' \url{https://mc-stan.org/docs/functions-reference/matrix_operations.html} #' under "Gaussian Process Covariance Functions". #' #' There are several parameters estimated for GPs, the most important of which #' are as follows: #' \tabular{llll}{ #' \strong{Parameter} \tab \strong{Notation} \tab \strong{Support} \tab \strong{Meaning} \cr #' \code{lscale} \tab \eqn{\ell} \tab \eqn{\mathbb{R}^+} \tab length-scale of the GP's covariance kernel \cr #' \code{sdgp} \tab \eqn{\sigma} \tab \eqn{\mathbb{R}^+} \tab marginal standard deviation of the GP's covariance kernel \cr #' \code{zgp} \tab \eqn{z} \tab \eqn{\mathbb{R}} \tab latent variable values of the training data \cr #' } #' Assuming an exponentiated quadratic covariance structure, the parameters #' can be broadly interpreted as follows (see also #' \url{https://mc-stan.org/docs/stan-users-guide/gaussian-processes.html#gaussian-process-regression}). #' Note that in the above documentation the parameter \eqn{\sigma} is denoted #' as \eqn{\alpha} instead, and the parameter \eqn{\ell} as \eqn{\rho}. #' The length-scale \eqn{\ell} controls the frequency of the functions #' represented by the GP prior i.e., values of \eqn{\ell \gg 0} lead to #' lower-frequency functions, while values of \eqn{\ell \approx 0} lead to #' higher-frequency functions. In slightly simpler terms, \eqn{\ell} sets #' the distance over which observations in the input space are strongly #' correlated. The marginal standard deviation \eqn{\sigma} controls the #' magnitude of the range of the function represented by the GP i.e., it #' represents how much the values of the function tend to deviate from the #' mean level. Lastly, the parameter \eqn{z} represents latent variable values #' per observation (or unique input point). #' #' @return An object of class \code{'gp_term'}, which is a list #' of arguments to be interpreted by the formula #' parsing functions of \pkg{brms}. #' #' @examples #' \dontrun{ #' # simulate data using the mgcv package #' dat <- mgcv::gamSim(1, n = 30, scale = 2) #' #' # fit a simple GP model #' fit1 <- brm(y ~ gp(x2), dat, chains = 2) #' summary(fit1) #' me1 <- conditional_effects(fit1, ndraws = 200, spaghetti = TRUE) #' plot(me1, ask = FALSE, points = TRUE) #' #' # fit a more complicated GP model and use an approximate GP for x2 #' fit2 <- brm(y ~ gp(x0) + x1 + gp(x2, k = 10) + x3, dat, chains = 2) #' summary(fit2) #' me2 <- conditional_effects(fit2, ndraws = 200, spaghetti = TRUE) #' plot(me2, ask = FALSE, points = TRUE) #' #' # fit a multivariate GP model with Matern 3/2 kernel #' fit3 <- brm(y ~ gp(x1, x2, cov = "matern32"), dat, chains = 2) #' summary(fit3) #' me3 <- conditional_effects(fit3, ndraws = 200, spaghetti = TRUE) #' plot(me3, ask = FALSE, points = TRUE) #' #' # compare model fit #' loo(fit1, fit2, fit3) #' #' # simulate data with a factor covariate #' dat2 <- mgcv::gamSim(4, n = 90, scale = 2) #' #' # fit separate gaussian processes for different levels of 'fac' #' fit4 <- brm(y ~ gp(x2, by = fac), dat2, chains = 2) #' summary(fit4) #' plot(conditional_effects(fit4), points = TRUE) #' } #' #' @seealso \code{\link{brmsformula}} #' @export gp <- function(..., by = NA, k = NA, cov = "exp_quad", iso = TRUE, gr = TRUE, cmc = TRUE, scale = TRUE, c = 5/4) { call <- match.call() label <- deparse0(call) vars <- as.list(substitute(list(...)))[-1] cov <- validate_gp_cov(cov, k = k) by <- deparse0(substitute(by)) cmc <- as_one_logical(cmc) if (is.null(call[["gr"]]) && require_old_default("2.12.8")) { # the default of 'gr' has changed in version 2.12.8 gr <- FALSE } else { gr <- as_one_logical(gr) } if (length(vars) > 1L) { iso <- as_one_logical(iso) } else { iso <- TRUE } if (!isNA(k)) { k <- as.integer(as_one_numeric(k)) if (k < 1L) { stop2("'k' must be positive.") } c <- as.numeric(c) if (length(c) == 1L) { c <- rep(c, length(vars)) } if (length(c) != length(vars)) { stop2("'c' must be of the same length as the number of covariates.") } if (any(c <= 0)) { stop2("'c' must be positive.") } } else { c <- NA } scale <- as_one_logical(scale) term <- ulapply(vars, deparse0, backtick = TRUE, width.cutoff = 500L) out <- nlist(term, label, by, cov, k, iso, gr, cmc, scale, c) structure(out, class = "gp_term") } # get labels of gaussian process terms # @param x either a formula or a list containing an element "gp" # @param data data frame containing the covariates # @return a data.frame with one row per GP term frame_gp <- function(x, data) { if (is.formula(x)) { x <- brmsterms(x, check_response = FALSE)$dpars$mu } form <- x[["gp"]] if (!is.formula(form)) { return(empty_data_frame()) } out <- data.frame( term = all_terms(form), label = NA, cov = NA, k = NA, iso = NA, gr = NA, scale = NA, stringsAsFactors = FALSE ) nterms <- nrow(out) out$cons <- out$byvars <- out$covars <- out$sfx1 <- out$sfx2 <- out$c <- vector("list", nterms) for (i in seq_len(nterms)) { gp <- eval2(out$term[i]) out$label[i] <- paste0("gp", rename(collapse(gp$term))) out$cov[i] <- gp$cov out$k[i] <- gp$k out$c[[i]] <- gp$c out$iso[i] <- gp$iso out$cmc[i] <- gp$cmc out$gr[i] <- gp$gr out$scale[i] <- gp$scale out$covars[[i]] <- gp$term if (gp$by != "NA") { out$byvars[[i]] <- gp$by str_add(out$label[i]) <- rename(gp$by) byval <- get(gp$by, data) if (is_like_factor(byval)) { byval <- unique(as.factor(byval)) byform <- str2formula(c(ifelse(gp$cmc, "0", "1"), "byval")) cons <- rename(colnames(model.matrix(byform))) out$cons[[i]] <- rm_wsp(sub("^byval", "", cons)) } } # sfx1 is for sdgp and sfx2 is for lscale out$sfx1[[i]] <- paste0(out$label[i], out$cons[[i]]) if (out$iso[i]) { out$sfx2[[i]] <- matrix(out$sfx1[[i]]) } else { out$sfx2[[i]] <- outer(out$sfx1[[i]], out$covars[[i]], paste0) } } class(out) <- gpframe_class() out } gpframe_class <- function() { c("gpframe", "data.frame") } is.gpframe <- function(x) { inherits(x, "gpframe") } # covariance matrix of Gaussian processes # not vectorized over parameter values cov_gp <- function(x, x_new = NULL, sdgp = 1, lscale = 1, cov = "exp_quad") { sdgp <- as.numeric(sdgp) lscale <- as.numeric(lscale) Dls <- length(lscale) cov <- as_one_character(cov) cov_fun <- paste0("cov_gp_", cov) cov_fun <- get(cov_fun, asNamespace("brms")) if (Dls == 1L) { # one dimensional or isotropic GP diff_quad <- diff_quad(x = x, x_new = x_new) out <- cov_fun(diff_quad, sdgp = sdgp, lscale = lscale) } else { # multi-dimensional non-isotropic GP diff_quad <- diff_quad(x = x[, 1], x_new = x_new[, 1]) out <- cov_fun(diff_quad, sdgp = sdgp, lscale = lscale[1]) for (d in seq_len(Dls)[-1]) { diff_quad <- diff_quad(x = x[, d], x_new = x_new[, d]) # sdgp = 1 as to not multiply the cov matrix with sdgp more than once out <- out * cov_fun(diff_quad, sdgp = 1, lscale = lscale[d]) } } out } # Squared exponential covariance kernel # @param diff_quad squared difference matrix cov_gp_exp_quad <- function(diff_quad, sdgp, lscale) { sdgp^2 * exp(-diff_quad / (2 * lscale^2)) } # Exponential covariance kernel cov_gp_exponential <- function(diff_quad, sdgp, lscale) { diff_abs <- sqrt(diff_quad) sdgp^2 * exp(-diff_abs / lscale) } # Matern 3/2 covariance kernel cov_gp_matern32 <- function(diff_quad, sdgp, lscale) { diff_abs <- sqrt(diff_quad) sdgp^2 * (1 + sqrt(3) * diff_abs / lscale) * exp(- sqrt(3) * diff_abs / lscale) } # Matern 5/2 covariance kernel cov_gp_matern52 <- function(diff_quad, sdgp, lscale) { diff_abs <- sqrt(diff_quad) sdgp^2 * (1 + sqrt(5) * diff_abs / lscale + 5 * diff_quad / (3 * lscale^2)) * exp(- sqrt(5) * diff_abs / lscale) } # compute squared differences # @param x vector or matrix # @param x_new optional vector of matrix with the same ncol as x # @return an nrow(x) times nrow(x_new) matrix # @details if matrices are passed results are summed over the columns diff_quad <- function(x, x_new = NULL) { x <- as.matrix(x) if (is.null(x_new)) { x_new <- x } else { x_new <- as.matrix(x_new) } .diff_quad <- function(x1, x2) (x1 - x2)^2 out <- 0 for (i in seq_cols(x)) { out <- out + outer(x[, i], x_new[, i], .diff_quad) } out } # spectral density function for approximate Gaussian processes # vectorized over parameter values spd_gp <- function(x, sdgp = 1, lscale = 1, cov = "exp_quad") { spd_fun <- paste0("spd_gp_", cov) spd_fun <- get(spd_fun, asNamespace("brms")) spd_fun(x, sdgp = sdgp, lscale = lscale) } # spectral density function of the squared exponential kernel # vectorized over parameter values spd_gp_exp_quad <- function(x, sdgp = 1, lscale = 1) { NB <- NROW(x) D <- NCOL(x) Dls <- NCOL(lscale) constant <- sdgp^2 * sqrt(2 * pi)^D out <- matrix(nrow = length(sdgp), ncol = NB) if (Dls == 1L) { # one dimensional or isotropic GP constant <- constant * lscale^D neg_half_lscale2 <- -0.5 * lscale^2 for (m in seq_len(NB)) { out[, m] <- constant * exp(neg_half_lscale2 * sum(x[m, ]^2)) } } else { # multi-dimensional non-isotropic GP constant <- constant * matrixStats::rowProds(lscale) neg_half_lscale2 = -0.5 * lscale^2 for (m in seq_len(NB)) { x2 <- data2draws(x[m, ]^2, dim = dim(lscale)) out[, m] <- constant * exp(rowSums(neg_half_lscale2 * x2)) } } out } # spectral density function of the exponential kernel # vectorized over parameter values spd_gp_exponential <- function(x, sdgp = 1, lscale = 1) { NB <- NROW(x) D <- NCOL(x) Dls <- NCOL(lscale) constant = square(sdgp) * (2^D * pi^(D / 2) * gamma((D + 1) / 2)) / sqrt(pi) expo = -(D + 1) / 2 lscale2 <- lscale^2 out <- matrix(nrow = length(sdgp), ncol = NB) if (Dls == 1L) { # one dimensional or isotropic GP constant <- constant * lscale^D for (m in seq_len(NB)) { out[, m] <- constant * (1 + lscale2 * sum(x[m, ]^2))^expo; } } else { # multi-dimensional non-isotropic GP constant <- constant * matrixStats::rowProds(lscale) for (m in seq_len(NB)) { x2 <- data2draws(x[m, ]^2, dim = dim(lscale)) out[, m] <- constant * (1 + rowSums(lscale2 * x2))^expo } } out } # spectral density function of the Matern 3/2 kernel # vectorized over parameter values spd_gp_matern32 <- function(x, sdgp = 1, lscale = 1) { NB <- NROW(x) D <- NCOL(x) Dls <- NCOL(lscale) constant = square(sdgp) * (2^D * pi^(D / 2) * gamma((D + 3) / 2) * 3^(3 / 2)) / (0.5 * sqrt(pi)) expo = -(D + 3) / 2 lscale2 <- lscale^2 out <- matrix(nrow = length(sdgp), ncol = NB) if (Dls == 1L) { # one dimensional or isotropic GP constant <- constant * lscale^D for (m in seq_len(NB)) { out[, m] <- constant * (3 + lscale2 * sum(x[m, ]^2))^expo; } } else { # multi-dimensional non-isotropic GP constant <- constant * matrixStats::rowProds(lscale) for (m in seq_len(NB)) { x2 <- data2draws(x[m, ]^2, dim = dim(lscale)) out[, m] <- constant * (3 + rowSums(lscale2 * x2))^expo } } out } # spectral density function of the Matern 5/2 kernel # vectorized over parameter values spd_gp_matern52 <- function(x, sdgp = 1, lscale = 1) { NB <- NROW(x) D <- NCOL(x) Dls <- NCOL(lscale) constant = square(sdgp) * (2^D * pi^(D / 2) * gamma((D + 5) / 2) * 5^(5 / 2)) / (0.75 * sqrt(pi)) expo = -(D + 5) / 2 lscale2 <- lscale^2 out <- matrix(nrow = length(sdgp), ncol = NB) if (Dls == 1L) { # one dimensional or isotropic GP constant <- constant * lscale^D for (m in seq_len(NB)) { out[, m] <- constant * (5 + lscale2 * sum(x[m, ]^2))^expo; } } else { # multi-dimensional non-isotropic GP constant <- constant * matrixStats::rowProds(lscale) for (m in seq_len(NB)) { x2 <- data2draws(x[m, ]^2, dim = dim(lscale)) out[, m] <- constant * (5 + rowSums(lscale2 * x2))^expo } } out } # compute the mth eigen value of an approximate GP eigen_val_laplacian <- function(m, L) { ((m * pi) / (2 * L))^2 } # compute the mth eigen function of an approximate GP eigen_fun_laplacian <- function(x, m, L) { x <- as.matrix(x) D <- ncol(x) stopifnot(length(m) == D, length(L) == D) out <- vector("list", D) for (i in seq_cols(x)) { out[[i]] <- 1 / sqrt(L[i]) * sin((m[i] * pi) / (2 * L[i]) * (x[, i] + L[i])) } Reduce("*", out) } # extended range of input data for which predictions should be made choose_L <- function(x, c) { if (!length(x)) { range <- 1 } else { range <- max(1, max(x, na.rm = TRUE) - min(x, na.rm = TRUE)) } c * range } # validate the 'cov' argument of 'gp' terms validate_gp_cov <- function(cov, k = NA) { cov <- as_one_character(cov) if (cov == "matern12") { # matern12 and exponential refer to the same kernel cov <- "exponential" } cov_choices <- c("exp_quad", "matern52", "matern32", "exponential") if (!cov %in% cov_choices) { stop2("'", cov, "' is not a valid GP covariance kernel. Valid kernels are: ", collapse_comma(cov_choices)) } if (!isNA(k)) { # currently all kernels support HSGPs but this may change in the future hs_cov_choices <- c("exp_quad", "matern52", "matern32", "exponential") if (!cov %in% hs_cov_choices) { stop2("HSGPs with covariance kernel '", cov, "' are not yet supported.") } } cov } # try to evaluate a GP term and # return an informative error message if it fails try_nug <- function(expr, nug) { out <- try(expr, silent = TRUE) if (is_try_error(out)) { stop2("The Gaussian process covariance matrix is not positive ", "definite.\nThis occurs for numerical reasons. Setting ", "'nug' above ", nug, " may help.") } out } brms/R/datasets.R0000644000176200001440000001533614527413457013375 0ustar liggesusers#' Infections in kidney patients #' #' @description This dataset, originally discussed in #' McGilchrist and Aisbett (1991), describes the first and second #' (possibly right censored) recurrence time of #' infection in kidney patients using portable dialysis equipment. #' In addition, information on the risk variables age, sex and disease #' type is provided. #' #' @format A data frame of 76 observations containing #' information on the following 7 variables. #' \describe{ #' \item{time}{The time to first or second recurrence of the infection, #' or the time of censoring} #' \item{recur}{A factor of levels \code{1} or \code{2} #' indicating if the infection recurred for the first #' or second time for this patient} #' \item{censored}{Either \code{0} or \code{1}, where \code{0} indicates #' no censoring of recurrence time and \code{1} indicates right censoring} #' \item{patient}{The patient number} #' \item{age}{The age of the patient} #' \item{sex}{The sex of the patient} #' \item{disease}{A factor of levels \code{other, GN, AN}, #' and \code{PKD} specifying the type of disease} #' } #' #' @source McGilchrist, C. A., & Aisbett, C. W. (1991). #' Regression with frailty in survival analysis. #' \emph{Biometrics}, 47(2), 461-466. #' #' @examples #' \dontrun{ #' ## performing surivival analysis using the "weibull" family #' fit1 <- brm(time | cens(censored) ~ age + sex + disease, #' data = kidney, family = weibull, init = "0") #' summary(fit1) #' plot(fit1) #' #' ## adding random intercepts over patients #' fit2 <- brm(time | cens(censored) ~ age + sex + disease + (1|patient), #' data = kidney, family = weibull(), init = "0", #' prior = set_prior("cauchy(0,2)", class = "sd")) #' summary(fit2) #' plot(fit2) #' } #' "kidney" #' Clarity of inhaler instructions #' #' @description Ezzet and Whitehead (1991) analyze data from a two-treatment, #' two-period crossover trial to compare 2 inhalation devices for #' delivering the drug salbutamol in 286 asthma patients. #' Patients were asked to rate the clarity of leaflet instructions #' accompanying each device, using a 4-point ordinal scale. #' #' @format A data frame of 572 observations containing #' information on the following 5 variables. #' \describe{ #' \item{subject}{The subject number} #' \item{rating}{The rating of the inhaler instructions #' on a scale ranging from 1 to 4} #' \item{treat}{A contrast to indicate which of #' the two inhaler devices was used} #' \item{period}{A contrast to indicate the time of administration} #' \item{carry}{A contrast to indicate possible carry over effects} #' } #' #' @source Ezzet, F., & Whitehead, J. (1991). #' A random effects model for ordinal responses from a crossover trial. #' \emph{Statistics in Medicine}, 10(6), 901-907. #' #' @examples #' \dontrun{ #' ## ordinal regression with family "sratio" #' fit1 <- brm(rating ~ treat + period + carry, #' data = inhaler, family = sratio(), #' prior = set_prior("normal(0,5)")) #' summary(fit1) #' plot(fit1) #' #' ## ordinal regression with family "cumulative" #' ## and random intercept over subjects #' fit2 <- brm(rating ~ treat + period + carry + (1|subject), #' data = inhaler, family = cumulative(), #' prior = set_prior("normal(0,5)")) #' summary(fit2) #' plot(fit2) #' } #' "inhaler" #' Epileptic seizure counts #' #' @description Breslow and Clayton (1993) analyze data initially #' provided by Thall and Vail (1990) concerning #' seizure counts in a randomized trial of anti-convulsant #' therapy in epilepsy. Covariates are treatment, #' 8-week baseline seizure counts, and age of the patients in years. #' #' @format A data frame of 236 observations containing information #' on the following 9 variables. #' \describe{ #' \item{Age}{The age of the patients in years} #' \item{Base}{The seizure count at 8-weeks baseline} #' \item{Trt}{Either \code{0} or \code{1} indicating #' if the patient received anti-convulsant therapy} #' \item{patient}{The patient number} #' \item{visit}{The session number from \code{1} (first visit) #' to \code{4} (last visit)} #' \item{count}{The seizure count between two visits} #' \item{obs}{The observation number, that is #' a unique identifier for each observation} #' \item{zAge}{Standardized \code{Age}} #' \item{zBase}{Standardized \code{Base}} #' } #' #' @source Thall, P. F., & Vail, S. C. (1990). #' Some covariance models for longitudinal count data with overdispersion. #' \emph{Biometrics, 46(2)}, 657-671. \cr #' #' Breslow, N. E., & Clayton, D. G. (1993). #' Approximate inference in generalized linear mixed models. #' \emph{Journal of the American Statistical Association}, 88(421), 9-25. #' #' @examples #' \dontrun{ #' ## poisson regression without random effects. #' fit1 <- brm(count ~ zAge + zBase * Trt, #' data = epilepsy, family = poisson()) #' summary(fit1) #' plot(fit1) #' #' ## poisson regression with varying intercepts of patients #' ## as well as normal priors for overall effects parameters. #' fit2 <- brm(count ~ zAge + zBase * Trt + (1|patient), #' data = epilepsy, family = poisson(), #' prior = set_prior("normal(0,5)")) #' summary(fit2) #' plot(fit2) #' } #' "epilepsy" #' Cumulative Insurance Loss Payments #' #' @description This dataset, discussed in Gesmann & Morris (2020), contains #' cumulative insurance loss payments over the course of ten years. #' #' @format A data frame of 55 observations containing information #' on the following 4 variables. #' \describe{ #' \item{AY}{Origin year of the insurance (1991 to 2000)} #' \item{dev}{Deviation from the origin year in months} #' \item{cum}{Cumulative loss payments} #' \item{premium}{Achieved premiums for the given origin year} #' } #' #' @source Gesmann M. & Morris J. (2020). Hierarchical Compartmental Reserving #' Models. \emph{CAS Research Papers}. #' #' @examples #' \dontrun{ #' # non-linear model to predict cumulative loss payments #' fit_loss <- brm( #' bf(cum ~ ult * (1 - exp(-(dev/theta)^omega)), #' ult ~ 1 + (1|AY), omega ~ 1, theta ~ 1, #' nl = TRUE), #' data = loss, family = gaussian(), #' prior = c( #' prior(normal(5000, 1000), nlpar = "ult"), #' prior(normal(1, 2), nlpar = "omega"), #' prior(normal(45, 10), nlpar = "theta") #' ), #' control = list(adapt_delta = 0.9) #' ) #' #' # basic summaries #' summary(fit_loss) #' conditional_effects(fit_loss) #' #' # plot predictions per origin year #' conditions <- data.frame(AY = unique(loss$AY)) #' rownames(conditions) <- unique(loss$AY) #' me_loss <- conditional_effects( #' fit_loss, conditions = conditions, #' re_formula = NULL, method = "predict" #' ) #' plot(me_loss, ncol = 5, points = TRUE) #' } #' "loss" brms/R/brmsformula.R0000644000176200001440000021217715057506034014111 0ustar liggesusers#' Set up a model formula for use in \pkg{brms} #' #' Set up a model formula for use in the \pkg{brms} package #' allowing to define (potentially non-linear) additive multilevel #' models for all parameters of the assumed response distribution. #' #' @aliases bf #' #' @param formula An object of class \code{formula} #' (or one that can be coerced to that class): #' a symbolic description of the model to be fitted. #' The details of model specification are given in 'Details'. #' @param ... Additional \code{formula} objects to specify predictors of #' non-linear and distributional parameters. Formulas can either be named #' directly or contain names on their left-hand side. Alternatively, #' it is possible to fix parameters to certain values by passing #' numbers or character strings in which case arguments have to be named #' to provide the parameter names. See 'Details' for more information. #' @param flist Optional list of formulas, which are treated in the #' same way as formulas passed via the \code{...} argument. #' @param nl Logical; Indicates whether \code{formula} should be #' treated as specifying a non-linear model. By default, \code{formula} #' is treated as an ordinary linear model formula. #' @param loop Logical; Only used in non-linear models. #' Indicates if the computation of the non-linear formula should be #' done inside (\code{TRUE}) or outside (\code{FALSE}) a loop #' over observations. Defaults to \code{TRUE}. #' @param center Logical; Indicates if the population-level design #' matrix should be centered, which usually increases sampling efficiency. #' See the 'Details' section for more information. #' Defaults to \code{TRUE} for distributional parameters #' and to \code{FALSE} for non-linear parameters. #' @param cmc Logical; Indicates whether automatic cell-mean coding #' should be enabled when removing the intercept by adding \code{0} #' to the right-hand of model formulas. Defaults to \code{TRUE} to #' mirror the behavior of standard \R formula parsing. #' @param sparse Logical; indicates whether the population-level design matrices #' should be treated as sparse (defaults to \code{FALSE}). For design matrices #' with many zeros, this can considerably reduce required memory. Sampling #' speed is currently not improved or even slightly decreased. #' @param decomp Optional name of the decomposition used for the #' population-level design matrix. Defaults to \code{NULL} that is #' no decomposition. Other options currently available are #' \code{"QR"} for the QR decomposition that helps in fitting models #' with highly correlated predictors. #' @param family Same argument as in \code{\link{brm}}. #' If \code{family} is specified in \code{brmsformula}, it will #' overwrite the value specified in other functions. #' @param autocor An optional \code{formula} which contains #' autocorrelation terms as described in \code{\link{autocor-terms}} #' or alternatively a \code{\link{cor_brms}} object (deprecated). #' If \code{autocor} is specified in \code{brmsformula}, it will #' overwrite the value specified in other functions. #' @param unused An optional \code{formula} which contains variables #' that are unused in the model but should still be stored in the #' model's data frame. This can be useful, for example, #' if those variables are required for post-processing the model. #' #' @return An object of class \code{brmsformula}, which #' is essentially a \code{list} containing all model #' formulas as well as some additional information. #' #' @seealso \code{\link{mvbrmsformula}}, \code{\link{brmsformula-helpers}} #' #' @details #' #' \bold{General formula structure} #' #' The \code{formula} argument accepts formulas of the following syntax: #' #' \code{response | aterms ~ pterms + (gterms | group)} #' #' The \code{pterms} part contains effects that are assumed to be the same #' across observations. We call them 'population-level' or 'overall' effects, #' or (adopting frequentist vocabulary) 'fixed' effects. The optional #' \code{gterms} part may contain effects that are assumed to vary across #' grouping variables specified in \code{group}. We call them 'group-level' or #' 'varying' effects, or (adopting frequentist vocabulary) 'random' effects, #' although the latter name is misleading in a Bayesian context. For more #' details type \code{vignette("brms_overview")} and #' \code{vignette("brms_multilevel")}. #' #' \bold{Group-level terms} #' #' Multiple grouping factors each with multiple group-level effects are #' possible. (Of course we can also run models without any group-level #' effects.) Instead of \code{|} you may use \code{||} in grouping terms to #' prevent correlations from being modeled. Equivalently, the \code{cor} #' argument of the \code{\link{gr}} function can be used for this purpose, #' for example, \code{(1 + x || g)} is equivalent to #' \code{(1 + x | gr(g, cor = FALSE))}. #' #' It is also possible to model different group-level terms of the same #' grouping factor as correlated (even across different formulas, e.g., in #' non-linear models) by using \code{||} instead of \code{|}. All #' group-level terms sharing the same ID will be modeled as correlated. If, #' for instance, one specifies the terms \code{(1+x|i|g)} and \code{(1+z|i|g)} #' somewhere in the formulas passed to \code{brmsformula}, correlations #' between the corresponding group-level effects will be estimated. In the #' above example, \code{i} is not a variable in the data but just a symbol to #' indicate correlations between multiple group-level terms. Equivalently, the #' \code{id} argument of the \code{\link{gr}} function can be used as well, #' for example, \code{(1 + x | gr(g, id = "i"))}. #' #' If levels of the grouping factor belong to different sub-populations, #' it may be reasonable to assume a different covariance matrix for each #' of the sub-populations. For instance, the variation within the #' treatment group and within the control group in a randomized control #' trial might differ. Suppose that \code{y} is the outcome, and #' \code{x} is the factor indicating the treatment and control group. #' Then, we could estimate different hyper-parameters of the varying #' effects (in this case a varying intercept) for treatment and control #' group via \code{y ~ x + (1 | gr(subject, by = x))}. #' #' You can specify multi-membership terms using the \code{\link{mm}} #' function. For instance, a multi-membership term with two members #' could be \code{(1 | mm(g1, g2))}, where \code{g1} and \code{g2} #' specify the first and second member, respectively. Moreover, #' if a covariate \code{x} varies across the levels of the grouping-factors #' \code{g1} and \code{g2}, we can save the respective covariate values #' in the variables \code{x1} and \code{x2} and then model the varying #' effect as \code{(1 + mmc(x1, x2) | mm(g1, g2))}. #' #' \bold{Special predictor terms} #' #' Flexible non-linear smooth terms can modeled using the \code{\link{s}} #' and \code{\link{t2}} functions in the \code{pterms} part #' of the model formula. This allows to fit generalized additive mixed #' models (GAMMs) with \pkg{brms}. The implementation is similar to that #' used in the \pkg{gamm4} package. For more details on this model class #' see \code{\link[mgcv:gam]{gam}} and \code{\link[mgcv:gamm]{gamm}}. #' #' Gaussian process terms can be fitted using the \code{\link{gp}} #' function in the \code{pterms} part of the model formula. Similar to #' smooth terms, Gaussian processes can be used to model complex non-linear #' relationships, for instance temporal or spatial autocorrelation. #' However, they are computationally demanding and are thus not recommended #' for very large datasets or approximations need to be used. #' #' The \code{pterms} and \code{gterms} parts may contain four non-standard #' effect types namely monotonic, measurement error, missing value, and #' category specific effects, which can be specified using terms of the #' form \code{mo(predictor)}, \code{me(predictor, sd_predictor)}, #' \code{mi(predictor)}, and \code{cs()}, respectively. #' Category specific effects can only be estimated in #' ordinal models and are explained in more detail in the package's #' main vignette (type \code{vignette("brms_overview")}). #' The other three effect types are explained in the following. #' #' A monotonic predictor must either be integer valued or an ordered factor, #' which is the first difference to an ordinary continuous predictor. #' More importantly, predictor categories (or integers) are not assumed to be #' equidistant with respect to their effect on the response variable. #' Instead, the distance between adjacent predictor categories (or integers) #' is estimated from the data and may vary across categories. #' This is realized by parameterizing as follows: #' One parameter takes care of the direction and size of the effect similar #' to an ordinary regression parameter, while an additional parameter vector #' estimates the normalized distances between consecutive predictor categories. #' A main application of monotonic effects are ordinal predictors that #' can this way be modeled without (falsely) treating them as continuous #' or as unordered categorical predictors. For more details and examples #' see \code{vignette("brms_monotonic")}. #' #' Quite often, predictors are measured and as such naturally contain #' measurement error. Although most researchers are well aware of this problem, #' measurement error in predictors is ignored in most #' regression analyses, possibly because only few packages allow #' for modeling it. Notably, measurement error can be handled in #' structural equation models, but many more general regression models #' (such as those featured by \pkg{brms}) cannot be transferred #' to the SEM framework. In \pkg{brms}, effects of noise-free predictors #' can be modeled using the \code{me} (for 'measurement error') function. #' If, say, \code{y} is the response variable and #' \code{x} is a measured predictor with known measurement error #' \code{sdx}, we can simply include it on the right-hand side of the #' model formula via \code{y ~ me(x, sdx)}. #' This can easily be extended to more general formulas. #' If \code{x2} is another measured predictor with corresponding error #' \code{sdx2} and \code{z} is a predictor without error #' (e.g., an experimental setting), we can model all main effects #' and interactions of the three predictors in the well known manner: #' \code{y ~ me(x, sdx) * me(x2, sdx2) * z}. #' The \code{me} function is soft deprecated in favor of the more flexible #' and consistent \code{mi} function (see below). #' #' When a variable contains missing values, the corresponding rows will #' be excluded from the data by default (row-wise exclusion). However, #' quite often we want to keep these rows and instead estimate the missing values. #' There are two approaches for this: (a) Impute missing values before #' the model fitting for instance via multiple imputation (see #' \code{\link{brm_multiple}} for a way to handle multiple imputed datasets). #' (b) Impute missing values on the fly during model fitting. The latter #' approach is explained in the following. Using a variable with missing #' values as predictors requires two things, First, we need to specify that #' the predictor contains missings that should to be imputed. #' If, say, \code{y} is the primary response, \code{x} is a #' predictor with missings and \code{z} is a predictor without missings, #' we go for \code{y ~ mi(x) + z}. Second, we need to model \code{x} #' as an additional response with corresponding predictors and the #' addition term \code{mi()}. In our example, we could write #' \code{x | mi() ~ z}. Measurement error may be included via #' the \code{sdy} argument, say, \code{x | mi(sdy = se) ~ z}. #' See \code{\link{mi}} for examples with real data. #' #' #' \bold{Autocorrelation terms} #' #' Autocorrelation terms can be directly specified inside the \code{pterms} #' part as well. Details can be found in \code{\link{autocor-terms}}. #' #' \bold{Additional response information} #' #' Another special of the \pkg{brms} formula syntax is the optional #' \code{aterms} part, which may contain multiple terms of the form #' \code{fun()} separated by \code{+} each providing special #' information on the response variable. \code{fun} can be replaced with #' either \code{se}, \code{weights}, \code{subset}, \code{cens}, \code{trunc}, #' \code{trials}, \code{cat}, \code{dec}, \code{rate}, \code{vreal}, or #' \code{vint}. Their meanings are explained below #' (see also \code{\link{addition-terms}}). #' #' For families \code{gaussian}, \code{student} and \code{skew_normal}, it is #' possible to specify standard errors of the observations, thus allowing #' to perform meta-analysis. Suppose that the variable \code{yi} contains #' the effect sizes from the studies and \code{sei} the corresponding #' standard errors. Then, fixed and random effects meta-analyses can #' be conducted using the formulas \code{yi | se(sei) ~ 1} and #' \code{yi | se(sei) ~ 1 + (1|study)}, respectively, where #' \code{study} is a variable uniquely identifying every study. #' If desired, meta-regression can be performed via #' \code{yi | se(sei) ~ 1 + mod1 + mod2 + (1|study)} #' or \cr \code{yi | se(sei) ~ 1 + mod1 + mod2 + (1 + mod1 + mod2|study)}, #' where \code{mod1} and \code{mod2} represent moderator variables. #' By default, the standard errors replace the parameter \code{sigma}. #' To model \code{sigma} in addition to the known standard errors, #' set argument \code{sigma} in function \code{se} to \code{TRUE}, #' for instance, \code{yi | se(sei, sigma = TRUE) ~ 1}. #' #' For all families, weighted regression may be performed using #' \code{weights} in the \code{aterms} part. Internally, this is #' implemented by multiplying the log-posterior values of each #' observation by their corresponding weights. #' Suppose that variable \code{wei} contains the weights #' and that \code{yi} is the response variable. #' Then, formula \code{yi | weights(wei) ~ predictors} #' implements a weighted regression. #' #' For multivariate models, \code{subset} may be used in the \code{aterms} #' part, to use different subsets of the data in different univariate #' models. For instance, if \code{sub} is a logical variable and #' \code{y} is the response of one of the univariate models, we may #' write \code{y | subset(sub) ~ predictors} so that \code{y} is #' predicted only for those observations for which \code{sub} evaluates #' to \code{TRUE}. #' #' For log-linear models such as Poisson models, \code{rate} may be used #' in the \code{aterms} part to specify the denominator of a response that #' is expressed as a rate. The numerator is given by the actual response #' variable and has a distribution according to the family as usual. #' In Poisson models, using \code{rate(denom)} is equivalent to adding #' \code{offset(log(denom))} to the linear predictor of the main parameter. #' For negative-binomial models, this equivalence no longer holds and #' \code{rate(denom)} remains the statistically correct approach. #' #' With the exception of categorical and ordinal families, #' left, right, and interval censoring can be modeled through #' \code{y | cens(censored) ~ predictors}. The censoring variable #' (named \code{censored} in this example) should contain the values #' \code{'left'}, \code{'none'}, \code{'right'}, and \code{'interval'} #' (or equivalently \code{-1}, \code{0}, \code{1}, and \code{2}) to indicate that #' the corresponding observation is left censored, not censored, right censored, #' or interval censored. For interval censored data, a second variable #' (let's call it \code{y2}) has to be passed to \code{cens}. In this case, #' the formula has the structure \code{y | cens(censored, y2) ~ predictors}. #' While the lower bounds are given in \code{y}, the upper bounds are given #' in \code{y2} for interval censored data. Intervals are assumed to be open #' on the left and closed on the right: \code{(y, y2]}. #' #' With the exception of categorical and ordinal families, #' the response distribution can be truncated using the \code{trunc} #' function in the addition part. If the response variable is truncated #' between, say, 0 and 100, we can specify this via #' \code{yi | trunc(lb = 0, ub = 100) ~ predictors}. #' Instead of numbers, variables in the data set can also be passed allowing #' for varying truncation points across observations. Defining only one of #' the two arguments in \code{trunc} leads to one-sided truncation. #' #' For all continuous families, missing values in the responses can be imputed #' within Stan by using the addition term \code{mi}. This is mostly #' useful in combination with \code{mi} predictor terms as explained #' above under 'Special predictor terms'. #' #' For families \code{binomial} and \code{zero_inflated_binomial}, #' addition should contain a variable indicating the number of trials #' underlying each observation. In \code{lme4} syntax, we may write for instance #' \code{cbind(success, n - success)}, which is equivalent #' to \code{success | trials(n)} in \pkg{brms} syntax. If the number of trials #' is constant across all observations, say \code{10}, #' we may also write \code{success | trials(10)}. #' \bold{Please note that the \code{cbind()} syntax will not work #' in \pkg{brms} in the expected way because this syntax is reserved #' for other purposes.} #' #' For all ordinal families, \code{aterms} may contain a term #' \code{thres(number)} to specify the number thresholds (e.g, #' \code{thres(6)}), which should be equal to the total number of response #' categories - 1. If not given, the number of thresholds is calculated from #' the data. If different threshold vectors should be used for different #' subsets of the data, the \code{gr} argument can be used to provide the #' grouping variable (e.g, \code{thres(6, gr = item)}, if \code{item} is the #' grouping variable). In this case, the number of thresholds can also be a #' variable in the data with different values per group. #' #' A deprecated quasi alias of \code{thres()} is \code{cat()} with which the #' total number of response categories (i.e., number of thresholds + 1) can be #' specified. #' #' In Wiener diffusion models (family \code{wiener}) the addition term #' \code{dec} is mandatory to specify the (vector of) binary decisions #' corresponding to the reaction times. Non-zero values will be treated #' as a response on the upper boundary of the diffusion process and zeros #' will be treated as a response on the lower boundary. Alternatively, #' the variable passed to \code{dec} might also be a character vector #' consisting of \code{'lower'} and \code{'upper'}. #' #' All families support the \code{index} addition term to uniquely identify #' each observation of the corresponding response variable. Currently, #' \code{index} is primarily useful in combination with the \code{subset} #' addition and \code{\link{mi}} terms. #' #' For custom families, it is possible to pass an arbitrary number of real and #' integer vectors via the addition terms \code{vreal} and \code{vint}, #' respectively. An example is provided in #' \code{vignette('brms_customfamilies')}. To pass multiple vectors of the #' same data type, provide them separated by commas inside a single #' \code{vreal} or \code{vint} statement. #' #' Multiple addition terms of different types may be specified at the same #' time using the \code{+} operator. For example, the formula #' \code{formula = yi | se(sei) + cens(censored) ~ 1} implies a censored #' meta-analytic model. #' #' The addition argument \code{disp} (short for dispersion) #' has been removed in version 2.0. You may instead use the #' distributional regression approach by specifying #' \code{sigma ~ 1 + offset(log(xdisp))} or #' \code{shape ~ 1 + offset(log(xdisp))}, where \code{xdisp} is #' the variable being previously passed to \code{disp}. #' #' \bold{Parameterization of the population-level intercept} #' #' By default, the population-level intercept (if incorporated) is estimated #' separately and not as part of population-level parameter vector \code{b} As #' a result, priors on the intercept also have to be specified separately. #' Furthermore, to increase sampling efficiency, the population-level design #' matrix \code{X} is centered around its column means \code{X_means} if the #' intercept is incorporated. This leads to a temporary bias in the intercept #' equal to \code{}, where \code{<,>} is the scalar product. The #' bias is corrected after fitting the model, but be aware that you are #' effectively defining a prior on the intercept of the centered design matrix #' not on the real intercept. You can turn off this special handling of the #' intercept by setting argument \code{center} to \code{FALSE}. For more #' details on setting priors on population-level intercepts, see #' \code{\link{set_prior}}. #' #' This behavior can be avoided by using the reserved #' (and internally generated) variable \code{Intercept}. #' Instead of \code{y ~ x}, you may write #' \code{y ~ 0 + Intercept + x}. This way, priors can be #' defined on the real intercept, directly. In addition, #' the intercept is just treated as an ordinary population-level effect #' and thus priors defined on \code{b} will also apply to it. #' Note that this parameterization may be less efficient #' than the default parameterization discussed above. #' #' \bold{Formula syntax for non-linear models} #' #' In \pkg{brms}, it is possible to specify non-linear models #' of arbitrary complexity. #' The non-linear model can just be specified within the \code{formula} #' argument. Suppose, that we want to predict the response \code{y} #' through the predictor \code{x}, where \code{x} is linked to \code{y} #' through \code{y = alpha - beta * lambda^x}, with parameters #' \code{alpha}, \code{beta}, and \code{lambda}. This is certainly a #' non-linear model being defined via #' \code{formula = y ~ alpha - beta * lambda^x} (addition arguments #' can be added in the same way as for ordinary formulas). #' To tell \pkg{brms} that this is a non-linear model, #' we set argument \code{nl} to \code{TRUE}. #' Now we have to specify a model for each of the non-linear parameters. #' Let's say we just want to estimate those three parameters #' with no further covariates or random effects. Then we can pass #' \code{alpha + beta + lambda ~ 1} or equivalently #' (and more flexible) \code{alpha ~ 1, beta ~ 1, lambda ~ 1} #' to the \code{...} argument. #' This can, of course, be extended. If we have another predictor \code{z} and #' observations nested within the grouping factor \code{g}, we may write for #' instance \code{alpha ~ 1, beta ~ 1 + z + (1|g), lambda ~ 1}. #' The formula syntax described above applies here as well. #' In this example, we are using \code{z} and \code{g} only for the #' prediction of \code{beta}, but we might also use them for the other #' non-linear parameters (provided that the resulting model is still #' scientifically reasonable). #' #' By default, non-linear covariates are treated as real vectors in Stan. #' However, if the data of the covariates is of type `integer` in \R (which #' can be enforced by the `as.integer` function), the Stan type will be #' changed to an integer array. That way, covariates can also be used #' for indexing purposes in Stan. #' #' Non-linear models may not be uniquely identified and / or show bad convergence. #' For this reason it is mandatory to specify priors on the non-linear parameters. #' For instructions on how to do that, see \code{\link{set_prior}}. #' For some examples of non-linear models, see \code{vignette("brms_nonlinear")}. #' #' \bold{Formula syntax for predicting distributional parameters} #' #' It is also possible to predict parameters of the response distribution such #' as the residual standard deviation \code{sigma} in gaussian models or the #' hurdle probability \code{hu} in hurdle models. The syntax closely resembles #' that of a non-linear parameter, for instance \code{sigma ~ x + s(z) + #' (1+x|g)}. For some examples of distributional models, see #' \code{vignette("brms_distreg")}. #' #' Parameter \code{mu} exists for every family and can be used as an #' alternative to specifying terms in \code{formula}. If both \code{mu} and #' \code{formula} are given, the right-hand side of \code{formula} is ignored. #' Accordingly, specifying terms on the right-hand side of both \code{formula} #' and \code{mu} at the same time is deprecated. In future versions, #' \code{formula} might be updated by \code{mu}. #' #' The following are #' distributional parameters of specific families (all other parameters are #' treated as non-linear parameters): \code{sigma} (residual standard #' deviation or scale of the \code{gaussian}, \code{student}, #' \code{skew_normal}, \code{lognormal} \code{exgaussian}, and #' \code{asym_laplace} families); \code{shape} (shape parameter of the #' \code{Gamma}, \code{weibull}, \code{negbinomial}, and related zero-inflated #' / hurdle families); \code{nu} (degrees of freedom parameter of the #' \code{student} and \code{frechet} families); \code{phi} (precision #' parameter of the \code{beta}, \code{zero_inflated_beta}, and \code{xbeta} families); #' \code{kappa} (precision parameter of the \code{von_mises} family); #' \code{beta} (mean parameter of the exponential component of the #' \code{exgaussian} family); \code{quantile} (quantile parameter of the #' \code{asym_laplace} family); \code{zi} (zero-inflation probability); #' \code{hu} (hurdle probability); \code{zoi} (zero-one-inflation #' probability); \code{coi} (conditional one-inflation probability); #' \code{disc} (discrimination) for ordinal models; \code{bs}, \code{ndt}, and #' \code{bias} (boundary separation, non-decision time, and initial bias of #' the \code{wiener} diffusion model). By default, distributional parameters #' are modeled on the log scale if they can be positive only or on the logit #' scale if the can only be within the unit interval. #' #' Alternatively, one may fix distributional parameters to certain values. #' However, this is mainly useful when models become too #' complicated and otherwise have convergence issues. #' We thus suggest to be generally careful when making use of this option. #' The \code{quantile} parameter of the \code{asym_laplace} distribution #' is a good example where it is useful. By fixing \code{quantile}, #' one can perform quantile regression for the specified quantile. #' For instance, \code{quantile = 0.25} allows predicting the 25\%-quantile. #' Furthermore, the \code{bias} parameter in drift-diffusion models, #' is assumed to be \code{0.5} (i.e. no bias) in many applications. #' To achieve this, simply write \code{bias = 0.5}. #' Other possible applications are the Cauchy distribution as a #' special case of the Student-t distribution with #' \code{nu = 1}, or the geometric distribution as a special case of #' the negative binomial distribution with \code{shape = 1}. #' Furthermore, the parameter \code{disc} ('discrimination') in ordinal #' models is fixed to \code{1} by default and not estimated, #' but may be modeled as any other distributional parameter if desired #' (see examples). For reasons of identification, \code{'disc'} #' can only be positive, which is achieved by applying the log-link. #' #' In categorical models, distributional parameters do not have #' fixed names. Instead, they are named after the response categories #' (excluding the first one, which serves as the reference category), #' with the prefix \code{'mu'}. If, for instance, categories are named #' \code{cat1}, \code{cat2}, and \code{cat3}, the distributional parameters #' will be named \code{mucat2} and \code{mucat3}. #' #' Some distributional parameters currently supported by \code{brmsformula} #' have to be positive (a negative standard deviation or precision parameter #' does not make any sense) or are bounded between 0 and 1 (for zero-inflated / #' hurdle probabilities, quantiles, or the initial bias parameter of #' drift-diffusion models). #' However, linear predictors can be positive or negative, and thus the log link #' (for positive parameters) or logit link (for probability parameters) are used #' by default to ensure that distributional parameters are within their valid intervals. #' This implies that, by default, effects for such distributional parameters are #' estimated on the log / logit scale and one has to apply the inverse link #' function to get to the effects on the original scale. #' Alternatively, it is possible to use the identity link to predict parameters #' on their original scale, directly. However, this is much more likely to lead #' to problems in the model fitting, if the parameter actually has a restricted range. #' #' See also \code{\link{brmsfamily}} for an overview of valid link functions. #' #' \bold{Formula syntax for mixture models} #' #' The specification of mixture models closely resembles that #' of non-mixture models. If not specified otherwise (see below), #' all mean parameters of the mixture components are predicted #' using the right-hand side of \code{formula}. All types of predictor #' terms allowed in non-mixture models are allowed in mixture models #' as well. #' #' Distributional parameters of mixture distributions have the same #' name as those of the corresponding ordinary distributions, but with #' a number at the end to indicate the mixture component. For instance, if #' you use family \code{mixture(gaussian, gaussian)}, the distributional #' parameters are \code{sigma1} and \code{sigma2}. #' Distributional parameters of the same class can be fixed to the same value. #' For the above example, we could write \code{sigma2 = "sigma1"} to make #' sure that both components have the same residual standard deviation, #' which is in turn estimated from the data. #' #' In addition, there are two types of special distributional parameters. #' The first are named \code{mu}, that allow for modeling different #' predictors for the mean parameters of different mixture components. #' For instance, if you want to predict the mean of the first component #' using predictor \code{x} and the mean of the second component using #' predictor \code{z}, you can write \code{mu1 ~ x} as well as \code{mu2 ~ z}. #' The second are named \code{theta}, which constitute the mixing #' proportions. If the mixing proportions are fixed to certain values, #' they are internally normalized to form a probability vector. #' If one seeks to predict the mixing proportions, all but #' one of the them has to be predicted, while the remaining one is used #' as the reference category to identify the model. The so-called 'softmax' #' transformation is applied on the linear predictor terms to form a #' probability vector. #' #' For more information on mixture models, see #' the documentation of \code{\link{mixture}}. #' #' \bold{Formula syntax for multivariate models} #' #' Multivariate models may be specified using \code{mvbind} notation #' or with help of the \code{\link{mvbf}} function. #' Suppose that \code{y1} and \code{y2} are response variables #' and \code{x} is a predictor. Then \code{mvbind(y1, y2) ~ x} #' specifies a multivariate model. #' The effects of all terms specified at the RHS of the formula #' are assumed to vary across response variables. #' For instance, two parameters will be estimated for \code{x}, #' one for the effect on \code{y1} and another for the effect on \code{y2}. #' This is also true for group-level effects. When writing, for instance, #' \code{mvbind(y1, y2) ~ x + (1+x|g)}, group-level effects will be #' estimated separately for each response. To model these effects #' as correlated across responses, use the ID syntax (see above). #' For the present example, this would look as follows: #' \code{mvbind(y1, y2) ~ x + (1+x|2|g)}. Of course, you could also use #' any value other than \code{2} as ID. #' #' It is also possible to specify different formulas for different responses. #' If, for instance, \code{y1} should be predicted by \code{x} and \code{y2} #' should be predicted by \code{z}, we could write \code{mvbf(y1 ~ x, y2 ~ z)}. #' Alternatively, multiple \code{brmsformula} objects can be added to #' specify a joint multivariate model (see 'Examples'). #' #' @examples #' # multilevel model with smoothing terms #' brmsformula(y ~ x1*x2 + s(z) + (1+x1|1) + (1|g2)) #' #' # additionally predict 'sigma' #' brmsformula(y ~ x1*x2 + s(z) + (1+x1|1) + (1|g2), #' sigma ~ x1 + (1|g2)) #' #' # use the shorter alias 'bf' #' (formula1 <- brmsformula(y ~ x + (x|g))) #' (formula2 <- bf(y ~ x + (x|g))) #' # will be TRUE #' identical(formula1, formula2) #' #' # incorporate censoring #' bf(y | cens(censor_variable) ~ predictors) #' #' # define a simple non-linear model #' bf(y ~ a1 - a2^x, a1 + a2 ~ 1, nl = TRUE) #' #' # predict a1 and a2 differently #' bf(y ~ a1 - a2^x, a1 ~ 1, a2 ~ x + (x|g), nl = TRUE) #' #' # correlated group-level effects across parameters #' bf(y ~ a1 - a2^x, a1 ~ 1 + (1 |2| g), a2 ~ x + (x |2| g), nl = TRUE) #' # alternative but equivalent way to specify the above model #' bf(y ~ a1 - a2^x, a1 ~ 1 + (1 | gr(g, id = 2)), #' a2 ~ x + (x | gr(g, id = 2)), nl = TRUE) #' #' # define a multivariate model #' bf(mvbind(y1, y2) ~ x * z + (1|g)) #' #' # define a zero-inflated model #' # also predicting the zero-inflation part #' bf(y ~ x * z + (1+x|ID1|g), zi ~ x + (1|ID1|g)) #' #' # specify a predictor as monotonic #' bf(y ~ mo(x) + more_predictors) #' #' # for ordinal models only #' # specify a predictor as category specific #' bf(y ~ cs(x) + more_predictors) #' # add a category specific group-level intercept #' bf(y ~ cs(x) + (cs(1)|g)) #' # specify parameter 'disc' #' bf(y ~ person + item, disc ~ item) #' #' # specify variables containing measurement error #' bf(y ~ me(x, sdx)) #' #' # specify predictors on all parameters of the wiener diffusion model #' # the main formula models the drift rate 'delta' #' bf(rt | dec(decision) ~ x, bs ~ x, ndt ~ x, bias ~ x) #' #' # fix the bias parameter to 0.5 #' bf(rt | dec(decision) ~ x, bias = 0.5) #' #' # specify different predictors for different mixture components #' mix <- mixture(gaussian, gaussian) #' bf(y ~ 1, mu1 ~ x, mu2 ~ z, family = mix) #' #' # fix both residual standard deviations to the same value #' bf(y ~ x, sigma2 = "sigma1", family = mix) #' #' # use the '+' operator to specify models #' bf(y ~ 1) + #' nlf(sigma ~ a * exp(b * x), a ~ x) + #' lf(b ~ z + (1|g), dpar = "sigma") + #' gaussian() #' #' # specify a multivariate model using the '+' operator #' bf(y1 ~ x + (1|g)) + #' gaussian() + cor_ar(~1|g) + #' bf(y2 ~ z) + poisson() #' #' # specify correlated residuals of a gaussian and a poisson model #' form1 <- bf(y1 ~ 1 + x + (1|c|obs), sigma = 1) + gaussian() #' form2 <- bf(y2 ~ 1 + x + (1|c|obs)) + poisson() #' #' # model missing values in predictors #' bf(bmi ~ age * mi(chl)) + #' bf(chl | mi() ~ age) + #' set_rescor(FALSE) #' #' # model sigma as a function of the mean #' bf(y ~ eta, nl = TRUE) + #' lf(eta ~ 1 + x) + #' nlf(sigma ~ tau * sqrt(eta)) + #' lf(tau ~ 1) #' #' @export brmsformula <- function(formula, ..., flist = NULL, family = NULL, autocor = NULL, nl = NULL, loop = NULL, center = NULL, cmc = NULL, sparse = NULL, decomp = NULL, unused = NULL) { if (is.brmsformula(formula)) { out <- formula } else { out <- list(formula = as_formula(formula)) class(out) <- "brmsformula" } # parse and validate dots arguments dots <- c(out$pforms, out$pfix, list(...), flist) dots <- lapply(dots, function(x) if (is.list(x)) x else list(x)) dots <- unlist(dots, recursive = FALSE) forms <- list() for (i in seq_along(dots)) { c(forms) <- validate_par_formula(dots[[i]], par = names(dots)[i]) } is_dupl_pars <- duplicated(names(forms), fromLast = TRUE) if (any(is_dupl_pars)) { dupl_pars <- collapse_comma(names(forms)[is_dupl_pars]) message("Replacing initial definitions of parameters ", dupl_pars) forms[is_dupl_pars] <- NULL } not_form <- ulapply(forms, function(x) !is.formula(x)) fix <- forms[not_form] forms[names(fix)] <- NULL out$pforms <- forms # validate fixed distributional parameters fix_theta <- fix[dpar_class(names(fix)) %in% "theta"] if (length(fix_theta)) { # normalize mixing proportions sum_theta <- sum(unlist(fix_theta)) fix_theta <- lapply(fix_theta, "/", sum_theta) fix[names(fix_theta)] <- fix_theta } out$pfix <- fix for (dp in names(out$pfix)) { if (is.character(out$pfix[[dp]])) { if (identical(dp, out$pfix[[dp]])) { stop2("Equating '", dp, "' with itself is not meaningful.") } ap_class <- dpar_class(dp) if (ap_class == "mu") { stop2("Equating parameters of class 'mu' is not allowed.") } if (!identical(ap_class, dpar_class(out$pfix[[dp]]))) { stop2("Can only equate parameters of the same class.") } if (out$pfix[[dp]] %in% names(out$pfix)) { stop2("Cannot use fixed parameters on ", "the right-hand side of an equation.") } if (out$pfix[[dp]] %in% names(out$pforms)) { stop2("Cannot use predicted parameters on ", "the right-hand side of an equation.") } } } if (!is.null(nl)) { attr(out$formula, "nl") <- as_one_logical(nl) } else if (!is.null(out[["nl"]])) { # for backwards compatibility with brms <= 1.8.0 attr(out$formula, "nl") <- out[["nl"]] out[["nl"]] <- NULL } if (is.null(attr(out$formula, "nl"))) { attr(out$formula, "nl") <- FALSE } if (!is.null(loop)) { attr(out$formula, "loop") <- as_one_logical(loop) } if (is.null(attr(out$formula, "loop"))) { attr(out$formula, "loop") <- TRUE } if (!is.null(center)) { attr(out$formula, "center") <- as_one_logical(center) } if (!is.null(cmc)) { attr(out$formula, "cmc") <- as_one_logical(cmc) } if (!is.null(sparse)) { attr(out$formula, "sparse") <- as_one_logical(sparse) } if (!is.null(decomp)) { attr(out$formula, "decomp") <- match.arg(decomp, decomp_opts()) } if (!is.null(unused)) { attr(out$formula, "unused") <- as.formula(unused) } if (!is.null(autocor)) { attr(out$formula, "autocor") <- validate_autocor(autocor) } else if (!is.null(out$autocor)) { # for backwards compatibility with brms <= 2.11.0 attr(out$formula, "autocor") <- validate_autocor(out$autocor) out$autocor <- NULL } if (!is.null(family)) { out$family <- validate_family(family) } if (!is.null(lhs(formula))) { out$resp <- terms_resp(formula) } # add default values for unspecified elements defs <- list(pforms = list(), pfix = list(), family = NULL, resp = NULL) defs <- defs[setdiff(names(defs), names(rmNULL(out, FALSE)))] out[names(defs)] <- defs class(out) <- c("brmsformula", "bform") split_bf(out) } # alias of brmsformula #' @export bf <- function(formula, ..., flist = NULL, family = NULL, autocor = NULL, nl = NULL, loop = NULL, center = NULL, cmc = NULL, sparse = NULL, decomp = NULL) { brmsformula( formula, ..., flist = flist, family = family, autocor = autocor, nl = nl, loop = loop, center = center, cmc = cmc, sparse = sparse, decomp = decomp ) } #' Linear and Non-linear formulas in \pkg{brms} #' #' Helper functions to specify linear and non-linear #' formulas for use with \code{\link[brms:brmsformula]{brmsformula}}. #' #' @name brmsformula-helpers #' @aliases bf-helpers nlf lf set_nl set_rescor #' #' @param formula Non-linear formula for a distributional parameter. #' The name of the distributional parameter can either be specified #' on the left-hand side of \code{formula} or via argument \code{dpar}. #' @param dpar Optional character string specifying the distributional #' parameter to which the formulas passed via \code{...} and #' \code{flist} belong. #' @param resp Optional character string specifying the response #' variable to which the formulas passed via \code{...} and #' \code{flist} belong. Only relevant in multivariate models. #' @param autocor A one sided formula containing autocorrelation #' terms. All none autocorrelation terms in \code{autocor} will #' be silently ignored. #' @param rescor Logical; Indicates if residual correlation between #' the response variables should be modeled. Currently this is only #' possible in multivariate \code{gaussian} and \code{student} models. #' Only relevant in multivariate models. #' @param mecor Logical; Indicates if correlations between latent variables #' defined by \code{\link{me}} terms should be modeled. Defaults to \code{TRUE}. #' @inheritParams brmsformula #' #' @return For \code{lf} and \code{nlf} a \code{list} that can be #' passed to \code{\link[brms:brmsformula]{brmsformula}} or added #' to an existing \code{brmsformula} or \code{mvbrmsformula} object. #' For \code{set_nl} and \code{set_rescor} a logical value that can be #' added to an existing \code{brmsformula} or \code{mvbrmsformula} object. #' #' @seealso \code{\link{brmsformula}}, \code{\link{mvbrmsformula}} #' #' @examples #' # add more formulas to the model #' bf(y ~ 1) + #' nlf(sigma ~ a * exp(b * x)) + #' lf(a ~ x, b ~ z + (1|g)) + #' gaussian() #' #' # specify 'nl' later on #' bf(y ~ a * inv_logit(x * b)) + #' lf(a + b ~ z) + #' set_nl(TRUE) #' #' # specify a multivariate model #' bf(y1 ~ x + (1|g)) + #' bf(y2 ~ z) + #' set_rescor(TRUE) #' #' # add autocorrelation terms #' bf(y ~ x) + acformula(~ arma(p = 1, q = 1) + car(W)) NULL #' @rdname brmsformula-helpers #' @export nlf <- function(formula, ..., flist = NULL, dpar = NULL, resp = NULL, loop = NULL) { formula <- as_formula(formula) if (is.null(lhs(formula))) { stop2("Argument 'formula' must be two-sided.") } if (length(c(list(...), flist))) { warning2( "Arguments '...' and 'flist' in nlf() will be reworked ", "at some point. Please avoid using them if possible." ) } warn_dpar(dpar) if (!is.null(resp)) { resp <- as_one_character(resp) } if (!is.null(loop)) { attr(formula, "loop") <- as_one_logical(loop) } if (is.null(attr(formula, "loop"))) { attr(formula, "loop") <- TRUE } out <- c( list(structure(formula, nl = TRUE)), lf(..., flist = flist) ) structure(out, resp = resp) } #' @rdname brmsformula-helpers #' @export lf <- function(..., flist = NULL, dpar = NULL, resp = NULL, center = NULL, cmc = NULL, sparse = NULL, decomp = NULL) { out <- c(list(...), flist) warn_dpar(dpar) if (!is.null(resp)) { resp <- as_one_character(resp) } cmc <- if (!is.null(cmc)) as_one_logical(cmc) center <- if (!is.null(center)) as_one_logical(center) decomp <- if (!is.null(decomp)) match.arg(decomp, decomp_opts()) for (i in seq_along(out)) { if (!is.null(cmc)) { attr(out[[i]], "cmc") <- cmc } if (!is.null(center)) { attr(out[[i]], "center") <- center } if (!is.null(sparse)) { attr(out[[i]], "sparse") <- sparse } if (!is.null(decomp)) { attr(out[[i]], "decomp") <- decomp } } structure(out, resp = resp) } #' @rdname brmsformula-helpers #' @export acformula <- function(autocor, resp = NULL) { autocor <- terms_ac(as.formula(autocor)) if (!is.formula(autocor)) { stop2("'autocor' must contain at least one autocorrelation term.") } if (!is.null(resp)) { resp <- as_one_character(resp) } structure(autocor, resp = resp, class = c("acformula", "formula")) } #' @rdname brmsformula-helpers #' @export set_nl <- function(nl = TRUE, dpar = NULL, resp = NULL) { nl <- as_one_logical(nl) if (!is.null(dpar)) { dpar <- as_one_character(dpar) } if (!is.null(resp)) { resp <- as_one_character(resp) } structure(nl, dpar = dpar, resp = resp, class = "setnl") } #' Set up a multivariate model formula for use in \pkg{brms} #' #' Set up a multivariate model formula for use in the \pkg{brms} package #' allowing to define (potentially non-linear) additive multilevel #' models for all parameters of the assumed response distributions. #' #' @aliases mvbf #' #' @param ... Objects of class \code{formula} or \code{brmsformula}, #' each specifying a univariate model. See \code{\link{brmsformula}} #' for details on how to specify univariate models. #' @param flist Optional list of formulas, which are treated in the #' same way as formulas passed via the \code{...} argument. #' @param rescor Logical; Indicates if residual correlation between #' the response variables should be modeled. Currently, this is only #' possible in multivariate \code{gaussian} and \code{student} models. #' If \code{NULL} (the default), \code{rescor} is internally set to #' \code{TRUE} when possible. #' #' @return An object of class \code{mvbrmsformula}, which #' is essentially a \code{list} containing all model formulas #' as well as some additional information for multivariate models. #' #' @details See \code{vignette("brms_multivariate")} for a case study. #' #' @seealso \code{\link{brmsformula}}, \code{\link{brmsformula-helpers}} #' #' @examples #' bf1 <- bf(y1 ~ x + (1|g)) #' bf2 <- bf(y2 ~ s(z)) #' mvbf(bf1, bf2) #' #' @export mvbrmsformula <- function(..., flist = NULL, rescor = NULL) { dots <- c(list(...), flist) if (!length(dots)) { stop2("No objects passed to 'mvbrmsformula'.") } forms <- list() for (i in seq_along(dots)) { if (is.mvbrmsformula(dots[[i]])) { forms <- c(forms, dots[[i]]$forms) if (is.null(rescor)) { rescor <- dots[[i]]$rescor } } else { forms <- c(forms, list(bf(dots[[i]]))) } } if (!is.null(rescor)) { rescor <- as_one_logical(rescor) } responses <- ufrom_list(forms, "resp") if (any(duplicated(responses))) { stop2("Cannot use the same response variable twice in the same model.") } names(forms) <- responses structure( nlist(forms, responses, rescor), class = c("mvbrmsformula", "bform") ) } #' @export mvbf <- function(..., flist = NULL, rescor = NULL) { mvbrmsformula(..., flist = flist, rescor = rescor) } # build a mvbrmsformula object based on a brmsformula object # which uses mvbind on the left-hand side to specify MV models split_bf <- function(x) { stopifnot(is.brmsformula(x)) resp <- terms_resp(x$formula, check_names = FALSE) str_adform <- formula2str(x$formula) str_adform <- get_matches("\\|[^~]*(?=~)", str_adform, perl = TRUE) if (length(resp) > 1L) { # mvbind syntax used to specify MV model flist <- named_list(resp) for (i in seq_along(resp)) { flist[[i]] <- x str_lhs <- paste0(resp[[i]], str_adform) flist[[i]]$formula[[2]] <- parse(text = str_lhs)[[1]] flist[[i]]$resp <- resp[[i]] } x <- mvbf(flist = flist) } x } #' Bind response variables in multivariate models #' #' Can be used to specify a multivariate \pkg{brms} model within a single #' formula. Outside of \code{\link{brmsformula}}, it just behaves like #' \code{\link{cbind}}. #' #' @param ... Same as in \code{\link{cbind}} #' #' @seealso \code{\link{brmsformula}}, \code{\link{mvbrmsformula}} #' #' @examples #' bf(mvbind(y1, y2) ~ x) #' #' @export mvbind <- function(...) { cbind(...) } #' @rdname brmsformula-helpers #' @export set_rescor <- function(rescor = TRUE) { structure(as_one_logical(rescor), class = "setrescor") } allow_rescor <- function(x) { # indicate if estimating 'rescor' is allowed for this model if (!(is.mvbrmsformula(x) || is.mvbrmsterms(x))) { return(FALSE) } parts <- if (is.mvbrmsformula(x)) x$forms else x$terms families <- from_list(parts, "family") has_rescor <- ulapply(families, has_rescor) is_mixture <- ulapply(families, is.mixfamily) family_names <- ufrom_list(families, "family") all(has_rescor) && !any(is_mixture) && length(unique(family_names)) == 1L } #' @rdname brmsformula-helpers #' @export set_mecor <- function(mecor = TRUE) { structure(as_one_logical(mecor), class = "setmecor") } #' @export "+.bform" <- function(e1, e2) { if (is.brmsformula(e1)) { out <- plus_brmsformula(e1, e2) } else if (is.mvbrmsformula(e1)) { out <- plus_mvbrmsformula(e1, e2) } else { stop2("Method '+.bform' not implemented for ", class(e1)[1], " objects.") } out } # internal helper function of '+.bform' plus_brmsformula <- function(e1, e2) { if (is.function(e2)) { e2 <- try(e2(), silent = TRUE) if (!is.family(e2)) { stop2("Don't know how to handle non-family functions.") } } if (is.family(e2)) { e1 <- bf(e1, family = e2) } else if (is.cor_brms(e2) || inherits(e2, "acformula")) { e1 <- bf(e1, autocor = e2) } else if (inherits(e2, "setnl")) { dpar <- attr(e2, "dpar") if (is.null(dpar)) { e1 <- bf(e1, nl = e2) } else { if (is.null(e1$pforms[[dpar]])) { stop2("Parameter '", dpar, "' has no formula.") } attr(e1$pforms[[dpar]], "nl") <- e2 e1 <- bf(e1) } } else if (inherits(e2, "setmecor")) { e1$mecor <- e2[1] } else if (is.brmsformula(e2)) { e1 <- mvbf(e1, e2) } else if (inherits(e2, "setrescor")) { stop2("Setting 'rescor' is only possible in multivariate models.") } else if (is.ac_term(e2)) { stop2("Autocorrelation terms can only be specified on the right-hand ", "side of a formula, not added to a 'brmsformula' object.") } else if (!is.null(e2)) { e1 <- bf(e1, e2) } e1 } # internal helper function of '+.bform' plus_mvbrmsformula <- function(e1, e2) { if (is.function(e2)) { e2 <- try(e2(), silent = TRUE) if (!is.family(e2)) { stop2("Don't know how to handle non-family functions.") } } if (is.family(e2) || is.cor_brms(e2)) { e1$forms <- lapply(e1$forms, "+", e2) } else if (inherits(e2, "setrescor")) { e1$rescor <- e2[1] } else if (inherits(e2, "setmecor")) { e1$mecor <- e2[1] } else if (is.brmsformula(e2)) { e1 <- mvbf(e1, e2) } else if (is.mvbrmsformula(e2)) { # TODO: enable this option stop2("Cannot add two 'mvbrmsformula' objects together. Instead, ", "please add the individual 'brmsformula' objects directly.") } else if (is.ac_term(e2)) { stop2("Autocorrelation terms can only be specified on the right-hand ", "side of a formula, not added to a 'mvbrmsformula' object.") } else if (!is.null(e2)) { resp <- attr(e2, "resp", TRUE) if (is.null(resp)) { stop2( "Don't know how to add a ", class(e2)[1], " object ", "without the response variable name. ", "See help('brmsformula-helpers') for more details." ) } if (!isTRUE(resp %in% e1$responses)) { stop2("'resp' should be one of ", collapse_comma(e1$responses), ".") } e1$forms[[resp]] <- e1$forms[[resp]] + e2 } e1 } # extract the 'nl' attribute from a brmsformula object # @param x object to extract 'nl' from # @param dpar optional name of a distributional parameter # for which 'nl' should be extracted # @param resp: optional name of a response variable # for which 'nl' should be extracted # @param aol: (as one logical) apply isTRUE to the result? get_nl <- function(x, dpar = NULL, resp = NULL, aol = TRUE) { if (is.mvbrmsformula(x)) { resp <- as_one_character(resp) x <- x$forms[[resp]] } if (is.brmsformula(x)) { if (is.null(dpar)) { x <- x$formula } else { dpar <- as_one_character(dpar) x <- x$pforms[[dpar]] } } nl <- attr(x, "nl", TRUE) if (aol) { nl <- isTRUE(nl) } nl } # available options for the 'decomp' argument decomp_opts <- function() { c("none", "QR") } # validate a formula of an additional parameter # @param formula an formula object # @param par optional name of the parameter; if not specified # the parameter name will be inferred from the formula # @param rsv_pars optional character vector of reserved parameter names # @return a named list of length one containing the formula validate_par_formula <- function(formula, par = NULL, rsv_pars = NULL) { stopifnot(length(par) <= 1L) try_formula <- try(as_formula(formula), silent = TRUE) if (is_try_error(try_formula)) { if (length(formula) != 1L) { stop2("Expecting a single value when fixing parameter '", par, "'.") } scalar <- SW(as.numeric(formula)) if (!is.na(scalar)) { formula <- scalar } else { formula <- as.character(formula) } out <- named_list(par, formula) } else { formula <- try_formula if (!is.null(lhs(formula))) { resp_pars <- all.vars(formula[[2]]) out <- named_list(resp_pars, list(formula)) for (i in seq_along(out)) { out[[i]][[2]] <- eval2(paste("quote(", resp_pars[i], ")")) } } else { if (!isTRUE(nzchar(par))) { stop2("Additional formulas must be named.") } formula <- formula(paste(par, formula2str(formula))) out <- named_list(par, list(formula)) } } pars <- names(out) if (any(grepl("\\.|_", pars))) { stop2("Parameter names should not contain dots or underscores.") } inv_pars <- intersect(pars, rsv_pars) if (length(inv_pars)) { stop2("The following parameter names are reserved", "for this model:\n", collapse_comma(inv_pars)) } out } # validate formulas dedicated to response variables # @param x coerced to a formula object # @param empty_ok is an empty left-hand-side ok? # @return a formula of the form ~ 1 validate_resp_formula <- function(x, empty_ok = TRUE) { out <- lhs(as_formula(x)) if (is.null(out)) { if (empty_ok) { out <- ~ 1 } else { str_x <- formula2str(x, space = "trim") stop2("Response variable is missing in formula ", str_x) } } out <- gsub("\\|+[^~]*~", "~", formula2str(out)) out <- try(formula(out), silent = TRUE) if (is_try_error(out)) { str_x <- formula2str(x, space = "trim") stop2("Incorrect use of '|' on the left-hand side of ", str_x) } environment(out) <- environment(x) out } # incorporate additional arguments into the model formula validate_formula <- function(formula, ...) { UseMethod("validate_formula") } #' @export validate_formula.default <- function(formula, ...) { validate_formula(bf(formula), ...) } # incorporate additional arguments into the model formula # @param formula object of class 'formula' of 'brmsformula' # @param data optional data.frame to validate data related arguments # @param family optional 'family' object # @param autocor (deprecated) optional 'cor_brms' object # @param threshold (deprecated) threshold type for ordinal models # @param cov_ranef (deprecated) named list of group covariance matrices # @return a brmsformula object compatible with the current version of brms #' @export validate_formula.brmsformula <- function( formula, family = gaussian(), autocor = NULL, data = NULL, threshold = NULL, sparse = NULL, cov_ranef = NULL, ... ) { out <- bf(formula) if (is.null(out$family) && !is.null(family)) { out$family <- validate_family(family) } # allow the '.' symbol in the formulas out$formula <- expand_dot_formula(out$formula, data) for (i in seq_along(out$pforms)) { out$pforms[[i]] <- expand_dot_formula(out$pforms[[i]], data) } # allow 'me' terms to be correlated out$mecor <- default_mecor(out$mecor) if (has_cat(out) && !is.null(data)) { # for easy access of response categories # allow to update 'cats' with new data out$family$cats <- extract_cat_names(out, data) } if (is_ordinal(out$family)) { # thresholds and category names are data dependent try_terms <- try(stats::terms(out$formula), silent = TRUE) intercept <- attr(try_terms, "intercept", TRUE) if (!is_try_error(try_terms) && isTRUE(intercept == 0)) { stop2("Cannot remove the intercept in an ordinal model.") } if (!is.null(data)) { # for easy access of thresholds and response categories (#838) # allow to update 'cats' and 'thres' with new data out$family$thres <- extract_thres_names(out, data) out$family$cats <- extract_cat_names(out, data) } } conv_cats_dpars <- conv_cats_dpars(out$family) if (conv_cats_dpars && !is.null(data)) { # allow to update 'dpars' with new data # define distributional parameters based on response categories if (length(out$family$cats) < 2L) { stop2("At least 2 response categories are required.") } if (is.null(out$family$refcat)) { # the first level serves as the reference category out$family$refcat <- out$family$cats[1] } if (isNA(out$family$refcat)) { # implies predicting all categories predcats <- out$family$cats } else { if (!out$family$refcat %in% out$family$cats) { stop2("The reference response category must be one of ", collapse_comma(out$family$cats), ".") } predcats <- setdiff(out$family$cats, out$family$refcat) } multi_dpars <- valid_dpars(out$family, type = "multi") # 'rev' so that mu comes last but appears first in the end for (dp in rev(multi_dpars)) { dp_dpars <- make_stan_names(paste0(dp, predcats)) if (any(duplicated(dp_dpars))) { stop2("Invalid response category names. Please avoid ", "using any special characters in the names.") } old_dp_dpars <- str_subset(out$family$dpars, paste0("^", dp)) out$family$dpars <- setdiff(out$family$dpars, old_dp_dpars) out$family$dpars <- union(dp_dpars, out$family$dpars) } } if (is_cox(out$family) && !is.null(data)) { # for easy access of baseline hazards out$family$bhaz <- extract_bhaz(out, data) } if (is.mixfamily(out$family)) { # every mixture family needs to know about additional response information for (i in seq_along(out$family$mix)) { for (term in c("cats", "thres", "bhaz")) { out$family$mix[[i]][[term]] <- out$family[[term]] } } } # incorporate deprecated arguments require_threshold <- is_ordinal(out$family) && is.null(out$family$threshold) if (require_threshold && !is.null(threshold)) { # slot 'threshold' is deprecated as of brms 1.7.0 out$family <- validate_family(out$family, threshold = threshold) } if (!is.null(sparse)) { # a global 'sparse' argument is deprecated as of brms 2.8.3 warning2( "Argument 'sparse' should be specified within the ", "'formula' argument. See ?brmsformula for help." ) sparse <- as_one_logical(sparse) if (is.null(attr(out$formula, "sparse"))) { attr(out$formula, "sparse") <- sparse } for (i in seq_along(out$pforms)) { if (is.null(attr(out$pforms[[i]], "sparse"))) { attr(out$pforms[[i]], "sparse") <- sparse } } } if (is.null(attr(out$formula, "autocor")) && !is.null(autocor)) { # 'autocor' interface has been changed in brms 2.11.1 warning2( "Argument 'autocor' should be specified within the ", "'formula' argument. See ?brmsformula for help." ) # store 'autocor' as an attribute to carry it around more easily attr(out$formula, "autocor") <- validate_autocor(autocor) } if (!is.null(cov_ranef)) { # 'cov_ranef' is deprecated as of brms 2.12.5 out$cov_ranef <- validate_cov_ranef(cov_ranef) } bf(out) } # incorporate additional arguments into MV model formulas # allow passing lists of families or autocors #' @export validate_formula.mvbrmsformula <- function( formula, family = NULL, autocor = NULL, cov_ranef = NULL, ... ) { nresp <- length(formula$forms) if (!is(family, "list")) { family <- replicate(nresp, family, simplify = FALSE) } else if (length(family) != nresp) { stop2("If 'family' is a list, it has to be of the same ", "length as the number of response variables.") } if (!is(autocor, "list")) { autocor <- replicate(nresp, autocor, simplify = FALSE) } else if (length(autocor) != nresp) { stop2("If 'autocor' is a list, it has to be of the same ", "length as the number of response variables.") } for (i in seq_len(nresp)) { formula$forms[[i]] <- validate_formula( formula$forms[[i]], family = family[[i]], autocor = autocor[[i]], ... ) } if (length(formula$forms) < 2L) { stop2("Multivariate models require at least two responses.") } allow_rescor <- allow_rescor(formula) if (is.null(formula$rescor)) { # with 'mi' terms we usually don't want rescor to be estimated miforms <- ulapply(formula$forms, function(f) terms_ad(f$formula, f$family, FALSE)[["mi"]] ) formula$rescor <- allow_rescor && !length(miforms) message("Setting 'rescor' to ", formula$rescor, " by default for this model") if (formula$rescor) { warning2( "In the future, 'rescor' will be set to FALSE by default for ", "all models. It is thus recommended to explicitely set ", "'rescor' via 'set_rescor' instead of using the default." ) } } formula$rescor <- as_one_logical(formula$rescor) if (formula$rescor) { if (!allow_rescor) { stop2("Currently, estimating 'rescor' is only possible ", "in multivariate gaussian or student models.") } } # handle default of correlations between 'me' terms formula$mecor <- default_mecor(formula$mecor) for (i in seq_along(formula$forms)) { formula$forms[[i]]$mecor <- formula$mecor } # incorporate deprecated arguments if (!is.null(cov_ranef)) { # 'cov_ranef' is deprecated as of brms 2.12.5 formula$cov_ranef <- validate_cov_ranef(cov_ranef) } formula } # update a brmsformula and / or its attributes # @param brmsformula object # @param formula.: formula to update 'object' # @param mode supports the following options: # "update": apply update.formula # "replace": replace old formula # "keep": keep old formula # attributes are always updated # @param ... currently unused # @return a brmsformula object #' @export update.brmsformula <- function(object, formula., mode = c("update", "replace", "keep"), ...) { mode <- match.arg(mode) object <- bf(object) up_nl <- get_nl(formula., aol = FALSE) if (is.null(up_nl)) { up_nl <- get_nl(object) } # already use up_nl here to avoid ordinary parsing of NL formulas formula. <- bf(formula., nl = up_nl) up_family <- formula.[["family"]] if (is.null(up_family)) { up_family <- object[["family"]] } up_autocor <- attr(formula.$formula, "autocor") if (is.null(up_autocor)) { up_autocor <- attr(object$formula, "autocor") } old_form <- object$formula up_form <- formula.$formula if (mode == "update") { new_form <- update(old_form, up_form, ...) } else if (mode == "replace") { new_form <- up_form } else if (mode == "keep") { new_form <- old_form } flist <- c(object$pforms, object$pfix, formula.$pforms, formula.$pfix) bf(new_form, flist = flist, family = up_family, autocor = up_autocor, nl = up_nl) } #' @export update.mvbrmsformula <- function(object, formula., ...) { # temporary until proper updating is implemented if (!missing(formula.)) { stop2("Updating formulas of multivariate models is not yet possible.") } object } #' Update Formula Addition Terms #' #' Update additions terms used in formulas of \pkg{brms}. See #' \code{\link{addition-terms}} for details. #' #' @param formula Two-sided formula to be updated. #' @param adform One-sided formula containing addition terms to update #' \code{formula} with. #' @param action Indicates what should happen to the existing addition terms in #' \code{formula}. If \code{"update"} (the default), old addition terms that #' have no corresponding term in \code{adform} will be kept. If #' \code{"replace"}, all old addition terms will be removed. #' #' @return An object of class \code{formula}. #' #' @examples #' form <- y | trials(size) ~ x #' update_adterms(form, ~ trials(10)) #' update_adterms(form, ~ weights(w)) #' update_adterms(form, ~ weights(w), action = "replace") #' update_adterms(y ~ x, ~ trials(10)) #' #' @export update_adterms <- function(formula, adform, action = c("update", "replace")) { formula <- as_formula(formula) adform <- as_formula(adform) action <- match.arg(action) if (is.null(lhs(formula))) { stop2("Can't update a ond-sided formula.") } str_formula <- formula2str(formula) old_ad <- get_matches("(?<=\\|)[^~]*(?=~)", str_formula, perl = TRUE) new_ad_terms <- attr(terms(adform), "term.labels") if (action == "update" && length(old_ad)) { # extract adterms from the original formula old_ad <- formula(paste("~", old_ad)) old_ad_terms <- attr(terms(old_ad), "term.labels") old_adnames <- get_matches("^[^\\(]+", old_ad_terms) old_adnames <- sub("^resp_", "", old_adnames) new_adnames <- get_matches("^[^\\(]+", new_ad_terms) new_adnames <- sub("^resp_", "", new_adnames) # keep unmatched adterms of the original formula keep <- !old_adnames %in% new_adnames new_ad_terms <- c(old_ad_terms[keep], new_ad_terms) } if (length(new_ad_terms)) { new_ad_terms <- paste(new_ad_terms, collapse = "+") new_ad_terms <- paste("|", new_ad_terms) } resp <- gsub("\\|.+", "", deparse0(formula[[2]])) out <- formula(paste(resp, new_ad_terms, "~1")) out[[3]] <- formula[[3]] attributes(out) <- attributes(formula) out } #' @export print.brmsformula <- function(x, wsp = 0, digits = 2, ...) { cat(formula2str(x$formula, space = "trim"), "\n") str_wsp <- collapse(rep(" ", wsp)) autocor <- attr(x$formula, "autocor") if (!is.null(autocor)) { autocor <- formula2str(autocor, rm = 1, space = "trim") cat(paste0(str_wsp, "autocor ~ ", autocor, "\n")) } pforms <- x$pforms if (length(pforms)) { pforms <- ulapply(pforms, formula2str, space = "trim") cat(collapse(str_wsp, pforms, "\n")) } pfix <- x$pfix if (length(pfix)) { pfix <- lapply(pfix, function(x) ifelse(is.numeric(x), round(x, digits), x) ) pfix <- paste0(names(pfix), " = ", unlist(pfix)) cat(collapse(str_wsp, pfix, "\n")) } invisible(x) } #' @export print.mvbrmsformula <- function(x, wsp = 0, ...) { for (i in seq_along(x$forms)) { if (i > 1) cat(collapse(rep(" ", wsp))) print(x$forms[[i]], wsp = wsp, ...) } invisible(x) } #' Checks if argument is a \code{brmsformula} object #' #' @param x An \R object #' #' @export is.brmsformula <- function(x) { inherits(x, "brmsformula") } #' Checks if argument is a \code{mvbrmsformula} object #' #' @param x An \R object #' #' @export is.mvbrmsformula <- function(x) { inherits(x, "mvbrmsformula") } is_nonlinear <- function(x) { stopifnot(is.brmsfit(x)) get_nl(bf(x$formula)) } warn_dpar <- function(dpar) { # argument 'dpar' in formula helper functions is deprecated as of 2.3.7 if (!is.null(dpar)) { warning2("Argument 'dpar' is no longer necessary and ignored.") } NULL } # return the right-hand side of a formula rhs <- function(x) { attri <- attributes(x) x <- as.formula(x) x <- if (length(x) == 3) x[-2] else x do_call(structure, c(list(x), attri)) } # return the left-hand side of a formula lhs <- function(x) { x <- as.formula(x) if (length(x) == 3L) update(x, . ~ 1) else NULL } # convert a string to a formula # @param x vector of strings to be converted # @param ... passed to formula() str2formula <- function(x, env = parent.frame(), collapse = "+") { has_chars <- nzchar(x) if (length(x) && any(has_chars)) { out <- paste(x[has_chars], collapse = collapse) } else { out <- "1" } as.formula(paste("~", out), env = env) } # convert a formula to a character string # @param formula a model formula # @param rm a vector of to elements indicating how many characters # should be removed at the beginning and end of the string respectively # @param space how should whitespaces be treated? # option 'rm' is dangerous as it may combine different operators (#1142) # @return a single character string or NULL formula2str <- function(formula, rm = c(0, 0), space = c("trim", "rm")) { if (is.null(formula)) { return(NULL) } formula <- as.formula(formula) space <- match.arg(space) if (anyNA(rm[2])) rm[2] <- 0 x <- Reduce(paste, deparse(formula)) x <- gsub("[\t\r\n]+", " ", x, perl = TRUE) if (space == "trim") { x <- trim_wsp(x) } else { x <- rm_wsp(x) } substr(x, 1 + rm[1], nchar(x) - rm[2]) } # right-hand side of a formula as a character string str_rhs <- function(x) { formula2str(rhs(x), rm = c(1, 0)) } # left-hand side of a formula as a character string str_lhs <- function(x) { formula2str(lhs(x), rm = c(0, 2)) } is.formula <- function(x) { inherits(x, "formula") } # wrapper around as.formula with additional checks as_formula <- function(x) { x <- as.formula(x) # fixes issue #749 rhs <- rhs(x)[[2]] if (isTRUE(is.call(rhs) && rhs[[1]] == "~")) { stop2("Nested formulas are not allowed. Did you use '~~' somewhere?") } x } # expand the '.' variable in formula using stats::terms expand_dot_formula <- function(formula, data = NULL) { if (isTRUE("." %in% all.vars(formula))) { att <- attributes(formula) try_terms <- try( stats::terms(formula, data = data), silent = TRUE ) if (!is_try_error(try_terms)) { formula <- formula(try_terms) } attributes(formula) <- att } formula } brms/R/data-predictor.R0000644000176200001440000011340615053305627014456 0ustar liggesusers#' Prepare Predictor Data #' #' Prepare data related to predictor variables in \pkg{brms}. #' Only exported for use in package development. #' #' @param x An \R object. #' @param ... Further arguments passed to or from other methods. #' #' @return A named list of data related to predictor variables. #' #' @keywords internal #' @export data_predictor <- function(x, ...) { UseMethod("data_predictor") } #' @export data_predictor.mvbrmsterms <- function(x, data, sdata = NULL, ...) { out <- list(N = nrow(data)) for (r in names(x$terms)) { c(out) <- data_predictor(x$terms[[r]], data = data, sdata = sdata, ...) } out } #' @export data_predictor.brmsterms <- function(x, data, data2, prior, sdata = NULL, ...) { out <- list() data <- subset_data(data, x) resp <- usc(combine_prefix(x)) args_eff <- nlist(data, data2, prior, sdata, ...) for (dp in names(x$dpars)) { args_eff_spec <- list(x = x$dpars[[dp]]) c(out) <- do_call(data_predictor, c(args_eff_spec, args_eff)) } for (dp in names(x$fdpars)) { if (is.numeric(x$fdpars[[dp]]$value)) { out[[paste0(dp, resp)]] <- x$fdpars[[dp]]$value } } for (nlp in names(x$nlpars)) { args_eff_spec <- list(x = x$nlpars[[nlp]]) c(out) <- do_call(data_predictor, c(args_eff_spec, args_eff)) } c(out) <- data_gr_local(x, data = data) c(out) <- data_mixture(x, data2 = data2, prior = prior) out } # prepare data for all types of effects for use in Stan # @param data the data passed by the user # @param prior an object of class brmsprior # @param ... currently ignored # @return a named list of data to be passed to Stan #' @export data_predictor.btl <- function(x, data, data2 = list(), prior = brmsprior(), sdata = NULL, ...) { out <- c( data_fe(x, data), data_sp(x, data, data2 = data2, prior = prior), data_re(x, data), data_cs(x, data), data_sm(x, data), data_gp(x, data), data_ac(x, data, data2 = data2), data_offset(x, data), data_bhaz(x, data, data2 = data2, prior = prior) ) c(out) <- data_special_prior(x, data, prior = prior, sdata = c(sdata, out)) out } # prepare data for non-linear parameters for use in Stan #' @export data_predictor.btnl <- function(x, data, data2 = list(), prior = brmsprior(), ...) { out <- list() c(out) <- data_cnl(x, data) c(out) <- data_ac(x, data, data2 = data2) c(out) <- data_bhaz(x, data, data2 = data2, prior = prior) out } # prepare data of fixed effects data_fe <- function(bframe, data) { stopifnot(is.btl(bframe)) if (!is.null(bframe$sdata$fe)) { # standata was already precomputed return(bframe$sdata$fe) } out <- list() p <- usc(combine_prefix(bframe)) # the intercept is removed inside the Stan code for non-ordinal models is_ord <- is_ordinal(bframe) cols2remove <- if (is_ord) "(Intercept)" X <- get_model_matrix(rhs(bframe$fe), data, cols2remove = cols2remove) avoid_dpars(colnames(X), bframe) out[[paste0("K", p)]] <- ncol(X) if (stan_center_X(bframe)) { # relevant if the intercept is treated separately to enable centering out[[paste0("Kc", p)]] <- ncol(X) - ifelse(is_ord, 0, 1) } out[[paste0("X", p)]] <- X out } # data preparation for splines data_sm <- function(bframe, data) { stopifnot(is.btl(bframe)) if (!is.null(bframe$sdata$sm)) { # standata was already precomputed return(bframe$sdata$sm) } out <- list() smterms <- all_terms(bframe[["sm"]]) if (!length(smterms)) { return(out) } p <- usc(combine_prefix(bframe)) # basis contains information on the smooths from the original data basis <- bframe$basis$sm new <- length(basis) > 0L knots <- get_knots(data) diagonal.penalty <- !require_old_default("2.8.7") bylevels <- named_list(smterms) ns <- 0 lXs <- list() for (i in seq_along(smterms)) { if (new) { sm <- basis[[i]]$sm } else { sm <- smoothCon( eval2(smterms[i]), data = data, knots = knots, absorb.cons = TRUE, diagonal.penalty = diagonal.penalty ) } # may contain multiple terms when 'by' is a factor for (j in seq_along(sm)) { ns <- ns + 1 if (length(sm[[j]]$by.level)) { bylevels[[i]][j] <- sm[[j]]$by.level } if (new) { # prepare smooths for use with new data # mgcv smooths are based on machine-specific SVD (#1465) re <- s2rPred(sm[[j]], re = basis[[i]]$re[[j]], data = data) } else { re <- mgcv::smooth2random(sm[[j]], names(data), type = 2) } lXs[[ns]] <- re$Xf if (NCOL(lXs[[ns]])) { colnames(lXs[[ns]]) <- paste0(sm[[j]]$label, "_", seq_cols(lXs[[ns]])) } Zs <- re$rand sfx <- paste0(p, "_", ns) out[[paste0("nb", sfx)]] <- length(Zs) if (length(Zs)) { names(Zs) <- paste0("Zs", sfx, "_", seq_along(Zs)) c(out) <- Zs out[[paste0("knots", sfx)]] <- as.array(ulapply(Zs, ncol)) } else { out[[paste0("knots", sfx)]] <- integer(0) } } } Xs <- do_call(cbind, lXs) avoid_dpars(colnames(Xs), bframe) smcols <- lapply(lXs, function(x) which(colnames(Xs) %in% colnames(x))) Xs <- structure(Xs, smcols = smcols, bylevels = bylevels) colnames(Xs) <- rename(colnames(Xs)) out[[paste0("Ks", p)]] <- ncol(Xs) out[[paste0("Xs", p)]] <- Xs out } # prepare data for group-level effects for use in Stan data_re <- function(bframe, data) { stopifnot(is.bframel(bframe)) out <- list() px <- check_prefix(bframe) reframe <- subset2(bframe$frame$re, type = "sp", fun = "%notin%") if (!has_rows(reframe)) { return(out) } gn <- unique(reframe$gn) for (i in seq_along(gn)) { r <- subset2(reframe, gn = gn[i]) Z <- get_model_matrix(r$form[[1]], data = data, rename = FALSE) idp <- paste0(r$id[1], usc(combine_prefix(px))) Znames <- paste0("Z_", idp, "_", r$cn) if (r$gtype[1] == "mm") { ng <- length(r$gcall[[1]]$groups) if (r$type[1] == "cs") { stop2("'cs' is not supported in multi-membership terms.") } if (r$type[1] == "mmc") { # see issue #353 for the general idea mmc_expr <- "^mmc\\([^:]*\\)" mmc_terms <- get_matches_expr(mmc_expr, colnames(Z)) for (t in mmc_terms) { pos <- which(grepl_expr(escape_all(t), colnames(Z))) if (length(pos) != ng) { stop2("Invalid term '", t, "': Expected ", ng, " coefficients but found ", length(pos), ".") } for (j in seq_along(Znames)) { for (k in seq_len(ng)) { out[[paste0(Znames[j], "_", k)]] <- as.array(Z[, pos[k]]) } } } } else { for (j in seq_along(Znames)) { out[paste0(Znames[j], "_", seq_len(ng))] <- list(as.array(Z[, j])) } } } else { if (r$type[1] == "cs") { ncatM1 <- nrow(r) / ncol(Z) Z_temp <- vector("list", ncol(Z)) for (k in seq_along(Z_temp)) { Z_temp[[k]] <- replicate(ncatM1, Z[, k], simplify = FALSE) } Z <- do_call(cbind, unlist(Z_temp, recursive = FALSE)) } if (r$type[1] == "mmc") { stop2("'mmc' is only supported in multi-membership terms.") } for (j in seq_cols(Z)) { out[[Znames[j]]] <- as.array(Z[, j]) } } } out } # compute data for each group-level-ID per univariate model data_gr_local <- function(bframe, data) { stopifnot(is.brmsframe(bframe)) out <- list() reframe <- subset2(bframe$frame$re, resp = bframe$resp) resp <- usc(bframe$resp) for (id in unique(reframe$id)) { id_reframe <- subset2(reframe, id = id) idresp <- paste0(id, resp) nranef <- nrow(id_reframe) group <- id_reframe$group[1] levels <- get_levels(reframe)[[group]] if (id_reframe$gtype[1] == "mm") { # multi-membership grouping term gs <- id_reframe$gcall[[1]]$groups ngs <- length(gs) weights <- id_reframe$gcall[[1]]$weights if (is.formula(weights)) { scale <- isTRUE(attr(weights, "scale")) weights <- as.matrix(eval_rhs(weights, data)) if (!identical(dim(weights), c(nrow(data), ngs))) { stop2( "Grouping structure 'mm' expects 'weights' to be ", "a matrix with as many columns as grouping factors." ) } if (scale) { if (isTRUE(any(weights < 0))) { stop2("Cannot scale negative weights.") } weights <- sweep(weights, 1, rowSums(weights), "/") } } else { # all members get equal membership weights by default weights <- matrix(1 / ngs, nrow = nrow(data), ncol = ngs) } for (i in seq_along(gs)) { gdata <- get(gs[i], data) J <- match(gdata, levels) if (anyNA(J)) { # occurs for new levels only new_gdata <- gdata[!gdata %in% levels] new_levels <- unique(new_gdata) J[is.na(J)] <- match(new_gdata, new_levels) + length(levels) } out[[paste0("J_", idresp, "_", i)]] <- as.array(J) out[[paste0("W_", idresp, "_", i)]] <- as.array(weights[, i]) } } else { # ordinary grouping term g <- id_reframe$gcall[[1]]$groups gdata <- get(g, data) J <- match(gdata, levels) if (anyNA(J)) { # occurs for new levels only new_gdata <- gdata[!gdata %in% levels] new_levels <- unique(new_gdata) J[is.na(J)] <- match(new_gdata, new_levels) + length(levels) } out[[paste0("J_", idresp)]] <- as.array(J) } # prepare data for group prior weights if specified if (nzchar(id_reframe$gcall[[1]]$pw)) { if (id_reframe$gtype[1] == "mm") { J <- unlist(out[paste0("J_", idresp, "_", seq_along(gs))]) } # extract and validate prior weights group_prior_weights <- str2formula(id_reframe$gcall[[1]]$pw) group_prior_weights <- as.vector(eval_rhs(group_prior_weights, data)) if (!is.numeric(group_prior_weights)) { stop2("Prior weights of grouping factors must be numeric.") } if (any(group_prior_weights < 0)) { warning2("Negative prior weights detected. Make sure this is intentional.") } # check that group-level weights do not vary within a group group_weights_consistent <- tapply( X = group_prior_weights, INDEX = J, FUN = function(x) length(unique(x)) == 1 ) if (!all(group_weights_consistent)) { stop2("Prior weights cannot vary within a group.") } # deduplicate weights vector (so length matches number of groups) # and order the weights vector to match groups' assigned indices distinct_J_indices <- !duplicated(J) group_prior_weights <- group_prior_weights[distinct_J_indices] group_prior_weights <- group_prior_weights[order(J[distinct_J_indices])] out[[paste0("PW_", id)]] <- as.array(group_prior_weights) } } out } # prepare global data for each group-level-ID data_gr_global <- function(bframe, data2) { stopifnot(is.anybrmsframe(bframe)) out <- list() reframe <- bframe$frame$re for (id in unique(reframe$id)) { tmp <- list() id_reframe <- subset2(reframe, id = id) nranef <- nrow(id_reframe) group <- id_reframe$group[1] levels <- attr(reframe, "levels")[[group]] tmp$N <- length(levels) tmp$M <- nranef tmp$NC <- as.integer(nranef * (nranef - 1) / 2) # prepare number of levels of an optional 'by' variable if (nzchar(id_reframe$by[1])) { stopifnot(!nzchar(id_reframe$type[1])) bylevels <- id_reframe$bylevels[[1]] Jby <- match(attr(levels, "by"), bylevels) tmp$Nby <- length(bylevels) tmp$Jby <- as.array(Jby) } # prepare within-group covariance matrices cov <- id_reframe$cov[1] if (nzchar(cov)) { # validation is only necessary here for compatibility with 'cov_ranef' cov_mat <- validate_recov_matrix(data2[[cov]]) found_levels <- rownames(cov_mat) found <- levels %in% found_levels if (any(!found)) { stop2("Levels of the within-group covariance matrix for '", group, "' do not match names of the grouping levels.") } cov_mat <- cov_mat[levels, levels, drop = FALSE] tmp$Lcov <- t(chol(cov_mat)) } names(tmp) <- paste0(names(tmp), "_", id) c(out) <- tmp } out } # prepare data for special effects for use in Stan data_sp <- function(bframe, data, data2, prior) { stopifnot(is.bframel(bframe)) if (!is.null(bframe$sdata$sp)) { # standata was already precomputed return(bframe$sdata$sp) } out <- list() spframe <- bframe$frame$sp if (!has_rows(spframe)) { return(out) } basis <- bframe$basis$sp px <- check_prefix(bframe) p <- usc(combine_prefix(px)) # prepare general data out[[paste0("Ksp", p)]] <- nrow(spframe) Csp <- sp_model_matrix(bframe$sp, data) avoid_dpars(colnames(Csp), bframe) Csp <- Csp[, spframe$Ic > 0, drop = FALSE] Csp <- lapply(seq_cols(Csp), function(i) as.array(Csp[, i])) if (length(Csp)) { Csp_names <- paste0("Csp", p, "_", seq_along(Csp)) out <- c(out, setNames(Csp, Csp_names)) } if (any(lengths(spframe$Imo) > 0)) { # prepare data specific to monotonic effects out[[paste0("Imo", p)]] <- max(unlist(spframe$Imo)) Xmo <- lapply(unlist(spframe$calls_mo), get_mo_values, data = data) Xmo_names <- paste0("Xmo", p, "_", seq_along(Xmo)) c(out) <- setNames(Xmo, Xmo_names) if (!is.null(basis$Jmo)) { # take information from original data Jmo <- basis$Jmo } else { Jmo <- as.array(ulapply(Xmo, attr, "max")) } out[[paste0("Jmo", p)]] <- Jmo # prepare prior concentration of simplex parameters simo_coef <- get_simo_labels(spframe, use_id = TRUE) ids <- unlist(spframe$ids_mo) for (j in seq_along(simo_coef)) { # index of first ID appearance j_id <- match(ids[j], ids) if (is.na(ids[j]) || j_id == j) { # only evaluate priors without ID or first appearance of the ID # all other parameters will be copied over in the Stan code simo_prior <- subset2(prior, class = "simo", coef = simo_coef[j], ls = px ) con_simo <- eval_dirichlet(simo_prior$prior, Jmo[j], data2) out[[paste0("con_simo", p, "_", j)]] <- as.array(con_simo) } } } uni_mi <- attr(spframe, "uni_mi") index <- bframe$frame$index for (j in seq_rows(uni_mi)) { if (!is.na(uni_mi$idx[j])) { idxl <- get(uni_mi$idx[j], data) if (is.null(index[[uni_mi$var[j]]])) { # the 'idx' argument needs to be mapped against 'index' addition terms stop2("Response '", uni_mi$var[j], "' needs to have an 'index' addition ", "term to compare with 'idx'. See ?mi for examples.") } idxl <- match(idxl, index[[uni_mi$var[j]]]) if (anyNA(idxl)) { stop2("Could not match all indices in response '", uni_mi$var[j], "'.") } idxl_name <- paste0("idxl", p, "_", uni_mi$var[j], "_", uni_mi$idx2[j]) out[[idxl_name]] <- as.array(idxl) } else if (isTRUE(attr(index[[uni_mi$var[j]]], "subset"))) { # cross-formula referencing is required for subsetted variables stop2("mi() terms of subsetted variables require ", "the 'idx' argument to be specified.") } } out } # prepare data for category specific effects data_cs <- function(bframe, data) { stopifnot(is.btl(bframe)) if (!is.null(bframe$sdata$cs)) { # standata was already precomputed return(bframe$sdata$cs) } out <- list() if (length(all_terms(bframe[["cs"]]))) { p <- usc(combine_prefix(bframe)) Xcs <- get_model_matrix(bframe$cs, data) avoid_dpars(colnames(Xcs), bframe) out <- c(out, list(Kcs = ncol(Xcs), Xcs = Xcs)) out <- setNames(out, paste0(names(out), p)) } out } # prepare global data for noise free variables data_Xme <- function(bframe, data) { stopifnot(is.anybrmsframe(bframe)) meframe <- bframe$frame$me stopifnot(is.meframe(meframe)) out <- list() groups <- unique(meframe$grname) for (i in seq_along(groups)) { g <- groups[i] K <- which(meframe$grname %in% g) Mme <- length(K) out[[paste0("Mme_", i)]] <- Mme out[[paste0("NCme_", i)]] <- Mme * (Mme - 1) / 2 if (nzchar(g)) { levels <- get_levels(meframe)[[g]] gr <- get_me_group(meframe$term[K[1]], data) Jme <- match(gr, levels) if (anyNA(Jme)) { # occurs for new levels only # replace NAs with unique values; fixes issue #706 gr[is.na(gr)] <- paste0("new_", seq_len(sum(is.na(gr))), "__") new_gr <- gr[!gr %in% levels] new_levels <- unique(new_gr) Jme[is.na(Jme)] <- length(levels) + match(new_gr, new_levels) } ilevels <- unique(Jme) out[[paste0("Nme_", i)]] <- length(ilevels) out[[paste0("Jme_", i)]] <- Jme } for (k in K) { Xn <- get_me_values(meframe$term[k], data) noise <- get_me_noise(meframe$term[k], data) if (nzchar(g)) { for (l in ilevels) { # validate values of the same level take <- Jme %in% l if (length(unique(Xn[take])) > 1L || length(unique(noise[take])) > 1L) { stop2( "Measured values and measurement error should be ", "unique for each group. Occured for level '", levels[l], "' of group '", g, "'." ) } } Xn <- get_one_value_per_group(Xn, Jme) noise <- get_one_value_per_group(noise, Jme) } out[[paste0("Xn_", k)]] <- as.array(Xn) out[[paste0("noise_", k)]] <- as.array(noise) } } out } # prepare data for Gaussian process terms # @param internal store some intermediate data for internal post-processing? # @param ... passed to '.data_gp' data_gp <- function(bframe, data, internal = FALSE, ...) { stopifnot(is.bframel(bframe)) if (!is.null(bframe$sdata$gp)) { # standata was already precomputed return(bframe$sdata$gp) } out <- list() internal <- as_one_logical(internal) px <- check_prefix(bframe) p <- usc(combine_prefix(px)) basis <- bframe$basis$gp gpframe <- bframe$frame$gp for (i in seq_rows(gpframe)) { pi <- paste0(p, "_", i) Xgp <- lapply(gpframe$covars[[i]], eval2, data) D <- length(Xgp) out[[paste0("Dgp", pi)]] <- D invalid <- ulapply(Xgp, function(x) !is.numeric(x) || isTRUE(length(dim(x)) > 1L) ) if (any(invalid)) { stop2("Predictors of Gaussian processes should be numeric vectors.") } Xgp <- do_call(cbind, Xgp) cmc <- gpframe$cmc[i] scale <- gpframe$scale[i] gr <- gpframe$gr[i] k <- gpframe$k[i] c <- gpframe$c[[i]] if (!isNA(k)) { out[[paste0("NBgp", pi)]] <- k ^ D Ks <- as.matrix(do_call(expand.grid, repl(seq_len(k), D))) } byvar <- gpframe$byvars[[i]] byfac <- length(gpframe$cons[[i]]) > 0L bynum <- !is.null(byvar) && !byfac if (byfac) { # for categorical 'by' variables prepare one GP per level # as.factor will keep unused levels needed for new data byval <- as.factor(get(byvar, data)) byform <- str2formula(c(ifelse(cmc, "0", "1"), "byval")) con_mat <- model.matrix(byform) cons <- colnames(con_mat) out[[paste0("Kgp", pi)]] <- length(cons) Ngp <- Nsubgp <- vector("list", length(cons)) for (j in seq_along(cons)) { # loop along contrasts of 'by' Cgp <- con_mat[, j] sfx <- paste0(pi, "_", j) tmp <- .data_gp( Xgp, k = k, gr = gr, sfx = sfx, Cgp = Cgp, c = c, scale = scale, internal = internal, basis = basis, ... ) Ngp[[j]] <- attributes(tmp)[["Ngp"]] Nsubgp[[j]] <- attributes(tmp)[["Nsubgp"]] c(out) <- tmp } out[[paste0("Ngp", pi)]] <- unlist(Ngp) if (gr) { out[[paste0("Nsubgp", pi)]] <- unlist(Nsubgp) } } else { out[[paste0("Kgp", pi)]] <- 1L c(out) <- .data_gp( Xgp, k = k, gr = gr, sfx = pi, c = c, scale = scale, internal = internal, basis = basis, ... ) if (bynum) { Cgp <- as.numeric(get(byvar, data)) out[[paste0("Cgp", pi)]] <- as.array(Cgp) } } } if (length(basis)) { # original covariate values are required in new GP prediction Xgp_old <- basis[grepl("^Xgp", names(basis))] names(Xgp_old) <- paste0(names(Xgp_old), "_old") out[names(Xgp_old)] <- Xgp_old } out } # helper function to preparae GP related data # @inheritParams data_gp # @param Xgp matrix of covariate values # @param k, gr, c see 'frame_gp' # @param sfx suffix to put at the end of data names # @param Cgp optional vector of values belonging to # a certain contrast of a factor 'by' variable .data_gp <- function(Xgp, k, gr, sfx, Cgp = NULL, c = NULL, scale = TRUE, internal = FALSE, basis = NULL) { out <- list() if (!is.null(Cgp)) { Cgp <- unname(Cgp) Igp <- which(Cgp != 0) Xgp <- Xgp[Igp, , drop = FALSE] out[[paste0("Igp", sfx)]] <- as.array(Igp) out[[paste0("Cgp", sfx)]] <- as.array(Cgp[Igp]) attr(out, "Ngp") <- length(Igp) } if (gr) { groups <- factor(match_rows(Xgp, Xgp)) ilevels <- levels(groups) Jgp <- match(groups, ilevels) Nsubgp <- length(ilevels) if (!is.null(Cgp)) { attr(out, "Nsubgp") <- Nsubgp } else { out[[paste0("Nsubgp", sfx)]] <- Nsubgp } out[[paste0("Jgp", sfx)]] <- as.array(Jgp) not_dupl_Jgp <- !duplicated(Jgp) Xgp <- Xgp[not_dupl_Jgp, , drop = FALSE] } if (scale) { # scale predictor for easier specification of priors if (length(basis)) { # scale Xgp based on the original data dmax <- basis[[paste0("dmax", sfx)]] } else { dmax <- sqrt(max(diff_quad(Xgp))) } if (!isTRUE(dmax > 0)) { stop2("Could not scale GP covariates. Please set 'scale' to FALSE in 'gp'.") } if (internal) { # required for scaling of GPs with new data out[[paste0("dmax", sfx)]] <- dmax } Xgp <- Xgp / dmax } if (length(basis)) { # center Xgp based on the original data cmeans <- basis[[paste0("cmeans", sfx)]] } else { cmeans <- colMeans(Xgp) } if (internal) { # required for centering of approximate GPs with new data out[[paste0("cmeans", sfx)]] <- cmeans # required to compute inverse-gamma priors for length-scales out[[paste0("Xgp_prior", sfx)]] <- Xgp } if (!isNA(k)) { # basis function approach requires centered variables Xgp <- sweep(Xgp, 2, cmeans) D <- NCOL(Xgp) if (length(basis)) { L <- basis[[paste0("Lgp", sfx)]] } else { # compute boundary factor L L <- choose_L(Xgp, c = c) } if (internal) { # required to compute eigenfunctions of approximate GPs with new data out[[paste0("Lgp", sfx)]] <- L } Ks <- as.matrix(do_call(expand.grid, repl(seq_len(k), D))) XgpL <- matrix(nrow = NROW(Xgp), ncol = NROW(Ks)) slambda <- matrix(nrow = NROW(Ks), ncol = D) for (m in seq_rows(Ks)) { XgpL[, m] <- eigen_fun_laplacian(Xgp, m = Ks[m, ], L = L) slambda[m, ] <- sqrt(eigen_val_laplacian(m = Ks[m, ], L = L)) } out[[paste0("Xgp", sfx)]] <- XgpL out[[paste0("slambda", sfx)]] <- slambda } else { out[[paste0("Xgp", sfx)]] <- as.array(Xgp) } out } # data for autocorrelation variables data_ac <- function(bframe, data, data2, ...) { if (!is.null(bframe$sdata$ac)) { # standata was already precomputed return(bframe$sdata$ac) } out <- list() N <- nrow(data) basis <- bframe$basis$ac acframe <- bframe$frame$ac stopifnot(is.acframe(acframe)) if (has_ac_subset(bframe, dim = "time")) { gr <- get_ac_vars(acframe, "gr", dim = "time") if (isTRUE(nzchar(gr))) { tgroup <- as.numeric(factor(data[[gr]])) } else { tgroup <- rep(1, N) } } if (has_ac_class(acframe, "arma")) { # ARMA correlations acframe_arma <- subset2(acframe, class = "arma") out$Kar <- acframe_arma$p out$Kma <- acframe_arma$q if (!use_ac_cov_time(acframe_arma)) { # data for the 'predictor' version of ARMA max_lag <- max(out$Kar, out$Kma) out$J_lag <- as.array(rep(0, N)) for (n in seq_len(N)[-N]) { ind <- n:max(1, n + 1 - max_lag) # indexes errors to be used in the n+1th prediction out$J_lag[n] <- sum(tgroup[ind] %in% tgroup[n + 1]) } } } if (use_ac_cov_time(acframe)) { # data for the 'covariance' versions of time-series structures # TODO: change begin[i]:end[i] notation to slice[i]:(slice[i+1] - 1) # see comment on PR #1435 out$N_tg <- length(unique(tgroup)) out$begin_tg <- as.array(ulapply(unique(tgroup), match, tgroup)) out$nobs_tg <- as.array(with(out, c(if (N_tg > 1L) begin_tg[2:N_tg], N + 1) - begin_tg )) out$end_tg <- with(out, begin_tg + nobs_tg - 1) if (has_ac_class(acframe, "unstr")) { time <- get_ac_vars(bframe, "time", dim = "time") time_data <- get(time, data) new_times <- extract_levels(time_data) if (length(basis)) { times <- basis$times # unstr estimates correlations only for given time points invalid_times <- setdiff(new_times, times) if (length(invalid_times)) { stop2("Cannot handle new time points in UNSTR models.") } } else { times <- new_times } out$n_unique_t <- length(times) out$n_unique_cortime <- out$n_unique_t * (out$n_unique_t - 1) / 2 Jtime <- match(time_data, times) out$Jtime_tg <- matrix(0L, out$N_tg, max(out$nobs_tg)) for (i in seq_len(out$N_tg)) { out$Jtime_tg[i, seq_len(out$nobs_tg[i])] <- Jtime[out$begin_tg[i]:out$end_tg[i]] } } } if (has_ac_class(acframe, "sar")) { acframe_sar <- subset2(acframe, class = "sar") M <- data2[[acframe_sar$M]] rmd_rows <- attr(data, "na.action") if (!is.null(rmd_rows)) { class(rmd_rows) <- NULL M <- M[-rmd_rows, -rmd_rows, drop = FALSE] } if (!is_equal(dim(M), rep(N, 2))) { stop2("Dimensions of 'M' for SAR terms must be equal to ", "the number of observations.") } out$Msar <- as.matrix(M) out$eigenMsar <- eigen(M)$values # simplifies code of choose_N out$N_tg <- 1 } if (has_ac_class(acframe, "car")) { acframe_car <- subset2(acframe, class = "car") locations <- NULL if (length(basis)) { locations <- basis$locations } M <- data2[[acframe_car$M]] if (acframe_car$gr != "NA") { loc_data <- get(acframe_car$gr, data) new_locations <- extract_levels(loc_data) if (is.null(locations)) { locations <- new_locations } else { invalid_locations <- setdiff(new_locations, locations) if (length(invalid_locations)) { stop2("Cannot handle new locations in CAR models.") } } Nloc <- length(locations) Jloc <- as.array(match(loc_data, locations)) if (is.null(rownames(M))) { stop2("Row names are required for 'M' in CAR terms.") } found <- locations %in% rownames(M) if (any(!found)) { stop2("Row names of 'M' for CAR terms do not match ", "the names of the grouping levels.") } M <- M[locations, locations, drop = FALSE] } else { warning2( "Using CAR terms without a grouping factor is deprecated. ", "Please use argument 'gr' even if each observation ", "represents its own location." ) Nloc <- N Jloc <- as.array(seq_len(Nloc)) if (!is_equal(dim(M), rep(Nloc, 2))) { if (length(basis)) { stop2("Cannot handle new data in CAR terms ", "without a grouping factor.") } else { stop2("Dimensions of 'M' for CAR terms must be equal ", "to the number of observations.") } } } edges_rows <- (Matrix::tril(M)@i + 1) edges_cols <- sort(Matrix::triu(M)@i + 1) ## sort to make consistent with rows edges <- cbind("rows" = edges_rows, "cols" = edges_cols) c(out) <- nlist( Nloc, Jloc, Nedges = length(edges_rows), edges1 = as.array(edges_rows), edges2 = as.array(edges_cols) ) if (acframe_car$type %in% c("escar", "esicar")) { Nneigh <- Matrix::colSums(M) if (any(Nneigh == 0) && !length(basis)) { stop2( "For exact sparse CAR, all locations should have at ", "least one neighbor within the provided data set. ", "Consider using type = 'icar' instead." ) } inv_sqrt_D <- diag(1 / sqrt(Nneigh)) eigenMcar <- t(inv_sqrt_D) %*% M %*% inv_sqrt_D eigenMcar <- eigen(eigenMcar, TRUE, only.values = TRUE)$values c(out) <- nlist(Nneigh, eigenMcar) } else if (acframe_car$type %in% "bym2") { c(out) <- list(car_scale = .car_scale(edges, Nloc)) } } if (has_ac_class(acframe, "fcor")) { acframe_fcor <- subset2(acframe, class = "fcor") M <- data2[[acframe_fcor$M]] rmd_rows <- attr(data, "na.action") if (!is.null(rmd_rows)) { class(rmd_rows) <- NULL M <- M[-rmd_rows, -rmd_rows, drop = FALSE] } if (nrow(M) != N) { stop2("Dimensions of 'M' for FCOR terms must be equal ", "to the number of observations.") } out$Mfcor <- M # simplifies code of choose_N out$N_tg <- 1 } if (length(out)) { resp <- usc(combine_prefix(bframe)) out <- setNames(out, paste0(names(out), resp)) } out } # prepare data of offsets for use in Stan data_offset <- function(bframe, data) { stopifnot(is.btl(bframe)) if (!is.null(bframe$sdata$offset)) { # standata was already precomputed return(bframe$sdata$offset) } out <- list() px <- check_prefix(bframe) if (is.formula(bframe$offset)) { p <- usc(combine_prefix(px)) mf <- rm_attr(data, "terms") mf <- model.frame(bframe$offset, mf, na.action = na.pass) offset <- model.offset(mf) if (length(offset) == 1L) { offset <- rep(offset, nrow(data)) } # use 'offsets' as 'offset' will be reserved in stanc3 out[[paste0("offsets", p)]] <- as.array(offset) } out } # data for covariates in non-linear models # @param x a btnl object # @return a named list of data passed to Stan data_cnl <- function(bframe, data) { stopifnot(is.btnl(bframe)) if (!is.null(bframe$sdata$cnl)) { # standata was already precomputed return(bframe$sdata$cnl) } out <- list() covars <- all.vars(bframe$covars) if (!length(covars)) { return(out) } p <- usc(combine_prefix(bframe)) for (i in seq_along(covars)) { cvalues <- get(covars[i], data) if (is_like_factor(cvalues)) { # need to apply factor contrasts cform <- str2formula(covars[i]) cvalues <- get_model_matrix(cform, data, cols2remove = "(Intercept)") if (NCOL(cvalues) == 1L) { dim(cvalues) <- NULL } } if (isTRUE(dim(cvalues) > 2L)) { stop2("Non-linear covariates should be vectors or matrices.") } out[[paste0("C", p, "_", i)]] <- as.array(cvalues) } out } # compute the spatial scaling factor of CAR models # @param edges matrix with two columns defining the adjacency of the locations # @param Nloc number of locations # @return a scalar scaling factor .car_scale <- function(edges, Nloc) { # amended from Imad Ali's code of CAR models in rstanarm stopifnot(is.matrix(edges), NCOL(edges) == 2) # Build the adjacency matrix adj_matrix <- Matrix::sparseMatrix( i = edges[, 1], j = edges[, 2], x = 1, symmetric = TRUE ) # The ICAR precision matrix (which is singular) Q <- Matrix::Diagonal(Nloc, Matrix::rowSums(adj_matrix)) - adj_matrix # Add a small jitter to the diagonal for numerical stability Q_pert <- Q + Matrix::Diagonal(Nloc) * max(Matrix::diag(Q)) * sqrt(.Machine$double.eps) # Compute the diagonal elements of the covariance matrix subject to the # constraint that the entries of the ICAR sum to zero. .Q_inv <- function(Q) { Sigma <- Matrix::solve(Q) A <- matrix(1, 1, NROW(Sigma)) W <- Sigma %*% t(A) Sigma <- Sigma - W %*% solve(A %*% W) %*% Matrix::t(W) return(Sigma) } Q_inv <- .Q_inv(Q_pert) # Compute the geometric mean of the variances (diagonal of Q_inv) exp(mean(log(Matrix::diag(Q_inv)))) } # data for special priors such as horseshoe and R2D2 data_special_prior <- function(bframe, data, prior, sdata = NULL) { out <- list() px <- check_prefix(bframe) p <- usc(combine_prefix(px)) if (!has_special_prior(prior, px)) { return(out) } # number of coefficients affected by the shrinkage prior # fully compute this here to avoid having to pass the prior around # to all the individual data preparation functions # the order of adding things to Kscales doesn't matter but for consistency # it is still the same as the order in the Stan code Kscales <- 0 if (has_special_prior(prior, px, class = "b")) { Kscales <- Kscales + sdata[[paste0("Kc", p)]] %||% sdata[[paste0("K", p)]] %||% 0 + sdata[[paste0("Ksp", p)]] %||% 0 + sdata[[paste0("Ks", p)]] %||% 0 } if (has_special_prior(prior, px, class = "sds")) { take <- grepl(paste0("^nb", p, "_"), names(sdata)) Kscales <- Kscales + sum(unlist(sdata[take])) } if (has_special_prior(prior, px, class = "sdgp")) { take <- grepl(paste0("^Kgp", p, "_"), names(sdata)) Kscales <- Kscales + sum(unlist(sdata[take])) } if (has_special_prior(prior, px, class = "ar")) { Kscales <- Kscales + sdata[[paste0("Kar", p)]] } if (has_special_prior(prior, px, class = "ma")) { Kscales <- Kscales + sdata[[paste0("Kma", p)]] } if (has_special_prior(prior, px, class = "sderr")) { Kscales <- Kscales + 1 } if (has_special_prior(prior, px, class = "sdcar")) { Kscales <- Kscales + 1 } if (has_special_prior(prior, px, class = "sd")) { ids <- unique(bframe$frame$re$id) Kscales <- Kscales + sum(unlist(sdata[paste0("M_", ids)])) } out[[paste0("Kscales", p)]] <- Kscales special <- get_special_prior(prior, px, main = TRUE) if (special$name == "horseshoe") { # data for the horseshoe prior hs_names <- c("df", "df_global", "df_slab", "scale_global", "scale_slab") hs_data <- special[hs_names] if (!is.null(special$par_ratio)) { hs_data$scale_global <- special$par_ratio / sqrt(nrow(data)) } names(hs_data) <- paste0("hs_", hs_names, p) c(out) <- hs_data } else if (special$name == "R2D2") { # data for the R2D2 prior R2D2_names <- c("mean_R2", "prec_R2", "cons_D2") R2D2_data <- special[R2D2_names] if (length(R2D2_data$cons_D2) == 1L) { R2D2_data$cons_D2 <- rep(R2D2_data$cons_D2, Kscales) } if (length(R2D2_data$cons_D2) != Kscales) { stop2("Argument 'cons_D2' of the R2D2 prior must be of length 1 or ", Kscales) } R2D2_data$cons_D2 <- as.array(R2D2_data$cons_D2) names(R2D2_data) <- paste0("R2D2_", R2D2_names, p) c(out) <- R2D2_data } out } # Construct design matrices for brms models # @param formula a formula object # @param data A data frame created with model.frame. # If another sort of object, model.frame is called first. # @param cols2remove names of the columns to remove from # the model matrix; mainly used for intercepts # @param rename rename column names via rename()? # @param ... passed to stats::model.matrix # @return # The design matrix for the given formula and data. # For details see ?stats::model.matrix get_model_matrix <- function(formula, data = environment(formula), cols2remove = NULL, rename = TRUE, ...) { stopifnot(is_atomic_or_null(cols2remove)) terms <- validate_terms(formula) if (is.null(terms)) { return(NULL) } if (no_int(terms)) { cols2remove <- union(cols2remove, "(Intercept)") } X <- stats::model.matrix(terms, data, ...) cols2remove <- which(colnames(X) %in% cols2remove) if (length(cols2remove)) { X <- X[, -cols2remove, drop = FALSE] } if (rename) { colnames(X) <- rename(colnames(X), check_dup = TRUE) } X } # convenient wrapper around mgcv::PredictMat PredictMat <- function(object, data, ...) { data <- sm_prepare_data(object, data) out <- mgcv::PredictMat(object, data = data, ...) if (length(dim(out)) < 2L) { # fixes issue #494 out <- matrix(out, nrow = 1) } out } # convenient wrapper around mgcv::smoothCon smoothCon <- function(object, data, ...) { data <- sm_prepare_data(object, data) mgcv::smoothCon(object, data = data, ...) } # mgcv doesn't handle a lot of special data types well # need to prepare these variables manually beforehand sm_prepare_data <- function(object, data) { data <- rm_attr(data, "terms") vars <- setdiff(c(object$term, object$by), "NA") for (v in vars) { if (is_like_factor(data[[v]])) { # allow factor-like variables #562 data[[v]] <- as.factor(data[[v]]) } else if (inherits(data[[v]], "difftime")) { # mgcv cannot handle 'difftime' variables data[[v]] <- as.numeric(data[[v]]) } } data } # Aid prediction from smooths represented as 'type = 2' # code obtained from the doc of ?mgcv::smooth2random # @param sm output of mgcv::smoothCon # @param re output of mgcv::smooth2random # @param data new data supplied for prediction # @return A list of the same structure as returned by mgcv::smooth2random s2rPred <- function(sm, re, data) { # prediction matrix for new data X <- PredictMat(sm, data) # transform to RE parameterization if (!is.null(re$trans.U)) { X <- X %*% re$trans.U } if (is.null(re$trans.D)) { # regression spline without penalization out <- list(Xf = X) } else { X <- t(t(X) * re$trans.D) # re-order columns according to random effect re-ordering X[, re$rind] <- X[, re$pen.ind != 0] # re-order penalization index in same way pen.ind <- re$pen.ind pen.ind[re$rind] <- pen.ind[pen.ind > 0] # start returning the object Xf <- X[, which(re$pen.ind == 0), drop = FALSE] out <- list(rand = list(), Xf = Xf) for (i in seq_along(re$rand)) { # loop over random effect matrices out$rand[[i]] <- X[, which(pen.ind == i), drop = FALSE] attr(out$rand[[i]], "s.label") <- attr(re$rand[[i]], "s.label") } names(out$rand) <- names(re$rand) } out } brms/R/summary.R0000644000176200001440000004771615053072461013260 0ustar liggesusers#' Create a summary of a fitted model represented by a \code{brmsfit} object #' #' @param object An object of class \code{brmsfit}. #' @param priors Logical; Indicating if priors should be included #' in the summary. Default is \code{FALSE}. #' @param prob A value between 0 and 1 indicating the desired probability #' to be covered by the uncertainty intervals. The default is 0.95. #' @param mc_se Logical; Indicating if the uncertainty in \code{Estimate} #' caused by the MCMC sampling should be shown in the summary. Defaults to #' \code{FALSE}. #' @param ... Other potential arguments #' @inheritParams posterior_summary #' #' @details The convergence diagnostics \code{Rhat}, \code{Bulk_ESS}, and #' \code{Tail_ESS} are described in detail in Vehtari et al. (2020). #' #' @references #' Aki Vehtari, Andrew Gelman, Daniel Simpson, Bob Carpenter, and #' Paul-Christian Bürkner (2020). Rank-normalization, folding, and #' localization: An improved R-hat for assessing convergence of #' MCMC. *Bayesian Analysis*. 1–28. dpi:10.1214/20-BA1221 #' #' @method summary brmsfit #' @importFrom posterior subset_draws summarize_draws #' @export summary.brmsfit <- function(object, priors = FALSE, prob = 0.95, robust = FALSE, mc_se = FALSE, ...) { priors <- as_one_logical(priors) probs <- validate_ci_bounds(prob) robust <- as_one_logical(robust) mc_se <- as_one_logical(mc_se) object <- restructure(object) bterms <- brmsterms(object$formula) out <- list( formula = object$formula, data_name = get_data_name(object$data), group = unique(object$ranef$group), nobs = nobs(object), ngrps = ngrps(object), autocor = object$autocor, prior = empty_prior(), algorithm = algorithm(object) ) class(out) <- "brmssummary" # check if the model contains any posterior draws model_is_empty <- is.null(object$fit) || !length(object$fit@sim) || isTRUE(object$fit@sim$iter <= object$fit@sim$warmup) if (model_is_empty) { return(out) } stan_args <- object$fit@stan_args[[1]] out$sampler <- paste0(stan_args$method, "(", stan_args$algorithm, ")") if (priors) { out$prior <- prior_summary(object, all = FALSE) } variables <- variables(object) incl_classes <- c( "b", "bs", "bcs", "bsp", "bmo", "bme", "bmi", "bm", valid_dpars(object), "delta", "lncor", "rescor", "ar", "ma", "sderr", "cosy", "cortime", "lagsar", "errorsar", "car", "sdcar", "rhocar", "sd", "cor", "df", "sds", "sdgp", "lscale", "simo" ) incl_regex <- paste0("^", regex_or(incl_classes), "(_|$|\\[)") variables <- variables[grepl(incl_regex, variables)] draws <- as_draws_array(object, variable = variables) out$total_ndraws <- ndraws(draws) out$chains <- nchains(object) if (length(object$fit@sim$iter)) { # MCMC algorithms out$iter <- object$fit@sim$iter out$warmup <- object$fit@sim$warmup } else { # non-MCMC algorithms out$iter <- out$total_ndraws out$warmup <- 0 } out$thin <- nthin(object) # compute a summary for given set of parameters # TODO: align names with summary outputs of other methods and packages .summary <- function(draws, variables, probs, robust) { # quantiles with appropriate names to retain backwards compatibility .quantile <- function(x, ...) { qs <- posterior::quantile2(x, probs = probs, ...) prob <- probs[2] - probs[1] names(qs) <- paste0(c("l-", "u-"), prob * 100, "% CI") return(qs) } draws <- subset_draws(draws, variable = variables) measures <- list() if (robust) { measures$Estimate <- median if (mc_se) { measures$MCSE <- posterior::mcse_median } measures$Est.Error <- mad } else { measures$Estimate <- mean if (mc_se) { measures$MCSE <- posterior::mcse_mean } measures$Est.Error <- sd } c(measures) <- list(quantiles = .quantile) if (!is.brmsfit_multiple(object)) { # TODO: add a viable post-processing solution for brm_multiple models c(measures) <- list( Rhat = posterior::rhat, Bulk_ESS = posterior::ess_bulk, Tail_ESS = posterior::ess_tail ) } out <- do.call(summarize_draws, c(list(draws), measures)) out <- as.data.frame(out) rownames(out) <- out$variable out$variable <- NULL return(out) } full_summary <- .summary(draws, variables, probs, robust) out$has_rhat <- "Rhat" %in% colnames(full_summary) if (algorithm(object) == "sampling") { if (out$has_rhat) { Rhats <- full_summary[, "Rhat"] if (any(Rhats > 1.05, na.rm = TRUE)) { warning2( "Parts of the model have not converged (some Rhats are > 1.05). ", "Be careful when analysing the results! We recommend running ", "more iterations and/or setting stronger priors." ) } } div_trans <- sum(nuts_params(object, pars = "divergent__")$Value) adapt_delta <- control_params(object)$adapt_delta if (div_trans > 0) { warning2( "There were ", div_trans, " divergent transitions after warmup. ", "Increasing adapt_delta above ", adapt_delta, " may help. See ", "http://mc-stan.org/misc/warnings.html#divergent-transitions-after-warmup" ) } } # summary of population-level effects fe_pars <- variables[grepl(fixef_pars(), variables)] out$fixed <- full_summary[fe_pars, , drop = FALSE] rownames(out$fixed) <- gsub(fixef_pars(), "", fe_pars) # summary of family specific parameters spec_pars <- c(valid_dpars(object), "delta") spec_pars <- paste0(spec_pars, collapse = "|") spec_pars <- paste0("^(", spec_pars, ")($|_)") spec_pars <- variables[grepl(spec_pars, variables)] out$spec_pars <- full_summary[spec_pars, , drop = FALSE] # correlation parameters require renaming to look good in the summary lncor_pars <- variables[grepl("^lncor_", variables)] if (length(lncor_pars)) { lncor_summary <- full_summary[lncor_pars, , drop = FALSE] lncor_pars <- sub("__", ",", sub("__", "(", lncor_pars)) rownames(lncor_summary) <- paste0(lncor_pars, ")") out$spec_pars <- rbind(out$spec_pars, lncor_summary) } # summary of residual correlations rescor_pars <- variables[grepl("^rescor_", variables)] if (length(rescor_pars)) { out$rescor_pars <- full_summary[rescor_pars, , drop = FALSE] rescor_pars <- sub("__", ",", sub("__", "(", rescor_pars)) rownames(out$rescor_pars) <- paste0(rescor_pars, ")") } # summary of autocorrelation effects cor_pars <- variables[grepl(regex_autocor_pars(), variables)] out$cor_pars <- full_summary[cor_pars, , drop = FALSE] rownames(out$cor_pars) <- cor_pars cortime_pars <- variables[grepl("^cortime_", variables)] if (length(cortime_pars)) { tmp <- full_summary[cortime_pars, , drop = FALSE] cortime_pars <- sub("__", ",", sub("__", "(", cortime_pars)) rownames(tmp) <- paste0(cortime_pars, ")") out$cor_pars <- rbind(out$cor_pars, tmp) } # summary of group-level effects for (g in out$group) { gregex <- escape_dot(g) sd_prefix <- paste0("^sd_", gregex, "__") sd_pars <- variables[grepl(sd_prefix, variables)] cor_prefix <- paste0("^cor_", gregex, "__") cor_pars <- variables[grepl(cor_prefix, variables)] df_prefix <- paste0("^df_", gregex, "$") df_pars <- variables[grepl(df_prefix, variables)] gpars <- c(df_pars, sd_pars, cor_pars) out$random[[g]] <- full_summary[gpars, , drop = FALSE] if (has_rows(out$random[[g]])) { sd_names <- sub(sd_prefix, "sd(", sd_pars) cor_names <- sub(cor_prefix, "cor(", cor_pars) cor_names <- sub("__", ",", cor_names) df_names <- sub(df_prefix, "df", df_pars) gnames <- c(df_names, paste0(c(sd_names, cor_names), ")")) rownames(out$random[[g]]) <- gnames } } # summary of smooths sm_pars <- variables[grepl("^sds_", variables)] if (length(sm_pars)) { out$splines <- full_summary[sm_pars, , drop = FALSE] rownames(out$splines) <- paste0(gsub("^sds_", "sds(", sm_pars), ")") } # summary of monotonic parameters mo_pars <- variables[grepl("^simo_", variables)] if (length(mo_pars)) { out$mo <- full_summary[mo_pars, , drop = FALSE] rownames(out$mo) <- gsub("^simo_", "", mo_pars) } # summary of gaussian processes gp_pars <- variables[grepl("^(sdgp|lscale)_", variables)] if (length(gp_pars)) { out$gp <- full_summary[gp_pars, , drop = FALSE] rownames(out$gp) <- gsub("^sdgp_", "sdgp(", rownames(out$gp)) rownames(out$gp) <- gsub("^lscale_", "lscale(", rownames(out$gp)) rownames(out$gp) <- paste0(rownames(out$gp), ")") } out } #' Print a summary for a fitted model represented by a \code{brmsfit} object #' #' @aliases print.brmssummary #' #' @param x An object of class \code{brmsfit} #' @param digits The number of significant digits for printing out the summary; #' defaults to 2. The effective sample size is always rounded to integers. #' @param short A flag indicating whether to provide a shorter summary #' with less informational text. Defaults to \code{FALSE}. Can be set #' globally for the current session via the \code{brms.short_summary} option. #' @param ... Additional arguments that would be passed #' to method \code{summary} of \code{brmsfit}. #' #' @seealso \code{\link{summary.brmsfit}} #' #' @export print.brmsfit <- function(x, digits = 2, short = getOption("brms.short_summary", FALSE), ...) { print(summary(x, ...), digits = digits, short = short, ...) } #' @export print.brmssummary <- function(x, digits = 2, short = getOption("brms.short_summary", FALSE), ...) { short <- as_one_logical(short) cat(" Family: ") cat(summarise_families(x$formula), "\n") cat(" Links: ") cat(summarise_links(x$formula, wsp = 9), "\n") cat("Formula: ") print(x$formula, wsp = 9) cat(paste0( " Data: ", x$data_name, " (Number of observations: ", x$nobs, ") \n" )) if (!isTRUE(nzchar(x$sampler))) { cat("\nThe model does not contain posterior draws.\n") return(invisible(x)) } if (!short) { cat(paste0( " Draws: ", x$chains, " chains, each with iter = ", x$iter, "; warmup = ", x$warmup, "; thin = ", x$thin, ";\n", " total post-warmup draws = ", x$total_ndraws, "\n" )) } cat("\n") # TODO: change order of the displayed summaries? if (nrow(x$prior)) { cat("Priors:\n") print(x$prior, show_df = FALSE) cat("\n") } if (length(x$splines)) { cat("Smoothing Spline Hyperparameters:\n") print_format(x$splines, digits) cat("\n") } if (length(x$gp)) { cat("Gaussian Process Hyperparameters:\n") print_format(x$gp, digits) cat("\n") } if (nrow(x$cor_pars)) { cat("Correlation Structures:\n") # TODO: better printing for correlation structures? print_format(x$cor_pars, digits) cat("\n") } if (length(x$random)) { cat("Multilevel Hyperparameters:\n") for (i in seq_along(x$random)) { g <- names(x$random)[i] cat(paste0("~", g, " (Number of levels: ", x$ngrps[[g]], ") \n")) print_format(x$random[[g]], digits) cat("\n") } } if (nrow(x$fixed)) { cat("Regression Coefficients:\n") print_format(x$fixed, digits) cat("\n") } if (length(x$mo)) { cat("Monotonic Simplex Parameters:\n") print_format(x$mo, digits) cat("\n") } if (nrow(x$spec_pars)) { cat("Further Distributional Parameters:\n") print_format(x$spec_pars, digits) cat("\n") } if (length(x$rescor_pars)) { cat("Residual Correlations: \n") print_format(x$rescor, digits) cat("\n") } if (!short) { cat(paste0("Draws were sampled using ", x$sampler, ". ")) if (x$algorithm == "sampling") { if (isTRUE(x$has_rhat)) { cat(paste0( "For each parameter, Bulk_ESS\n", "and Tail_ESS are effective sample size measures, ", "and Rhat is the potential\n", "scale reduction factor on split chains ", "(at convergence, Rhat = 1)." )) } else { cat(paste0( "Overall Rhat and ESS estimates\n", "are not informative for brm_multiple models and are hence not displayed.\n", "Please see ?brm_multiple for how to assess convergence of such models." )) } } cat("\n") } invisible(x) } # helper function to print summary matrices in nice format # also displays -0.00 as a result of round negative values to zero (#263) # @param x object to be printed; coerced to matrix # @param digits number of digits to show # @param no_digits names of columns for which no digits should be shown print_format <- function(x, digits = 2, no_digits = c("Bulk_ESS", "Tail_ESS")) { x <- as.matrix(x) digits <- as.numeric(digits) if (length(digits) != 1L) { stop2("'digits' should be a single numeric value.") } out <- x fmt <- paste0("%.", digits, "f") for (i in seq_cols(x)) { if (isTRUE(colnames(x)[i] %in% no_digits)) { out[, i] <- sprintf("%.0f", x[, i]) } else { out[, i] <- sprintf(fmt, x[, i]) } } print(out, quote = FALSE, right = TRUE) invisible(x) } # regex to extract population-level coefficients fixef_pars <- function() { types <- c("", "s", "cs", "sp", "mo", "me", "mi", "m") types <- paste0("(", types, ")", collapse = "|") paste0("^b(", types, ")_") } # algorithm used in the model fitting algorithm <- function(x) { stopifnot(is.brmsfit(x)) if (is.null(x$algorithm)) "sampling" else x$algorithm } #' Summarize Posterior draws #' #' Summarizes posterior draws based on point estimates (mean or median), #' estimation errors (SD or MAD) and quantiles. This function mainly exists to #' retain backwards compatibility. It will eventually be replaced by functions #' of the \pkg{posterior} package (see examples below). #' #' @param x An \R object. #' @inheritParams as.matrix.brmsfit #' @param probs The percentiles to be computed by the #' \code{\link[stats:quantile]{quantile}} function. #' @param robust If \code{FALSE} (the default) the mean is used as #' the measure of central tendency and the standard deviation as #' the measure of variability. If \code{TRUE}, the median and the #' median absolute deviation (MAD) are applied instead. #' @param ... More arguments passed to or from other methods. #' #' @return A matrix where rows indicate variables #' and columns indicate the summary estimates. #' #' @seealso \code{\link[posterior:summarize_draws]{summarize_draws}} #' #' @examples #' \dontrun{ #' fit <- brm(time ~ age * sex, data = kidney) #' posterior_summary(fit) #' #' # recommended workflow using posterior #' library(posterior) #' draws <- as_draws_array(fit) #' summarise_draws(draws, default_summary_measures()) #' } #' #' @export posterior_summary <- function(x, ...) { UseMethod("posterior_summary") } #' @rdname posterior_summary #' @export posterior_summary.default <- function(x, probs = c(0.025, 0.975), robust = FALSE, ...) { # TODO: replace with summary functions from posterior # TODO: find a way to represent 3D summaries as well if (!length(x)) { stop2("No posterior draws supplied.") } if (robust) { coefs <- c("median", "mad", "quantile") } else { coefs <- c("mean", "sd", "quantile") } .posterior_summary <- function(x) { do_call(cbind, lapply( coefs, get_estimate, draws = x, probs = probs, na.rm = TRUE )) } if (length(dim(x)) <= 2L) { # data.frames cause trouble in as.array x <- as.matrix(x) } else { x <- as.array(x) } if (length(dim(x)) == 2L) { out <- .posterior_summary(x) rownames(out) <- colnames(x) } else if (length(dim(x)) == 3L) { out <- lapply(array2list(x), .posterior_summary) out <- abind(out, along = 3) dnx <- dimnames(x) dimnames(out) <- list(dnx[[2]], dimnames(out)[[2]], dnx[[3]]) } else { stop("'x' must be of dimension 2 or 3.") } # TODO: align names with summary outputs of other methods and packages colnames(out) <- c("Estimate", "Est.Error", paste0("Q", probs * 100)) out } #' @rdname posterior_summary #' @export posterior_summary.brmsfit <- function(x, pars = NA, variable = NULL, probs = c(0.025, 0.975), robust = FALSE, ...) { out <- as.matrix(x, pars = pars, variable = variable, ...) posterior_summary(out, probs = probs, robust = robust, ...) } # calculate estimates over posterior draws # @param coef coefficient to be applied on the draws (e.g., "mean") # @param draws the draws over which to apply coef # @param margin see 'apply' # @param ... additional arguments passed to get(coef) # @return typically a matrix with colnames(draws) as colnames get_estimate <- function(coef, draws, margin = 2, ...) { # TODO: replace with summary functions from posterior dots <- list(...) args <- list(X = draws, MARGIN = margin, FUN = coef) fun_args <- names(formals(coef)) if (!"..." %in% fun_args) { dots <- dots[names(dots) %in% fun_args] } x <- do_call(apply, c(args, dots)) if (is.null(dim(x))) { x <- matrix(x, dimnames = list(NULL, coef)) } else if (coef == "quantile") { x <- aperm(x, length(dim(x)):1) } x } # validate bounds of credible intervals # @return a numeric vector of length 2 validate_ci_bounds <- function(prob, probs = NULL) { if (!is.null(probs)) { # deprecated as of version 2.13.7 warning2("Argument 'probs' is deprecated. Please use 'prob' instead.") if (length(probs) != 2L) { stop2("Arguments 'probs' must be of length 2.") } probs <- as.numeric(probs) } else { prob <- as_one_numeric(prob) if (prob < 0 || prob > 1) { stop2("'prob' must be a single numeric value in [0, 1].") } probs <- c((1 - prob) / 2, 1 - (1 - prob) / 2) } probs } #' Table Creation for Posterior Draws #' #' Create a table for unique values of posterior draws. #' This is usually only useful when summarizing predictions #' of ordinal models. #' #' @param x A matrix of posterior draws where rows #' indicate draws and columns indicate parameters. #' @param levels Optional values of possible posterior values. #' Defaults to all unique values in \code{x}. #' #' @return A matrix where rows indicate parameters #' and columns indicate the unique values of #' posterior draws. #' #' @examples #' \dontrun{ #' fit <- brm(rating ~ period + carry + treat, #' data = inhaler, family = cumulative()) #' pr <- predict(fit, summary = FALSE) #' posterior_table(pr) #' } #' #' @export posterior_table <- function(x, levels = NULL) { x <- as.matrix(x) if (anyNA(x)) { warning2("NAs will be ignored in 'posterior_table'.") } if (is.null(levels)) { levels <- sort(unique(as.vector(x))) } xlevels <- attr(x, "levels") if (length(xlevels) != length(levels)) { xlevels <- levels } out <- lapply(seq_len(ncol(x)), function(n) table(factor(x[, n], levels = levels)) ) out <- do_call(rbind, out) # compute relative frequencies out <- out / rowSums(out) rownames(out) <- colnames(x) colnames(out) <- paste0("P(Y = ", xlevels, ")") out } #' Compute posterior uncertainty intervals #' #' Compute posterior uncertainty intervals for \code{brmsfit} objects. #' #' @param object An object of class \code{brmsfit}. #' @param prob A value between 0 and 1 indicating the desired probability #' to be covered by the uncertainty intervals. The default is 0.95. #' @inheritParams as.matrix.brmsfit #' @param ... More arguments passed to \code{\link{as.matrix.brmsfit}}. #' #' @return A \code{matrix} with lower and upper interval bounds #' as columns and as many rows as selected variables. #' #' @examples #' \dontrun{ #' fit <- brm(count ~ zAge + zBase * Trt, #' data = epilepsy, family = negbinomial()) #' posterior_interval(fit) #' } #' #' @aliases posterior_interval #' @method posterior_interval brmsfit #' @export #' @export posterior_interval #' @importFrom rstantools posterior_interval posterior_interval.brmsfit <- function( object, pars = NA, variable = NULL, prob = 0.95, ... ) { ps <- as.matrix(object, pars = pars, variable = variable, ...) rstantools::posterior_interval(ps, prob = prob) } brms/R/sysdata.rda0000644000176200001440000315242515047367755013615 0ustar liggesusersBZh91AY&SYl%@Pi}I!}v: プn]g:i+ͽinN:Nӻ[Q&޷휤훶Jtҵvw4hjJ T, -4>)Cw/oU{}}z $ PF vЉU +:ǣΊ}_gγ>JfgZ56+5zoC}MKtw]C {d BM,}{Ҷciۆ>϶=}]3- Alsé_i=/ {Im{g ;I}zuw5B6ׇ6oyzTIFRSk1RUM1(S7n(WݒC5.Hۭj H}bJHP> [չ_}ݺy׶ Un:[M`h Gｻk(CU/@TTZm)l = {rx}w/TM^<zvKPr/0)6n.TQ'Y@( 3]ݠV@P ( )A * }w5WAP;n@ ȡ@}CzTClTP8}>yCG}9}ךK:z|}o;ŏM,>6ҾkK qo9l;y[o{|۞{p};x=ow$:[+Wｽ7o{ǞSUj6w((4EYZlGkw9}#`AHc]N 5M4ٹ̶jw{0UJwM+6k Yo-Ser͝n^.s,am[MkhVpԚ4Xɸn{t9׳XЯm;`ᦈ 4&hLA1 zF y56SzѢ(@ =LIO$5d=2 #dM4H$D#@ `&hO#"~4=OCM4Pڃ)L 04ѦD3I=O4'J6jdS5ڠiB@iF '#m 5OGSM4Se44PI@ h2OAMs8{iqTʩf&p1G gMqrӧ:f4j7;XákJ8MrD05kԌ[a&spd̬kl, ElklbOf5uA3PڭVVA 1P 41O|ϥ!휢(?]R}dvsd׻X2T+L16'7YC8VN29l,ڜt>w?Ot:g6`-< 2n°4wg''K?ښ|Z$+llO'_L&QCYBM!y0(3^gmrCʨJLwY&iur_lxrE#dTO`I*>?gH~0惴?K1Yۜ-=aܮ9 18ܑ`3IҞ 3jpBOoL G``ϋi]j"z%#Y'kRKy`Ao6z?N5YDr / PTH#( UfD?ys JO*Q]fDiH/1l| ȨeS¸q :I_xjr}jz~s9dLK#n^eW?yy_N#zl6*L~G;n.SQIqdLdkr?5Np݉z:.s;!Lxdue/AC(P[C2HD ,:H3܀`Ҡޠ=Ѷ p%+{Q6LNL€IH,Ft区Kf'۳LO<;4*3qGơC&AQn8yb2- 7i6ˆEobTEGQ}ʩP~hAWfRm${X|?E@U#nZg%wߟǗͩ`v늦yOӣI"3?Re=v@Uxj|fܩ4i ,xy']S:"+|}7C})6 G GKJz0q t*`fg NScD .LUWK$q" ӯ#B~l=k@ Ibޙaq5P*RPbd-V?֩Dqv1v."qY1XĺjF!L>ZүUVu#[Ekڛ_>Oz m.߹gaT{^✪rq7D\ 5YuP$\˥r;:Dy4k@DՂޡT;r"͕s!($u@(-Qg2Y>NӾϏjw:z])=MmVs0!2Y{K#6p(() 3ґFvS砵ʥklQpPTI\\ St'Q9&aABZPWpkaUEE1?8ll尉NQb$|J;6ߍ٭;==>gYV̈́5s:N:q/&} aNٙE}~TTo*Q PE]FhPQY9:+l3JW ,L@QXʣu>FsvY>#_3V/2-AqC~gc`^vW_%3hrZ΀-AMV auP.4{‰,ĞU`: ڹ}}>I5c%s }V,onq/OSI_wUvG*4jY6l  `ɒJ&DT5/0zH!wC9ژUYޮW͐چyZG4fnJA􄛡̮ȑ5瘖6]3o2cMce]`ѧxB_ĺqeMLlZw#MP'׎GuujՂ=[" ->_n1.q6F* V`7s1Z0xkƌ!UIƇ Cn؇ b~j]C8/Y,S$Rhuu !⶚{@Z0d*\q BM|iQ0ӑLuFRPc{LɡVAM/Es T; Pp`ᚘeNj|Z{O˽mJ @kۗlhN)P%[uCq|=jrQ6dmrPb2!t*..S_Ȋ`([M:i~s !+? zt | Ywh" L((SЭeK; 6љd_1OBE>+hN;n47/>uҊT#歠F,3n)!:R-$p>rיsAG9fp I!\P9 a[LsLQNb>Gsʞ׫M7VZݑUbv,G )S0YDW9i9R,5`O̹nKfoߺ,D{GGOf^M]#Oc eg@ž<DUcn0-8VwHEyf4fx2 /$fcZ}).nQqDE2+0N-twlj w{uIG;s/hG.}o-eku~²1|Rx0's2.W8bY;&$5ć \Ƨ;b Y,5;^s, c$ moOuso,> o!m'N=qPWlY`sp:fk} 1%Q;Ԟg*,a39P`TkږɪLܻ4qū#dO,lR^Q[B(En:t'zuܮq79{UaԚtVI1uvO[3|*A 꾺".| SF?&ŸE^-_g^7CQEC!aS#>{ɧxSHrcH8~Ǽ'(/ͯEI즡zCgw#1+';k-y?JV XχHsW[q*M9,LD@b/s Mx>DUPL::Lo` "݄zo>>aK)kR[Rd;ÆD$Fr*jLҢF,PԒQDn jMv[ ܘgrN[]PʵTxn*#,YdZAz>˗!qf0q5ppǾ<pb"hId;%ELU K6\P,8Fi[нPQxgX`ߒzN9Qi6~;:vJqS*~Ơ[f (Fm9e8ô-6 m`Na;)ʎWY \`D [x},G\pJش>S67MG.su^c hoX==ɨ)aX^&y(9ECQZ1ٟEpN37?v2hApi Pc[QVh5+ 'hUH14+hx"|kg+Q'T%`Uy#T$)(!pCWYT U\/'K܎cΪk<Lg {Y='T}t拇Z#PSVْs GU|ɷ=vj$x@e٨fx;U][Ixc&e,og_MUB!nS,a^\Tyibr}O[ъ'&Sҳ%e=&AK vcX5 N[bH;⛳N MέҗLfLTN95492=F0|oTT" D$)ԭ'_6D8jY:R!.T3) GB RZCt0vB=J&X;-{P`ALd% <K(֐W2ԡӵwV(eX0̀O\#`f~9$pVײW(ڵ#$CMAƟ@\`^:ʖ}a|PTG$*/TZ9}3K,՘g?E-1~|!\el}ʘi%L "AUJqpһ^eMYT @gpK^8ۅ!ijtB0 nPu/Y3<>ʷM=4永~^9uav{[i=vÝmaAHφӀ&_iOlr;S2?QRѻe/|ƗcI:q_}4Z-^ىk (SNjԐR*ةO"͑ I9sջU+S,9:MCUj_^#'ۙ]<,oIGͽ=8ߧ6~y׿o]iypu<\~2`]Uwqp},l"Dr񻚎\m#MM^>^݃߈29{WuҶr C%I/Y{mOg7O΃CeGPa<@ -3[pՆ]Ͽ{;WwSϏbB!Px+ۀ>)ycWu]YkV[sGu:蛠n|67_oe~Zbqqwe~]uP٫˿uou#~Bm_/|:3Ouz* ײNk3o_6b=w;|ѧ=߫/l=۽ot$=\6pj}3ջQ>]?OH=s Co9ݻ/gWwGO5Z5xW;5fн : 0r?auts/M xx:niOyÈ8d!avow5#~۫Guӿ^3=FT?{PSiKla]yuy߳7BiÒ.cg7 M3Ju)gۻw::Dz~C͕4Qkxscz3tϳ>~BSdrut9[@>Ƕƭن|wOJxeX5PF5>0'4N5yOjj=_.h QѳN>niǖ\{gw;=^8g@CvCD]>t~g[lz{u uD͙5uavm]v }C^on'ʽϴG;W% 5tj v0ϱ5EOor+Y!vynфrO>ovʇ. u%AӨpw}eE#,;L$'R y~!q52Mp0˳ɹ#h5u闿?mˠOuߠ?׎{{Ɵ]<8Ԛ~?drݿOu__o]c=To~?N-HYԧƞVy?Ǿjci-b4Ҿ{ӵU}iު ڬ9T_폨kO^\77Rq>/kW!<#!S ȡg[x^[[쓷|~(>a|f9}Q5T5 pwB'{5qc#>8_jV%sC8B,wn:gt0KÓjյ ˍ("mv?dάow?׏oc~&|L~lus{N:3o?9õOOemd*ۃ*lߧ!W[GF]~ӧG.^/ϛϫNzw߿GzF?*|3թ1W4[^ XBu]<(?0!1qN9/>֞5e߰{}яo +xu_ͣj,j.֔p#[61=xf.wj%uttk(yӪMUMf_#t/xcrocXF!G>y_:7Oͧw7̇VvΞ/}fk˞VWPj? =2o ~s=G7WBoJsR==>;zGp*x)d#y?j?$φC <;n>oB/~y}UF==i: |M4vԜ4y9P&^wU%#.}u=NǗs_pцO; ,w*{'Hw%}̫D5Gkom hd:F+}ibT55{Mͷf#=/oȍ2e>-ӫuYp:}A~4uפY&ٛ@{@@{YU+B %99^~}^_f4yf F96y/ë๸Ojs/X5=|lnC@<ǟg7-^_Tk{~ǎ-wwg|yL>)KӿM7{mʿB{Pxyrv:%-^?*IRӯ!wuohշGψտ>#6w?FW;4yFlFnpus~e]2OϿϯNn+8XITsjܾό]v@qnάxjn8۠")cAe;l_](#Ut}9;[ (q˧M滊?y=Vl7U]5~YѾ|3=ӳu62_;tyIѤxw˿r鏣O_𫦚lwu]{6z9PcGz<8OT:ow'ߧ_ϧ0*b<^qIF=;ilEh _#0788|w|}F~Xt=EGǎ=Q~=;]??u޿47n?mo&4v_ϻ _ZO>WW/VSxF{4ˈߎw0XM5{ѸO={Y9kwyz)jW 'Zy)STZ)ZA(A(@S*F) ZbdȲ0T C1% 3 $ G 2"0h(32 B&Tr]H9 JV0bȍB5JM@dNfPFHd j]Dj0f%Jr əEȈ)B3 \ % JGc0VC%=j'^ݏe'uBjg/_߄<=C::'o6&;^mn{oMZ8h&lLܿ^~oD=s<矍b@ZGO.T{rH6V:AA>w~1vC>!J4˟?:ץwOz{TNZPNc{Avp5g}5ODdzސH\@pu 4 F5EngnBܠ }[9mv4,ܽ/_(ߞ+S8yn #O\s$݁FOf}^SW(ۯ7?f|ՠC8h;=9YreIG Ïw) $uDDCVhG_;~ voƽ=ˢ^:;&\sV{4{3Qy麏W8%F˶{93b3m322Dl|*FhgAҞd'Emnզ+ l~uxz?ߣݻǯ7V;Nyjꗚ/Օ>C90K)Kp@k N=!mtJavQݛZ/.7rt7>C $dyt{z$}[@zO<hany)0lj;sք Gw'?Ojvd:o>z~|3;Pѭ6Z3H}v#'1(M#PpawoGL _igOgnS #Ր?NNIꏙ߻}?q@NKN^1M[|ԉ?Րn?/bu}q^_]7e+`)AG84{2.ytv2D\ߺl#5T0N>dﮮtar~1 (R!" ڟ{P~8t~  IB@$XksglPO#G]ߘex_ݗ۳IWE?׶꼺Nu(WEJ3NIwPȜ>fЀdky8'jSk9ZMCh o׋#Dv*vtD8}|ɻpZxzC{3w{4ޝo>Zup?[d&!kÛ./o͟:U;61}>O`Oޢlq!EG&|ƅLhWaCvwWbY c=.YMgF<8=Fe.SX7et+4¤4"sG)]m||Ż^$5XL (M">ffo !Hoy#%L2yc8v,XhM4A|>3vɥ8u[^oJSO(I}c~zɺsOfށpح몼7Tr"cq53.5S$R<.31ֳ津qʳvüd\ä?#ۓo7=lׯ$k_#WeprmkGoLnܮVZ}~ǣ 9l4'!f.2Z= xW̳פoTm泍N/EopI&f!`dD x0(=i[?u|ԄzyE G~$)1|iƃo0ϓQs5>DG(># Ǐ݃LÃ6a#nO߱<ϞNЅ zt;\Ue vcr%e[Dg8Ƶal0L6iȵ+PC6o1vAՑJ'^W.ӑä^WY#J5k 630AqO^g^O@BCdN8 z3I~!E.;3HǹqzK0iп9嚓lMLcö^r{w+ZԤ*bI4V3Da>DT~k qm#,^6g#[c0f`b`JQNAqrUCx޸ǞguҒJ@~)O1AقϨ8ufiVSvRVr"h}LZ\+3c>TOG-~rT7~u) :ĤSB, 0cE*<3ܨa+\ܩ>ij:@ήu>y6k p{}b|筧l'`}]\PK+/?wTQЉJ"~><)q"~(wjh %1cpViX4[?'ϩwi>yhs-fަ@Pks2jb$>^3D2^χ^8 i(8$3Bsyc1-KS)mR\LkFM#P` .:%q5j1i3/WA ԿJ XV*ՆsT]8i2buye-98Z`O!CghKxwAc )[i[uEId L8c*\Ěaepbi40HaH(\%ì}L'M+Îygܧ$U2-h 0&E1PTU4YeH$0=؇-#g-}2t`4mЇp0hQeʰ@Ax=!L!'^Wi&=c(F*:`ԇ ȵ6SAjwݭ =lLjIXgPGҔ¾a,P̊<&PPH 3 b7Ԙ`;2yz__Tr>c;!>i.Sf^#ϧykB8s2w> L`B.3Ԫ A =LCM*4c;6>-mz MQ Om4IvuC&g `)SFf'D_gRf[&2d f 3).8Aܽ6KE#7:)Z y%®A=C ȴsZ!Az"O}'<6{/sIc3:f)ΘM[(z, k8͖~n@BȲ&ܯ<$^zstA卭soVںJ9tJvGoI5âA*unC A>!խu 'yKI9FJ#cxZil9%|`[}1dz8XYD战rp>w<:hCB}VgRy@+ 埏ILUjn>onP:%t'¡ckBNО UkRДTG**R_6`A?귯|dnV{L`} c6HK4jQVGu[c ZDwg,,Exh6G*(]"Bw_f`m1F+c[ùp f R"ۀ'5k'}\bZsl1ӮA$LYtaV !^'' w&;.0JCE\!hHJ(=Q ]ʃxjLW9*,AؿNۤ"'?[dU} Y tN!ƈUĦ }n5!/Vw̑ Kj9KZ#L瘥a"Yu9a1F!!ʈvu/'A{(&~c@UzR,|\/ݾlA|ϧB|05ãhtv^Vu5^վitN~\47j.ku ER[K EueUjOPm!ծUJyG J"]CnܤCҚS wyŒCϜG #n-9Z]uٗYA]GRT|hRֳѫv$㿍T1 EIT g.1}6M_yx!N7SmW|;s[ƹegלt%U{Ļ-~ @ByvIn78|ι^V|)ߺ;xt߻ |bH]8fV!mk`ƋHA7 %:ÞU|XI;ۧWb්; /۟SH~uQ6r*9TG7zv8J|3AIHᕄ\UԚ."zϊ;YЃQjX{Ϧe@ eEo!+2ҽY,rrB1\ >,'(cd:`_Fk=g;(S.}6Lh 14ĸjy:,eNїmt\5TfCRܺ3V“nucb-=7KVAԢpP@⃉MF]T١uuhWF1/F4[ .0#! wn,CdN&ijt$@aDӻ>ihaFr@9Dž|8͡61(cd-&MӤJ\0~q;n@ 5S38Y"B.IP_l9LWljV:irM@Zep4jvG3^ 7lXl*_z#\obH`bre؆Lx[#bB) -Hjâ#d'\O)ӸʣfL ~F˛h(mC~߯>E /Yq!xw}xQluՕbQ04B$nEE,K$sV2?. (K-3U]C|o3fSU%D%j6j(: Trt(Fw%ɺKqS g|<{Vb ?-WksRfQ\tEs:̚W*x3'7 a=E#A1b+[ơM.[z xJmf A8cYޙ[ݣj'! ?9:r;FB\_AKRiﲠ/qgQ6ub`C j Qqm~ze-1J쁩: E ː~V+~k.R# jBr%QϟKn 80r|\}NE35 J#`G+$` Z/lXolU,tNv^OmR/)~w3"|Ӯpޔʼ3尐naN5]KC\䢐{Lv3RFٳ0]"; ݵ##bD{(ģܮ3Ũ(8`ɺyWqQg$ܙfg$x}ŐN_4[KC[V3 *y;^:0|ys'P7e MrrvԀ֎K@sB(54~x?M7.^p[>i$ha~ T<=Hl3P f]Ņ16FP;K|܀wq2z#ם2bX5c* g,3h}D jRXN{~/ϡ}}zd>8FL nӣ) = /p`>?k~:~MSs⽍Bf 6[gfg};*ϗ87ݍ^t?]b=N;0s_5 'q4tMb0~LQ@I"ie&0RMtF<(X~=8_yv;7zOpG&c^Y[;KvG@$cXL L y@5%!Bry=|EPYDhx՟?vq'5-˹ρٷo[4Sf,H!'A<⎱jA8 SmthM+-h$bO3ںg:9& Kc'ɟ;W"< m;dGGw0H E"SMM`FTo< >31kFEwLMAڎ8~!aoRx7kY2ߏhI #o`ް@Ѯk8f#[9cp *3$x\0>Z hG]v\^ hak>ǂ'CԀ̰ 9 AUA7$6 R*K&shIE/DRĭP##EWҖ9.w勄T8UœPmvvP)F!P)AVQ("Ai f HBHa (Jb""$*jhb$e*HjP*%iH b " h(Yd $"$%b"!d!BRYdBi!Jf Pb}ޮ]\=93׶]\m1aaA8#c)юFg*P;ùи:f&|ϗ6``W#@mYkU([SiZo*t+NgN0f0ihoBRB'1Kv.?w9УEffbrBaݕ>x%\`.bPQu5c-qTR/wu #nqOT Hpw5㜢Jw-l̘d8Lq3B.K@ԅ @@}vrW Jz2XiYa#|Gݺ!i B; dq;`4Ɂt g1gEt0q'4R}uŹ&rLE.jC=PicY3jN0+" .z)Տ%zQ .hA6 6n) &M; j#7{[YhTq~mp}@ 1iL AYy&I8Pl@@'ԟkugB?/ˎ>>=o^0^l$`b8Sd6);o'}>;z>J%I4VbGJ.3D48l=WI)̽8krI ~_aBŮxJhFF`"CyݢDXf4+,(Pcs XE\A"m"CdfMBHٲ䃔Xzs̊:h {? }g<8Hp`ˑ~mr0FNF xp:Szy1vI?')b񻎓?uRm@In5ó@q/tc"gZc2g^HM~cwٻiOgUuRqp/?}uXpc{NpGngaAƟw8,.`|s 0%Ϻb5cRsUχ6ݗy8CLj@rO:-7DRѣ0s{cozw]f/oMp'yV8vgԭW g5>"FDzҮ֋=xtMyjZQRU<#{1{{s@3;9,u<8mN_'>cL L>Mm3p9ն|=$𸕨:SM :CkdMn jb{g7SVݍhd|?ݗU<?yD'C=[T| 1RL0$k@}C߃owű(1.W WBiEu:suYA^^+Y2FsiFm<Oc=,lpдkHij>;/L%qn!Jmd(jo5m2l˧x u8^é.42M8$¶{?s `Л}n(ǾD!ӻ5$QxX9уF|~79 YY++YuAt7w~К;|璎YDCheE!~#7X1!D0teh[b(>ч_{2c=.'VB|1>}]pP4hvx>'i]~BJ-*ŏ  ?ت/yz~Gޚ'Jiů:y>Sѝ#ńE/I^pB(;Dj*DPgU@G _$L wT8Pk&hv[ͭ{8X[Q`bIL#2c7E]2Uθh#Ƨў/[|qRtVp"ЪEq6cN8 n5\2BOT#D i`j!Fн!A*X Yh)UPص~hq ҉z%}7W5}A1A`0yum#J) fyy+`~4>IթaO6p^[WIגvgk\ĬPõtҀ%a;q k {Sϙд>?bDH&i6(cafeϧWw1=/Çu \4%$PIO>TXIÕq mN ƹ{vWY:1@D8n@_*x߾_ ;o2&;!P_T!%E˜Ea3ٴ0j('/ D ӥ#r`DK?([G?Ʒ-yBpgǤ\0]|gAO;FneuLaE:aȑV*8:qq,gQח#!0 F$2( JwxJ]J mCG#; B EFQsK6X3L1ľ$D6x.{&(_aLX8^=i"sבؖ%.}7H},_uϯ~ԯ^VUS=Dr^/w g<lmQRO1щ!$Ӿ. @ S׷ˏɷ`LgC\sɓ IRTQ2s5+wiRr-3>nLznނ@HBFp&'uϴ%HY( Kqtf d|C&My^IwD\JP;ʅeSiIZ7id7t֞u\) %k ̫Dy^bӈ.5r@SCfjJDMsvRrCr*D{U&)ښn٭ԅeF{fnUG2ѧg9 z8{9M3! cɅ9kD7F b̚+9nXz!\ת-gx_^g^:iY|bT~ϸ`+6ü3LŠM9W4G~i@*̫"E*( 3DhgrQ R}9ؖJZ%b"SXx!5 Et@}3l9p&[l!6^{k(W)a νE5IDFatE XdVBηi+dP$9:ck~8>oӷv:L?d5` !p~J{"{ظ+Hl,c(,HW;_Ez|~@.jތ9%lne-z=T0$+7 s߿< iڜayP *adץ3ܘm8={f'e$ȹA[K2%`QX5s$JR2Xb6I m䩦YwՀ".0X %LJ$!Yjh4HL2#H1 N$/RO|VsgB;^;OG.GKA9CN@$9~IPߘt_|u3}pU;i\}2'moolpyj镇ǾQb J3}~n#4=0)o=< ]ioa@!>6ei|k^l1?.X'vϬgSPLB RF+ݖXa x\3*mEvgp-,Es8l愑cL  LHFA\dȦ}eȩ%s܆p&Rw/ ĠU|L1]k=g_U>Yjg+gHwwt'Bh͚Fj75ϦNGC0Rd& ؾK3pM;,sOk89ݞBm֌Zb_=Y ܤ@b.gә GSܪDXA@~"h(cr C^v$%Y\)#SٓK8MB#C6J{*!E8\z |//@\؋߰VP{w!-,#\$q쾽> dyՋ*‘h* T!rfi QȺMbc?)[:g~ܔ!%Ξ$w}~WԝcqT9荲# *coQ- -[&"nP3aEѦ;)19TđDO -vulbqG'ߞa Ĉ8o{\kj<Ή=T HHE'{$QC|@A`lc64MEaF#(HJXm)Dİ(J6QB,%\qhYhs8T q ,N$Ul5LVUr(RPXyC3^e'J8[ f 5Лrܶ;{k KPls23$sHJ@30JMjUO'gxrLW Z0P -`4D"gSiM99D so dshH Bu8~o:m㍟_Y25vp-wcJ\oHQ8 _q 31\8zuv-ft-_9F?@ϴJ[FDB/hESir'ApPZ*GTeh&) h.5L K| (r|`}~ FcO&V$eZK $ zG/^>60mV cU,FaNH"uk5،(:Rߦ O 8f0a7rWn/$Oc2)]T7םoJR1D 2+sTpyfQ3[ LsڕaAWY_UT/딃*ɦ}'žHSiPDzmkS{v5[bU0JP(A/X،wsdީ~4L5\ĐZm'^?n]ӿx|?zRTe:~7ɶFBg*R..x."@7>]#yr߸EYvdVgV}!i5-]f$8 :ʝވ&tUuL[9Bs%yB_|oXv73Ce3JtaL\W1ۜW1˺8~QHU2PY((2wu$,RD> ǗWyw+f{DG^j*O= O'n'zk"0V9G9^c(0$!SWŚi WZj"4h!f)FRͶ>C{9R=Qx' {;FԺ( I*n?F Bd Hb݋8 ~r׺=`4j݆ݿj@e58Ɔo82j013|F[^a9i|Vx% &lKn-isڢ!B@C_LL|"ah%gv"q&R&g)I 큭SyH)S ,b0M!{֦Co(BXzf֮wicӛ#Ӿʜ.w Qqdhx7`08DCC{u{ž-TYY.=ڝ"?)Dmo_Ws0© lf|nm¡6Rl ݗ5P<1QSJ88̖{ +3s C*RQ f̨g1#IG?k䣵=Wi!AA-!!Ê'yg 5|]}5(v:)E%HP]z nDR#-JRK@Ѓ 1@y8AI1LQPR&= J)BuJPjʑ2 iB!\=ē&pbZf`41߯b1hAQw@l 1҇YYzdžuΏuߒB_&щ|)Oqy *8o!l=S|.AT'=O`2uKKsBcu@4;]JT@j IUȿ{È$ LLl]y=*@rv\pzҞ=&(5(в AOdo\:-ӆ.t*[YBdQ~f!zʧ;FokA Lך#ozؒ+QwD 'i/=ō]>vt{)HdwYD*Ph?oÜPoxlo+NNXnt2 Շ*.Hyq'Y1Z^tw$|%a9]_vhy/BSBCVRõp~T u(~|SWͺa Go;51! - $ӊBƽ]9QIF0ϝzNΝCq .~b7Pm"j[NJs}cg "ᰠOq D W@·j "\yj_A[* A.&HǖjgJh#%Oi0~::ƽltas^դJIgN5Y xSւB_x9 Bf݄5b=]_W3#F&ԣȎ)낲꺳V (JQЂ56!yp7XFC_5,dԿGH ffyf'Hi4 >֟=oy[֞8}DNn CJf{ 7㾤'\'qrN뱻Vc1&PSEAtnPDfy&h:܊5W3|xGz薔dofB[淛7U3QR #'p*78WmU h \8EύY$yȧQAÁ#Ke,8*"+/{+?7L/᦬hPo=%4 ,MrJk ]RۖJA"ǔUlc5h~X :`(+ܬ1x4e>S:^P NUh7A}]IxnoVm=~9P-"%,uns -h.=3G;~^<34yEw;y9n:eF *2Ñ@# n2iQP.u7斲Li~ }rԱvgo Ouï˷$gwR'!$ 8&z]n$ JjXq"L3x1lt<\'jJ>Jz&P843-2yGJy_78g1"+aObԛ &B9dQ3\YXi '%S\r`ӋdOdpLi޲_ܻyFAP8]vA -&~Dc.OTk~c!x˟<ŝZ˺~eA@ә^$i>Pt+a`::'I$|VbS\p*!{cb[j @6 1C\!! HjR ABB) D"H ( J܆55rNs=]\Xdٽp% X=ZC\-jx|(TTa&=$; a+DQAK +0EzҦl&ކ=}‚b eV{I[}!tm`0WzMv_R0E"=Ł-k.\OC[lCFIeƝV,wIB ; $@y ɱan54[w7Nr`'"NS! !0a4c(~ QlV%6ϞNS@)_p[37oZ>LK@PugA<_i4#|0 %]7!smΊ"߃ҭuSumS> 4cO"g uV[k%1amUs}s/4H- Y4'@d 1]:c Va0Mc(8Cp\Lq{:TU˚{L9 to+KuD4eIDDd4;I9DlX( .AU`LtlbM{sZV*r[V"GA9ƈ_RQB¬==gp@+xQ%kRȖ3e"GK1G9yX % V$@*#i~ J%!yg6֥ "R.TtYZ >(.pKIU37 $ףAEvqJ環ʘmu$!޼KUAaV1$*p@q pc)6virW'R @"/ $ϊ%}vgo{_D 3NVv+l;5#W|I[G7iTSW̭[O4}EYzn9/N]nwqF#1̤f6c֜ݹWm=ޘzv3(.?\ϚL}Ħ\R{tM3^O ``}rfHO7z,o54UDP[bߏ|:{W̔*IZ9!XcDGl-<ʘZNS3uDu3A AW-r뿆xC>)wv'[rVxa BH!V~F=E-Taؚmin5b>ZhlLJ{pN#sl2|`.-}.l !@yGDB@9ñ6y@WIQ(i&=vwf3%w <^));;:׳<֟H]prX!~.Dtt~r֤nZ?я:߃)cfK^aaDatBcW!p Vu={=H N/bLm@+mJ';頢G&4x3JHX&C:y'($@Prrh-[O|-XFdx*R_a&.8!6yRՊpIv7a?~  JPcf8'r0r;:ǨVΘ5C8|s>>Uu_7gpJ1)PPi9rgϘ%z=3J yt`ynw`sl\BO|KMuꭙ H05i&|  Te11|ZĒ¦,Lw *@ gM# gnd#FϱNZ\vc&yWvحolֱ٥T&Vu}eYS ({>n!ٗ悛GS8¦@u&"My8)QDXջly۩ݼv#.xmaQ6>~;|'܀ٸ~)8%46yylY''߿).9})j?l@RoouɗxfYtY>vAː"»sgWŕ^.{Wr {&q-Ry%)5/^~3Gxufk@6k]B5^甓C4!$Bkqߗ._W! ^i~5+Wǫw<7(S63g|kSZz Hӌdl|o9rL,᳈,.y_2~J霰):Gܡ0Ed/ ےHMLmYOP 2RC x2N;֜ZPɮ쨏MƠ'֌g~-~:_/NAWS^dv)5T'ӎ(^]1xXn?>]<ۮݍ_C CbKyzv>33|3Pr&d;3Bf&q4|y s4eDtȸ.ǒ+ u;c o;̎4;\jeEh˜l3FQ]qw;FP?zx.{DV3?5cɔ:ywכ<_$zJlQQ3.yg r"h=/u9}jX4,P3k*Բ£{Ը2?9'oW66@kҤyzPrF[93L{:<$iNMv3DDEa-X_wn!- G[dN WUL=;]Q ojV?ЛVw ^Ba\*jJkwix ?㨊t_)T0ud~/"zR}[%ptΑX "[JbTKꢹ{޾ỆZnmyzN63ḟty@G?}C@$HSY·*aY@MT]D*3՝gpUdBD4ѿó <#>D>[z9&\\Z*+l#$<5A Jir8cijr2:*1곕R 1c6x"Oa57J1DKH>LoU c^?}96jϮ6D֬C3fhpI󒎥V_1%#Fv3\1U*,0xܙf'+\_N ~߿7 .kP9PLyẲey>yۏ= A  POYaJ*ʚ^HQ P>eWrߦnq~4Θ_GC33@C$?Yy`v+IZmEu1 F 5tKfY&d,QDbeh%&${R]CZ]D^N怔SY-nvϱ9{De y덝?}P*3'gݞÎv2+_S{gsAƟ] ?. #xx{(jU^ng,LB`<˶w'\}%cÛxv6pv?9d\)Y`GƧ:$ qrj֌~^3L\حb];.*>xpuu_uy޼\K?.)~dsB݇6 j>`~XmJڢCRFGkJt"tߧ;fՂy-87np}^`yN-}fV嫦 7VC AL F_.FךSƁ0EJQ bJ\ 9 'Crǽ]A,E qagO(#7ɏؿ?!( fFicԱBjGY>nCՒ_^ qaJ % O]jI&Y0x@ {}.WtĜ4t}gqF{]2rOҧQ$V+zWvXT@PP/ͪORAiթe.VjΌǬj5Ğ;sFQv\HleS-7RMlӷ͟U?+.~rQWog3^Zm*=dl>oEy2?<)gD_^HNVO0"֡qkHFe5$8٩ ɞie|zE :'5o椹TҾ+D -p em)o@6!EnTHvB$x$sLnq]$! jTe 3UebB*JM6mUhN״<^kS1|uН~yR;b'}1뽇a:fl&uGkyեueȊvB00!amUD-89BH#'cI3G7)͒EV ;\3hvɃo+"՚,h#4 S#/ N2A"@!FS9W'' oǶ5~ũ8ԂС<(ooڶ)8Ƀ43Őr9UۮE#kXǚ;z3+O4vTsݐ@)b*ddA]h Tذw:B´Mftv.{)KQoVaUȶ`~ 1z F)ܿ lʙN{yLm>8ud+,&ٻh`$Tq從^瞮NҔHqN)H?s?JCz˳d𽼹 yL'AH!DԥHTB/Ѹ>z=$VG;&=:h>IS7dh!"zgm F.@m6HBLLQ2ֆwVAEjS:ԁ8IB*= \ 'NG]"w"lA|cz 2%a;S1}:{ۏH<"N&ɨI5ʦv M  Jl in~m:ʚN8TN&EI|bV3M67Ej%)RB )k*QjݭݳF_/?Kqazv6[LKTyNٜLBoݎ?ٲLiR 2Lr+fhYR(PZDR}`KEj hm Ux6Gv4j`- my%鎽>7$$(qߙ$Bb}晇e.'wL.Hv9O /H{ilD0 (i v[uIg|]Safׄh,p>JTq!06P *+% =mS1bHt]*A"2|䖗IН,uI>Im"w+԰Q[rh4DۢL"* e^cz5cL$D"j-a lJeXեH|GP =%8xoO,ܿnma~s/I{'4N >HDEs>]=G>I_*Vjh aS k>}VY0tK:f Dr圂偏$9w΃I DbNwu !2"M ^]kN5;'eQuRfN, 8Ӫ u/OSо{stw/hƜb<9GvRpv =1)l!AYO80VuZ1sqD2 rr5i_D7a3 v^޹H&rs{%N2FYz(6P3E1˜[:(ԢM 1o92tgT'fv&V~p߄5ڤvK:t6fPwV]: FQn7JvmJ}OsOYk_l[xzӚ_'oLֆ~WZCǗ}j#]8:J1ֲ#rF+ߚFARtiZ "k9լ~5'Hv໋IZ]7ە*1ܢ¢qT9+Iدz.}nGy.ffTD>K+Ogr5R99Oڗee|$\bh,-\jJ ZrFw^w֧~v;w0y *UxL KmcV3?֏Q\1$ fHAUb st^t#jnLDbHF7 d!P Aj䞠SE~y3X7v5:fD:9p4h:19y*"n &`|YX'"ґΈl!m{Uqr .[Ls (J(kCP(93p Q{r Bf1 EH/jX0.m|H9oA6+fs3IɓAo/F!ڹE)\BPt\JABGXoGhVb;#Y8{}H]kT}(-o|Exv8z.Y-8|Y}J}Q֔,>٠L3V`-||CC*t|%w @3MO4ߩr0alkyY.[k<F(Mz'!ܶaiI$Nɑϭa%mZd%BW];biiֶ>{ĆiR>ػsk[\kFSFxa;'X9m; WX[ln'hآ_5uMWuQ8ץ}:Wi͗<<`ix75)ӞH#+T><MoCk Sw8֦&/ t:yْCsPg)y==_=юߎ߿7nKr j(t<\7TӁa]ήѺ\<:vrGi:pdW luǦ1K&ӾRmyJ4:٘M*&v񖓕qjn\ Sa57ʵNvE<3x5V{<⳷^Y4\=P:e4 3ڛPt"JTltKP.qHe\ 3D"< y#? ĺL.Tn.PĴeu")1ze;s1?ݳܾpn#EwvDMsPg2o8fئ{Lb4TN8u8\~R+vXt?.|OE14Q,*}#; ^tpũQӛcy{{ţnO)1=QY_ Ƹݡl3G\?~Ss\JUO^#kɞL# hl a$l.T5VيƴI\@tzZ:ml+4\ Xf)zTe J6#E(:{2W|˴ 1z3 P;0@+'rDD$6Q퐾 /~mXEKk=[#Av#$@*:Vi,'orkLWvnw9 gvQcZq8Scy=9˷Kic9776^ =w/-Ȓzq?>S]7~ׇs̺$?$t2,mo8 HBey 5Ϡ|g59MƱ7OݩlFRjv~14ˍ(MU6/a]P+9YcJahEm&Pfp`4Q]0v{kaQ^^|4T7Cf入Ƨ-{D*c<<ў7/,SG%?.s՝wB%M?\6 r"Xj H9({@ 1p m6bsBbXxZ`r!0%tjQ~~Nm׸SlnX#Y@;MGyv [Y%mH]-0́ MK]dϫҫ~.v2:,i.aR b*хi]^$`BU'50̌E)N}/V/ۇs)j!`}<'S}Q~qeFo/n|^ґLQrA,;?0g}6qrLD9~ $˿2P8wGӵY_<՘憚ju48]b;լzss4tƳoWp=*֚*5e3[>cpΖM`@*0Dyg%[=W~3:XNPk)I=KAG+ς9r;D$YcۮPq*y<[5L0O5M1:;G]sevvŠhk$h@v\5HK\}= 0V=KRZ=Q_Zρc ߑCԩBvBQ㦋ݪ<\xnՅyBj?.p\. WWҸy{g/2W4-zSYb Ai,ݿKLVXOnlAs,j^`2 [fuH5m2̡"B?A~w^7׎ԪNEͯ@0BF-g{[WϽWގAɥ[br,(m;s0 _b*ac3ׯZ ~7>wՓƫ o__fzy .r \~iÎ/- xAVY棋U|f$X~ΆKe汚n W}=oAI^'WHH#Y+{ӄN#հeI|<&l鰕vB|m^]ca9K2gI$C>;t&p&`C͐닸kv&AapE!Rr8`:ן/{ZŽ1s)ژvKSO]DuK渝=O r>2qWoRhQΫ0.EU@`DH}PhO[slqߏEtn"$A4HP5B!IJ2"JFT"@*08JR,JDLTE Sv "iA()i" b)J"(DH(DPCJ%PH443(PAbFJH)h)F i i ""ZJ FJ!Z)R*V(()iR(JP @䴭AE)@SE+$Zr0iJVa)B"P>Ntpa9(cn7w̝ y(D)5ITg(Wll>H.$;(pU!d}_ǾchpOٹ&l:% #>-`Wp/ t)Il%ըS[7gظ D#yBкEq2CYUTe4&kE+i-,H)"0k 21 HP)B)BT,J儬(UMa!CI҃k(c2Ze""h)wx1~40,C5hz5njAG~^|D`lӟ#V+1Ef⺚xaBVlEЯS :P*ݡV H"p!@fʨ5y=t{|hQNt|nwyY9Woa !WMGsBR1Jj3*lNf&J(_lP?Z(Ω7E1J#H K^^vf9|0(9tW9E9D]۷5 'e%a/^yLk TG[ xLK2JGӱ[jGQLTH_N=K@j KXs}h/My50{bq19ѝZW4+:ª0܀&65 Uf\JLtK<+Vُ'': ~^]cn f̤P`ާx)1_,8yd% (V%gVVIׅrR8oku˃ѱ٨Ov'8*&` )!7{82:nЕ;v׹1vQuz3_&CWv1ߖggMϳ}Q 2|8ѷn))>ND:T(%2@7Z2S']Zi:ƀ?@$j>K7IQ]L49쵷 ϿS@:T&eIH!Wo^؛oeX AAAĆH EML-+]@ h  hR1L'^] 8\p>Rz~󅓷~;J66 (J L|wὖ!w|iBh5:_UbD]$I5` (F>m+e{0&p/tys^  Ň`1I׎h2̴? tt@h:7Zb`yePYFLc>V"qv#44-/+ bڠi"6E_!Q"ز>)`W)!UA9p~6SAhpU'>H.fhk, /͡{_ft}Hm/`GC!œ.sQ7 u3p>O^nHkOb7&tiPǐ4! K->k"B%TVLz-[x)):VLxx\-');.\;uȁFѷv^+Ϙ~h-G!J$&398N-D9 W'=TW5ay@ W7 IYVe w+C][(,)R`%1zOjk;%L@MH Ke?мS bީZdbDAeM/;,֊Vy'9wܧ<3GY6Fa $`FgF ж'ʼ$?ٹ6`%f$ECZ^1$ق %4D-wFy3h;a0Ѹ+8xʴw.u(*@(Fߦ$J 0op|0XJ 1"(ytA?*$+Q}Q.bCW rõZ_6" 4^%AV`q.,%eXxxa1 %yn7\0*DzVue(h$2D 3&(QxdX˟k9Z)%LUlm _tV0HR+s֤h@N3.iIzHn;4" HR%.5SMo.ccIDC! [DeW\xU4IRnO8$*Gg 54%Sd2Z[r"VT R3҄#7 Hm …mZ2bM04 avpPb %C04 (ƢQ LI;`\ 4<ɖXS<ڐUR s2 )!A`ZX@ʦ!Ո=!;k^8 &.æ;lA|q="\ΒQ ÝߜRYqG&d `مk_G&=W~wߖI G?0 @ >ol8sպCb(ٿ@}h;+?쿻jAT~$\]?{?ͪI _g?\reO}'pm:-EY|<Dzn e 4ͱ9>AX js4}^)oۦzwnw }8Uan=~mw &d/:s}Gvއ]/6=xעt4[=Uy3OF;vVD 6\ns:np3oNG_o(s`itPx "cxf+{yYK/O܃ޜ]Hm7?ɵ>#=~nnnuK?/]뿠guѧK*ٿ˴y?$@Q_Ѳy̾=>30R~'A1_:($=*JGz} l⨏!Z`f Rм=N ]b_4^$4Z!_iGl|4jџǸ9ߢ2CVٮ萖I+Motk^ޕvxPBq#N7dHjǺS(7߶mc(~?Ng'5?nz/.Hлy*Փbsݮ2OgcެNg߫~ֿ%ymGXgjQGUssY=Ы6n|cv8tpo_pmyr̶F.J?4y:9OLf͔yk㠆p#"(qG*"o@(~z>ȞD'K ˄$&Әhyxp/@j*a9z_߯}^'y{OOmkkeiF_{E6:v>C_|z?w=?7y+?,OOG/;=v8p<Ty[>.k5@w?٧٪5g=,Ͳw[Vͅ)xuѷ#<:d5mG/4lޟ_jB6̺rQΎlͣ^ʵc$lClڙ6F}Cǒao ;f4u=WY_1tuiFrt)koK- Yu|)>ݵa=p|VO7?vvKߧu_WG'۠@|ࣛe̾뎩mx5s{oBsë<_)jcg.~c;kW(Ӆ`˧e> p|L{><|_62135>yqkݺ8ϻR2 w>Oe[D)mPO>;z1%7CpQz}q]Pu1V:߅: =;xӗ}QL͟[ _XʫmuCk^- ^lߘ{G}w]A6}wFL~z~ͣ[{{mŏdnsO쳿%]>~wwAE<6/gV[D\o6G~6S^z(~/I^I{iwO[~xU>_>}g«37 5Z·?oG%e?k1&jG?Gkp26aJM^{-#g|L޻x]wƞ#7ۚiY,߆]+5CY!Emt9Sz(O-)C@Tn;nǣbzkQwﶿ_}[~Н)?.H'kA߯*x|7˟7tߗ/o3|8iL=!C\;=G3/ѷwLJݽn;1ux~^ 6Guu;#?yyUy˛˷]~L|GYqށf-o6ðyjY|>kfl^koMϫ790=0}e*sIozzy^wt[fw{{WxoeOp̻|HҼn >wo^=:jʌ}?Ǔϳaeَ=[}L?﷍+_Hǻ^᧗ynX~ߟ|?h=ߧ6-qS07j|X|˄ƝK`9|Qpǯo]ݜ9?&Ji0rOvXyM6Ky|ݺ>MibƮ_|tw[0ɿngV.}OkWV[}_aQz%/Vj=zs_z›rAۡμ̟n<# yOZEZ[u]j|?m2?lVfk~χ@MnVxխÅA+('^Oy_a:|9ƫ/ċ=#}}8˷Ov}B'HD jyxY?Ïϸ}f8x\~_x(reSNc=>2""XNqTS@DbP߀PSx;C Afzs"1B " D1?~`~a'ΧDD NiNpbQhlPev{:˄SFq rF6ǦY cP1Hmx7+aj%V4@$3`x &P6a`鮼NvʷEm[.D4wO4@KJG 5LldtmHs9u#cnq19 㹹Z|bQli3vLӎ:biHVV#[iOTŽ癳×[c8hQ ==+;CVZ0S P竳,P l!螝PS~8]䄼 Ӛ=茉B-eviͫf~xN95!&Hm{ RdNz==1 HM39==<^=zQW̨|TB!bIZHΠF.%bvX]g_I@F#f *p1<655RB!`e1=|m;i˵a7[)qV"p92)Z$CRPZ$yNaK|Z#WP/O]bvt#!O J[5 75;.-.T.:C)cYMgY8X,'f&ZRx0̓ۅ 8$=f{B:nێ'"^>N֞EORC>  %C CԆM@nɠ<?[?CR(2HP$IM4$24%0,I HU< rH!|Nqr _q98_nlODӜ/Cy@ofm?pƟ!0(uqH?|T']$F}=]p0Ӷ!-B1RDP%@1%BJ(L@"K ԕ$LPP1$AD}๴kn*ݸTK txK"$#ILsQ"U߶l9b5hQטaG^\tD|'!^RZU(E%(! zwtPlېih -.Q#7U)L3ךHBɈ|C$H&1 z85:B!qܚ I,i$.` Ma:/.tvQ 2LFGM n꣱kc꙱猭\R x lYSKI!$̑Cg1ƙK2I E ݠ nėlzFrx .u4bVZA@M1]wTԕYh։aT12P<759mQ4!doz % 3,@3#{hy$^M%OKDK͜u=bͯt0Cztr%raN;-5g-"M  ~€| jWz=΃kvpWD96>Dόy~B Zp/1KNUQ)RHHGp[tud\9? |v;ɩ6bOKd/MQs!$O8?vD0׳F<\t&qwg3Sx qY9ng}Em+lur<J}HrX$e*PpwIZDFow ;ՊŜjma:CJ.+}NOclXy\F+&ɞsPps^zQT S9> K`?'1<6yHIm=7gz ?N~yH;ب3 .ǵF@"<̮p.w}h:9;㷭L%zeўkUi{ofx-V2z\*cck4]:N$3+϶6u8̅6 fEx"Gl5W D<}Tp^/ۣ5m 7_#lxѬ [|/ubO2"w88qo\#h2;$7_\{^3|0ć?R+~xBxnӌ4rЧs{qAw׋NxLL7[#ETDNI.=vS\;÷#v+b zU3S{K=4ٗy|!y$ ը"a mt1낣h5 N7}4upLc#ǃTCW}ݲ!;؎>[\Bb#7/Nqaew^F5z@CQK0)r=2 cY6"zBevʤ "N]/B-}5Oe=ž:{z|rQ BQuya7!7fA}$JV-ggXxϾY͒wA6Bmi7wM!kٿ_gz(8 Kyߠls:U 0iofo)4q+m7|}z9iJeqk{ܼ#/M+yJIQj'q7HAU Bf0A=^ 4Ҷ܍ȜyM KFԌ>7܂:ڴ\jD9q#l%F! :W@::2f4% P?ג~_՛fM dցUAFW@Xϵ9?#4C3`f9{7'ih'l?H% ca8lj5G>+9g)c|1lɖ\9r>= =kwcjߠ_bc:ɗp/4g3Hp'r]Lh+5NMod2oS0kxKb[\=A!068|{~ ب}zrf'eI* mv_}B -ennyX'۝/i{~Ƣg!7*^1 zy<N7j_rPޓNǐ~Du|q'frχf>Iקu']DStІ3+? .Y[R逘3bܨvF?'ˆ0P~ۋH~<2zwuESTuE׽;7` @ݲ!=nh±:rb5@>3=)M'RcuX9gy!\J\s`~b sm,$|?sA\auK9R]l?~;D m^"bĂ>ЙlZ&Y)ݫXޚ\=ytHlqx5B |Z8nye\n'w]B0;kޟOe" Yy\gTЩ69՚a1,diN,?+cѳuOj!;j2]êpP[ P#, z^\{:N!EO6!ۊvwGiwl}d0<5% 櫪hEr㘈xVךI*sd-8K# yfsJ/8fxʽ2BSfGd$)Z3^鹯(j=:ߩ1"gNU,!!)AWKҚ$ۘ_f}O[ϞUR@xTB&ua ">#O77sCAj+;b |}Nj~`4oCWZɹm{NG8xq#S+Dτ\ow6,ekDo=_?uF-WeՎ*:Īsw@\~?ZүxU9J{(usQj޳yHw-&\?屒]^aFPu>ӑJ.ʧ挱Pq %R*Hͭ&6.˘5[/OHWIT> 5|Ś.*#Yˤ:Hh4 `hX3\6<p3g"Ij7(U%k.QZ馅L[%ZQW*Ե\P[[ϝ~P+0uQumf=Oeqx \!I*reʅ$/-NeGrf߇bbR򾑏;?{s)qo &KUc y|u[c_r/u{N/AlZ]M8Mq #HrWGyN&VT:WK̩f`ƭرF\S6Oq \̲jŕC4Ob-5݉o߯{Vob+/"u ņK,|qrqjU_mmg4Lʣjm>z^ _ɕTm[sAۏ=<#Wn9svݶ2HwxXֽ=+k‰P8-h[iRr=U҂'ϷKr5UXj "AW ۯ^݄|++TRzL{NqrAr6TADTD;q3Ug|+^ t^j9/ b 'nC}5prVO'F{gg%[BG%kD| -M=џw M60q;T\FFo]5^Yy\%t.'j8:;!8SM+U& ]3ġ njENӲ6NO6Qw].Ф+L`}Vs{*԰SX Tn191K/SP36>xLW2j d:Pk\"\,?Csrq–H+ sVϚwnU];qHz6C_U8KзȈXcLOJhuU9vbf7gWDta&~Clh;b"ID!GjŬvʓfb-FxoC2z9e7G3v>uI~=E&rJ/T:e^sXS!6":f*b %{(|Z5U>8 Ja;D4gCvUxG}vZo4uoۭS\ձѶc*Z `'OuȚf's,`򉉠Ĉ_YpܠpOWjpr)$^êv/c$xiɴɶE3!%)Z;{fg}+cE~rLy5U$qw'ƺ4 {)w,uFS}ݔGZs'cefjK 7KDuǒڡzت mVuĵӂOG$">,;@9"D/:a'Q|B7{xK,4N~]k& q+J!+aCj|LWMh]t fZ_lVZhi's@j-6 qke+Sv\]lz_5gl];9\tҺ߂hk{3]K6*+s nxemyD߇˪"Pg>tߕ00F\~3MCC"0~!a{3fn>׼] n_uڢq?%2e^U74+Wke¾Z9L*L(E/]G+Fѵ*S ]P/ye LD4Dj͚ښգezM|٪hn;sUBwWWnO(Zhk>e0tk;&t-/7RmgH/z٥.eA7?Cs=<̔'CڍNB. DsayY#vU̒6p UʫLI{L@PP{D7_5DxJiӔQNtƹNyaߏx*!LۻXXN\ EK";"J6znK~b>黻Ft[61M}g(0|-9aDLpܹ‹ԁN_Ȃcs#p7E{`^aS LASuW:7쀅w I7?LOcZ$C&`icUU߆n0!&g dwCr}hu|"SQ:7fÑɭ DD3XOfOqA 91E:1..Jf)IJR(V5yAP0U+S q #D(IRî S1Œ}SG K{vҞ#*=COwo{vL~cYZrzzf0Ir֚gn\wQg:*mʁ>]KKB6no1 Q2(M6Qa3 i2RoJ 1'~UKLӡ#iȤH1EVx6c/g8#=Pړ{E FOWn_<ËXsR)wǮ^ M{M+v`OR(J©GӃMD~Hk*$pਤ K~D9es e*51eȫfnImhQK SΓiY.H ʻY SSH*ڗrBr^>KSaMp]k7K$N" h&Z5'bT@|q*ɪurն(,夊F0Jz0&we>.yrQ<'~SF_<Ryώ⵺aRh3kON+@}7(IdW싇V˜0љ"sY6gԦRft{cs5v8cFh٥RbD?|[cc%Sm!߾F+HIɅOXs+3EO]tep^YP4 *g:E. (B(-vSdC^]{:"ˢ=VEjpRvWN͔W_=+=+ӽ\g9Ziu?tKPՒDVۮTНXJsRxѮ99֯X#ߌ;!ވU~Bzk;ğNoG?OCB$. $A}x U2^ Wl U9ά</063)ѕgur[a;wxX 66{3+/mКl Tl]<yN uu T3j PMY4+)k9ճQoGߞǘKhv>\x ;uNPЊW,eKKa[3/+:Vj#-T) |4<*+2gG1tW]?R$tPoF0nVupv#\:hj…P#iik[K'Q8]MYTt}៑c]\s[Үڻzx0 32y'&> Yf)5ѭoTct"jW2W?]&n4AEV-^Qw)iu¡sOߕy>*FCtE fRܜ&gUO&GfGTfuaZe\gDiD1`^;MXcѰ^ 7U<njxu͕^+1(Wk#Õ/..s^?nS0mzrSH)ocCȜ+  INҶp b|l{ /}1aQHQ{U%+|5jnTW0j=g}osE^FT.  |[gņYekB?wh#H|" ܗI ].}bq7Qiz8$52>ҩ6$1p(ö<|%>kb!7m_bn}h*"Q+\G<,oҫl/X 3wnvM;s_[n`Em~B~b =tW}5F ~ſsSl4u4XjllV4r|yD|1F-5}-3V G xul)3K;+DcpvR)_T(Iy- 9HTT::}9Eddעs^gRask9 P}AH<,9;EVk >1P`Ȍ=Q)96fԙSr:Da#4&sPN7R]RTvFsT~>0[Q.]ԩKcǟ /IP%*䎮y" Q 3|(|!^*(m@kU._}ϫכsuA%Qx~P9> q`zrIFb@8.̳ij@@C)MBB}rF$b3hy➟J8S4PD#1 OVMv-n\Sݹksv(VE|wxLuۯ/X)gjή$lc cϼ#z~?;ݸG"sH>khF;=]G :h>F"3ͩc/7<~_'QZˉP2(3=M蕈$?JR* ʡ4\3}(9P ?~݌΃pFNʨ7v/Dpk^D{_=E/HD3=_-Cd;rnd ?UNA6Jz$yp3k5A@B]?+,|G #Ϝ=.q*LlV;5ZiMBakIi픪;/.s˥Y_ x|)|ڌ: `*^צruBM1QddOQG{=8z 3bwv8u7[P!$f>%JQM6bV3I3N$̂f"߽BWn}yBF. 7ۄU u1h+eQ U$͠q d)ـLB't1Wa8ɍ|!z!q [ndiL?~7@2y«;5Gf224p3ͤ!i.q\ DÊA$s\Qc yAZ!K(* X*CDz` S\Pc#9J٬55`CgK&qw`2fؘ7i:i$֨&C-ʜw_UJ]6q:IO@0=93Čt; 6F31HDx{ +ܧa;;S IΖj5i*蓓O0I@ޖie[hg[]KFke: ٻߛ~ FCE=Rѡg."8I^I.y)?i+UFXh ֯Ju>&0\6Q(D.\A!$kV3eTTPF |V yLH7D<4ܻb~8c7{l̕lD? sqkSg 0Xe/)[ KWoUUGZM5Y ;s.ӧ<\@ѫB :yEp/GO݄C$dNhON,)cd2}\av0Ya"@ mr _PX?olqz;K@n¸쎷.;HTͺplC0:le2p(nm4)GxP2V6# Yftsk]!! —b3oL|zW$Ǚ8$`aYP9eߜ9X<$_T)N#]PGV) yU\B۠(@_qS5yg"8gFCV Ii0KKiv!2L!Ndm"Fǩ` bSm g-c0ͮT / Tv"Ḩ2!x%8B'SMObg(Um,;k;]؉ @)t84~o꾸莏Z֏w%7:9ßeB;F?%dLK҉bRf;crĢ%D1v98ꉵ/**^8fxRN?sp-fmK=KtГ-!sc;ܱ唑*Zш=d AGl^#\O)DXrH-_R_;uۛhK}$W=|};cZM;B!Z $q7OdJFWNuO97hN)4 5윈j$v:v=Kȡưi(e4 N2L_a׷c:g5ag8 ׉Ümq~Rb3S@ıv*0ć*Z:E coޥMSttռlK iZ-[X XCHH߾m-w*}B Ù \Oqm Ox>&'"|I:v?nJ¼rTȲ; f龸j iSKєHÜpW"eϯv+C >3"|gj)Aٌt#Cnxs +ޛ<~I&Cnecc+Я1qVRX{xߵpM0@R-DCTfTf#f`I42?4s0PpV}LӉ8%R-]"fu;AsS`q|~si3O뀿 ٙW.D/x%;QnM RA9Rvԛ>0uITF|]:'FqFM0 4y%9PGzBZ!/W325дa窋 j8*38 (9MѪNu[!HgQ[W`PhLÉ3`s8}{d@sKt N HFz5Kb33Poi'5A[2*E8I%~#ljӲbv@|QAn+G^ꏂj_a}QuWy?X'L߾fc%hSo"`D}|;<=}xZxȫJ5 0Vo(7fF99[vvC6)fʥpj8,.MPӛDf (Y JVJ3Ay“t;HNBfuE.GS:m\ d&pG&Tg&A̔m SYٝ{x#LK;~p ]|VH,?L}a8jaۙR6O{(ƺxKza!xLBRL{SO6$fMia,= ^ V!fqfDvd%7\5oLz}c!uhd2M liJ}H4b ;ځ냋D&tG ڈ53]!n-(_K1نih$( 5(M4PPSHP+44ʄ SP,BPPHNU@*HA F@R @4#@JB@E-DHJ!@)(L@D-!" DM*LT-(PT!0+,% J/Š%&A(A%*O:}h {0g*6az~AY6;@+ '~Ԉx0Dp]&G0+Ys$,px@I7m,{x3d&~Mɝlc'U̯- aKxfi>`'G>9џPI U#;l'`)ķQ_|f%>fAfWxtMH(0W-ShxX R$8T % dfz"EB*8=Vkgx.1N҇njI>>6|exņǣn~]>_/.wޜK#ƙ)ZX6t[XCq 1So4e bIcfZq51y׮M{C'NDT|܄q䋎~L9ROaŹ 1)a++whMLዏ MtyQ*s]gwsrQ]{7px䥹_rs0渇;qc9.gR~x`7v޸@CX:G֕ s5Asqw<\TeV*|LZ-qe+Q#/龻aLP_qeKe{/ԛuBHPQ^=6bz=}T}=z|ܱD8O,pOğDi7ڨW~!1? Z;rvq? U30ya*uXY_T57K8!8 s'OeyCݝόWdGgFtnt]^nI%ɷ)}O&"&>"T5F5d/s8Cs}{?4ƟC3 { :K \@3TR R*"")j#QKCTxEpLɦXb &|qw{t־?}=)1 9,`濷ii(5Tbe,$`ޗ2}Iy=b2j:Py\(|!ޮLS p^@3}=B_ o WXC`UMK4r/._21NL)Yc_n \aO=y*\Zm?87Xs41oh֢o3)!JW꿝gߴp9~SnMWc:-},BP'h#AlQ + wP%v0B-F wG8Be~WBt'Oz'`F+Q/\M2G隑545l5}o]#J%/(%:XT Z`K T1 M1 D@2|埄f&}|` Ϡ_Gcyo{y<;9ġHl*|@N#vOr}+5?[”IBIR)8C1:}j}uL?(hu=y CCv@E?'i#!WV{ )*&z#*?Z؏~0SOl8xזIҩq0oihIC釟~ |>d {Clx7p|O56gQ'vM|>~yqҍ1yty&'L ٞě z@q_y; ?y~8\ړNDJ4o1 B)~60A OD4!`3i@Sp|X<JH88>?ji3髌oq߳&ai!$L1 Z{L(46hfk7s~jtƾtqUQ.洎.&es5H w/Ùؑ3rwN)o[CǏ]t!,"QJb",gȼ?LiIW1w&.(C1>L9>GHޕ>wO^iFSƣ MywF*[aj8?+-&j~g{ n=5O&|aɅLcR8@ q_m a`wxa: ":#H䝻j+1y>M`u6g0 L`R.lSX"Kg d-jH1A=\k(Mc,3AADE Fs~0IZ~?_&F)JiߗNdV] r<>ȭ&>ygpxCs((u BqqmX46idJ@E{c 1f^q;FsmN$C#NBmYI!Й?hcx9x8&ٙϟll`?yq:rfoŜV5'bĽy`Ʀ5:UGs dpcJ|08*Y|YW %Ѝvkg%^H5;YD1Іwc,Xx] h}|9<֏-yg7C= {@qI[4G}*g@S1Ns&MRCY<DĊd'v_?~}̇X& V-c. Ջ0sI,A-3 }ݪロJR8Y:vt"L"0u::&`"_~ZPФ҆X`waa6ny!U7z3'qY~VmOcuweyjd~0ypLkDR g"џᔼܚDDB yMo'F~7ΪI~AqP;4*G߾?/8lOakNH!c9"HCS0L4DJU $HQ! -fL QPf ̔00 WAJV<[u(4*60ř9SQ."o؛cR @eZՎbv3֢JJaԚ 54 PP ";`Pii EJH2&"j5X T +Gp-d &!tB@&HHrP)Xc}Q/9;{J>1 N}=yk`"Q!|f >jz̸G,0xߵf?9{Ϩ[ a~N˜Q(G%`=i{ 7M uv[ UBN 2 ZuTօSO Qt0;JN`Ox8G@YA%`6ɓ hOm)auFvl8` !4FX=4?hGU=3 v" pbCiV uU`1_-ȎsM@ !Mp.SP}f4ÐpdhB, d|Vf 1 1@BB%_|ߓl{=E@KB@tTK,wsq.`r& P? J P!QM2?aw;;? $JO?ؠffCp? \n:UO6ޝĴvdiAOҁqf㫜6| t&VDH_EZ> %@ !>mMb;O_0CYOhUb=4+"$ߝ?Ve1߸篰"wDʊ*M]7*Gk6+VTP:%fc S-V-U1Ɔ7fH RA@.w<>?DW@ZO,?9L8 aW5܊l;Kg 76u{|ݹCeT t Iq2c,נ?G!u!F'aA`=A|{E:o:ڿmFkYkKPZǍiHٟO'Б>$;@(ԃs=>X_m1MQJ @PD;ZEL-u "ט`o).9 X6wxWz0~ }}9%؉^6s&i ebDn@ߛNJ8vРCD'1 z6Nk  +!۬FO%{N?='p3A{JL 8}]4datGR3N.-U8}lK|f36ޅ ٪##!쎓81$OȸZ׊/,bzDwv>zcPv2B( ւȲ%?_z|OA#HyDZJ*>OcsxCô=9 uJJ02#u;C1 L86'7?C DW0uq>#R! 2x{ĵSsd- r&L>Hx`71>MQ;*yGʉQ wB&BID* L'%$L@3 2i BQNWP ]~Shw6SOP_^s e#.(}gQz.(m $f:@((] ˄ tL:^/ͭh?e/w4V6/^?j)V%K=^eO⟙:jᏱ=߫eqr6wxR, lp#-"&kfr|])$"['B+DDD {#!_!;"$X9^\̀s_Ϊ*LFh(|AH2Ba!BWJ)TA->C$Q}c_W`"~K6 "C"e"NB"feMT"V-QS">w'O{ikBԟ: t|#jLoɩlX[WJTQw^X2n|2vLc,NK|焚#5JlP=pǷ5RpPSByyp1l1X-|j0}A=;ܧ<"Χ ;ֵ8uT[VPR#^0OjsBa*jxߟ|e,K;=n ]HɹxqDfLb.:4J 4t]o Q0kӛn:!Tb"*-eޒ[#m_fŎF2Ҕ$"*>gr1>I8Gws) bnY33Yeb0m(Mâ\ r5@P4/̂q,^mE=5/x@̠./M|$P!Ϳ?)W^[q[ PY'6 D)߲?̟b |Pg+_|5D|mct%8C09luX (>v(#S:a+ޙo22&m3g 4st9v9w`\6c4`rGBqЬ9v52?80|Oz7mE^V7-V3ǒ=eJ(Ti>*"U5~ J+A4p% dZ FCPa٣DWl ؀a;?/=_Ԧv\.T$|LOI':&6E\>3^`ydyCTM. #:C\(sƶȣ !퓍95o99CIlp9FAx֨vAC"Qpǯ-rs3io}vñm!ݍ S=&VWnu\s> qǩ:M$Q6AdCн>سzlً/Н$3~ibd&l~3W)#odNc„<;6mƤmZUgUuF-1=2cGfM|5/ۑ=j}90K T=CmTz5Lj_!u\'duoU󕎱!]oe Lwݿ$ޮUgKHETo++QCm!#MqiCdH}C9^G=ش]ʘh"(b*}jjvh%=Lze+^akfWgY v\^]vxHD_i;aмexxδ+gY=kgO8H>TМ߻MI4 ,Zj[b;& q;+ eԹzsIYZ3LWǻ߳>{윻,4Hk`svve5Mfpv@dʑJȊgH&!dG.f~#?J :IΣ\yp"9荈^ugbgꏼH+^]>zGߟ:s@JS )R&h,)N׎c*BWF,+ }V>QbQF[Z3#YB`缊DC% g&LFWh| @/33XK&Ww-fF+%~ydrSYԭѵ=;FI ȐyrlQ]j(ϗ@# xeD;ey)I~DQ^99Dϳi); zn˦o6shuV&ì~2rmh=z у4w۹]rJ!v6XެwD&^,3>0z,QU`Q55hs34zvÅ3֜$><`0CJmWS̠'|sC|ps")!go5㽿GNIbEP9K;"wH,mb# ^^ Α3-^GOBE ){2z6ozonIoh$؍ӱs )fwu9f7rTBt1 qܻkВ!yE_vR7c}fxCܹqTS-t%T-J ,1S`;>HC׷kX[p2Zi6_?n(LR#otSo=$=!;I F$ʫw2DIs2؊"L]g_RM*z֙zI*9ҷ&/~LeFϾ, UAipz܎tf|O/}?[KǦ)l19ꪈ3Kh(Og*q%MP% >|m,-hsg<=4[jJw".#:7G=Àr""&$A. *;i!"t = Mu7vo3Pgěi vFN9݅|7[quSAXŊ cgfj;=<&$ WpZh( ([NSϘJG< sɃHD9N#n "<itj0͜ =-RQ`$玒<_9Mc"LQdZ"j$5zrvn.r[:g]&b b;v)X!M#;!R3:ǟj 7hu=ǫ`7C}.gIa|QW<aE%b{锹 ޅQVDl`..!ʜ6%d)MnRWi!%x,kk:}]̑RijhzSLOb$*1p#Wk{Z*uM̺DhlFfI]E@B! b`6dNEFA;)aқLk&ƖjmMT:`,FS|"TCs@V\!D8 Vh$V;K9`_#A!!,aoیMeFƦ^iar`oqmĢ(EX B6 f/ːy".F2cRRD`,f]k)s VLڣk~$A!6r < dLF2iX )Cldb )+Xbl@6Ię!NpIf(HqUV4r,(*bAou#Ȳv6rRIYpF "lFeZIKE-F(QcPIHY89KF*0ef0j"*%*0b0f5 112j鹭fkV*3WYܵMc ViU(%k2BAV9j8kZ֩XIEbd#8Y,PZʖ̥DDEEɃTfQc1F)R( Fe(˅-2LXaDDff D.88c `[C^ m%HH*`% *nq‘,D\0D@qZrF%407DDx ueFt|ZVeM92%T%TLLNL5  #gG1 +iM,9` 4R EST fv e j!YhZi (a 4 I;P;Ẅl Y{-TP !6uH`\:(r$dK~Pe9le:O1=q ̾v #S_A4.n"2)5Bm@)Q3?6ma" ]V8f>ԯq?w̆M'.e}0OSiI!d[eH[`[diH FX`υ.h$ߦ:9ϾwPSϴNo'TdP#&MdBe$"B CSSJ4>6t>SaKbh',b_cIfǣLAt5 /x 90S>cYE5&mC>%2TNj % J /}D!*I*MIBf H%|}A ATA0LZg`f%=٦n38n#ӝ|M\J8Q28;ZzUeKpk8&{G-Ĉ3HlL\+є$-s)N6̓ry$U䙳:DgYzdI1/1ubI#1NaVF>e:iqNDqE˃G"+ D 5v̂狠1񓌰Б5jVw%!2PnsòwRl`q)4t Hn1;dv 8 9WI)}"\$p4ZcvHU.A@] ʝ,).r Z`hp0t{=%T X@G|'SB>,KP`Z513z9w&R&'@p+/*Cd0H|2l1ۧ0$ԣ$c.(ʙq|F.??`Ey!<ʛG3r0o(-J}ɏNݥbma$J #zJU*YLQRH{g3&$䖊ed y~hA(4C=޻Ä әU#!.А#BBIGl nD|jd8/۔ j %gfd RK1(#2q02Vܱ-4 AQH`db1A#TAA%LTR4HKY`T"jTbrPEBaHiD N"?@RD"$P@ ;}}!㓘O%J2Q- "REKMJR+H  g8i )M6Rƙv0"`#N$FJk@K]PDHJ)`Ɨ FLc&#&dAZ"X0M0 phu#xql͌ˈ*eх06f# 25 ²pa#Yl&-nb|ahVa[XãU1FÒD.`|2XH }=*'PrSd/ $ 28|^ QC6`ð&fr~S =U DP9 "`^xҤ(#6P9/@`nNs"H{ah~ 3Î5!bL2@=pkKQPMͯQ˰DG8 oZa;:/+iC/(\/}U @F (n E=՝f s?=+LwLә-w2 Z%wMaei)0CqĐ(QP; #&VtA~ke{Cdby}GG]gI&PE::qd%0̿o" #-D=l:шCRIkxᐉ[ 7#$Q R ҂RJ r:=7 Cr}ӮD (CSDL%)MTx{@@S@dU* V17\mv @b)'hs,"@E׷fbCF@7LkkVplҘ I#1. d,.S 6'"f$RQVzh7x4s?O!I14?>@;T?/BD'heDƂ0]V_õMA,0LDT,QHĄS$Mf8PD4PCI1HE` Ra+0K @UnC"j(DPATU0 dHbS3R3k "XcS$W9fE5CSP["*&`"J`*0)jB"(H!)X bJb*bj*qPAEAMUETRP0%RUn0*)XS@YA$ )J| ~>_$rJ'dZ؃Uh٘lD$ Aŋ`_v|Gvy3-f'mRyoK u/,h!dށq({hC 1 (.nɂ ] Ѫl8"ZY "nE pΤPT4d7)zH H 2E |a5TSJ)@Q蟷P0>~lP5(R2PR&wII%j+Ci`Hr0KB5􁳇 ^aHal4x66PD A J`I{L6~]JE wՂ\G}muW*|sDxǼ ;7{!@7@(5G` NÄP3z'5biS 6B\B>bEKidQsf(Ni8]!b>JtexK`ڊL%!#}*tu I$ K><쐈 l%J_h}O@fD->2$?M(~=o4Cin1'eA8fT+m9ղ,P?ؕLd mk'%{`fҽ'x<>pff" )AMv^hY4R!np?ϕ猅A2U`mBr2YHf8䛂-V'I5 B4}!fVpid8xp?{z&IP Hb2rG;/I2mHuҲNk 1 &b?"D$H9=xۥ,+Lf Zڅ0Zcs%e]hъiETP1346OoFhr3XY(*s !F M>&.ej> 6 40D j(/I=:6!0>߸ŒJlϠ'_NX؁+ME8 )X?k4 HPZ0'G۪(4/?8o>ܠ$#R:a{;4;6{`(yDJla iTJ A<)X~bҁ='SJĚ#zIީEw/|`xf#7$}{d>AJhncL`2ʚJ(Mt2n[q` [^~v@8 `D>5ɎBci^zC)4#ͅ*}*0 ȼDPCqcXcK;~''n~n}zj WIaOHVx#v;txiyL;8zQA@HCkWq?;sŘ0;ΐ`WsV9NC8h]nj(rDpXIcIҍ9 ¼،Y A9' NcUQ&%s]Z+ `Sl [$PcA|?5Z[\UdzH>¯>_49SV *2Vy&aRßW cm. ,9ӗ&q5ߨ5cD  Æz|;:7| ]8;/jH# eȣֵJDiQoIt.0avOfw |E7+NYK\pp"$r{ Fw;p)k!BQVtM0eJhȮKC&K0Ve4B))rbJ & a U!B҅RDmLZt?$ rFDq;q}АA;"`Ӝ3p8n 㯠Dɉ4@CT@;]aGʖ J ,# r`JxrQ"t, ƓP e*Ln8%M2S( MbB,)"ipQ4bG|O4@eh^Ah?q?$@Vl#6%aj"SĞxC` *&j&Y&Ib(HztN@F83W.Kɮ-'10{@КiCFHl}=ױ;. AO:~Su; }I#g=r۴A}w은i?'u 7dD%@j"XaIҲJ( j  u+P9ъqa\܎Mئ!܅_\J)F 3pQo& >q}0;7rOHhM˛jüfX Qh#1/KîdS-/Kp o~@)$uIx1`1SX Ao6|@x1-K( N_,9(og=3Y}JguD&r)lo4Di`cZv`Qf & ,BEBێ}՞Y_:柸)2{8R|_~בM<ۏ_һSig7E^ھx~đyO")(fL%:ԝ] `)LVM >."j @ްiy~},M }(%MjRp 6XSԦA<ۛcZShJ;sש0QMT w:qjyk/o:.(2E CKUE(0,+@a ^"XXL0>Ha`֪//D&iyg]) -Cpp`G`eI! :x7ǯ#6= OG9`ؿsުaߨfM%I QIAY"R`x~>'Ι*|6QmbK~+KdnBVJRϓ ,pg8Sifu>*'DIP3w҆An3=(NGVH֞O`ł0 2\/ց9bQ=OV,ŊB) %D%H I"ܵF#> $A0DV "-i+&4EE QJ1A)("eb()6K1C$JGr:Ze ;@F?.NȂ+2JRG 9@3 V,NR2Bw Dц)Ni1J Φ&FQjbh @kR TŹMZPjcSk 1JXLPfnլHR'!p%3fY0MA-PKTZP *e *e]fDKXBPP "Lr0&J1Kp iPH-jѣk!+j mm*+W J#KiEXQeQFX 8@(;Cn翞nC=Q? UM'i>V(l &~~vpy h ?1DJ /~"5_">F&4.MB=|?ן@R6jRZ̸1qQb_3F҈0ƹCtX]5M좬PJ:7 ,us H685e* ᅅgT1?l%#J.DTضZ&i=oR|^j,Df.^׷6;xJè P`<]7jƍˊ9!JL1*h)e&``ڍ36PJy nabZH,Lwe"7%jOF XD&E2HLCIHA6jmpt%r.\Ӳd&PdqeSP!̦ qкMBVF6jzODk+wKM &f8#3YpBP XAq`M qMf"rC|.IbD@㘬sxk-LiJR$(Cq m(P+rj2(cEQ4&iٙBsl\0Gj̶ eӈ#rq0AUZ@"d7ѩʈ&CrPc{ecyM`Xf)JhbpL1slYgiԬ[JbamU`Fj) 20n*Rk1W$rMllJ=VC K cuZ0\MҘaeaY mq̜Jg,XMlx7&XR3;jI5UP*1/,74Jp83y**tp1,uѱRP"P8$0YuTԢ.U ܄⻇PmxXL&J? :WvrM[i\Қ9a ޭcQC\ڼjFAA&,4f,QxS4e]WEMAmb!ƃt5!q,ހJKHRRj^cV11;VqV FDAKJMPj3Fj\Xu伦{7R-`#hK4i 5Dp4m &mZZ +,H&SF*T4jذCt`::p1@hc!@Ć(:Hv? ~>H`6= cB~bVA=;&VGѧXs^WsmOe[ 6p6=]ofs1 hcMEFt=fJ%xG'qʝshAѽ:}֎'8 5q1whCe}-*gO6jثj{9BeI֌9'7gL]f؋E4{+Su17Tz"fiV+Qd6+(ǡF5NZY`5M%F E'~NЩ5tʏd:Ff'S0bnaK 2lD/wo9`tMP$ >řj Yu%ލA_S+D(+jEW+c9N{%).}U RHiF!HX@/f8GA ;K~^'>n\R)Dmf f(!Tdt)jPhDH%XQ+Yƒ$i&05B.}-`aC *@GiOɲS; f8i5}0yS A3xf4ikNeAB`s:ق סr L5 P0K!:f+eA0=|uT ! 4`&#g#$BXOyi=7!G9OAQ1J49"{8*b IKK?{ݤF} ̗!B!!P_F ᗰ| #2_*e4A*#&Ld2_g?,72o ?gCH|H/i~;} 3^4 sgD߹k{=P0X Hױ~Wv~ǗnP{8^r|udb#.4LHt][əeht5>JԤ2U0oz]q;J#sbOzYwWJfͭF16Wn;|wu{IA+~%`ON$2gz<;MXkMZhp oѶà@z0bv[] !*/g!0$!,Ԩ2 B'`8Nm؆ Y!/Ƿ!(|D#'T!Ř]L@x B^) )#"`}Xh~sG0#i{P"w03 _ mg8tg9XnCN#XƱ1hZ֦v?"#:h+u1v&I~B!rG364e:,۬nǑZ+e"JdKZh_-]y_:~lu}*~0XHR)wkٝ>c WFgDqx3${~Sk?_9|y^z{}cRLp):bdqBU7@%Slʚ#UɆtSf2=~xRm%4"- ?y5#hېm6%*d\FEFt(LC>~Ͽ=>>{z8vyI1H=`bS}O'KV.H0]f&l"8k{~ȥ^;uhxpc2uaUV*\EX(,'~p^P4wQ%ҵ2`(l¬WE(v%Y|BHeC-I Ä;{狃QFcgE Ig8$C IRtQ%9.[Fp6Jx`,[eei*JGȄ&t?A32ݽD%250k$1N |e,@hXMkmD9*(Q140NB5!>E&hÄA 4k8)P"w,ašιA)6€i0Z˳=zZ9ƶ3Bi3V6""᳢{ B*vp,;!闥(9qfqJ]Z'0KiG; os10CB%!J4RnDU{䳵BBK5MPx34`i1 bu.(.4؟fJA(=3LFphC$+ݿH;Q^ Li,S'90cRLq:aˡʱVߎ lp.\(PS`gۛK<.5y|TӐ0I ti ga)DLC-7!;3˄;mƖ6e Da :Ttb:9}#᪥<-,Vt㖎TJTAuߍ#pN8hBHEqG.)&K%R$`MgS"xŦqH>v@n/8ܝv8FB%N %/RJ89z|= P'|a^)Z߂>'6u4uڪU M3*CRb m˒ 8%/xȹF0S[1(1rq H,g|n4Z;btBV!("Vx1^>3IN:iHh:^Ɏe:{WdmhY%t El>5LtS2!<($m1c &5΋Œx#u옔h l&t]"BjM1WJnu.'ڙ%1&g!'n"M{MA}" S`\C z*#vú 8_O۷[gu,'CO|[m,]usm!ɘ^'%K.;x5.=(ݐ'qJ"0n_ 2T;T7S8yMC8 sj{s/<^g|Oi42fF;*l8ajgsPHr{E@g+8/f1+E4HPU7~w,YFc9r2 7Y-dgԘ0e5$YBC[Ɲ;,A#ОD7`4&#\v8ʩhu812%qhie;ErF45aNd%Тu5Ů!lp("4:N^x**I!'!ES0坱BM%069xǎd .;7'VR2&.FTAQ$lNOCf=9nr*ţ~iByEqD8>B xaLO0v"4r@Heb"8av) p'W8bby=ڡ֓x=囃rHd8tw6I(灴xt ͕S G? ܓ2}2'2 5yI?!uD%30S$$Շpu]ӏNP&)ޠiCf9r> x{H'F=s1 {_\<+*-Vs8HTB01v^24R%!CM(Sdb1`cB fdy<ɮ8+0T0v`h(i$ u캆5p ͭ6ť$mjG\G@"  a@p71QAE ,14Q-D1ҹ8A$jɵ)DTAXHC_|ߎѹܗE|t:xx)pbZ*RSag.?EyΖc+=sqg\y9-C$xaRQ&܅;Sn.-O tqSq-Jط]3&O\ Vwn 1}¨XFFզcma q'O[pwn;N.<4sw{[掖 5ȇj1*uSdx1C+<"t;:hIf5 /7/. &I$A aw^9;@ B -D cS69{u$rNJrҍeS J5IJt&KV@Fd 23ID:e&(&"rJ"3Z,m{k7]': ׵ TC;  (:A`Kr(`dNcQ faXcF}0Waw~C(jJaFb)!A EhTd$/Հd@"e0!u#y˷=$S3a̟O$1;2 R2ƟPߋ=V^&ToA 0T {!`j%-#% XŬ}ͩb%B %&W0Rlm6s\b$m;$A1Cƴi6͚+5$ e8rЪm(EV`[H؂bVH y,a?ZyjP%28`ufdD9nm $ у*Q@tdj,'G = "/R!\t?;%ܷjIOCՀ|0W P`4`%Z9M B^B/k\:Ԝ@NROHtI^|ǭ#r{Ip2B"`3 `x3Z2tɪ($;M22d00T$#y@CR0RDBrd jcNP9ƴ"e*աJ$C4fL%2JF%(2N% H 9=!q*mƠokʾ*z>haϓs Cg+=Ph_*)(%(R&J0 ( F Ҁ)eC01r D "iI`"h0 ' +iHj!9TME;7+/Nu{ k#&Li3 {w⿻ ySO%hCSi:ƟTWNaۺ5Vm?gz$J~2ZJ啦8}4\ٽ241F)DRj9H.Mjܼ/:#;B5kG/`o,]Py>),EDZPuhl:m5qed܍?ǧL4v*@mz]ᐢL=8& _?I~yQ=g_U8xP¦&@y]7zHGϓHtY>$ xYٙO`ls#I+8 d3N3U8ZHT2LfWR4K ZC7ӕV,C} C>pJs֝aq$TFF (e*n& {Y #A0r@% sͫ#kt6>xOY\78ALY R6VQ&! LVV2[:j3(%уGdG?[B1)$%;,,-xZ*JhjܮJE: 4 bd(Rt?W Q*tP`NC(?wX|ʃu!w{V!DN"!҃xK:t yG\a\?f1ޠ:Ŗc6|DL}3T[U̎ 6  Na~:&E9&SS2(fl 55eڦ9$Lùj @2l4[@I$bL~jS-T'n8.Abajx3Qidh1𠖖6ȞnE,n^B@40PRJr2&Eތ׆ᐻq\WMT,kÅZ@.9["أlYyaVNq$ٝ@USr,aSϦI5 tfx 50ѩsy:9:=5&'+B5F%7jw,r*Ԯ!7Iu`hB:)0y ñFEN*4x L[Üm'x'%ĻaaJqnU2,Zfw3%7T6$# Ɋ߁K0Z56mLS;!Uh$a:FB@rZ-"rvOہ|tn9 j_P"{v>P: I @̳4>B#?D1 $%ُY BD=O PRFQM;_Kkg=灈-.b,v/'drx%E'6ߌG9簁ˍYvvlTBJu*BA;m|lf  B"JC}o1>> !~{RO A@{Cf-g-Z8 BV$ ītF0eO?A (0FL.OvM ?1s/?= G88 f^A-Hp D򈂰H[ȗؽYZ C s3#IˀÖ3n>8|5Rw4,@LS>|zн0 Gb#_=z#1ӁsF>F|~ٌgT~%\Nܹ_q[ޱT]`:D$(OXs<JO܄UfI.PI d*,RTQ)Jo%#9\:ssHte+j(`9{֐K(g.֗Q&w6 K)-4eVUFX(aa B.0:()R@v'PAM.e9R5q`d)TKFR2HE٤PX[`$ aPStJmJŶ(Z5e!X8ܠi 5 H%j5)KLfJJ!T4L@PL@CD fbKHPP%DJPsdnB04-(1Ei3~tC">_f :HPR|#T`ZtzN`oxR%F2tUń4gY) ,iUMQ3E+QL Sq.8nӌd4T E g @͘A4kx =2H>|& @Tf6FgLɜ:Z Cb C衉E F`}f (7=r)3$-?x>g2HaKW3tbFKKy ]vpòd ACdXƥ^uF15 _M` SK۩#~˒Y\L1lSeF4 td1 r'UycjѶw]pM: !u)jn4tڀFr `@_6g'h׃,uG̷D0g*"hDO.pa%j[ zd8>Me`@ $ʌAA"Q2DBjQ! t|sb sqMDwGpmNfNÍ_}u-Kn1K%Mv!~Э*7ѢZ;fR VA4ۺ&w (B!Lky4J("@D4%l $)$cIoJE}%7 A%r!aC٫q lVU1H  @S%I4A1܉K31o++ ;-ePƣu852._{A% T'hUH~]c6SؙU~kM xc'}1qD!MضO 5j;ˠaMl:!yF)JϽ`-il&+!\3BgݭitbM4 uP7$jJCdwt(uaSNvy5WVDA96߈=ABS3,("mL5ƭŋXauBZ"0Y86R'$(fZUcmKim03,Vܔ8Apwkm4QDE zgBVpbR%3qQБ!K9?6v4 "Ne"H(q_sZ<*~sˣ#&lL0Õ4KJa$$Rz?9Xs#QF71Gڎ05,({nHT}gHlPԂw5Cn<ú>ɤ>yb=dv0D4 d )\A((SUAu  X}L%'&#*RA5%.g}KD?a]Ȉ_}|>ϏA|'*f 8Pk&磞_NFAS@dD">W}` 0 @7l)TR)Q dlBa9b DrN `JV֏RH anR>MF#J3(S)%L8M81YdkCՙ%.;g؊`2.G`˜cHIV+qxE29Or6#\рK#o`=3a&C"Dl\BZH=d˼ Q9B @9=t鞮Gvz[OwV';;I<~-Up1Af)xN.J> Ns0Gy< q&RQPlE.@52 L - Ɔe)/nshf@I@7*~]sg⻘"RM )pXa):'Qc$Pí S (r̨("=؟/9/8_?po!%Yf{TE4d(Pv<|_DXk@ s~M{?hl=\KI3L.`&krRGS JCio#]?λ?*Q O(Huz,uǎ\wI31c8XWݐ˷&1f!v\/rړb'wn݃e/7{SH]o5@e&oS3(SVuF/U|b](UkӒ;Q Ec! q^?J1; 3{a12y:51tx,:Ń!'mfQN̵Z DMfCJŬSg=7n #))"X=aJI'f:(Í RYCH^ToHr` /;վ8_v&U<5"*|#2 Pk7 44BɨW`|MND |GwQGOIz93f !&' KAU1߂cs3=`QL`*!"$* b "!q"& l JB b "(h*# 1ʖ+3FaдJPФHATJDQB44S1@ C@+Aa$Dbx̮6.3#p"@mc\#ئDb< /e>6? xmU9 O$(iFSAN`L %FO1Ҥ}[Y@/6TP/(Cжu-E 3]U(칃;g?|Ts6 >7K)4! (S? 9p:x)F"ZhR("*ZH%fF$`b) B"iThj%hbBJE)R*")V`ZZJ AJiPaJAiX%b R%h) " VQbJ)%J7W@0 R:|=.ŸBc{͐5C]aHR Ŷ F*ٷ;n"!2@fP&f,5~Ȉ;BpCJ `x@DF"P> UrtH {œQ@4'n90S)A5P4IETTHS-)UBAN{qW#|yAhQ'j0 gcHSbi{u5ZJz4ceD .3i !J0RRX,VZx`Ր^I~>6 p6/$<.+ӵUi#m7Vf‰Lm lN#D'5.|r&BM"Y1C`M[7(58d 0qs.NϯX1G}C>~}Fdf`Ɓ ${@̮%xI%*4 *&젎J-^4C! ◘nNo!ì_R)qj=CigYrIݭ<53G)6k\w#BW}3 zrD*H5!|D6ه)fb% 0|`g 0''B8xTX$~zzٌN{d*P ۇWk6qhuxea.%OPUdP>V`xpD%4 AŽ ri &$s4 X6j%H{d(16Zۈ3-@98h ,ݵd U$+ *&}c41 Ϳ|\ (^sydi@o j1AeݳwL˔ɖ rX"QQ-ABmنE+ E\&*(+}̴X`Pę. CZP2FVƨʑeb0("*mB(Y$REmb f$:lm"*A‚iU"mkYK[aPc ZiP-NVdNT\jSmSNAQDj6j0ET%WDk,XѧfQ”J,V86¤:.abddhڊV6<drҌHFL[J E#a&5 d&faN R#!OeCHmmq;@JG]9(R$0_1:I}RbӨ.H1QECMf8B£6ŲաX8$R "cede($Ur "b3,)'!aN%1TQE>Cz J`;bK*r<P߿ _T+Ra e/n n/3A;P@W0 8P [[>¤{؏q)EDyPF`t N"<F++Bb7D:r|iJh"}(J3-O(7@djBjqZ2 H`fhASŦUJ#!CVsbHw"҆!(JD\RL ' e"}%^}16k;f :9, @I T1@Z1,O/_lW91L™0'}4AJ^{9;~7{'n(<7'S% O-%*?^TB=Ҿ } ʈZِ VD)mJL☱H 0aKX0@BBGx\h,Ԋh[oMZ3B$( Jb}Vof@M}L-f/>g(ni)H,l\XZO^j>ԦwʅgR i4.]jwr38egiRݛN voy7s䒓AۆxdM;))Wb35kj]JbGXGqI:sΑdyjd:u{ΞO,Ϟg Ӥm| rb9 >Gt57ww\(P^Aɵ]';EGXug/'"Ӓȇ[Fa`pF9v#[L9txP+UxُSwB. lVK\D4JRcrt>Rz˹#sovq6R#pRG)%,DS5TAA@<Ą#(:iw(PC ЇӋtEg(}ykF_\ P>Z$"B&>*E=\HБ; .DAgZ/6mY4ȊZ:ad2fOUWqD" [!h$opCU֔3jLQAծ EB;sn <.;jHN<! $ВLB:M.xy`!Y(⁐{{ެi# S exu(LDTI@<&cW~ av]t dϩ]sO{~Y3B x!$6^Yp9%&ߎ|ԞaϿӾ@Iz YՀTzp+̌=z>5VJXa̺\'&\,U#ƥJ KLeLըZ#cT nX/T-d0\Ḑe#ù)kMߣTԣmC44\nUiu-tj;A\*r=ey2!$~n3N^%hm͆{[V {Lޝn[(NR,*ŕ *X \QV Y#,(*i,\+[lRTbPRJ~ڈ`*b28$y.m=MZY0+ "K QID* ]f \%RRŝĂnjI"1IiXcn1A0VFxreZHդ-2HĠ V,F([*]m+)%JVDa`Y`b¤0 B y4Ce7E \d@ C,1 F=_9 q`/ņC:CgA61($Zy`$ًŕdP6Jrl$50#&"hd'\ F U+N#!"(& if&*OGN% N,,,ȲPd Lg2AbT0b`"Mڈ*M$DQfk (ҧ goFj,32^l-#|S:}0\9 jR M(z;];1rn q,;G)dT5h'\ߝ#볩^љmGY2T dkDDhr\i PNixHu"9i ~tΰeK58< \m%(((^@i)$ E J$$NT1<+:H0`9i&H, 0 JSaTXϘ?Ɖ ]3c)ނOBsj H2G!3ZG坖/pz0mċUYTbbCFUD7o>ߙ<p _wϤV!( =>$b* B @8?:xm\ǟtz[ րdkH EhFC$+ ,&"r|SnÊgOfw΋ܻW;,hqUȜ'JK=Q}^j+M2,$9{0fru ۥz$5hEfXUSL&2lkIADծdFUIQD~a0`&o)C1ф.oX,6Jʘ㶩S`Tr2idzٷy %Ɔ-2\čTjv<d!- jX hM. Z6tbU(&̙S 2EQQ2*2洑YRs%eb5b`gIJa b`  )Hu/4$;d:gZ#jC2a.*P-OHyaR`M;86_7:SIvMx(ux!FakYDE ZϘs)(-)mPUQJ,)[TJD)d+CS%`PYl !jQ YR)2BکҨg`A+tFDi% /̭&IjΑB2,V'1f6D21 vn}Pi\h#>dB!XQUn1 u d_n&$"pV-YTDY*QR(f`V 3P}>GٿRN|_/YQSu5,RIl|*2mX t{7@ժ[EL i~DFg-3FSNXF0 Zs;=7dy2DXej^sENM}!,6hm}Caqi=s9?pBfhEBI0MSP]tvZ:ԭ" 9c-#))Kkjŋ1e2hYt1t2T4Ga%,Kv䉹ѭbku(8g&0^kdhgl=;RVD~ "_4THmZQU4CVt!BakA&aJ*,hVS 40ֳX,8, f.!ԁ %(F"h!" hI *`"B Z!IJB*X b *80v+m3)dT9vH.\1` z&%jb_7*qC  I03KB%*g߃!r?p?˿ICN]]Cu(HyRs5dMvnnis0YS dHHWTv=|#^hnrT:`7&G|si΀}_'Øp(悋A)d㊋@֣ϊvx|!1&C~S )"ۄ0QH s-l e ¤%@ϫJ 8pr_wGb@%a'|>aG䄁 |Z ]H0!()^N:ײ9t'0hR!2[~V "WiT(;maTTY\N$|` (BHnn iJeY (ZB5 ÉHC0Qt(0JZXpӜԥ-RI)UJlJ*6 V[Z%N!^2N._(t?6OP jA9- 9<3_uQ`G}z(r[4 ,;%K L;_5+ VHɤ׼+XJXh WQFKRd-XcɑV~}Kǃ3NApK_HL{&p2yi։f8ϧ!:h;3cL FFш.+ƳF#hk*xi:# 0f##Kڎ7u vw`+@c8C̕'@SP&)W'&)B+Fe09m BuA1(Ғ6 `E1*IFLH*E(!irwB!"@F9@nSjΓ7;rqXT/%QlczըZ ii4 \:öSD9 =b$Ąl;&9 ' qDX"֣  fA!DY$uchr%Y5p QkQó*?5-Y֖e"o҇H:*6Bl4qU#hᣇ 4&_^*ԍ؛]/$bZ=2F3&Kct  E␠"@DQ#vbٷpbo^LM(ֵ )BS%L6IE3MFvGRPBāPɠK_5']m!X$Fļ/Xm} NiL4g`KFf(8&dXQ+(c6|ʇ/20б/,b?|86w$ESH+6,S:6 >NLhb]|k^KxȐx&;&QÃ$T-CAly2P CD,kaFU%r_ t0D yċ~ӆb}?A??((O?=R䳡c`H{y4ޗYC3@IU+۞ ?o"fS>i>'GfuXqLF5;Om MZ]v8Z&fE(\sΥm##l*#5vu-2ڐA\$LBcAE>d JlY,bIFСe# <7)IX7.ܼ41QDhV W5z;V$bQڴ œ0vn Kؚu6 7 I*1AU+`H0 XMN'aaw_j~?ƈeI}12fX¤ij!{~C$ߞZ٬10 z>ۜwsczLON+;W,y#]aJ@LR? 1,b=DlGUgLIXC$ECs&4L5C1%J[N bs9 (B(:%JBM2JV[*$,4ҥ RfbxҡhFjD>^,ޠ68,zߋ?PMLi숄wa-<?{:A CNw!?&|\u_b>C͡A0CG7b 9m7Gkt|.>~6 pW~۟6@J)iij!⪆#8zcOgR h0Dj"o<;QHtXvQ-bH&ITǧd>X-&Lz貱l zH#Bbvy!BBVDžyKFY QruwZpܐMRN5"jؐ bJHJi9_4.7?(82L/v;!Hdcڇ]~ALBUd!~†I%EP\c2P {\U )dXhF8Ue bqRPt$hW!\I%os wY* H6a @S Gxry%h@`b܈dMʊhȂL$"H N!#X9"JԊ L rB>2F(lbв)5픣 3(dSns9~C"d 6B%V+Jҕ"I$=&u* fq'DEX0VPLK1`h?V(E?CQمMgwE <$mDXh~~67.6|4mƈЌ4A 3>ix~j|'rͲ*4!OJBT)aDQ*ZTar5`Tg ̤S\f2(mFc$#p_n=J7$I1eM^jAV`6iQ {y3=ڜ$gBvYxl8h1UVʍ/}֗]σ$@K/Q3+2)b)4b/OS @lr$F (}uk4cM<5|,י>{($ąt (1Qp 3c%-" 4(R)H3 Q@%#AC(n$F5)494 !*!UPi%[53\Md/a^Y$gaDr}A+d2fi r:I'~ ! 3Er Rٞv21h#a%>slfN3IQs64K.\UnM9[uuO1$2iR 2Ęc:rg&Wzzx14V1 iCo:h ಝJoI~[vz1-}ᡢYv"߀CW!bM:X#/GAT<61Q 6?t#&I^}<#JHR,A3$T#J $KKKAHdjtQ'T\K\}ݏ VfF  >st*ӠU>"dM!\OBi;l3$Eۆ$M5`fbaD(|Xɦ&Nb#VwO8nk(AcWLUMŬQ[͙I&VęE)cy 44!1VFhIJdNԊF7SV',X44̥peLXJrGm5SUÉ"Qa i6{;,L> 25d AEEE)`Hh`}G{ʹR )E/ޤTJӨyX$M(`7 >fKI,#2 _"xvIED/+.O،'~M4ޙˌ'X)ruhɊ}WEءNFn! +T)" .CT&H)( Vg&%05/ %Գ8,*h.I$>:yf⨂XuJE lFY9Ԗ|9jK 9;HuhP-(4$7d%2lw <10P>+sj8clZKMC"0ls) Ёŵ*Ci͔KDj".n(L fK|l'`xD 5* a>i@%qOz Ahҩ?JU DIJwpFNڬr@j0i l4z ' ;0T~A0?dҁ76{ hm M{= uA*sD5, 5AjB'@ZO)dH(iIHSH!H BD%AA3,B!H J)4hwwZ%hG;8잱QzaD(4"=s,gai>&cyO11 ) U EB*5 00Wc(y* ʰr @`iE ,ELSHĄ/=C )]:;5蟙1(2*bTn/".# m& E_0 ?!XCF8R5A@$Jɨ}fpZ,0 y)vC6hdO92"Y =+ly)*8o$пTwD:N[ *D R  XZ9Ne&vgN1#` @!]!liO,/KȻPڞXӒxtTxe )P@hy>iSrP.CJ Jyg2c y'GDPDBy11TF!bP&%Y \\ ʔW ihT>( 09 jJ@){nat4f%0#4T1-Y"( E"#@JAf127XDF5 ʓ,CMCF6,ZTlJJ$(ȂI]'v"q{6𫛡NJryC{tS}>G XM9d2zAhtO{7BG aU1{}զP>-wC88F~OľWd E Y12l IRhl-Q6-`ed@4;9GS;̀>͈?1 tH%h /f`G PU0B"PBQ*PELh}$amLJ ԆcJUB)UT6*\#45ej U7Pd4RAwxS;FJITsDjŒnfJHOxTN|a5(TmWbJD7ߚ>K0/$ 8v[XR@HU(JO!CFv`'3\e R&(`)J"aB+JH2QTi ȤY1%  avjXE0E!j* XԦ` `W@h% 1?& ȼ@T0|d l}~slFTN>}? KfTTTim"0bV"J[Z j" - 2 $ 'Y :fc_㵊 !Pk,-()EE#-)K(0~> #Kb+6sWK~4TVzjf #W(ң L/ G4]Dn0r H"2_+hV-U395`mVT"% F1$z-Z<2(i(FJJP 6CdD\.QfSk\p!XI#lڬL$k7M0Ӛ. fοl% O`xihJA|aEB?A~N ?5@yp{vG^ ?<#eH©?Hղb"aUCA 8ib$5d"91 >;-a2r i&IH%@$Z(Lp{C " ҡG2d|!_okݼfd6f4/$d =O۩3a+taӉ<ݰ^..6nHt/빑*ox|$ЋIqN8ylM]K)L 2d"` dL&FS52$%S!JLfcTU!QMBAR0d L!bZTh@$ע>3>J*$=GuÓGs֋r %Y^n9]LG.r('~S{ vYٝ|{N"1"֠t$ֵ@84Js=IF $Ǎm'Rz˺:a~ ^ve0?& ԐDvP PA ! &X&`M|I<{&&`*&Hb)(Sm-hRh.ªp5(^$EE&( 1C#Gxu/S Cr_\^D<}1ў#ߍn ()iDL>'O9z徧&2ݢKhkt]W-dQ䩼(66d(Tf `%PQ;z?0:@:lPCdÑ>a?*'|@~mV[@XZ79/-~4χ=f`D}rv!s`~7Y`3zU W[܉3*T7tHu&r8')ױ %=>/ƒH} ԹPLJQT'  b^w"JL:{L2 0_~KV5,U&%EMŭuM*(=i,/!x0<օ8" FE]*+a;&=W~WK#H2;/hNcJOZy1oZii!9c^o}gɟr?x!c!Oh0)N|(ЙT4fQm3k H~VAI lRॄ`@򇶡 )VV# zy)Yf~8 hX|Y dkaFmn7XjJDIE>?=ղ#F l$ "J"q1V lF0`V ʯw|kYFN 6M_?|Har'G]fni< "6F5DjxBF5ȱbݼ1ԎDTA0S $ES`a -],fLCIIbPR""V҂ZBX*˼{D\Xh*Gjr-"JrThXd&UbKh%a))EȻsv1I"A P4EQ1PـeA4܎M#ub- `,(2"$Ŭ"1ATL52JD0LJA1BP4B1 - -  )HF,"1(B)Q kdĢ)QjM$1 (!E1C1 kLjh&*d1ɩfeThJ DfbfiF,bh`H!ZI Y5IAN(5 HWX=M_=dEfg38&fd9f[[lDf6 0:^nWJ m[f< l9^޶M t.58) fi}谪!ŁVHI1( &hR[($x\300,&UjJ27\ 4ɽ #vPMax2%ѴY#D14I, [[0™SU"f Q<2ZD6ah $ FJQ7Ҫ0Y@iﵗolK#pc2lDcMŒ݅n7ɷnX<;&4]]|4/rSK[cR+qq2 6tSsC23utޕ4uh4nɹ%Gw΃1@2PxHی (ԭȦN@桐&'5i[j bئQS1%%4EmdXՖ!֔Hi:\^RSRjFx uJʪH>4 f`) hc^8h~:Ny%B 08!H SzE4hV kF8 5 :CB3 caqM#32s&HR]upN] PЊ6=lNq"ц !ĊR)r BH;~N)=O0OZkR; :[T+*eWjmCs)_ w0#mo1ѷ`qG [̶7Y61AGtj[P9xL_F=8x0.6-YYwCxGb:s m4m3l88%Epp1Kh.D s"XU;@僤R*9 6|6.qG`@9͟Hc_4Thѐ@:t!q|l{xEhK$،f245&GǝQ8^4e1B!,3(J%!1ӌ6JX!ҴA%d̸Q*T),I%)Ȧ()TY1v`SL,,I ́Ƃ84D`-M h& Yj5.D]A8"@\SfTrʩr|+ϵyr~~rld('Ňf2"R(pƢq47 6Hh̊$cdMR:l~]_ /VPZJD8''Z`If . l)~0F%EO~}7˘|9g|`0D$@PPZP M51)O1hMHRːaLLvbI]ӭ8l4BZT5wpH7-nPd491A/))Y=:TSD5~O0A: ]#$w8z_6RW^fEHCHD2l4y~$nqP|F\CH>|p=D9f;B w0*!#% a0b r ݃L_a9TZXrs# Ch_DZܓ uNهZ(PreDaD$?w0•'힕&=-#]F8DiyrCRl `wc$PB3Q26RP)% .J=}ҧiOc?wܛ+5Vʗ`8YL%'M8LIDw]~Odb܇XtSf`[5DhwpGHb]ֱ((+Ey$D1Htz S/)S2v-S RB'LꎯRܟЪm‰A? %џh{Mo`ێShŪRI()) TCzw ~&# B!J?| j&BKh)Bhfc{[ 3乪!y)`X~C@&A7p^*$) i)C¼{kxG!,ɸ'_9}s$EM:C$HXU` I b.2 XHA0&>R:.Q-B ̥2BJnp<="0*v̽>#7ʍcDqGEeLd0&@$dBL0:haDAALPQGRaX#01C%iA$VrA;G솕9PPqm ԍAR?t҉`w| #+2$ $!.B22&$pi(*Z߈bL9 LL4&Ә˙!B4 D1DF 4LSPC>ZXc{t_4$^y H%vp61!$c33his0\B@4E#)f %""IL0&PQ"R RH h`H\h*"A( 0JB@h P&(R" "9)@D(QLM5AEF(I%!DMDL4QUS$DA4HPD D3RSQL* F  (-*88RE.H(8bIH<7 8lCwk 3BDaDL(P*ppoA܄)Q;=|]:D?m )Ntw{!T9Wp!u'<{J (hQi i)Q)IP6#'n􏕽XC>GΔ X'Ш}W4)#p@sa8(?}P sr*YjXPkdDmia&E9(ҁ@ D SJ,.F2.bT"(J6bJ2%S2M$Ek3 \j$f!2XBZ5V(ۉL% PLrrrT"$ZLr%),q"iDXp G F%SQ(Ye "8&! A e VAh6'i^ʁȏAxQ"0^;ʉKryVI+ɜuo[5nNV{$m0o'Hs)ޚc&ҟS4uNuŰN tO2 ړv2ؕ;i|-F12g1U[[0QOL^*1Uv b~]mqwn^%a*^V1Pd\j?C8,+n4"p$链9S}*1oi$hI[[8,Y\zgL*&!sT;1-[Ɠku2U\]pa_Ki[YqN9QzT'c|jfr.&ZP#ż?y5bQǵX1 Y +0S:^+­=JN9ž&q^5XfֻNU0$3KuDι]rӚf?T;%*s dѩIĖ3r 1S29)L?wC"k6Do )741ʅdVE$:e?83ewLq .W r0\7Ji6U7Xrw]Y6z0pT˺.D|bWyXJT> mlYrq2}vϦ)ٗwgz$!rآO1hj! L5񆵒!6 ǎםG }K\ۭ/;};[w(|P(͌j YvgRǓ XݙR#+HzA1Zy!7e O93tʱ9P\ PQv2aVVip'xvɉ @NBG'Og})ǹϸ4jitIDF5b"b6uisPۼTcG:b=(5}Ii5lTc3T!9Ե6$h3!W $V/#͚`#[cF"ң- סN&#-Iŕ%&kGIK^y2$6x`U07\k`n v<טȈŪWQ->ga*aԺ1OxS]`((6NSru9PO9 FD۩Q0T+2aЌ'! #;]ˮ5o:>)YQZR:bP3M! ]0EB@LY.knoD=Cnfw)'d)b1CkЍ>"% \z fMU8bdR)W0e"7)•j6U:+Pؙ3w().2M(IӦqp_QU0wkge+(8R%KayZ smalE, LιʃQwPG2{D)& j4'& DK=XıX%MNưr&g0I[z ͒md` Y;$jO5.tolj|X=ZCL 8ӔХF%*b :ԣh$ZhMeQլ+[1iܨ6c4HE*4HrakJ1ͽ$)YI1.[f45 b_XBZ1q Y}P'l .$TVh`‚\NP&+mt6v Fۆd`x\v5mM&ZjN/gƭugSZ2'tlV2^ {:$A.b׮h,:35%]_c|\&cr[]Oԣ--C:\etp8: { N(q4Ɛb-7CfhN#b03x]-/}3Sr4&46gDsH5 m/G{[LNLJ! ]C%{9 3 pS^G1_&qd;}c-H6UVT  -6V8kFǃ˚68RܵMU $ۖˑGUH|Z 2GL$h+2ݰݎFV"˸0fv4 8 *2N9!yXOfɢ{i2Cv0jszD4 M;CywfQN2o7GN"26Y$~EٔS.*0;󅖇w=J+홴n]Cq0t.;O3:1NDNwMi|:q#f5E%9$\-"kIj]njZ=NF3Du؋310"* l&NZMtjpf ;xUUo5i흇Zk \ vnN_x׼]?YFӌ^Y['ͪo{35bPزyP'v~!F0|2qޖuK8-aO.vи~=n#Uq,/9sQTͺKz曟\4wK39X/BssK5k$u.i-Sw^}oy;W|v}1WQюt(OTA bW 򨧢wzվJtN$[LԈk{O/lIiSX[K񋗬b}3‡uRǵan$ZQ]?|_ +|װa34Y@nZ|s9ԔSGs{;b16/L$i 'N yوSvqxMw늂ş;75ó t {'ؽB?{Apc??G.Y4E%Rl^s8G&{e2]9w1?LlڞVދM1.4fTGclȺwt? '|#9}b(UXC 1i?[=> :W:RVuB){qOu%2 B UGHm6$vjOH?4b1wwA,I p>>O+"}sf?_ %}6RH$)tk*_vh Pg !z۔ekO29U ~ )􃂮05O/+6]}֟ uJÅ4; A*\wd$-btc8P?u)>?FX"<ݣ %`7Ǟ)ߘ ҟׁQ&'. xcэVe3{oM8#8L5q!Ả W&#Ì3 oW$1dSD0]&1{ IRLbb/&c޸ 7qhnP&,sA 6bt@Ns1oZPngC'{&VL{Rb*Co^ɝ=zlƗ[RhtQYiŴAie9N\M۳Ja ;?iD CDcc@c0;g㑼̶flᲚ]&su+; T1C=Eۯ2p@ xh2psv1f(Iˀ@5eH* TNk+!;uJ& Rf& j'T=9z^M")r@QLo|P+ucϭ`O|FwC!=)B'<";# )Ah,%ƈb@ioSn T=g "^+g֭ ROF<^ 5;YFL޵+@J'-#J\f }*m~հƚcfP "Q]CcD5]p:}?A&~]  jv Q 0RC!_qAP_0HJJ$B#@ڊa! PSGxOrv8PXnRyiz&`t{?p=C9je$G`Y RdX ~}g?0u \oW"NI}*OhH)*Fe ԡ#?2D0NUWP2*0v&~?/TޯX]gjp R_g ;OPG:/=  mV˿aV> 3:iB_€_f,rEFs)U6E~gJ02±4x #RIu~0_G /8fr`َ; Y$*i#:;\ Pi5ՅUi: * j*g%1BZ"Z"hœ*`CL^ITz. }엙5"Q{ Ɣdڪ ()H"#)׾P|[MѝKXpoMpPJ C8iE6)} 4O GHBGjԝ0 $4S; th==}Ng랬Ħ}YMM)Tŭlh$ d3-> pd-wwta%C0)(Ez`N ;OH5@:aR"{T9I BZ+"i҄-d!'f8~Ẻ $vT.ĆM&Z}s˕&Ʌ n@| h %a(<B/|t@7"&;R;h`n zXCv 8ᛒ>AF+5#Oy(r$e<gnn m>5kwޡ:J&Q,L Z[Kk[)DeJX%6K$%J(U+f8cĐCJ D4bb*i Hd( Py>}HkdbA~CC5{ 03 T`3)Q-i'I-faD0 (95V.I^blJ5ǠypUw+j!P44#3 \dkP֓piW{?_Ҟ>를jHabJMFahqpܠIeDC,/%:p ;H8ۈRfM-I(z!!mux5Dz@jGr 4w= YWT`!z:s;u:y=`ܛ}ξ|Zy>O០Cw=o!:/ݮ`}U?i@ 8ݫ)C#"!(| JE#"٬DS9vߧTgzϵڢ-)Zm"$LIZ Y-[a0((`[)nW;&eY(j԰wK5BsRi=X0oW <*7dܠ2άwe0҆!.pU:L|>S?uNP96]#Q=/IwTFM-A>gJfmEi_P q ;qN=v:f%j,G {:eAΠ16mddXm"rȍ33(<L"A5@WwRK\rQ" YtDǂ+₼.hlqv!RXS6S07e0g W2¬(ڀ2c͗y dt13DwRTx"BS{^;a;!6iE:+K=|Ʃy9)uÚ]5BM9` lї8M:fpށCx. Adn\k`tK`Ԡ!i!Q"eDݤD/* b&**rՅsAB[Cv#JrjqC:66Gg-35`0HxMnarlXbHnCU)8! "fD7wm 6&̦WdCfFLd.!&EQ6IL֚#gIzTmHuN ra rY$5 DT~2N\m(\͒>~7ׯ=3Ac ŵak%ӱXc Ax7ʃD%â3~V5mڊ#f^Q$m }&5ܼ#:}$&fvӰ &u"zL)"mFnsf9T!w~:ȶ顉n9asMJ63T+LiѮjkw/h"3/!(I\CV+3Us#8WҺ_/h lm$fJk׉&tǣck3ϋl`E=Mj.oڄj1(Lxrda*A&eMqSaL9$]0Na[\2 <Y:,N(%,ZoL(3UYynX1=!%g C:yKlrbc 5Q";ňyc<$! &Kc4ڧi\h:KWf$7GV #!\s pJ8LjiEZNY+B)jGñ{\>n\f,8I6)#I&Zm͎%xrfZr&fR=:삢I{X^sN\3f%U ,ն2p Gч/DvWO\/89 ;h"!6%ZOyE4{Gx5%Z'j-;n$iE "tK^`q0%KΐBpv ɤ-u, 11@BVՔ(kX!2Jzu`ZF)P^ c ِͪ8X TJSeQ;1)c5k!5s{J (605}P)e`ziAҙ3Qz&J aMYYiho!obqĐIA&.8 dF * *d /wwla@:w#6A]m1A喽ݴu{LTg.Tه<gd皲udW=U9-m!,Z/ IIJؗH(;:o69ùFtᓎ!V\#ѷS@ ! .yX.2kJYd>RBL(x!aŵx'Iƴk4 suX(#xtca0Ӿ,H`iLâӾ D|g-Ap$בcbv $Zv)o2:I-8VÛz͙4淸c79Gaӵ4o[+ lU FݪBf{=e̹߳s4p ,r !yY1R)\j,W$ca8&{3+y M./iΦ~%LP9L;1- H sӎ<%6 )g5K A0h;X2FIkeN )q fkF[(fQ FpԱTDKh`#JI&Ѯ$(䏶oY ZtRK?w\)$>4|bQM̲.AbF]5+nFp3}G 7f;-RsT?96ǂ)1p &클@Ar~8mf{i|w9 $ ]Fd$N%6cUYXPYn#{zt֢0'\CL$KY!l*HvZFL\aAx0); 0=KhNXNqs6N " Ġ SGFH B8#D׃l ;Y*`"v QE~TPhP, @!?owLCP͙S Y"f HEn2”T#|Gw*@H  QKAQQQO#d$G|a===xQ0Lj˱yC@V^p#;7:Nua4QR`269cT4"%&xdS㦅P#)7.G%C2n4a"L wΉ\N0KaXlSD4a4>mcъÑ,c͢3-HW$V8\ aU"q!!5'A.ZW1!sH%5IJAHJNΑŷcLQ 0@a@d%>IAy[3ד^q%9q%&vV-!Rl3SNMZ8;+Eiс'$=a<O*#kڮX3vf4A.vGB!NK>F{>g᝕MMwǟfNC:IbKC+Ѝ )[b삸#Wp[LYC9/m!Yj 9D3+Pؚag::c9/ '09sYBD|${|_||a'OXk3tZRFL&CIl [HA]ֻIǸ]du}?^_|ʞ\52xE; C4=Q:~Ո9;Lֆ~N*@k7Q:۱9zC7&պwga9L/9Aq0Q-u!' m)xvn_oٛϲ:jMfÚf>W7Ml$F:꼈U"&ay',{2tΡ `IӤ( E)Ti6VK[r%ljQF)\1 Z4H.\4:R!Y] ,R)`JˆPRe 1HX" 3%201q 2I*YKS "1M&!dAp`+]86.pLfdYb[`Z DQR(Z4 hf.#ц.V•BԉT¡MfX݆R7\Y#vr 3,ec)1UaV *R`P.$ըE$Ejw)-A!dLqj#6INFZwj2G,UCYm E12et! Ѻc+DDXb&*[ueb*V7nF(VT31TDM%p Ɇ\b1QfRAB*:amђ"lDԵr\ UQF8 1@&W%qf5Z@C8 =)ւ<)@Rԥ5$P`*!Y:g\)R($"bhDw ,*XՅD(vƈjIXZDh (fB BB{B)f'~,/BCSփ =Qvfx,cB~ı7bq~]ȕOc6oq8 ޹U|G? zCWPyIr{t$s;_~Wu7^Fl5uTQ; 8B]רftzIr"܊VfcT`pN(Fi/ErjɅΧYmE-8T(;M[$hUfefDpڮ٘CLsVڕU, E73ʇm3&Hr?ΚLPԐRduUTFPʥ'ALdXa %WLm3١=9%80Zsʷ}j7thK!>)Pۃ+qg!#Nin 0@(!b[m ( ދAKHhљ> fBHz-,QGwU(4<tCqYqQ2F)b 3.B:ߦ)wTRBz3LG6܍%θ؆tzi+`HLN-lclFrP0 ЈjFc3sY1g%Z 1rML*5bFFDD<9&XG2zqȐ Ċh*]I 2Yh b؈;.XK!PLNr' G>F hTZ3Bʒ!Y Q.riFq WڏN-X|_>Z) Ij&!d<)`$Q%$ 06MhpT#f@RhA)aQBbH@(l25ua&UX{9pLvLl4i 3QCX"d hui>)~vx.*CE~V)c"3Pv"xCǶ P*(F { >NT¨wEp YAA|1ud=0`j((*)сLE}%A*>47(Ԛ @twnva`I>\ NS_/a4EJLPUTQU;b% UCbPTMqPR#Ȁnn{(*Jp>$>!ߊ=VB UB%r30ޠ?$l?3 HÐ5͑q LM@Kpc 0MUCٽ$P^0Q1O:3ssssa*M^^Mt6B[!үHW@%h &B4fIaxbP)b kr@ !XLȈԦБJĽQ=xf͋:KրR/L0yO.m#@4$a퐌ߠ]:OChQ6C䅢ć!Z"/KUb8a\`TR<`B@xS ?xLL%RHDEO8P"hpp <_HUȕ} (!0 Ir~J; ܋>F+jC `&I?U6\ xmTQ;Ild"l]҄*f]0+U.)` ,.D- AnU"K`j֡l dh"իKL&ШeB"F:X &@d x`e(?92q у7lT*b~Xi D p\5A*n05xz`ĂDbC=:%HWqg4Fx&g?ul9m,V2Ej,f'] I;CN# KEOg8[j"h~rh)!sO͡w~sճoq2ifH!Tg~%*w~P4QD dOsO^K}+ txsiOZFq1'"fەשH_3*mPjXwhK`StI:c7keyIX;J*z)Vp4ЃmPe`g++$#Z( ~u")QfCu_ߌKO> (yi=1 ^Z1"-;lqIQKwrk|ҴP apGի6AiTwST1"{ M-vv*f,W.LiWcQ|XIjC4o#I:rH$Ap>|8&K7 SgXC,1 :ИyiShl/~Wr}ʔ> =u&Q"A)eFF1 1,!m!([,*Z 1JeD˄YSPa!pO P0wVNVJ.I]KDڃ:cBГq Q{A.ySʦId2}݅xsC۫ۢ)*`:SJKX=-؄5:vt|<)8?:/W3G>a?$x}0>c@G +T(\aiܼ !M#}CSN/KD6᡻)*$hJ *R BHJi&`j!!JX(f!hd$m>'+0J8~?w4WאAdZI7NC -Q/brÈBd2L۹ LiCśw3HKliO.͍f;QcÄL ;bX5Mg\Om5euD ޼ 6kBFJ[H0U(۬.T!]FM2ݙXE"$.MhҤ e4 "th -"0s McRAAAf.ovJhFB,ꔟ3Z "~Z" Of:`2 QDvB)wK&ΝuӖ滴Ō`RT&d0"*bW)Ee"CݨFL&9U%%2MZ+Z%MҰ]"/dN )d+1 @ BC1 lmҲ ,6La*ZZ3I%mK+#}jS` &W +8pֳO}BP? /U`5WƇ fbexI FUGl2kTUm;e$N,$ R3+E5(NC7'q)D&lvP x u]TF:=9U7#FqwH?J`Z_L#L3EIF۸XͺPV*Oc At.6k>[$^nsESz@,0 < |ogQ'W"NPxF J@ ;e с}t3Is ww'RNKv=n3(BR )BB{ 8 %DLT8}8=wYݒѹ<8.<>52x=gfQx1LnAXA_~~L5c2L',)yU׆:fWru9r ]WBbjDLR2C4M9OV^M MӦGх*؇<7%l6M0umuig`{Ed6 &w< x/8P BS1Lwt鮏9*"L}gMACs(4I`%8dYvCNk/n: .uiQym)r¨8i(h H{Ra,F(uȉNlj]MGT1љfQdG,ݬd4 \er-g 9mfH@`Zk YŜHqDZXaHL8 ҆ɣ!G`w]o(ђэc2ZԒ+)Vc NH,h l0kCTbo/YpETIaX *ڐ!@Ks10)JLL"0%pJP\FJ 6[knF HRe L8ߑ;Hu@6/+xv521b8eo9l mW.Hl+M%7kFn hwi9#3,Na2ix-HjZT1AÂt6EB N`qF]qŲrtpthj*n6zmCQˏFӳ9ERV!rD;E ܔ/] x}L 5&M@J tGXrÉ4NAо]HY~ceE];/#vHT8SyfH>'T xګ'Pw`1&M'C>(HA T RJ:.=fl&ZwC) *{⑱S)h T"L;=D NcD"v<#TiW .ət̒3$f_jUTM2UDqi͏l @|ɳ ߊ@ep(s9#G C/U| %" HB *#B0PJʃ`"D9*f4d)KyL P"tBMb1d? Zi "坑M2T l?wI 9ރ%GãHF hHH:5("IH(TԭӄisF!q)&M8![ưFee3e&(CJplӚ(Y C4О ^YF՚'*C4N# Iєr8ٻ!JUr-6"!#2 I2q!LP5;Ƀ#]FQI* BhԜ2Dlr_2ALSLTıP^$"7[ Q?G"۟ }%)(ɐt2jt|$On}"(E@~0efR$JiZPD\A! epU2Q) R*J)))*!df+"ZhӬbQexφ>{ɚBCN|ߎwi@G+(h$^a4AI1 j D A@\k$k*EW*B&`sӥN; |@cf `?V=eѓ}5ߜ<;0`7OwCF^o,WeQ>3V_2MKòB>YDa4]S6c1Rd3eԃoN2pSO_c֧^gWprlnH JAs*Umg HBϣ$TO E.(*5"[y%sV+m3vM v:6li{t6]VQ9][bϩՖ“z:x}AYM Z01x3 vMJJ|MNa $h3 -ZB# R-Xj IbҖQdeպTM20;330ϓ}(v\i`K@ xΡw4OSdDdx$Qo '3, pqYN @m:bC𵃉uu <kw4_pWaMZ$/[g<2qǴ\ W }&8ӝf~Ϫ~w֙l+ϭ`3<㎙ͥbnFE9&p֚4Ƿ}_bUÛZx4|ddtf5[7#! OCLܹhlxJT_e^Fj3OMQۆW5`EQz3ӈaW@ƀ3Mlk{hl3j*] 9;nޔzYJ_} G\btW= Z5 6ș$&2'E"I+ԤX᝭-cxdF*bRC,oxxT&{6.ڶzW]=kw>szds%W+j.„p\=lh53?iDR6Tn3D.F Bˡ^^t_b}~zkVah_rWkC bnT1tW#NnIݞR5AV{LwIԂ' Ϝ;(+</3NrÊӬL]z:HaȼC TgBHd䐙7LŞf~V3k6c׌Uay_ʛ/:B(v4-wʪi <$ b(a(Kv>RsO? G?Q__e5ài4}I{4ϙx=}sꪣ_>3Z{Jsvx;}|ϼK^4˩sSvwkwJ彮j뤅zzm{>5}}y:Aꏾ>:@{zw-o{'@f h`ӭNNA OJ``(9(NCvGlt4><>}ǃR[}@뫂R ёwځ]|=@7`nmW]|=哏V} bU-Nvk@z>v Z*$U I Qk# E*$$E57fM-k%P5Kk4pPk[ҕ,}W:mwޫ>DiOa{z>&|X{\>;݇w+:}/><=6P,SM[ưwEv}ϫcqzΟvy|rZR^.kznnu7m{:E4yҁ XwLZoZsj}vcn im [jGhv5X.uۊVQI'q٬X&v6U}NVtv ;m׻arnWo{lfJ(=lX<: ]@'u%U퀒P/LUZ ڂBwqJU=*xOk0DZiyC%AJ_GTuZ\ŠśۻMӚI=c e#l {6!U7.#BQ:s<={CGFÓ4m]v ˔NFUw N=pF^z@O}Së܊D:IsT^ۦ2 ^;{ZF{Ny;3VNY-4;]wtn$;9AP\\$dK`kz뺶*wnN맻Eێ4 e+͒gs`AzofNPP .!TkFVf̽74qٵ≤rc)(`upD@{hѐ(@-;q6 J 95w{l^{׻΁^7`-uSU'VM5è[%cL"|*WRp뽍N6B g!;K;=Xk.A@Wr'fp֤T5un4˷l!UsuP(Zӻ,]l.ok` } `:1y/_|/fV~٩CaF Fj.46g]':ixT$5ȉDD5;Ibbd eai` W8 6'3l58PvY(Co%5 \,!^KD$f bcAy|'UVI<(m~7{9‚@A=x(Bxߘ L 1`b6/yaЃ<ЏxNe~OPr ]PkwQ5#|_9ߦq!QJDN}_?~|y x{wx^ v}8"!q[8Glh8'=M*@Lxn& ˤUw"|B*}D <l|f*P@(9 ۡ; +@ @}~=Sz%4 рO8N GgX<!<~L7Yƨ\2NVbW\$<=KCv ( s+qQ v˷˜Niwہd Id @(SßMS(r~z O@M3v Ko4M>玛=oQb@HJ Ԃ" B!*""C*f%AHeDe   D8{9( pDx¨`(j (bET\?^7^ElEeA(IJU<BP"RҪ~3̚D)]r]@ ?9RRt/e8כh iNR//Q R" h܂< l H]|H)q*]~(t?g@n`b*(;;V-F';a쟕N /K{[B'b^$fMڍY@Fk[&Q,Dǎ-RKꔣ4ï䈭7+V>'lc4̓׽#_ҍ{{%wכҺ01pمEM*\gܚ^[SvW_F xF-41̚F!RtiS4cX)֨|kfc4`+bc*LXӆ)*Ƣ*Zm͖# C=$8kwYpbF{uu9eb`ӒJ(,m_ U䋍DR)p-5 6!Kͥ"hΐuB1iq 㦤koOoiL;DhU"Z=35݃Tf(0wO^Jhb W0b >R)h7yvQ#Z(V}/&Zv*0/ڏ_`=SURMSAi]8p"TMTI ]Ê!IȾz AdY F*|ݻ^QjiQ`25C}>\;vvLQQsB{읎7QGar.Dh+2'Ձ(řmy{y9̧ >?8v4hIRkѢ6O6L!<(tͺd)l.᥷Uu)i"Nc%9Nl-q% %3iƔR[wV \Dm$/niҝV4,*ybPm=竕b=lFǶL\4Kj+>}/m#-ڕ7"G=[Go|<6̣}v鰓M\':zo~H+cڷ5D&R(ѐ՟IX?w"QQ8D-y⎓ӚzRtCqTUVn)~1 䅢(2f{-7@w6|v;ϋ$#d 1xb mY֮~l?70b9aR&XZ"TuUDP~^fe9O<|Z͸nB\'3tu\mqa:7{M*o mϊef_v&6Ʉ~~Zӷ5Q6耎 &b8:grLup wӇTAۉ%4~Uz_Vy phY NPBsJ 2G2wa~)5>pL_h82喩4˓;w)vsG\)sfgx'ej}GxfƙS֧mDlmJÒO}zdžt5=eywFS0%ӉwG(+%'WʰEmX$tɣWI5SNygtn՛asK !KUm϶mk{ƏpP>/Ԛ?]+C8V^//m\hoOpK@}eL#MT  ?==HOJHs9: hH[{41|):3R{qv 뻁0rqA- S=+Tz Q\bZđƺRWJy^}mҵu'uQ βGғN Ե%4IJ XM&_wbPP&] U}ͽ qa)1bɜC?n:pp?{zX {8cbLY a3TU4ŬsSv2L)s7'Re)G=έ)Н3d`T| ru~n`|oGocci#;w{'o0lAux>,n=Bﳷ8a <1PFweY^ȤR/S^Zu&]ML;&{Gu:hAtvz"~%8Z?+Aϓߎ]9;OX?QV1S molСL=FMbV1G=_g $#WbsYR@z2Q!T9f,a~<[:SMb:TW RRv;Qs JbUD(C+9G5v#(bTu444Ύu]xQY7V7"W=uITMS',t6"dc!JWz6x!H Jӫ=Upn9v Tdy(tres׳gN ?,&1Os5s1mofԋ4ưV(tbRw2Zyo͞^\:48!!8+<(i_vMsLSSh-ۈk5K_ P{ğcF j",tgJIM@;@iVy$Z\a6GQS>Ap)4i/dSgzU)aQJy{ٴÌ\QɄV* "b輡t<}Nt@gљ!fi b#-NheQɼ߀1raF iYͦY$-qw#܆Isʋ g .+Dۋ7@$KàSʦTK٢Gdd~pF@r~^?UW澐X>'Sr1**nzun˲Y5HȒ^^pϽp#b^(mFͦГq[|Mhtx ;rvuWC2{/oaְYe~;;_R&qoj0ƚn =~wo} j饋eي g7l8`fZL23F 6%)*D`\1i:>bm9SP[Դa-a]z[`;a 6\nĿd;hvwɄøːb!ޓ:c޲$7FQc)OVN5K+OEz%JIG6 XI0ϛ֟8f[:(& 8N1DHClA@4zQ ϯ$Wϋ-Z63n R0\ ?xqZ;y5.Ucp}==LNyM޴ L )aD\K1n\#8[,scûtiUN1DtnEX#ujd$%1͹M:L-^`PQ%\O.Z.D<{OE_ڣ)#D#G~lP<⑇EZMq[|T=.Q/o[HT$=pWs ݉f4o8-їx V ~sIuvM١%ZDS=\~6+u|P-#^}V>K7.$m]|({y<84#<0cϝ|>;S\1eF3 D.PmsJj뾻/Q|I$ьP(%3Y1 煛 ( Bw0-D+0idjDCMkDcZ|O=o+V/&kvݽTl^=u{I'(t%]Һy^ԡɖ6xf.GQ;BJi.+t^K2r= -t}(og{t78Y;${ygCЭtV_cYQ5:*0RKjr*r}the%M2yLnfIs>ܘtNnQǙێ 5D v7=j[hP$!:qԱlY}^p.%Be0w XGGkXf=N 5 +srB A$eT-e/KzG:1]T K“ۣ" #iS$~\[1]JTnKQ<R݈;[maۺy;72>& egv-= 8$tǎ.r(p (Ն{)q+!:m|ʑh`  bl&+BJBIAH+!0xȞEUgEK/FtP!h;'rQB;NpC`,s 7=5Jf_xq4siE4$j/NDa" PaX .qCZϓnM?DDEOnK-&ci} )==_ݿ߷m˞sJkE&~){1^6?vًVQ֡hLJ>aLz˓N sl\Z;}rɭvbt8&NӴ#Hge!h~g`v=<)x;u~wNmG,o +hE!Rj{XKҌQsq-hFA)Q:ttJ(Y:༛]4)% %G@ 4Ѕ"PE=$񌄣H "2$IZѣB$B(ErR"2w` HO\P(0DH*eihbaXaH%fD`?_!T^DD93K_?À)?:%BPP SERRTIQ5*- 54(4Р(IJP R" B"!T- QQ% SMQ1-RQDLE4)Q4D4RR@"P(+- *R #QR 4)K0$4H%RTʥ!AH#JĥRIEL@T-)@PE0SB@ЀQЀ#B)2P+J M P@Q0P"44BJP4 J%(DJ "!IBU( D@HD!E1 HH-2H@4(E$J)TPJ0!DEP HPDAI!D% $@CL*,Ą2 1(R 4BB-LPQ S BЋ@H@0QBR HA* B!0+P ADDPU H JK*IJLDI4$TM,JBS @,0#,( HRE@E2T $ *PEL (0BH@ H H 2B0RЩ (QHBQ*B#C21@(C$U@#%**R,PEC(%J $+0I*L@PR!JI%%D@!P@4*RR HBBOڐzP3A  L! H-#% 4L*0@̪ HAKM%$1P4KLR+|m@L2 M(P%I *B3 4B?=w l>t !Q!C("hl$(??~!FO3kc >/"bVa8p2Xhc㵩%CW/j$]̿fq$xij L'8NziJn8I&0@*m ?|APC1$"! ITd҄`?į?8~N@l\#>0I ^)SH"'? ~Q o"2:Me$ABb8! 4?x"/:"D/Z "_>` @Dؙ J- +BQ6=F IsA0Bj+O3smHaUO|!A~??_X//ݏ@zW~gO*mfOgueG$w߻ޯtN9نo$tS/`gŎ~o./} n^E΋?0ӟd\xZݺ^^8ilttGqks!?l965 * +ݒ`ՏNA9R%?;o;9FAN}[5 %ї"nΎZ{&ۙQFҫb׹y߼ssmvnjqEL9*0tF˨1f웴C #O4}e,oO4]1?ދtj󿻗nplͼ箨S>XhD O?`.ؒW{D 0? 9|kbk5֯b6zpziwUkO>>C6UKvmoqVbջhR\Q(:&6xwF\LtyjzHdًf,s{ @|3dwպ؟/-z0\'Ewyerb6hUU1bi+IÒ4,OY|stk-_ zmYɌ?&Od~v^Xboflb=ʓ9Vq;VKKYh@)ΥD JilSO|i|s⑂y 6 /TjWu@ .l7:.[l6_d3:7^m=GGd)g!i} n(:\Mn3Y{;ĥ/`櫊&B8G$J>bC$|&s vn&#7L,Ak >ʸF;]H`4 Nɸw loXlLXB+sˉcb׍LGhoW#DpC@4#Glb 9{B1QLxVO[xr wפ6> ;>ejuj׃@=nx6 GLON=JpW8e3x_m^D{;!,X~O>qb˩Zګn/~m[Ǒqz#'.cbÂ\Lc|b\]-7-xHAx3i 㣋LqlPPfz!'DŲJ[U^:|d' =D(-|so-Q\0v51WU|c>G}\rNw CPw'V`jaWl.Nٶ :i{ǃt @7qN(p+sVy8z (P aFN0p soloN #wawW՟Tqţ8 c?,|;sӗ>['>? ;pv+:2>7ut9Ca0x4F]5j駢-`-$PR qtc@9%fؤ$cm/wY;G-oR`>}EsUrB#2Q/_LZbfà<">Ztͥ^Fr?O.e+@˝:S{'VNHohΨ;yXכ}:yyYj %H.5(yz (໘SN_)ö(Am}J?ӳzo.}Z:9b/z[:Q]ï\c_~^͎J\}PtW:9Ӆ/8׬zV̀ ѷ=L]}/f>H8/h725SR.1W5zdK>L6yqywqy#4x0cƝ ssE rYxu3VZ..[,|rg-t13tGl)+,ˎ@*exJ8Etfۆ(xg`zk'c}c=ov=9^_L_#ͱd]zL^s֚˾ewϚg|~;u GztS~Ϻ sxMsvaG/Xvgnn'A5ё;9A^i9箮m˛a8B1 {ڄ_866er4t}Tgy:D!0"L#YC?x8p .D[.r"]um\ 9F@07$KBҁW?W{VV5~H&_4sSM@wwg)B&/ ܔV'l{4AFe,^>I'Go{>nh-};/Q'Gqe3/Cvq`dUzpc0w/oQ&sYs⟦Yg]k@llrlr};n7l}b/Q5=:HyzC1tѢup}%;O7uJGo>lw8vn;2G5&&^Wɣ-F_}iG #Luszѯ 23}|cOf47^pӺ+_?N[%G&l$b}j6mjf V*ɟ8D^.Nρ `Z"2' eb&Pdt/ߪg3Ƒ,O?DU^a@+0ZkZʳqtteZdΆ|:n=l/ɓ9o{(~h}"Ia-Cx3l ǗكdOx;.OufhJ;sui_L?&.(kSnLp@$][pI<4vm k =׃T'w9ۋ@,=' ey 97nW`1|lFnѠud:u=ݺ,["")5u;1MohK"Gw~jP;Z2r{דEu._ ~q@m6I1̽3ud(3.~[ eR_= Ke .[.m];6 齮۫Hz"ٻ7#evv}X\y~0fL7{<͏N],H9+ǁL^CXIӓ \у:$Y#9=?N& i}&:zY<6e0r[9R fl$ӝi3NZw4TP  QP6y׈}S36)ᦎXMPMN*exWfUi=xɍtnp䲼!бodW~krɇ?fC{fbu4`zޗZJk6.FxFpC r­:fn,vzeKT7t3>e_QOì1B?P>Г C$2C$9;E4y>!^@м +ąRS 0$ Ƞ8Νm1e܄Ȗa"ZCƹ .D>6:;34e?y4%Tlz8d9H" Ņf!Hit@](# kRA&4XU b}i9"n:@M (,3flt}.X3^n@Lt">{9axŸ7uö}uz8sy/se+>yaL;We|=֚`w&T{~F&=iWO Ze%IHgO tRL;-׷ ܝ>3`㏲N N܉E XGn\w;-˯ꃪY6'hVL[vꜱƏ y|_  B,?_؏1R))J+铬`ADCIC3"PD$@b$ДMPQcٖHD1 AH䦒 CXLQDD" "ma |~䏟ڶS~k{vάpʄH Ţ1ր*o|0hij(z}2n>;b1ȁ|~X !J/x3)AHlCrfL Vx@͑a2|$YBAsfX+  B4(R~~y~4eWA >j>sj <ȪP\>N_8?]0ϛߔ(ӱZyz2pN.:4<;> [Kd`d 62"c&E V23d1 ,]kY=3ӗ-[/WK咢&!/ћl__vPQzOcQ{FŖEuewIV ,n{5Rr7rug[&<| u NP^kOc G/ >M<1\cI:|>p9\td0WrF6׳zpCCI+sCO-z>0wҾY_~wo?W'D ܜY^ϫQc.6 spJbRRcQl)t2B~߯o5SF 3 ΙCH%2G\/qt~Ֆau Ou$~~)e$=r_۶_V6qcf|^7 Aػ{' L5K:s5j/nfA*{rGA|SI\S3n:ĶW-0>;.(8 "*8!CE#DQkR,F1ǶKuT(XK*ڭ( 2Tm[OH}8¶r{ 6v{\Ftv`ŷQL{lMy')4$Yq x..28p{_W( b.G/T3q8!y_hL=xIc'Y. 0CtvEH9b}!)\7n>Q!}B61u^߷:m ,RP3GH',Rx0\6Dь1\ h6NOP=4`<-FyXL%J6WJk*Fr$aηyW|ۏpr<q`||?7cϹ*J,<ˣz&Y:6N:̈ ?Ҿ;4rG/F|%gq8? bQA3" :e@ڱëäB^NW^l)_(4emG7 ZpoWD:H EeëHxcߓѐuy>.xe_m~w!ݛg_^Qnu}C]=eAۗL3M]+x3.e6 Xy "sp]Z9Ǯyzc8d@ }4uN3-& Q`FOOT;1{ķc?-_SC˺Zw+%v9R.A/Ⱥg%_8d6N.v}O;? 7=j|97[ $Lh%uHQ۶𘆁UvZHz䟭Rh|>DКz8 jr{; 4-d\ [P}\?+ur1x}J8 [kn+໶:4<3gx;b4s_t@k;Hz{yzwC◧H| $#啞w=Ow~-_ǁocLϫ˪?nh?p.ylph,v3nPb /E!/PDhH BdD#-f` :%=ܚqt> вɾ|YbϸP*)u1Q2G?f~_MC]4UUG]eRӖXA?@ `OP vF0G)]l0S!0R$K!$J,!+BHY((G/{N7{vp! :\G!šN?yFu?nJG3;%qD?7LF'8uN-b"؉wSl/{a/ʿ $ix 0.lYÞQWw_T( i2@I(O@˥̲O`S8j6Xy!ēIs;0Øtk3%T({XPDO .T@Fo r |6ΐ(q65cY<`(! !bт-R1l+F0BƑbi b1(9k8im1J1y@_%mB 4`EYxF7DX*B]'JyRScDU41X3GlPCtÒcA7ar8IDQ3,41L1B.'LRRvNÉ DݪH "(+6CmQ0Qԓ`61\X8-I2DA21)@Q S2$Ją14R{=$#^R'6عGٿR? ]x@ -6BgTDq9}ǜ/2aRZS&kmgM Bxq2BN= ܚX/5 9 wʧyBFlT@|>o TDnRpB4) v@c0jwT>o j )p sCԆ hY 1sw  9T(*Gk\} '(͓=:r8]nA|qz'"3t7% U\ ~H#j}Px 5ھOĊ]hS rm{E ]پ{u7~offa\cksʡ #2^_Z\I4"W-:!HyȆ6c 4wgw7詄"o*gq&~W0+=- 0Q i8l@MXx t+b#\۶BDDez}Mjl2\Waƨv% 1'a_ O̲iQ|ZT}Y0d8hX|Z]1jѮCŀD $?gyzY ! )m!IꓡtJnmכzûk4x?O䟈5s#!F g`0hgCgվ|3LrH*^=dmwzJ 4n?db Vs"$K`z&TUmL7u{B@-ܻ|_c>=5ppUPabxsqUOhDv#,L9e4{0 ƭ-Hl+:k1jZqgQƂ kLfJ֪1\8|%FJe۳Ϟ3ߤ] 'tL]"FR`-'yub U9ǙxH4\h:xgEl&2_xxΩ,\zOV$A:mp0.ŅQfYu~43l-(xHF,U raq)F@jk{klNoIyr@m2hi-IGz/f:Lv`[7lkE^Wxn7RbP8#p%hW sJb?*aYolb^sP n&bN+:A[ʕNj! )q |5D_}yTU`'([[d|qy\p1TXb$^VuKT.~޻Ц#wt ~#ֿ"&+{y[ H蟗A(Zrht BTֵݵCtF06uPQ X%a ΤX-0YXAK-toܘic~取\Xv-9ԣ"<'WRNDރA/Oi:n검MƤ?_+v nCk**ibN IL~)xc>szU=o)|V͌YPqDGl]EX;oX]zߧY  Qَ4͟(1wǣ0^H8f+[{:oE!ߩSj݋Ͱq7p;K-=Y2B,f9_]`9@,,9*a(Gn1Jb+ݫץ"R卷BF)}hW'VGoW^zmwJ-|PK{TKꊊz,&d㐬G;fL*Vq0 8$qM%gvSzHz ;e;16Q{bT f}[o[RrSmNIȝz\+V{J)bE"$S$8q37㵍BwGl3J6T!֓Y)|f*6$|q1/e©5'UDƇL|E#L/ף|w?/_oP;a 3yS}9ѵ FG{>[b8b1N h0f&фhMݶֽkE.9wFhA8%CdgCLCkIHAyl:T+/:֓y$O=}y(<{Hy$2ԘcvWdGviV9gKf6ľ}lω-aeټHkv[BK}#h8ӵ?o}✻[~kM-ӂZ밂mBL,%NhACwߒК{1!Xŝ[_7X^޼9 [.ӻϦ>~r8{О}ߦQLontL|G7)eU>v8iay$k S_O^S]@ئFaH" ܶWbo9Bα=*P:OQDbW#m_Lhz^=#p F#T׈ibpUsmxi Cb0pB:骺dl*: (N# 21jM:4tOIMf^cwng~_^l\ׁq6huz}>aGbw?lƑIɅ {تfS{!c6mmz8H/Oyxon t:,ӶKV^1)6h~!4nI(tq6_WR壁rm*,Dwm?m mLŽ?qyhoP u/P.b`|vSHR3XVHXd8D.X+@m6= <h7EՌ_/whW!O{;͂{ s+ a.t'/g?'{[kŬV2/EWǧla5ճTUO.(Z}a}&aΗr%` zTI(cwfуdT2Lnrz w<lcauv:3\gbX4M舕<^@th^*^w!jJ [PQ`!P»{K'9;4ԁ,hZN08ny̪PH+Hn!dt.*0%%3Eh23;|='vcM~?h9&?]smn_6O9Xx.vX$k!;h g}f!OaStF|S5s79l.ޡm$l!= } Lu:)Ԣ<veuڤa ^{x6x<\ŋC7de15Mk=1ve Pqh) U_zVe8Qm!Th'x&|b NC++I.07$ ɻڪ1.

Lua{׼~̢{m.Wm\[W{1(mЛMb2f'XlFlw۽F$e(&KxoZm ;›F=JZ` nX@.5f-3\|~=}vg'ݏónD}y׷?dA!b 丙=<>+g$s$9p%]=b ^ D C#*M9Ďu3z^rJ%*&ZS4 쟀d1\ۉ%7(./{]xRy-kRq/(\#U$||5gn|m95d9'lvnw O+>ԹfxK1܈>x[ln#zn 22)IkYC:틬f[9jb6p_n7{ىj-Kr> q~%btՆf)…(@jD F'ӓ'_]Jd0ٺ$ϴ?VX!UW}٢fh/c_Y涐G>&'RAr}{w&1 I䆹< }܈N;$-wcӎc7Etc"oD]Iڣ-C&Fxuz 3H :Ĉ= $3 hK36wfGv29cjxrGs!,h=OaM'0Z/(bwy]_8cr@#oWuga{= x ]~;`avkHffE% ]!+u_RgwryBUϒ<` r) 1o 8raD>=Xlzd/Ny?Xp'15zΞ}=`Fzs!w*uu<u uB323MA}:m d1\X VF/:uP!ڠP lx&7me>L~*?aujD݌ž64)mfLo!?7Q}c7Y{q(4s\>x:*2%t2svEq\;יfd=ʹ⢆IDдzʳu&ƫ`iI;k#y]MPυo:RnY &L 7MK7zكoP(WuA}q3i{3͹L$+1w7i ZafbjB4RSEMM4$S HPQ3RD,PA,44MDL4S+ST5MQP$ ! 2T4RL̐DDALE$ L 4 UAE r(}~cӤ-4%C9|*7j Tr%8PzΫ (Ǵ!sno874ybwNLD+wNTJ ٩ݓK0Њ "X 2JSV-䐎B4aNXȦtQ6عYv"YFdRC&˕9̒x0USq:4y; Iܞ +p9yvj:(ƪ TU(j<1N-.(Dd2:`As/|!Z~aCC[C ZG E$; 3x3 Yº,fŜ6to W_G϶?#'o~鸟=VF79.b4'e0ܳ<@411(4_k#/(``IF8nղ;4Lvڸf؁h<'gcv@N:gNzn\ o]Hj`H: jXꏽald 33yݺqn+an,t O>wo]>~֑.'Qq7ߒ`Ɣ{Co}u{8=^$AIyoMz.u6o*ȑ5&]跭x3cm 8Z4 0,+4?Qcfy7')Rc5v/O)U5VP8`Zb|r5PJVM|m1N@w5lD= ߈]lZ F}jI^+n·Gj͇шnnM4x*ܨ&gn2w|2* W/a9L#ZLC>6u!~5޴e37lˋyަoE҈=vsf{c/'vt-爴@iE%I6m|L G)+s 1! \[z<[~ܬ^2|;U;b+QlcҌ8 Zn+mZedЊles%<ƥxqG09&↳_Sj0%'כuS;tl֝8_{9mbd2ooe3d^X PJ'wѱw׌1Ve;!h-)EvXcWi3Hd8m>o~X( $An(Db*R0pl^Bc 7w0P+2*<BS &² 0?ewt&P=zeOUs6&3ƻi.2l&lQ 2DHiQR!r2ʪM:vw<{:<'i|/DqE.nM\jB SeAxDs dL(!kSLoMn/LEﵾ=j/Y9A I=LTL 3rX~|q &즸V#?cOA}sfәś|tq;Oz.f3RJOG:0ϨѡɎSYf \a,=t82L;2kϟVLvMHxβ?ss{^eUULQAUUW0L1au] CQIƙQkKG}X3)/<<TY-]&'>mxwͮݢݭοA}{ktB0,śYZOWC<)E>vGmü7e_ Ink7\ȉr3ν;Ѡ~ $ ~4̞n{z|y…`QhJ%҄Ι3&aHSN ͵3WWj@jf)ˈ -Ն ,%yWRIM^6pʉg rY^Fص5UXa*a[$WWJlF&"&^Q,7MI\FS[mDM 61L7¶z55ZZ;B HLc,b`Є"5*X֩Lb5I !Dzml%Yg ?\QLJb skmdFqĽұd/Yܛ^OUhX1ux;nfa~nt fR q't0u.}u^һ'&7MٷžB/Wo݆m;ޣCV6n2=|tCYRU R$,}!Kx}^%ѻe1Bi@F:m^ƸNG_eS!# ! ;q㊹ b.DfdO@<~ !A4Q2Y2S5Qɞ$mJs.F"8MEDѥp1EAs1e 5a~&l=e hx.GGsU{'C'Mk֜>sbow3ӽnL-S;1OI-f9T~ Ty)r!13y4kٻJ hT046hhHR:|}Mxs~pr3-A> m՗GvAoF;o(r9$|grە};9 /M0ILJHv_jv+rC@ $Wtd:;4`OƐ|J{Ëİ>q"z|4ɟ+x !^_u4e` GQ`:?bs;'pܦ46j~}K4lj#zxm]^Y3 ̀1{׍._5o˰9p/h!eKjbd~DL 42U0D  H&Ag穮oZ}Y_0r Bn,gM_cX:]~$m䷫BX9_e4D3TS$fsitͲ$L'-Y 7M]]Bd6Vk) nƕ`AAB$뷠կ+ըĻ:=ͪ#Psh_'vn`-Q~d qeZظu=,ֈ<)4$N˯7 V{{%uD>oɰ0>_CNo^ޜS5Ӌ3L!|&-?B6&Qu6tD % hu"_ D5"2 4y\-_ӌóo8|aCFڃ:8~N2 4z(y;圥}y9U TD -uK g65mqyAIEPR%D2o7v{绛 ӟtLh؍υO6M ܅Iϗڽ&EfN8ɀZYl%2 -fC:tfluث۟ML0{0GLd5= 鮾if &#w@ߕًP8iͤvtC[]ҌlWf^<3pa8=fs;{`n=#RM6ۃt֚cn&yvUu!S*é|RŞ c{-U9$})l )yWepo*bsxknCOvv6'O)iCo_};#Vۻ; w#zc鱮ZtbA8٤M1F/GkdžݏOWۣ9 &A]b8q߮vٶ|x'9+Zgs-ȡOo`:u~I鏆9^tI9szX՞<ٸ6f>o^_Go,AZ`%5nK3;pJQGxp|5;D|qzMHAtp8d.)yѝHNtcgҹѳ2l0Щ< C#)76eA@C#H*cr% EPʖ.)9T`F|`<{^yiHQzX"=L1ꇦcוvh3?u_Ep&-2:Odp]cV!V-4{.yK9}?Fo2L ]I6_5RR;?oo8sO! \Az(4DUbK5!:uZX/[bk1 XA30–=;_ǀzDO2/?i2ۉ[m\ffnB:r upAtۡ ݄ {q½Qc3(?HMm/cbF e$RV27ӯp=reD4O(:c8n!!w(<&7ݔ[Z!B{Q築ahȑ J)s֢!ATTQb*rW~qh6[{v/s$s2 90+oH۷/mr~)56?Ӈ~B8.z[fهmif6mCY}O[Øor=:УiHU[k= ab?ۇxg0]`qO#}fO[Vz[C>}آz,D 8Ak?Ǯ|z6_~VT+u~ޝ8Ho: ]dDLR:Q>G>g?b/}.D;xn EO!~z\Gs9$;#r|Kbr笗 K7}-=[_}7sF,X,1]H |^֏¼j`S9f"489:yr!qvv,{߱$sfOó][݃_Ÿm?V%?omT*N'@E!K8*CȂقi%tAEYnYK#irKYtk!u1SvO!MEi%3*y c]Ǎp@#4,8~Nփ -&ܙ:HtwnOA7tyAwnܨv|,eOGmsmKgt)A;;D0]1Uh$ ҟ$S3ҝC$2Z^d=19_P:LJ">}t%NmӒdo |ڎ;G0~b_=1muy`gGX;}Oj f~Wn[Xyb7Na2ÎI!돱`pUհU&xU\g, tݸ<[Qo6?+%?'_oSPCpiڦLg5; E=gewK/MA:p_|[jo=Snxwo>:1AهC$ Ů{}~\>{tQ߻GX_8E&fn_ o';wLϲ|:8"kc'cHb65ɲVoF9.eA@4e3FEl{[OPS$# ̼T_||@XN 8EJ%PAB=m6H,"~HsKY4e˷~x ĩ_;uۄAC7T~WggB:U´wŞ=flΙ۳@zmhM߉cDwMd-ElTC${Yc8"&w3Nr=d>w_&mv:g׿{z>6{MǬkGHب\sC,%=^"&'Tc7j궎 z=."(Ϝ(G:V#X[( H 6XtJ DK͋{H$P'Cה ?^;6;JD+jNǭߖfZm Or(/~ӓ'{!UkxwI70d~Ӷ;y0HZ@2K_9)+lMҐP)R$؆'eLJܫ1)8L$A#P}u?ms;tDJ * Z4̆ZJ L_6~C`m=xؑCx&edp[O:v' {iLf ֊D0pp5HJUCR\uD?Z?,(a -ԵolџOǺ~5WPQdO$ (.1bAH<6.dLlzin׾lrK+F$0Ɇ@]e nu@&V߅\{QHqb>֮%;vY/):rrkvLͶ"SjU8QoE ЛBou-nls~}Fm2u`Jmxg>;@rѕ>s1ky NXOi!ݝ"$ؗNа_U{wa龾l5b A0>Q2 'bc!lmP÷6\Dcc^ ʤ㬓>X94I`,Tf.1 ?^vRb”+壭ArBfcw ;NNȑ׳GuK>yfnf-_#-3r~S6S ΀:h1ck $UfݯQUPdQ7J %QE$؆Hw#;DcvF}'w-65_8{suP_v2c6>][oWNdsdE(uGiHo)~2Zpxv?F[Mʒ=BnN'BZfQY>!ګ-8Ec*ާ)GCED"wI<-Nff0q|x7wԤR. ɮzf0ٹx^wa,<suQ5b1Di%'9žc|{qyV%$O'FS$~oYbDZIOG=Rjw+!~OA!LG9_<> Ǧi>PܤSTNkaJ>J7}8ao 0e7'gaY:Q;jctLu)6j./y9G\'Ȯ\`^vr&M]j,:VSf!:z7KEL@0Ts2/AT߿j[ߊ? yTwBjN- ֈm.ø4m5z5o~nUj!ZXC"^Zl~QBy|Om8ݽN,ffn;$+S- [7M[InI]"OB۽>\G"c]ZCZS@lCOXBk3#9pL#0guG׆of뺦;>6#]Kbxkbg{鯺п n"]BG*]IB&i;[M7[aga}:I}P- tV)b I*Z)ƕ$7<=[cFJ"-8Rf מtr(S@kiA kP6hTL_:f!G1 ;&WilpSQ&f (m'^ Y5[Sͦ/f$K {!CE,RB!&f'BMD 6,<Jo{^0^g. (c535n+30q؂֔%rOCϜI}np&m fL:5ݮeܧGS:EYB=1nTgq-}4Vtw堺N\ b-&v˛7Y7d =~thMq2]^۞+md#}oUkx*k{>ӳykOrpMݱmw5Fz[yְtM\曎ޗ.{o۷+q9ޫИ}qGfo C; @)dJQfz'Dƹn#f"8 -<7Q6iaӽck}MQ4/\Y%07gnh uɎ ^ۄE@={p$Ŀʑ9#<.HD A% u(i!@&ȣQLˊij}jjiz;KI]MinkK], P߷;!Ea}C"7NrP7xlwǶrޚ 1GWOOZ=|xxl7}I.ʧ&z`e虌n[KOqlk /F=]b7Rߞcw_QXGr= ?R\mwW g:S'IߨT k&bY"@p۷ bσaھƹon$}n%̈́mwیql`VrN^Bdf gKD1WW%m)JƤ!?uJxy[n0q)dIF?p5D7'2pi h jCW=]$6@8ٶ4`MmaA=SۛxK@E|jJN˭|)Вuqבpq$Xv~~k?xN<[QWy:b疊>6f8V6?pW1H3c؄",Ӣ&>69Ġ&C9ϧhSܴ2-i5S$~xߴ2ohM}\%ML9~ -Dq~\I /:s}VkWˤOy> {'RXRI8Ϳ[P,0֞N\Nbڽ;lih)f_c8I_v^Nj׎c !D1:m8-{ӹ۶uZ/g &HL\[ǧ.>oЋIvF00E65) !@{ ;=a,w﯋8M}6z>OY9FB']n;˻T+9>g-d:ܜU:=sGyGClEʠ u@oa$!юE0CYfćozP믂pG f!9/EP&FۏS\əhґٸxFV 7(dz`>ajAM2RXGܹ~ zst`‰xߗctdovI9Z&gXǎ{4 y>1t;:Htvhpba:0`N:\5 yWKSD{e7⎨f J<RP]я=ٺ l,y;UL Gr vG[5;&@5?E;ywe||C+/ć# }s avwJ=͍9(4v}7:vY:dlvIB7Gtߧ$?H$G& `:umv_5̐<8M"Ë4D[Ǐh٥x4(ӹ*#Us'5!dܹE3vlo6KTt\Q>܁YZL/Lȁ!B,O]y8ώ;/B}7D82#]'J6AMA;qGUqEЂ8^}0%Ceb3 1- ]]ރ|~.g?|Sŝs>ik o9r{+a!8ݼn( H%|ͷ @)M<v05t+&8mxOfߣw2sƕk{O [];Btj7Rsi6Cڟnfwd:7)4xHr8Gʚ4OB δvep1FA|PZQx>LnԴ1' I S*VR1nwRT (`AVCaBL'|`@t= /Y]^ M/ ݚ7j/>͝.(o9}I;.t~K8ɿ~!qևn29_+z-AЄl0g\s;+nv :rYqp;~}@8 dj~x#O7۷PdnFaLrn/'OF !\D &qDXB+;^w6v?ųv=z/,p3\/Vl츎-v8wC>'P*jQ>aHy؏_ѱ}sof}l? wzqxl|*}K Az7>{NPLs&ckJAȮ biAH"km}sW(x\9xGh,}|3Sizۃ(E8k΂Z1n" ?Nέ&^S'rݸ܆|ŲWl7<Ʀ7<ƛr'YDghcmsˍdW-sQX-796U,'-gt2~UY n2̄fwmhQ}A=[ʌebb{dgUU#9dZ;/":˟ f=9V#ocs)-t/؃r&)mSmD!M& 3ǘuز6,!t]S`ڲ;6/Z\v!篚Ddn8N{NTטĴ;.")$%X~`ikhltncZ\mk 9q3*2>xx/.aN0eO+âaNylqb($zQݶXojt9FůYYVMM㋐"EԂ,*^7k6OQ-b_`i{:9Gq͚m*kؔWoELQVq5~z8KwUϥ+uEs4V(yx|ݵwFsk-}l7Np =70F(*"B P3JΒ ]Ч.;zD&;t*oӉg<~ ?r %[[1%m%#9c ^¹PZ=;ϣ\緍]$;t]D}*GϵGvh8CVACl<*3?J#X{qD"k=oxʈ2`w q#Fܵ>"wUY R]ZVz".tt/R>m}'ˡz{Hiχ<$麞3f}x`0# Ba5AƱӖ0.hrmvfâf<6xb&GÙȯ[H<;{8ɉS{cfƨ)3. 7*!['IINODzŏ;Qq4!rR:=6: نk-zX?w˻PwHX `AAú.!ŷxYAt!{VB;#`Gl6z8`0?(x?% 7v7e;ܹKeL"G WZ"Yȳ k-<^$:&PFJlMkkkco2g"7[_/opo׎zN,h 9D/(̢ j^ F6Ub@'[m7Bdsoۄ&6X؜)O}=~-DF;Yt[1.eRbMDzh8Lf_QqD"-+8'77͏4JP)I%S+w-0/V!1H?jwͶͿpkhG=`)4Bʰ@׫\S$krA7yQt!7gK;fg$FE;rj;Uws/^0"VbvNp kt쐿TWߣ!go^ɫVRX|CiMYa@8ka< |ٰScdsyܐuƉU6[ 5l-2lm䕳1?~FL}>zvDZ\fS\H㋞*-H-d8{W;+fx/;鱴زM5in/{xUkYȟ"A[11X$וo?$.Zs>$仺b:,7Z¢?Q n,E>C SI0!M"U  6(P&JUib ($ VB) Aj((ZZJP5e)"e"V`B&R"!!))iBPh(F"RP(bi$H(@ iF)B$fU )JG@*% ZZZ. i(R((E(jJRiJ kݽ9$w_ۼ.j"A"O&Q!зO~S4/fhuˮdV??_}?^NG=1Fïqu ^[]0~zEa>~"մo„|P"'OX~yp[}p!s" {}. ;La]+dԟVr6o댚jHgÁk_t-{ӎ*CBQɭ% hD1*zTĐHpLQ7`Qyft1m "xא]AZ3Bf Ȳaeɜ Qak_rh[.DBڣjYXr6Ccj)<^@hY'|+ᯇ{xlwt=*6PQҜZARa8pMo5SBܙe"E&b5ϗ{ rJ(sjK;TĿci^΀r<:xw'l3:W (ҁSUAUXCbm""(""&a;m95DVsn<J1P !mS:R U,S27-2.-NjHEML 9 Q80\ی*l&-F1yQ8ҭ. L6>wAgb@XQnz %Y21˶J dafZ0b?a{hgS$oNj |u6n%xfUhsHx4P$@R ( H%@ZV<D=x:yBaPeH9]o;/~ c6(YƓM3c5A 5M[%TkOo.qg>5nSMw5_NO~f:SSXX氧Ya7<*~:U5yh>wԲӃ Ip㲙^K02~DT?Za1S^ ۽ΈBt fhbC"Im= ,T"jIxYO.:(eN%W_ƜUml-1_`ٶFTŰdy$d! 2H,GI=ql NE͑}Jۜ66xųWR*AzS:K rL1@zpoȒ;EG87 8V7|gpac+ Vq;6Xc溨VQ\.rŵ' pf-(P$*3P#sV(,e(K{%/"(eHG6XsC pD5JNVS)IKW)no(S> f5F+r&I*_@ YP)DRD2rźO2 j`٭F}\qs򸧌pnH;ꦦIyJ;`i_\=HiER~EI fI ĸN%? s_"8Zrd!%ʅnCfSLW|,\ j`N Ŝ흒-ha}3rC&0ѴQ?oţ+V0@9Ď [8 l1,e8':EOWH~LAbnI8q3iw%kTc5@F 7V^KTT)fzd݆r@h{'vz!# Sk5E1~1_W%=~ͧZ;=e 25 ~+>JDÐ7-zeb3-8b%F)Q4c`}`]0(Fdr3u9㨼{CqF 󠈖m(<*NibZB 28c.پȇq2ThPSm!EL]D͟NSeYS } F$te#\> ݩCu-W(_Dѱ؄*ZXw!/J`M|ԃ=2aD"WXD ~n9_Y}OAˇr@Fg$~Ӗf cN4 SKH AT3wt>yt3=TJb׌اɧƳcU". 88`YB`ImR|'2qn1 1{B-@uӱH+?. e"J4Q2 Š} {Yufy8V0A`oCCXE ǥ[~Lf| 0BϪ~FؾHmܵ~)Qb7GӖ'yF_," ('7Y !LQL ljQr@`t*39bVf2λQWkN@H`3R+AC.&O2S3.'~ZC5U|?NR4C'u!)/py>v{^\Ks89 ;"xA/H )=Up gT!Km~;4CTn0Q FņwL|ͤlc* 4s:tsLDTCR$TEB4AC32(eJŜ&OwUU\}'s@Xy8z5rkh:r LJ+I.nw}@ "'wFo|bٲ^xr1]l<۾^DO0zHO\$4QEQQTPTZ UI!HKQ2(`3?Gu/ۅ)N&:}K M/86UH:U*FRM$]?.y=AMAI%1-M}/Pq $#PDRwBcDr4{; ZO/ڵ%i3C:od/J)"9ax[W"~Px+!I69soE:VAD613.͢_i"I።(!>6S*Vcݞ*bhӣlKkܐ&DJ=JDI,wX)i%MQO'δBr8 i(s0!8}YWu:W%ezi #:An^2)NO|PpKt |$y ˇdtku\xiynHچ1S,@G&;yk0b+=x4zx$WC ۵qd.' (ُV}\h̚qD8p+>z6,G7q76^$9n/ApnVI|rw|e++_u\W3z,>J x-,|8Wp zp $eB0gf@|F1 ÎxF #Ó@F^"QAjjgxo}b}[<[h?zs8ߥ'O|.z)RoDXRtW\2DsS=y֘F,Tjє1J<0hBSʋ<. Bq1ܰ +Y2fE؈f8"N6-E-ۯsFPAUNFƵ@}Fh̜fm'U͌Пm"RkS+JA"eLGxyoTG_ |S>ci`wpGrӇ6R@3~i2g֦ʒ|( ~t7>gEQ  ?T֤"jOJY[%)I}3ͮFk`$$q'jp|RKoS]OPRU*ܲC3/D)xuʀ LMSlڞ&Q 1lz Ʃ"T+C jV0 'e (pDM Higj>'YQ1Pkg 2$-~iaXJ(RXt²QH.K_ZZ/_,{խB~xX7?I^CE  q|GnQ \{@("ϒ~}:l@PX%2*~Wu3tu`W ӂh%8VLjf͘'eܘ˳]v_+_?o2z&.N2+9!W.;ó^]d||{cGg"rdwХxH=5ת:06m5~i׃M"`յ8_ԁwl-.gsk*5msX?]cRӮmU>4 ܗrA9N wFj7%K޾wlyo1{Vkvw_Ϫe?_F]Mw]=SK7 =ɸuÄoѽ_ʛU01<\;P,}Z Sw|תlޑ/؃Rg.<}/񊭆n^\x:s^i:+? |V#VsїvkbW@r튞GEj-\IʄC?go_KEMJ?ڃ_#eӶ&pl8U0_d ^ `m4Kl8J#}Yz69 r7~៷&U6EW! kp ڡCDv/mok)!uqY$iNKMWx@e K%=hr>!CYf-{z{d-1W1Fn9;?.t}ϋHz3G%|5_OW{gGg V+ގe3ƿQ ˞]jcԘ W<ß>L2=gOtEYa ;i2_U+I;MyJ2yJEˬ݂!I#S紶pЮl_v`N\x=`d;z$xh|8)ه Yugӫ<$>ݒvhjtGgwEEл ¿_<mX;="򻯶78탉y?D}{d9:oƎ,w& Y3st)w'V} ֎(&.,:$&B6oE nbao5ݹi~(ggÏ{Nj:,s Eo8VU޷#z1hޫxLz|3g8:գц^~CU #\xucZ@gZׯ3bI{/༕gnYCnXW}7r[*D>!\CO;ȇxd#kcy]M:促 |D> 3#gDfI2/:tțboP7{;8>*Hb{σDCWd?m?'g $lrfa£*4`: +Y<aͱF#q`";!xLs#lcebn_T, Δ.[%kSmݢ6ȘeA4: mQE5U#?ߛpgb+rN3efG'N9;u%!ޘVA~XwZKM)Wfn wlx*!;5l"qޔ42 iw(` `%$'ĸZz1Ld+Lh%XC2T!XuO[076!BEUU Bv+ (AaLM+X6xr*hCVFDyy@͞,5 6ˮnQL$0P+~sOXޔj1 Ŵu)}chz|ܓZ#x"dW6 (:.6Ty *DdB0SkaD{1nAOib(xZW!솾 #b1HT`rmqq8\8wNw(jN7 > i-$#ބ?oְC& 7 ir>iu@w뢙l]1#9bq5)Gh<@T T"Ђ$ PUUDK 2E K,PWM /l+-zjOKsGf/ P؃lqShoH)^!H}^}$1M :2!AW3378|`/82\'SJT[l彖WOWޥ-AWKMӟ^{qS:fWw{."ч2 '`6!9Id|4t%Z돛8C'pk|:=mE?k~&~>~?Hfe2 \*>Hvj6˱./7Ci.yD4FgR5sGiMBmK훸Y5tfb|LӤww  iܽ dMCU"˶=!Wta8Zx5Taގ{Č_͙3YGkC\͠jő"ȼ !5*XTX5f14=*>wc76?0hb} vek][*n=#{rM.Ld[Xyu"{>Pau]^:kBbFo^{bs{B&{s{O]rTֵ#IBHpk+"$ a`Rj.1661-1Jӥ `RGNAA^Voα)yAmuU#s4GpipZj(LcV'[_l祊2,Vb@G;"e˹Gyۨ"D O͏58&{åPR vW*{=&h̓x*3jwUL'pjm Em/M]yN0 ٽޱ?fb =hbjMJgB<m$ٖ)&6TÝ5l-[{Ai _x$Iz͏]sՐ'< !^߽I|9i<s˿:fi2NǑhyŰMg?4]ʒm<4"2m~_HT",ҊB:UzZ6-J A|vbN*{xt֠xî\u'1,HQm ,°P&2XG==2/+ ~4Y SyN;̗Lq)ߝ|*a9 r{.vrDbb 9CffbɩX|Z;x7Gr pc]p Kڱ.˂{T,FGi aP4mOBm1 { g_+x]ڌY;ه dLrő4 ȣj0_ۈ̉eOyT?}\i(_R2tphW*ҵ@ߣuB` J,##;g ,I?c3GMh% nVҷz[bT Y$,$"iyɜM3ZOό׮Z;qmz7L38~GkN ҎsV-އʿ^~Y^BaFX%{K?MqTt2}w: ,~ӉwH8nާ'~SCL g!ی|Μ=:yNI~ Mz!!N:8.YeMDFHrR. q5;.%1[EPY6vNM1la 1O>aa!K`v^ӗu1=r {~qBLi@]qiӇ5t=fQ e0!ەZ8i[{fH61k9;7^-9׎ֳ7c@ͣ9}'h} ,q|&tylkL>oMBFٱ!{pwL_"wG\G[iGijeƦzU)`xt0wUQ秉n$S|VQN; gIiS 5v祾ٖ͊Y8X!c6JS;oh`7سHVo "1pncsv٥G`W<~p.#_}#ydO_F壦Քqk~npV1y?S6RU jX$k/ZRL.؛@JL_{O <3:6WӲN.]4u>0)qCįNyhSj7ؒT0&8֝V Zg6QDžf.{ }%c4ҽU3,w.=j:[5g{Ś.8қ91ђ;&XN9웙5guӖ}PmSQ8S*7y]0~+&a29ݯkW]T]dzc'30 `;sW}a]/>{b55!1oopKCݸؿ}X~w sdO6 PcGF>y7X ēBk p"&GlFܱfu$ ;K&QqРzڹ=f*s35K;!dKXzBV.a!H+ngd}רt~v,ulm "s Gw{^EcexS;Lɽ MXqozY@o}Sn=<.3uԘYN#`hV~9דEgre³fL{kM #ɻ<g_&O?w>_Ob"!HCq*U&u(MŷYCsڌw So}g#tkmkWY E8U| 5f Lc˛Axгnvˋ9l}ΐ6.Ư1u7/9,30|{. a崨:H|tmӦ7Nm (pBو.!!E箮qKl4YVfK82\u=XNe;gfд+K崾ͬ pQ9G &FꚎ~wnϧ2򷎇nd:?vJft| fV Z}T3Sqo WN? -{䁌"}K GBDg0u8oԮF>!g:{d:$a3Mluog/IAўZ=}|ሳ-M;7 $p;wtSqݘktɪ6I@!3$^OĜyω{vTM٢rbriJ,HoS! y;-[sM|vGW=rn9fn:נf~P/ l(c;I|ƻtdq8]Cy툳 m &;p۩džxvа? 5og=ۧKInR.;ٍ5m$oFL̽MՅ]睜˖ٶf>>4a% To>Û$٫`9Jemm2Eazx<87gqI564i|izyK^8|:.x1Ke 0m'Ҷ}pB(~kdcsՋ60:_鞵6ݚZg!k8N;2^qx| !"cDYZ:\@'VmkҬx,~t|>Zm~^y?@OGϵ(*2O.Kwmoyѽ>^dHz9.LOaUmT-F5$l x+g/:hgl^.ʴ UfMx1rhMD+Jx'{@r"9oh?kaK[Gql{c;O2[;þi5᪇i dɝ58;ySDIУ@waR]G}nZG>]g<}!m/#dez8MY/F.Gur{#uE#^;b.ygw">YoO(=}FoR·G9x?\܋_N ^Z6M/EW罨uihc`0BdK/=z4׌1[K?QaKtֱɇ&PZ^r+5+LWfA7oYk=|*czqNuiⶴ&nK)KgߏEnf霗y&p+h+b؈[Sf|.}Nklc ]uFaxlSEty],6 I3#:qYi}OȩʪEmCT ?D$92 ?VZBqHL1yŠLK4uvu{GL H%i3߲)"߫Nb g}I[ Mfob[6/X}T]z"ͥ{O~Ă&G#&܄{рĩH`o>=P8I7w8's]ZJ !NP^]Mp\g.ԱƩt? #qļ lbNcop@8 fl[?R)~ξpSֵK#@ΎTLc g XA13 6X R6qY./Ō+ER԰M9(4\c*aby*\Yv6gh力r>jbKQw  \A#BY ^QEh"6 DHzGAܶ#My|*U?*==? 勵nLO'QU`sv]oNQͱwu]̲.V;[&fW|帔N 9vkj>P(BQ^],?4wuh[7KLv(e\5 0MླzWt>B1iz#?ϻkSLa%Ե%gn0@ ]rCU|4ڊByBьMoOjgJ֣Pb\qYѸHzÁ|< [z`8bH=kz@-BOR@ǥѹ - s!K0A9r%XZc/ F IS*"j3|ww~MqMHIw)񢀤_{m01vL Hš2$h0Q1X +%) hdc*QyC FR6#kT_IBv9nx<>bF0nABE>}'SE;ǖG\H^j#\}C }>zB/{{ \<ܸS(U}]ʢʮuR";RJ'x>KJ^s:ܳ 4;#H͇ V \h Ll-rj*𶹁0$UyN!IbyP`BiӅYMot TGe)gP ! ekZC)GbjvHh4p|CqrZLc@t%Bؚ9,PBgF]ۘ:1"(csRiFJgvfro1)f~#RЀ]LH-xU=%{.չxO+}Y5.z9?_uƾ?k;way$#QH#RN_D 1}JK:2&O ,f@ y,GLyh%INrhDF1!GVHݍ4x|'TmS$0 >@f[`{GZ T-rڱxu1?.15ՅoX>=z 3pg衽NoQ0N9Ş#"N[~U͈H6Ƹv᧤Tumӡ h!>smu6Ҧ%R*@nZJRSe6udpt UKV1ktȭEed)1=nZ$[Yf]IJ@bcg:܉K*0`b-~dYMq !b9t |쥍Tו9QX U#vg9I#^ժ*5pʵg;w[_+׍F椋aAHwAa)Ip§TW‘F/A"Y{DӈC^7:WwBk 7:0r^f7V_ɔ7Q+"BP%^B0" ZC3PyψɆh=:sVfϥZDwMZ0jȏn0ｻg_Zrօ$!y|kjJ 閝%leI҉rf7wf" a]v^ԩf9CK[3jm4\iDdʈ8֤lzepv0mA屓)jMBp*iJ|$8WR1EٹgJYes)rw8?1.v͂# Iכ,SmymEiZf3JHP=7  Of,!FlsJ{`pp8t"MkV⤓!JMDA!BjZe<)2&"1*9 1``8llae( w!0$F9<=fZn P^1nHAHY \ϐi[xA0znls=z|l|N ]Z;o.uGsG+bfdƑta7ȑ Ġ Pߢ--߹8&_)@:_X ]\@=1w)g4JEXN(;uƩ:W`RF5UYAAџ<ɫ]rc}h4"o$&u?tĉ>ZuWr(ջC ~3uL ߈`3 ٽ }Sw^7\޳4Y7PyőB[ÙEŔEzmޕŐ: 4mwҜCGK@]s񌒐z&:=ܦ9TҭsY|~[ȫw]#m҃󄶘LDo23ZZ9u#) $Hb`}Ja$5$'ۋzfCa3$ZͶ0zzG<J9o( 3ל|Zs}s{rTf1wO v$ԇE9*J9\G4ԥ"0D@,L82,'Y)*R+(5ʑ[Qsf>CFS#(9M Tvb٠F1gS=x3~K/^ _ۘןx$V<9 _=Jۙ<Ģ;)-)̨M[Aɼևb h*JՂq$Us[9ݛ2ZuD  /̛8~K_1)Ju|9xQd~$ j1bF2<4Eb=Z/Oyۜm*cyV1۽|G(=J*T S6EJ:ghdyJY;&pZwán'ymlF&D#ֿXϳk>~p 4}}#/8A߿)9WMMǦe#" #赞<nTDa̞\w8$̴ṯ qmަw1zhzFj 7 äB=yGLg61g^g"VC$VxCqPbA< `xs6xh#aWlT*;_[Yj|okDsm\~1Onm+Zi)= t{}ӕs|Ac'!5b0%0TH")C} ^HH,Cd۾- - Iߴ/㥶j|ެj\m-޲!0" S:+n%Щ߲vW瞲X6^<.xաj!ezMCTdu XNF9!Dayu&l:d!V9^vO#8WR8c5>v|wnyv$u4NC-O9LUQ~h[vxŏdin="&o9+aoJXQٝeUC)ɗuB0exxg3Jq[Dʀ7Ie6|Z/C%1 ug5!b?KU %y4CdxAq3[OC(8G9LR5U\#yGPW*y0_’Hʍj0= dvkLL? ݬ> y?P+˖Ѕo]ч n֍;qF)ddo pR,$b;=>E3n,RɆؤRFE MUs$KaŅm+Q g̀>>o| 0<c{=@zuB!ݭYrld)yn_x9悄A ,k UJ>`}[sIM55SQJ-:(l(ވA$@& 8&@hIIIn8beҎjdL( 2"DxFfCd(*fOkF!!!;M?&R{N=P?'J VOY4d65t [9b/w?S<ᾼoqPIA?w!Nh-qPcȠg/eMyp!4δ~a k0`r;r c}}7RO^?D4Cjbgj,9P]UșS|ġwp6qRl7Ne  "imI UW]&kR٩C]ů͛p~ ~ưgEF:Rt}!gԓkh].O{kgpN v .FNׅ6`UOi:X́= o=Q15TjzĖrv\snT'3gur;@Ry嫗" v`*.2A 5,9Lscq=B RNt:wo7Tf z4jƪն`[=) Ԩor[c̼3%HҶoTΑg6o$1'}CfNkq[ $T0򺆢relBթSשGi`8D[|Z#hGC  L6ht핂Fu]RD $Oũ-2LVL&?kM C$Φ!6Cp]l =!_@޿.md`|vUd_zs#5y{~$:*/v OZ"O̵#E 8b=ߨakN>ɥ1m[ث_oh|\S<<)I.= t/}P.Z\}ܹm{ԟϐۆo| qMq`>g_֝{~mw.v5O=gb?vZ~ۛ%mA!${j7#&Qf :QBM7/k~y\Z&:\rNߌ[?i}Eq0鬙Mञ %2҄P+]( DŽbrT^|WpƗ MكC~Ml>ŏFuv.! q5?ɧIhx1,$ژÔ iYJE0SY3q&FvwyŚ :FH2Dq?r5-9g7J79MYPդ\LsL͇`MY CL.D+ <ښA\J5!Ka7I)@dL~1e~d9ٛw^X˾uʉO&np5gv;I߷ˎC<bl+:{[gi|SYȧW7ɶ{sgs8NMlr+X%|YSlIV^C`";ˁڜp|<#̐ΌvɿlrmJ[ĚTkHFmb%# S=6҅5.E[UOQnblɽ5Ťpؾ;mq1LCCؗ{6cyt;{>\f~7FzJg[C60׻ c :gz=a3}3&7?<$ksmg>j ,XVU/>qtwDժZ~BhR|ba0` 0yK,TZeI1 -o ,8 CC Ք(,Bxd0* @ȡafhB88Pd ]a/ ΀P X%Bkb OW TrY'vۡk9z$|n$jV" Vs>KUJ=](Xƭa"Uh2w8(S`Bt[u=<8?λ~V />LqyuM_J,aE :{/_t OJ >cdP;2f\:> ۗO^xn)6 HG)/|r?Ёő༊^xCqzkt+t;H7{iou>'-`Oy_MG ?Glw5N.h05>: D#(VtA0ȑ 3"+O,ߴzEz0͎D t]GNCe$ Uo[-X]2aY:bxV)>#+~w;aS0a1vfF*fBRQN"MIZcQjDُ"FG&9ccvJ޳w~|`i ,0/;7Ďu $ENTu%!ÃM8>l4))KG_a:/[bUϹͱɰsW(ȍN߆u>-Vof@pȉ{_3V{׮8GpД3U#M57;Rt5UH 2p֭dm~R>-jBIg|zMK7?ԅT>:svDdd$+S&q(c$epM+Ѩ`[>b!=iz?qp"& x0%Y ,ӯVDt3-Ɓ*@>0NS\T%fEg" rxC, .0`?25iU``z[~뺟hAی9m˴S\<L;;6>\&Ug wٯ,xMr[tg@s('Q lnN]6KʘXU 03å%Gb!͇CN<{w~\tt 'i簿SpQ͆%`*I$% Gg <㱋Gx $I<l;| yGAvu5Wc@:B)cƠ%1zҼ S [!$;tĚh [n/ ㍋E&HZQs_sx~q0?ɬ`GPQV.D!fу;G~}ˍYJ]k+2@2aGo5(}f%uD-oEaЩR_DLn2$2i@˵Ϳs8h=*y{ZjAf#zS%oׯXhM%Of0UHHx f`S;;jnf&$E='Q!$J2+ܷBAnPk%0H8o &h32n7ɣ^ &t}bK]Z+06v~#ٺva5I8W79lh\xov&ND{|XHmѪ{iH}x_?ǮE s #e?]T}xni! a!}?wdjhpnص aM@tщ>dXw=ZXrII$z r;>|O2uPQPO>Y,/zc~NGgy6Y$*"!Q=|ҺDQɁRGFnZJXAL2oSܣr2b'67i(hD@p4"dWG8߽$1A"Uq/M8(YWb tAr@|wdTl}ur<$6k~^>6#[zU%ˮO bQy%Gꐔ_|zh=O~e}04 c^Im4O$(v 6,%//+f`?0X.AJH[ gRe:Kh<}\Xq$Y?il?9Nܗ _655X I&"% Ի41ݞͿo ]+6 '>9y>'>ϹӴ / GhC$ u,tSC'3ׄ~`1BbF7q^r@t/o̓fmy#= \޸pBoh['jA89xgBYrn2Xj:}љu_NNhL[)7ĉ鏕:jPcGSh.'=/Rz &^Wr]~7cJs6}PY.”|(Xȭcc&w5e G%pRZGXr̻?v$9!֭߈dSyZZ itN^MV='U{'a=W%@0)f;'QnːĞ1{dWԿP vmKw:.Ԭud|0'IH';}"IU(Q(ZxFS0Ah@l쓱ktqa$MRt;QJJMv&ʿf*$vh$hg1%X?G]w  X6c*D4SSQ "&c/썴V?ń뙨h xrw_Ӈ RP- : PbHJ`ؠF*hQ"P  VA)P(F A(Z(AT@`&$V(@ UJh!B JiE")H b@)aJ)A()T"fDR !)䘔B%P"URb%  (DA ((ǽo~h f<ӗa?`|)^>:@N!ﰋ|\ \ɇ.=|=+MNTg)o%w]Z.=0,z0` ./|17;9C)EA b)" HH#雂Kf338/ip5A sHlg1Z꘤i\ܱsDɰrzl{?g=' i׷OS ?~ͽzw:(-/ !/TmO*dQvZsӈuR gYIꉩ#f C!~kBXU$?xB¥MѼɏ y^INɐg mU_m{Z?յs"ߦj٘nS9ֲat*LV2;ؽep)۱93`B8>.RQ _T+1O!^ yJ]E=*~.ZN< MOrSNY0I! ,T/j1ut]kCؙܶ]ؤ_o,L-)e0FA#qA0Lde%ue@mZ?&5!O !/ӓ?.Y/7?j߶4;|sd؅k`dU\Jb=-\3XYn7~l k)H FlJd59Ћ}+)EftRb-x $8$G9s5WAͭNbI>ڒzGw⻲Li?-z0.Uqx6Q P~IwO屩њVlv5" ._,9ѵg|# ?s7Y15m' k]QHZoE;I?m'wT4)B@&U <=;W ߫h<T m PT*@=rE1 @R% )G$jQ)ky@km?!7{D=$J Q4DS45cH5}|S;h_tƒ4sn#cf0S݆n/ӿa.i酐U459)ܫچe" ^Ĺ Q < 2Lclf 3}oC0.(pYz?WEKGz~cM{?Xe=~Nv2/%IN_U ]!#Is$ԥ$2E&tW-q׽ʧy=f\bX ~"O|6QJ>:]0rt&%jŬüf3Bpz8Ǥ42H ),j><1! )!_/ώ4 tSO:ϐ?׃/?Wg@# KC$l2·"DGO܃ G ]~Ÿ|RBtCݚY6w"!0 R#@SOը AD "} }c*MM֟[ \`Zl3, "- fE L '5PbB֍D8S]zbtTAɜm?C? \TZcPQ "TbbHeH *b(wWy[ \%ģJHGԄ=<_ڮ}O B`@%%À1AvHn8 ҙвnKGٸ@yH0x`x?O83ĵs?m3Dg ?R>7Ok}:8] &v74]VvgiE% l ֙|O;\&JjZtC,vAaq)6 nI0熁ɄaM4qPoԤ pEMP9(>  16q:.juhb3lEh7@f^eub:h1 ɤ)JLvG'O, ͆t̐naAjJ"R/ 0 :IB^]>m8R{~qz"CuzrAtTuF]s '5 o)`pfam!뜜C(<1m^|kv4;𜗖bJzHuw+t4EU0,RTeQĘx'$8'&Fe0?/ b(bӛ4'oM%Oztx4A9LkZuMsUUJr?q|iQGQ%m]gu9ĂrFq_tP DԎ}RhV ~Nj4M A(CnOD@(9nFN|n>~8=8E0TESQ9Hޠ,Y2I,qr3y]y=Ɯ_7тmcUn(j>, E%ϸj;ǵl?K'~kgL UQEM4QJR%EQKr4|7ibL$3v~^zއ~c?_ni~eue 8gcS*Ҵci})f-4`q1k.HqC9yFRB,TE9n?$:q_3?/XaJaHN[1[a籼6ΟO3<ϳ54$Wkz둪],D#`1`S2z+0[:qb` 39ZJcN5o y}zœ X)RPh ̄]\m0Hb#ڇ\t׿GVgKfWI/@x=@wf_kR`ly ܃n:&1mŚ ~Mhrkt1fĈwFfzL0\243sװO G]_vtom6 0;bND7Zp8>Ls6x?}UC ]篂#[ YlC?~'jҵwau@  x@5BA[O}_0 Q" <7b,_׋3s?']Jwsuu"c10Z= }x@ [4g>' 1柄8r;OfY9^aIkMI3p&LM3.^bڙr Fpl=kxT)|RdCaAd޹~vpvGI(ߌ(=NB.P- iE&Fy3O8oh?zۢ-׀L5u!bg%.1`Q<ΊtJ`̳ L'ѻol p11$D3oqC|֭g)@(i^'Rϒ-*"MPS3: ig5U ȥ2RKTMO=5IU>4AU_aU4s|kSfьE;iUy0:Ut >/<`5y1ă{=e!qC%0禠MP( =Tl |@?،]JihZA"Pe)**b($J( &% Id(@P3QKI3 S% $-%4O# AtWmr3Aѧ{ew w5!˴z M/{gRt!{L^kr3/žz܌lA ħ/':,w@,)h EEFH$yW!0d s~G?+g6_xȿo}G=H _𐈯8$ J,Bh?}t jP]&% ! :1) t$HgOh*&_̌B8>؝dOӅ@Ŧ_-@uŻiO'n?1EX<;1^q,5!D}<3bk:ݠ UN)gjF%S]BC%|QNsA=؇E03~0 CC`d?2i?k0ԍ=Ra6d 6pwsAOg/U;"ޡ߁!b!ɐX;*֨ZUu51OB{R Igx sT2cGtCʐg0Cu,VpsC0AC'h`_|EMӿq6aNB!"1DLA$TQU$BPP5DQ D5-DR4UQ1BP0%D4RA% U%LQ4C$5LN6=@rz/Y~Iq&/GϬz/C󉊖D? NjY"b*WֲWY&P)DX!*g <\y9ơR$TxJux(g|_xJ} Lz:GLr¢W`?2x?iT1KA'~: S\co=Da(re?KߟQ55p(pÔ/ RFwia􈑜pL-/kj&4][1vKIESDXt_%C> H@.j DbRrlLcϝ1&co.o^Z"{Ip-^ qm'3]ؠR U؛򐐔)4*,/70ijK`"fQ֣19nyǑy"QĈĊiBם/ѠPCTSܟP$=֫_Pv?=UE v?r5g,T%_}eN^AzCxfHE`e:?WcI>Frǘ?9ӫ!d"|DO~~& `@۞6! RC{R fcD=v#kCExN <$q?TG-SouBX0@E-&={(^Ta%aufL31 @D:uY֡~9Ngç_A4~VOp̺a/cҴ|5털(EPO/xwcA_2{l>/F韏lMno[!Ri,"61_}߻Q-jH#Fm0So=7Ldž٢XQF`?<\ʿွ;nJ>⺿5#wjr}X AoholآZ4V9.*lzc!B9ݿO>*bpil H!3L\2AB(뙏QYƂTgo70N?لׂ01~0w/Ib O Z*`j+ҕF~L`+Yߦ5{5kaCf)rz]^S1\F%nE "11k`*X趶ʲŦ$#^*:qq랦NI94fLKu ?.aS'y}ǟg6Rm,Cv9p2D[ 108yv){49>Am jPM6=!҉j-ߎ&Ԛ& * 8:\NJ["[f|M $EC{bK](u_GcG`>oq/.Bz`UUUv[j'eMBg"%7[`}\QrkZaˆzLqd(vX-uX%գ+HxtLI&hWv6M׮*fУwhtX$gSҪ짒c7ֵK86Ji @AK}(g;4iHdxyʣ@Cݑ8y߹pKM2T]F}aAcw1}I;'ҧiaj^SYQ|ZQx>9q,y.em'c4bIS/pEQ8ם|&1Id"nK;r& ۙ4r!C&!U RNlU{x4ޝ,1;SYtvٕ݌ek>4ouH< zCl\Cug/"c̟y^v@T;N.AbdPҐ ~.$/Cd cCWܳr n }ܟ}<0v*~ ܪ@v?E@MY_wZ%T)Gݪwn4ʪ)5+RHo>E6i6q b[L+_H=5Clg 痰>Nas6Gm:bNA7D17tFUSJ( a]g0 -EȠxnp>b0m'/Y[W=!`~uCs$Ց1'<מCW :b6z:ޘ|BvZJ?K;p1oź6͏L,-;iW DӾ_#^\b….FG.n}|xt=X?T>jooOL$cny~a Sb($ '@:m>S*ŕV#sM}txŋi;oj%_H«rvY^YԳr G!t3n[ _,LTɩ{خ;FNls&8ah=VpEvˢ b>b,os6"')bYqbWSCqNJ.^^wsȞΑ+j™PG9e=+w511f`mѝK-}]cﺓmokﾷ RGC3{5坘|c6VoNr)p:L8beA;ٻ`x{yޅOŽ00`јgv6+.jNvAle<;B:uw@v[Z(b( EU{h2Ph~0N3^K!t0t(OkC ;nbXhf|S5&VFڮʜ C6^5|ߎR?=N%KZߛoؒ-Nު,dX! [4͏:2!?d&:a@EOe h{j rtG&eF.@ MWҕۏS1HǏ om>=i,F+L8eTQѢҊ4P!<\{{LWܽ9CNӖL a۫A `l\@n)bH/qل;c8+@/xK%lY zp}lEeE@\< 4w9mE2(Ls2 ]OYդXXT.J0J @b)..Rn+I.kR<Uƛ<3Y\3xσCC|S$= Egoz4bns3cE(1}>S&76nRdQnW[x-A(w86N/P[T-arh1 Ih` hv<8n VRى!+*E"k!읝 Cn^ԗVuwd%6Ċ&y͙_ݡ%wt|(f#EǍhyO1Ѣ`R$VoWBl:k}Yi$46췀@Xhnz܌)˸ؤ88TS6N`md^}Zog76E AkS3щ#3 lbζ9&tΞn Utd11ic}Ȏ V4Qq I(n gCL\jE Qaln_p`ÎCD6TD>%/)\7]4Pfn ;3nmU&fvsj{-ɷ0";;rQ SIΝ^WMWFެyǬ:IEEa>s3Bu"SDmvK$uƻ<~ɔ.< ҴBņ +8.Gx2pC] ?pZN.\ TEqⳡԋd"{BUPeay`hh@g üwfF̂\dT\FFVd3UA"&ȀH-MCD_D#A!h$ ̑K|džpMd̹Pm1+!"*F"Qw&W gÄHvBNtEU5E4*KG@E0ʫnq\h<( vm9H{\Eř*"}cax8D(Rcў,$ \#6HA$5pN2Sz^iFEH)^@m7am;p3ÛDL&0JB8p&s7y(&`; U ,t>}E I# ,rɒn܍< 6i9!S/&khSD CB_lhJ0 rhKH䜌tPgDq6 -h 8"ۇ7?/=ƹX'FPkqPc9XlkUŖ$-)wmƃ cr(4z%Aiytg kn*+*V:6&yB1VIA%$ưV &~6eJ!!`h\3R3m1L‰Y sSo$8P})\"KC E'bd_aB" %˻ ``P bc?Fx$M6`_,Ǫ 1h gs:^K$4IXdk@*Py>8DbgAzNM/0MxbI6n %@{;LP_m$@0:ek0 b1#DgmaXDI©1hl\;9J~Syp0;LB+ws=m41rw2r@eK  rS] r Q8_p9?#Y HP;:UӚ5lk]6N YpdJh 4 3-E"@`54g nVd|s1M3:ɢ„#+ hn`6W I'[^2$$"}FZUB!RJ)ZAh!_I?<0[M'e-̆s "hH60DН5H4Hw+Z"!«9=^lg'bxѡ)s=A ݆*&)䅑URBSQTBDr_عC0 3CD8yR4z,-.迖R;R˅I|;EPQQD}v'm661-i$ xm^OY0DMA<޲~* "{`#wrq}К O}<(<!b / .Ԟ0B0`涅By=9-IDQ%Wm TAEQ:!QPDQ\AEKPPZ ,UTбPs _;&jZ B``iaJ*d i"ATMCIA@R1RUr%4L6BE* X 6ȘI)hcJ$@%+ՊVdrlx1m%( HcD8P= $.'ԞRC4c1H!T0lmNęiO<$} H|>`u= qkܜ8R]b|0hѯ1O)wOkcJ<8;A%/V>K%@ņn6\y% C}<βRozY)Y]h?íRl=E *S0(yT+~?R9g~xq9/Op5@~?-> S^i&rbD҃B ±;1% Ih/[.k!JPPzjqY)39wK R9}~%%~.M&'.\luK=1)!79&M܈\\1Ɋ QmsD4/AʈVɑiLӚR1 ?L st4~ǂJH-(% B}C@*~,~M{}}WBltQN6mxSX|rۜ1ZFzfF7 :w7/2\j;5GV(hiDCEq<\+quӐqûMmJh"me)};tﳩtMByP ڸ M6`!]tCt`pVE@.۳{["I )#)gk#bCùqŲKuV1|lEGѳO*ge3CliuF.m%&)Jٕ.aD1Q\ \OqRl{r ˍk[(aZַfɨF Y:%N7p' a7C֐̓7:=g1={T-%+k´c|N7rg|GxJ@ }4(?'ţE C~EHeҫ98\J}iH!JXs8N7w5Ÿ(5q>*(R?b' SS46/ZJj5KԁvM40N(qխY~fUPHiƞ4b?}l>` %~PTMRa cu5] $*GS=]XBH(WmaRɉQv4 RE*, D^clcO:+={%ͼ%c4\TN8 QR,ijQxs|mc_fh~x޹\w<9nتjon;\jfkPh@҃&kG0B0"4[3ߡ@2׋*〹K9TWrLCQ7˟+kͺcKqE ԢX}*} W\TFJbr#lB'z 0zCi0|,!'oN|y@ϋ ~?!~N/>Lۤ5x>Iݸs_%8(iXEwdڶtntOyE#$ OmSɌ!کqA:~f>o*`j{9hkUQU,:CO?.HD18EV/X,5r 6/~o9Ggl-U H_a$ =5b@D ntjx+j/6ÅtT/S@]ST"TD8|s()t[{,ru:>}!rB]);/29$2Vl&ni˜aD$!~p|ޝm5neDC:aq] _npGdC!>Pǯ. p4 IQIQTHLEA THDE-(4Aֻǒt#t!Xa_r8/Z3?þɞH?L={{D* 2nI/΍&~γ޽|qŹZ+E`{ ^p! @ AR8lR Gpe*oEd~Ib `/V=L]:f589Ԛ Y^|4'2T !@˲PTC7B"+\jލmJ^^Fsb! I ]8XZN# ,OK-3%ݜQVHJjL86܍an8?]XksYe 1T|# F: hzwMY 0)anS6ܜ%LԎmB7F!OQV>T7rP(*<=(U(;8{ob$*V "(" v(!hg仰^^.;q2(o|ާpg*{0j,ѭKAsia!%AZ9BJi) znpb"#:,SbjYj ]xiBdpօ S$(i 2ҟ2}syRI%DSSSED\jf0T2w:5s&q-x@ltWLe(~ɇ/88+="9'`flF `Ozz./W` &_6\cݬqajz"9 KL`6c+.FgCM6Q1I]itLB:`=FΎo,)ERUSR ?kMgvlGIHi@c>G}^vI2̜(e$Ć{))& Mr3$5쩠pÔX ?n~k|z>lև5z(1pX]=&783-֊Asmmd1F-U;%kWFd2IDZ|G `ߘ,fd+6yYx[jv0vVKkowU/V38uĽ͂A :`%')ID3$U*I@5ڪ&u\z:g ^X[!:cȯ5q(8vd4ILm0rEyƫE@y~~ 71?~z:O 8>'Gͥ &,\I^E2'Sݪ/Yw6[C<7;?ķXa Ņb/y$oy*frp\/0ػ2y|xyٯ%}$I Bl!Rڳm\meX+@-M41U뛂(!D$I)|B!GQ3!$[1&@I -;dPD 2AɲݟHr6 9`xl:HE"MDS4m"Ӆ Hdb$H8= C/\#:EQ8ճ cj &6MFX(34D5lb @BY Z$4lH` `\V#FÄ%ZPHQJ$H`QuSl-̑]GZ?4|u;BAr7+O0{q2=U2=l{cLs} Dhze% upx[z1Y1{ׯ7R2i9e-sݵ͚&i̺MQ#m^w]ƞlsh&lmmr&%В[ESGWz 26.YXg)S} ^)[lQ>1AUri#uDJ *4c N;::pl@EAj in`5sh*ܹ3iʙQQ `,2<4(r8!ݒT >w֌gNGlGKO\zyHF ŷyU֥Cih9 yr <@1r at샠"W@vpyA\s&䆐Ur1DRt)9z#qņMlFd ct6ph!@1W,dH&K , nj[a^\//0nKhEX`pK.!I^Xf4f8檭AWe(Op(>^A@%cj1Fƺl*VI7 de0IJ"4рlc9jMAchkl9ΙOùSXE#jjf^BOm:S-SM (ρw:D Gѳ"LoMp0A 唌ǫt+lxKћIDŽ~c6Mn;]Sɢbx* FG-@T--*`ˆ0TLr4Ul ! )$E![;m4W"G;II$8sOsEGaBU HnF1E 8MY<~oǀ0p킶)A6:r>`'ǧL>0ąAISRB~4Q!4}gV ! q5U3 x@xWx6=+} <8d=$r~=w!d:>ƨv hۘZlł=,@/o8pldO3emk^NP|iBԎ*vNj}Qn@/8\Mp٣vM2ꂿ5`QF- k/=MnGݪXm)X)Gk:](PG.}ɔ;hXC~yre/(v-pt!H70QTi%ύ1p]bm Ox, OMCE[;^sC³a/|" "MKl  hcހp׸cpȐ: {jfЀnH >F>Կjht=DYť0Ri2`4y<oy' \^*)-6ĨviAAԃ \p50u1I'*e0+yğ3ORhT11)Jaկ&*z$h0RN>AWw9П_(ho!#};[mzy"!?/U~Ne^=PՓ '%O?--˒w8 `#) HZ^! v+o Jd>&LB4\\bd#OS# JNc %lhb::B d7cP)plqXe)ZdnHz`’G.5%d L&M94)◛S"k?@ţ$l0^,7y4.5#m?F']B|`/Ⱥm ~IN&zDE+E \;dNDPP6,Z:ӦHQKf]h9IId>W婼ڜmZOt&Hƣ^(y;&][;",2Тlm%h1=mtr:u>Lvٰ .wJ' hcpܴLTnp1ۘ2xqG2(<97^ 3E[Կ "{(-ڎxRfkI#цȍ4u~ib%YR{/<{rXz~o𺇇U|:> M!T2;׽פ0XR C'"٣j_6{1q$a8K~/zX׬y/n Yf4HO*խEPiM1FZ&#su$``cfm <$p"XQ/N ș^)]WevdUGY6I&q`T-^:x<9*wxB0/n>TJӡoT]Sy?ZAN*~Oj˛ 4U"y0^}^o;+Uۨ1n<,f 0<20i1uPaqd&vE)Zx~G5g$:d% MOoaҴY1Cj `|0P8N5˾6L(ق`G,SHjUg|g,5Б9z2im݉,LlK|D .G:0:X.Hn.$`fZXhdDO}iz#V΄"1)"ׇ)0 W&O6#5g|oa2kqL+C;!;W£GuRMs} 惱-CJ:Ԇe.^xV!S*B[%"v\pg8Dzn153Q g=HtL@ӌȣmzw*0D&Dm>_da!:q"pb3eW.F ru@6 Cfs4B~׼-%8.ت8Xqh32qM݆E jCtz,ἻjHM8䱱xC/U@$SN_g] ̂99-i_ïHHj]ӓw`ۖ.sZC.Q0MKɤMFp2yZIw) ƒbӪҰ˶ 6k@jW0Fw wv*$r*9;tՎw(wN+[V4Wa]dN XC]iIXER_%(;_H# z+0f .vؐn,Cams{};LB""菱9(]hYU' ʓ (B#Z;821iF$4cK\o;fL ^&2޴Ll>aBiD.#ldxnSs[fEf FԚgf[[a71 HP~Irfڪݙ dîe &% ;j&КYN@M>D(H5䪨n6tFGgK+m߮y++GfaͤX`HQj[O>oVikí&K yhMM=#.SqI: s!3B +,Ɛf6*v& ՜yX.JrF݅ iFY셳WQ@00YklVOQĚAQ~I {7x5T#@)gHy%<,hb:^q͎#D7SrXQRsDMŬ.WSF\"[{aϑ'n L0.#xbeTn+l8,ŞY.TZȯ&xE CvEut&q63h ZcSg !63ĭnc>wFrV;s[1:+I" q֞ml lzj(wENjvRfX½:SH{[QܦcI(cf] L6! LkdLlyIǝ>7& 6(E372twwz&M a;m9nMmf'vzmw_!BY:J /Mh+9z/U0rV5\ %d,Đ3RٴDVd셰Ym.;4{ܹ1i4CPk#(-,;@UV4oI*u "`Ap ۀ"iGQDsQpAl":!0TYCE-.#q &qUFҽF6օ˓Q1v_H 6E^e"*A:fqe}E|޶r[t+% ͭ.Av|I⺲0T!aØiV*F]ʖ}y7yv~7t6rͲ] )R,D!C]"a=Y^ւb̞Mt؜8LHF` 't7cNEL9?N q{ 9E[E %Ar舶jFE#>϶|{>2 e{g!mP.Mh)UB  S%gK@`YDA HO~]ofAvW4ylb\>{ՆDX͝6WޚCs;-;n:I QobH%VZ\N6p`z-! SU#$ D #LO)"zSpЮ)t"&٭#IqT0L8## !B趦p;p1"CFl aT(m$s1GDSdo"4LlCO`!$B ǩDPz9QC,jnqw&&X<,jȐdAa:B&x,4&9v Xc"]в3H5!rp]<8ih+nt11B KBVCPKH "}D>A;gLĨHPm<Qc3tء|q/HH[^'ddeiu%1C`Ar܇%!`R S8>ǩY*碊8e x'y) wDTDPD4QPP$$ IT14>Bh f"b *"BgoNujS|͓];e=MəS[>9qkP$$4.K!'Pt|F0,6Q먃qw̸-<#qQL>u A* 请H swˮ{Q6y2 CD itx:3OM8FV21T8CoftH&ɧj 9waݜl6ɒı2qwlI޻-%P""6xR9&ס -ݓxPV] )Vdms[!w2CkEE*bB 5BC/xm&io 'yvVxb`Vbm6ɆEiA`҂uoC]3KޜvLՆ0̲bmJb^zSppƓ&$BMChuc6WAvN# ܜRumV*OR3jěLQٍ)w!;$ j>[1i$gL,>J}Oh4 Hioόv0=2C#\#kHv19H945 ".^rb B[-2Yr8:eLluL'X?>]= A/8eZ b(.Oo AIwŎ!U0O !x|uۇ\?&26$W11z<_9+TWphaD@[֋1K@5`"Bm5Z m@ <)F6C)yIx lihU3 DdX8A<ȍ^rHJW4O"MiqY^"UJx+ޢ,dr. Bb9A" >[[2=51Mb@X6q*Vp>#; ! mŐN+{&#xBpB64." Ox@d5(S!Ji Hu{CDl,Ky79>4(+*U@k(8'"< >#e!ȬH`;sSnx겖b Nρ8g4Q>Fd/0 rTC=4KA,,M' Dc˷!B$CGt`@d$8CʧwNKOh0Eim?tz@v'z~ҼʼNm),C%S4BRCMR ASQUAB`I1K,CK$RDBL2Ē"D ?~@UB½gvNQ(˜w F~+rxBJF(>Fn1$KJħ~ǔϟ: T#;C9cZ9``4}B5Β^ŝZH#N|$X=-qYf21@H\$S-ތ::4i 6 H| ,Za zjCaN 2rUQΫi^زj$cYG:Eq#:`GDj&{M}gDʉa]hPVq`rͮJ] A,{}pod&`&֭tt@NzN(gB|ɢs4H4Pd88 -+3Dkٵ Ƚ*)]Z6wvUiNlO DD:":S6ɰzH.$AC>(Z DGqiD7- qݐZr0w =pA ;}  JwjRCc @C|#hCy/(O" ,d @o f! D/b7>g4w,kR8i¿WCaz19I]'*Wwzw&mmƲ娴]U(MhV"aEQ|<؍f àfyt8sclpM8yGb^0Lhmm3 N\NmYD(a][.֤RmClWRB(K @!@T$޲DvUUb00+ʊ1X {W1 #/{KP$d,Ö7I/~qz1gձ3`/!§{Lʾ3nGi(.U޳W+9_1gb_Yf$k7ƧX6He4b.֞UC8@|kEYZ, 5>r֓|CZmr$z_VQ*#C#*[ bNf˖-iz;\`9ȷV'|^@Q t 9};vi4 AϺemHO[̟Y90UL:rq`##Gg[ZwC !ݷ=28*J$)6p Wiӎ0,CNFx5]Rg]qYd[kvW%L\7qk;=NB$܇c2l5&xtVqȕ[jpR#*;`%krFA] SpnLûK;.u}|09QQ0T9:6q㐡Ι 7R^ g G }I5:O: h)֊Jm*"PzOQq检E;M^#4%RCbXd4-+Ts>"lׇ//y'V"0O'D.]I_2悔G|C"]P/YzOz O^瓔d`NI_j@| $ :Wn6 ͸)?C*1 LpJ9kj99l[0ƒtX"v1h\$f9#ba~?e!/@ܢob~7f&@?Tܗm Fh]$|,8bS .kRU5$%wٰ4ﻳ.}$}N(Wt<8)slxI ,(A"(mخ$Eykܷ{󒧧s =jը5f5Uh96<?ظ N.pnCIG^= M NhIQ?ɡV֚@1|OqmL3AV܊$; Ӝ cDExֵqo-[/ 645ȏ <ЊRdJH N}O9= K\~ Ok`<"!?y4p4ͭD b+ã"[,)Jk Lʞ~qm",j8Salg[1 .%-'Qbb"*&ҁ+" ȓ 'ç A@VCwU(I00dh83(h;;Cw7 ]yE o6,s|{ p"{N^zYo2I#T4MpC-}mҒ։ ľHʄ$J s&$G$EOlqN#w`dN:'ww}Ϸ<zI!CHt'lE@;!-ޏ0b!BAm9SJ^ s} 901.Ol}ID IG% =(]bAnc! Ò(|$p2}^K t\u;=ǎeMt'BMq9)8G4@M:×C\&{ر{QC![l,%&fLm vm@奁 (;G\y+`E u:Ðb ԃs@nHdl늳p믓oJC9>!lχ Yփ{索hj03EK lm vs<u~XK*0l;[RNa&P46N=8,~.jsnG.r(L7O.r‡.܊?8 B= AF2 ON"i(z{g %E #O4r"Q i!D(Z5J+0l=kﭗ??4V aƪ~bW W;x=}@ L!lN/x2҈|IHI uk67u ?y͕ z ǘ ~(d$R $5sGɳ+T#U-AH T Q2U ,D#Q PRLAMU#@PD4R#H45@@&hTrC_Ԛ#+pu~x'~0ϳaOy.h>7c fһÉk }0Hc$)DD$il+ :};pf"1 |(JɮU4g 9&szԓ+* 9+'[ۿ'" |m3!8&cjq0iݸz/G p:D}as弗A?˘*mj*RHW}ZJ2!+QjN ! rֺP1!֨A  É!y"8kLJIT DE7.qMMLC!3$@E$PMLDBY4#A Dȕ;f+NC2)1@LD 2 3@D)C2L,H PTGm[thep#BUA8~^  06"#x"qbO17O"hE4"b!$Iz}SUmxdYb ވUYI "#†*fqģJI %~T$Tr'h\bb>+m avt.z^6_O˨ YK= ~al ќMf#b dRjә;εnCChj!ZHXP?"i8%ԽI1Ԗ|؜Ȑ\ jgAe:3yEaA"fAy3:Drb"+I6vU)/؏3KJ[Z;0h %]uZtY|@p``˄|mP}T@P %(P (7zsg4p,HiFB^DLmCH?`("P6bLB 66¼K81vק hӑ!1xz4ux+It̡P1gk$ڲb=} *TB<2ľףZ=$%9"8bYU!2нzvQ:ěcp՞>o;a0 NL$HuK*J"Yp wGUK3@TT} V ERfRH8BSY٩P44=>>{}a^NgZK]P׹P;zJdp6巂gfǀ<WS(%J[ߓZ@~B=S4Ƿ¬&Й9)l,tc'dM[q"6 f "LˀfKz󣷘@ TC1!T4?EȌ\4m;ij`+j8vic%jډ&ZpmmrEkT(+r9bgnsr ?KO?V(lPD519^UtDFM`֪!)f#OynO"!C;2h!QIs&%6+ Qt$EDwbyYi8[[6tVwrba8AJˏ0dN[c-SL'Kag1: "XΡu<"嚠ӨFr9JncmkPkEu  P pd a[q!31SA!C̈`L%!W! !=燂Bd<*j؅?(!h0#@V""D  PIJDP ,L,?E COe@ł$O{x!6򡾵QqQ91cUÙͱX֛G>^ jYB7/90v/pB;2n )vʫ"m{Յ2SxG#,H@B=^iC,"z y1L})o$(L%a" E)h"j$LDJ?hh_DQ=@8l!>P9]zyЗTNQU+"ݚQChJC Q)c6>)Vg ~'"jh_?rE5 >J qל| li7nw |lV&Ϧ1@oSF !D\|}C(xBkE f&wuG_-k`CAW (%~|EWWs{~lR}d )k]UaL1yֱ+ՔwԑJ͡iq"l T?DMB'橿؝)7f1E=r?`8`}i1 kJwҲV]m#IaN, .֓2;"dwNeQuuf`Dmlrn6¹bG"49"ܜ/],fٻ2Y3ppVf^V2LpVSҗO&H7DmE΋-!KN؈6+x:ͱdю^Ii5P$H&kѠ]A+$DezOxhe6nNp,ʹn0:*F6|0N/w$*&v1")kD{TdOU^gO$ )HPB4]`# B)@d W)/>H8iLM'K#v%&#(~(b8+bJ}r9rh&f $?EP>mT"j@aO $=4v nIBpπ5$rW[X0ϛSmzaSB' J su[6.8?L6g9ly}zayQ50 N6hـBF1FM1V6j+NZRB)ZBdZZ I! ()""%(Fu#m(Jf6G!P !AMD %!J?hE 4lRP p!5fh"566ӥGHZІefT]#@RD4MU,CHĩ@" 4CB!AH4WE(B@W.g_ѹ!~ĸY6P;2$=ZGR/OYz0t|R4 5Q"A+DI44RNF)"S,"0)%KP("PHz&!qT_o&aa㮧` N\c,*'2l艉4cmm[btii/Gxg(R?j1WcM f"ZiXF5"FIfRDEPTmg9aՅ+:77iܖ 'L%dC $d''o^ComrVʘɾOC{&r(N7 1 "MG< !y0M!iII+! >vP>U`? !E `"q"_RJB HH)  AA2C=~QAAB ]%$BNCDF1:{1 \$B@PIL)#>dGO)~:&(}3{~c: W9EPL/Y C L"uJ Bd! (0pZPƛFhljgAX-hLB4BQD 0%! RTQ!jZ3.ij\8I1$"Qb )̚$O4$Tp&fhZ,lh@ЖK&'ubقb}7\^"bE3ESSE$@CHQ0@|'FGm%i7$,Eh1运OaN xկ ?0v}T܀fDX 3CNA̕y}O,tMSA:EmlF)|PjW1!VpD3H.PpEZm*fu( <Έ7P*!=?^OSY(Ɲd#]7v'6TB666y:z[L01׊s+dh; Dq`т$B;bŒ`H9~? QtxFSC(JcX%Iez 7ajy ;pZztSt/TN)n=Fr vA{\B&?A8tHUL/-%&L"w`¨*ohX䅰 FƆҙTPm'XaN$ nߵ:Td E-{emFq UHR(}vRy)Anc䭷2I/gN?68VS0q #Lquj /,#T[Iⶻ S! :7$ֆ/8p*۰P8yX ŶmFv6 (I+6- PmU^m$&^Xyyu1SK̴blh#դ m.LlBI1KI0r"ln(n)F " K)NJpr mi"sX;U3A 8B:aą4ɋɁdxS.H,yRb{oa` iqNLR5 D}1(T1} Vp!!49h+LiZN],o<6 cl&Hr1P=G$hJ|b6\hXA3e*%*\j,T$OyǁsĶQ46VV 2 qflSm2zQ&:%^jeU]iƔCgKAބVCR㰕 B Q bB{^tcw3* `QCL25wETI1S `O"H'|y<5CsA蝤Y(J1BG 4UXُ4^XҦ GPz?=q(pS6C_HMe?k !f(}R:bzFCCK@K;qhSj DIEz^(vEE56{ bL!B?Ɂ |hwXT4s 8!zH>5S!03"8)d؛x~R$xhᤘ!DGnwy -'2̥$>vAO5M[X4?A ͙1&Sd6pPLETDmb0mk;hxsm&! [b AKALkgZ"^~..c8+򉳉Ӡhb!q}XǑ%.D]ATtT:`ۛF_JHl8aD狅E|t;/ 1`*P :5ɔSG;] 2 ( < DP")# Xa=f]-Pelf17:#y4`T4L vtmv5\U-ǓC݂y"-kޢlXNLdĺ"HWX&=|(3q2 C+spW3WɊEx?@>𝵅ģ`'JnFQ驢r|1`7`=T%֏j:v!9u"EOa?Ԯ 0Ͱ!}fr2 !rh$s'ÙLJ; .vӆص5ubV]{\1k]aʗa2GP| ][Cu`X{_t ?b\rUـ`uy;ϫ~"/jE<1&C;Ԇ0HPSBAIA+&k(Op!uz^t@PRDSIBRd4_9j"PD ɓѹ.0J]Td=-c{JvоEHH'!8=}{)A'q #帳3.y8L h] JiVnvn[ɑBpM:[ZFHtJOw wc*]; \XW"'Kl7:hq#sb3;kL:gM9y8ΐ" @BE#HޞTm[5,HJBW]AH&mD37Ke6[v^_73Fi~vwEzN!YqzܷDvqKzh*ꐓj0bgj~SA7"7)gopimp 5scDVc82F" UP ,%'^ÉL'pg#LKOdN]o#y[CYv(>ϵ MJW=uWB0o刌vgv"$@p[PEK}>8q{o?V7^}r{I>`O]M>*cwHT'3>H{ }:Jrawd=$vO-V#SA *N|ẎkS~ܿ[`'Vt X|TG씦WSRC>!Y!2,h k)r 5C~x? &`e5sb3dsylj !D1W (; s1*坪HRr]#Ѐ.(N#+`+<<vύ)U%* ^04'9| zy`>o_< `6y＋V/v 1svJ~5Ęa%AXlKE>ټ{Lvd iם#2~p!Z/)1ݠ1{]hc|M' ED@~U0nݕq8!fD`{<<r|Q(։xlܜֶ8͵ɠV3T9;\)1gd O(ؒ{7vjŖ0)0xs""&"($b$:%_Wb &| p11?3i?Ms 6I*@= ,+A!}yi0}T^98>_ooiS"R.iAПA ~ Pr*ߗOQ{GN -q 0!o>&9B%l)&z@$H ?)p(]KK,X9q= A*yQ~;E7chbE]_ȇ <#0kv3"@@N5 f(TြVHp0\xx4f$?z>oMLI۴KJ8dl* 'K;28JP:DOL|~z^ :"kP ``8aœ[38@t< 2hʔwAr32lຆ4WXc9Ya$tCC@85Mg!I2I#yNfiK,Fa}60eB*Zc[cOrcr4r7:p5ɢ#E%4 ٛTLGŃUZ6#6q 8eH))+3KvM@Fŏk(F"켡Ltp!&9aKHD.vp&ÙjY5]+4a֛@A C m=G ٧FcCPUS K>^{h(QRCp1 ݃b8MLQPtP4T'Vk!Dv9PVWJ1U ATJ8ioFnbh0+OI1\E^ckZ[6u KO1S9?O2" X\; =:4W50k<ǫ#a)D6uAfk,e LSj8*)&Ю';Ώ4\]{%t`ϑ 4%SmM&lFc{[`Pki Z4HC!h91F#BƒLQh`dEҩ@!qDKyh2.C{*,mEBC3Z/$<s]W $FU֌D~a =sE{8q751ooO#W%i aa] PQ6pgdB .x  ߓqp0ks\j=e'w41m/AlQ2kE[ D%CP{{tYy'#}u4d[!a:|r}.Ϥ( =u?Jb+2 0SׅUX>bxXFTݹ `7>^zlDS/hQSJrq!$NZS\ay)` 1-q cG R0ؼ /7#0Xa伀Ӄv\]S3ǎ1tpQ $ùO>:kD@)@"`(t]yuÃIW|*=Dsǫ $Ϗ?=C19TFB0 (}ښgy$H.oܝlj˘0$H2@RADHTTL4-@@BH- }Kӕ\MɪbHr i;E1@ sƵǝIY%l+w0l^=P(?O1 mW,0-0۸<5?ÔMlg*#m=Fc""y!F&%&)ۧ![h,4Q%K qO7c>ҟQE zD!W "=rhh0Nz7"@B }0E#A@0HXfAR`oFkIqLJC@A ⤠uH\$U6*@j%i(͖ G @ţ O_0J!D {DT`@+}>cl&Gp먏{yb_g&:ɉMlI%T`#0I~Ue:I˦ח<2+w/%CTA @Gx^K!& uQK C;!`jk[&b M@PRz3 -K%̭3YΩ(֏՚~( Gl̀ҸO'%8J^Զ8c4ELq5`BB :x|\5SJr2W!NAd:!{vn׮CnV; `̕8$'IGNĦR!Cl @coưʟN 18 $C䩀I!GϨ臋Pe0N*c(vYg3FM[~"y4r]J4D$JD˔mlĆ%-w:n- ha#8Qnت*卙 ԦPtW8&N,S4)XD! ֌CDN1& Q"!^ExqvqHa_ 'I`J* I FȐJJiTN~/x$9>z1 ).$[Hav bHveL_hH04*rqш Q`Ar" tiC % HjIሎ6wu @FLDp_܂&;~] (%B@Do֎;w9O=\P ( g?SQr^809v?`$.JzE SBO@ ~!}g=29O؅ЂѯS]ֱTD1Mۥj*&46Xbowhֻ)iD%:{/ n#HUؚ( + 扞!0`v%b;C肢s˿sxwnVGz2HU8yRdE 4C MI!j# =z! A)V @#@)HPQT a@c&'QT8u{ P)HO̥C:T/TmL&>IWC*q@(IDp7?1UD`OG\S ) C$/ܠ?O þ !$\< ?(Iͬ0Cl(5hLI3ps|>}*&5p b"I,aKWLE-y2vc4' #n cRې9#=:f1j5p3lIE+Ri@N䃢 e .@>phGw/v}fC挄t'.aȁg򛞞)nG H(za_4eB CB)IXyv/*)U~"T~!^ES!#44wѐ"CQJ1ԀҡFƔ(XJ@`C H2NEE` LJ8  a^# :3ByNx#a#q 3ua-f?>` T%R ăљ^}P*jOKGWayyOrA)O4 8QURZL’H}B #e]gC +Sr#,k善NSUˈ\XFssV&b&Gm||4A'<؅@@ʑ {-wরIuÈl`@٠Ү(! H*@(o1Nl܍r#%pS5qa@+*n r-14GFL),MTzEYuFicʪS?>NM'cJp~RAarcPcbq9%sqIg <z5nyBn8M]%Ǧ96Nx!Q+ xz q^E 4DPHr'+ؽv}ФpCV^i 5 [ XF>L#Mz{vpd tt68eDpᓄzDmUX.b]L6Jv15P8D.`\ƪA3dž]-/#+$Z,up>ƥLALl?|tyjb iI4 JT*P`i 1P:EP;ZSJ8@~:u2]rmTQ\nq%zFf!lfQ 4@2H,!cwi!S~X+de; fC0RZ5-wI)ALHHrCjV(70EsE80rPUh4j(9nOOp=g'HiRdE#i}#m9DZ yo`Փ0̣uc kW,L8f iD Ml;c6R]m{va>ASpS n CA646Q}J$W"Hױ4! L[4*TGb9v變{ᐝ*U3IeQ$׀!׊tQ53vߎ)&97mz?udfzr6gLXB}釓\BÕv|k5bc\-:'!oXh" -8$>/mhEj" oD|!1dK`}CEDsHj}ܽP# /*hk)t19TVh9yMn@QyeHb>D0 `U"B xqPJA!d!0X$O.]kTauUF;5K&cv2Aani\ctWEր]̸HU$Jih˖9㉆t{IQcji!V@cTSp;DÊ!+hj`ȺPiOU =I쮀;,TieDDDΖ\KJr)cyX>' VW 6#5>/pt!1FgOޥR SJ {ˀ^?{,Ƣimq;1"07}!R@;|:pn]LEDpЄtn ֣vB-xwl)w;,E"03 ]V M5(:Aj&ۉa }QHFQU\5ۇҧr&/bBq4FCVCC`}y 7 $sjZsHbmQrF~,n%$v.(i4 6BV*1( H3ENC_;>ڦZ"5LמfxjLm1d.1|SaA{^GsS1Rqhaթ@D-IP&Ä̮< !QX"RicpÉR5 Mm&5 Q<5y'¼B{`8P%(ā E;"Ob>/YA""QR$=kp6ǯwit槗 /wt쎨&OzhXf Q6F>g=ԙ^áF ecj8$2^*. ya$ Z d>=b9V&ND:n7mY8S-ˌǒWDB [GJG5V:R<6L)F6gP4=! ԍx:j0&-Wrcടv$4Z7],?Q4ڂWBatT.ʮ=E1gOsj1?qu>:@n=盁r)mIOh$oeKSSuCn$@߁SIRokMXnpu>`IhA'<51uCu h}V`hB)nrLD\"5paLjoyj"=Â,Z1b;G]xO2)Όj:HbK2#=MOuƣ@S@n09/%`qC]E/3- #cJ= 1o(pۈoSERr0QER14"p?ŤQ8ܕPQL@>PiK;$s4ն5i Mpm+Q\ܹ99ibr6 ˙[)FB) Qƕ2]E:Y-\.k3ZKS7Iqut%w,fU7B'YywdZ,E1%u?S+5(B1rع ;eamBxvwaArye>4{/D@)N\8~y"*]0(2qA$5GRa~Wk:J5]0N;h} +7!{< Bexօc߈Ԑ#tu-Ά& fiNcGzr~T?cb@i+Qlc^ОQ^gs+{_vR^a9< ( w vĮs6Yfb Rb#~ * Bb*("B(Z0TTLrNhuTSQ5PTA-0$G-0ε,APCHN\bH *[ Q$D[-""oCDD4/@`\:Wv35.Uccf*Ɖ{xȉIHL4K8[R=D>\xħdb퍀љudD,MSLTS@QM^h)%fZfcNU,` RⰄS, M49mxy y ( s5i +ch[)f "ij9\&qH1--S:sU0r|@᩺laG)aCa  Ș JJd)*Hhb)hd&(ba"*|C@rJN6"éq2/*m!AOeT͢"" $Jhf)Jj(ȶ08X (F*!džq( )JZ5'sA͌p6512x:!iLAURAɧh8fs "?4<;t> x8&p1v$lޥ ^p#=1 xAiD%hD@O:S QB˛ ^JPJ!t'aHcP4 ;QFTJ )FQG vjkÙ97 ׺ 5PʚbW657p9j y)<U,LPmaL\dL/ Ci l6~_.#AߞIJl) ZTpl|f1$.!Oa_H#%RaB*tA4q/AO=F=+ZcpR$ؔPP a5 o?ס&&GB:}4TOk!ЇHJݮIt3J-3 )f4MFvL5sMAw6mrQP447'>>e :;p`'(KËTdϛ'x 7$4.d|?(Lw'(|D"xfV% TU_ =x/pw#XPf0IԂA`p%c^d^%h2 %pcpl/Butx(ߘW{FC&wdqJ4< $, :F>-i2F5[Bv]7n%Tsqv O,GQ۹R8[P%F$DR, q0X,GiE^hɪ_l8#Dkł/qM))d 3- OG܍._T=f'pQg/q@\@N_Ha{?/:|`&͉$Џl Bz 94Sc@AUK,A *$bc\[6FˈbիZ#io20MZ&6t8Fdpr Nn<*b.aQ b $h< >B!P@*DCP@~eg~פ-9t]^@^v |Sxo|s zpG,- {k/g=ZkUS73?o~}׾~y>>F(`c@n A+@D{i j*Zf!$(_%5"5aloaI(Ҿ*ENtA@b!Cާ4I:b#HC.I9a3ۅJ}>xAwGYxQT܋.1ݼv~FH'=$y JLhs#[.i>'wc=!`dмx*{OUwH~$7Yĥ=qwWt>Ix{XѼ'({VFQ H.ݬDggF vyLpL>5 B7$ ?`ТI-?_ XbGȗ᫶| [a$ 茐@)C!4b!`xB! }X%xK৽j^㡊/ͣ >/о+d"2e'wb0HAː4̖΅r>Btpoѣz~ ~>s$@!i4SPFEJb)hJI0g>p3 5D/CЀ"HQ29Ax24 @-/id O@~r5ȨFb(v]B̈́Z&i-!ܵl' 5䈁 PD PIBPJP 4K$(ʔD-@Ĩ-"HK "#"B 21Lh  PS!\Cs>nwn !D55A3cl6JbJ J6}9,Uo_.Ns:iӢ,LQB<m,U\A>?<q ?F)DGiQy2 ؈*!S*hitb   %%6bHBЌl.JT @(0QBi @>'ǠxC}h`:Ĕ CAAm@`Є di(I߿TL/Sx:(RlI.p|16 *P? pG{/ Rh(B$H6><^O8 |pN:E˚@ZN}b}$1E=3b|h#_UxOsĹE0G\tԉ3܈wD'Y<&zah"΅380^\*c&͑Y *BLș{- HRH$tå&8Xq!hM4V6ii( Klci*ZJfv5PLaLJPAC.e@ҁB(NSQLdM&h"/p*Zh i PlDI: gKh J59 mRVtbDN@D'%V 9. (I iMBU JJИ bRt: ☊fX9BlD1!0$ɜ5)I!ܫSy )=]uuyz~̇wYuɿa);rEə@ M?|\lB 3!Bm4>D!٪J,G5dVL"$ק ʧM~l(oa HI~D@] t=K/lil& xJ͋rSNG4C P% ]Hai$u,F`$ւ(-:Bm~\ W8B3ۈɥmq:?ׇ?wI\/0Oz"\pO$oj^PxjͭL77gw$Qln|dO,kMv0Z񣈆+9r*.8PtIxnD?mTy642`VWT;^O:tvPiZ-h)5yS> -9Y~oh$ӵx&FY/x˒02aMbnSE[H̶1'gI)&R}mKq.Cu.qhzQR1)Z5i;O-)I1zr)}.d8EǺԹwA:0v(b<3!jov`gR !kbЪyi8}]6/؎XgCEIޙG](/ЂvB-O/En]iQfpx,N)^ >ƅ1w\i=-jTGTqKzX{tL)͐lςvCS"mbh+}B]ZUس:Q׹iwja) D)Epfb8sތd܁K2zst;opr/u@Pe*(%; HnhN~j5rçYW9.H7j] mvSσ/?01qzj ;Y8$鶿b94 |0YE=-+,~cWz)͂zkhbʲ&etτCڡ׼*3r<~,M@V?]ȨW5K`6y؉BL 4^(Xc㦭 [ f>21 i L$z~$QcVB v-Nl^ W/=M6[u]a'yDX@(랑bË8{jis"#8񑍫SYy=29$ݚNLfw&ʺ5+^:n$‚8S|V櫣bwۻSl֙g@!vyɻ^(L:z2EJc6yJ~_X$xN bG.,Z,aZ0DrlCzyš/IJI1ڵiϦ9]0$$Y|qDsjKBf(4X'wIh21;b1wp)AdҚ<4M[~$dI)JtO9f2r7]@ɡۣwtăW65#LnUUQ(sddV'fQ2p֖ XQei ]S[/y{"rT;HDڴL22^ٞCY멆K=mޠUFմbF$kڵ4 /=t C C7y; n τ)ē)= s~* d˼ړ^ow&< ,ӢbY 2ASNټf!Z!S!+QH1j1œ`0;S^𔴖REt+_3ĸTT畩9hU>zXa\oVMQ+X<ڱ|NU>+DDE+Jj-S' rn;n*0!WSE3UބK,+Bgi=dNNqc3mwO:l+as{݈S;G( WG=/hM;`KŖO9~×w۬}V%뗉.]*m^]otTneʗѱm)XL'x-lSޒQ6 vڟ}c6Q^Em1|֥ٛ9fI76[,VgX|:8R{Y.]bi10PUy05ӈr5)"KIOTeViL&3QQ3M˹oxi12g9|gŠZ\T˝Z`ɭ ?+N4% 77bs)عLNYbGBTţ&۰Fi[ ; 5a-U\ɑ^.! 27 Gtf=:1U(8b٘}OV|Ek8QL%j8k2d',ﻸܡXwq}\ySMP)'/-k9^Q=82Թ4;YDzZ񘮊KZlt܊8'|8h1sҦmQاRnZ]%ܶYӒ͈cr/'0E-Mڣ^`99ZUsM+V]keW^E4B-P:0w6Jg,Ma[74~79s7K"Hd$a:IB~O%;c <˩a5g*`8N\s]%fKLWN]0I2ی?`U1JNN" S.&<]ޑ~Jk^T5*'b_{9UKqXѝ*9QeӖ mEȹfTm_aنPc"3fY0qN(VĽl3=ǵuuXA2X*/[9FoAh\氌fL BfX[9tU͛mֺFY/GBHB]\C~L_.3qN%tNCTcm i8Rƺ 2ͳp6((FAr\ԙDVJi Mbqv?a\CDKT14U)fb =yEZ ɦcY9OXx5rmn55urqaŨu< u\SNpw6-XU|L&0u2l=abڤXYK rSZﺲDRS1>D=wctVi$ "Gtԣ$wB .~nlp\!kÎ;2:&!<9_dMxhXKͩw(o,,i,$m Xc :n 6MTp+t!|òPd<;|svvvޢ;,{ב%H[Lώ3Y-,fų>?+;̓fgjkTG9WhKU$ &t BV~5 KaW4.!j+a䑰D+> iSB4 /P1!(%sISȤ bG;ВUj9zšg&Vk5ei-G,3Zi#8|lqe<!1WUi,|y"T WtpT;z`ҍq *7@*ij4`rWS_):NqAr)*],('M٤7bnE/PMg{ VVRQm#h b$rF`Ұ2cL75[/_ߡ:eVb$x.5,@%HB6,`JtdH0C|9 u/I.99lipdA} m*(4!i []O1 z|Uony0Kwmj!}Co'~1oT* 7':1)J*) 3𬱆[;x=CHӁ0{; y$$۴I*rPWJw9|czX*Mmp%Z&Z&+ Au2 ˢN Y[K3Kz{OOg&HS$gz|~ 0p%v{6|=_~?xn2$dK& LԔ34fj"|F7&CNoVF,Q2)tkx[O6nZ18 e'\Rk|Nw8-ZZuݛt٬f6b' E7JXSJg 0D{PF&ZMU8R3>`TAG`x=9= xZu{OqU'LQin6ŵWf2'İ4@Gc'`Z,QE5bXk0T4lB&*AJDw;)JyXMN1 - |b"e`Tx`!(?YB]wc`O:΅8 a*E=;8!kHx= ^Ϟ2 s3@EXL!=H|o|Ф ‚!>SLhN(5윢f1~]j0r? ԭFe6Aݡ#;#'FI0MaA-D8!lwϠI50EK7ҼEih24q&|0s "oҳ=O hG@ķ4T,1PB #u qB9e }toax*pSʠ"K -=uNP0os]<jG*%>Q,FMz)g&%| Y<Ѓ穜 nHRҒa,u6t4o al4FO@@,&ܓm?؛g|6=Fv(@n r$I_Rc2: S'?C Om.ƨ;8hS\HzbDZL+ "-o[[w[68ܳC3I@6LcUaf mSD ѣ$D"A 3*( mLU/qx|e:~5a {{vHB|ɑ޲-6<o~}B=xm(bpC|u띱 EV,g<#i>l2wk>b;>"YOdg`כpϿK3cT)56Nj{!dE":Χv+j9ge98f aaE`/ ץh e<FS ̂KE9]:݄8@bbx{[)4|1}M,Hw'ETM"E_ˀ Аe/h:^(*`(@e=9W0L p F1d]}'%TB6A?cC~8 {^vOiDqzP&BhЬI?#T}>+ ?~!',iPP)K q: E&3 RP +*Q ITЄMSIj(IB`T 31=gWGԆx`1"&n@6FPpdmM]K \2-N@Ņˍ"٭f$r`i󗌞 |czH !;JmM//wf!=@<~"~ | Zw>Տ$F :'ߋ;M9dYť@_˒?ߦ?GfȈLؚ!u+z~<#Eߝ@C5 'Gz?sT JSL |A2ot ^tRCu<(wӅP0 w 1d *{׈pAaE)&C 9 2dDՔ|Qh0.kZ."wZXqW#VhffqP 0 8Tˎ0I0@s9roEwwS.UONXnMFbz)ݍ@p#cS~tbùL!{]'/<mz@;73EE͐tʴrH?$) fxz+W˽*O % m3eÅ?;.Kmk˽F,j7s)dIXrߗP.Ĕ Y%DDvBAC0HsZsmc 8~MJ驑iRA4֋Ii/1\n:ʲ(O ɬ1 )pQ5cy FFee4ۛ`M˕4QŪ.gG;5%@(9T54Սh0?f^lOB ipOD T#G Q L&D30C?@V hn?T?!5+*_G.w\0N#ʉlce9=gf Jb}#_7 uzHI__ڠ?9x&G}^t$S^?NNL~PQxU+ $<&8u[N* &-M*"FZK٪$51:B{¡] O2joT `]K.qZ| G&c1K k!?]nP\Iua"p[Ќ tnqa:yqPZ,~n (?YPs5w\5c3c8[ ?;t}xpAtYl5|Ћ{b~ydXs&>HL ̪8EwNΌGTɫȵ\HXffe;kRDR}0hJ KaQ.$kN=Ckyk]4k4NhWśLVxL5Eo\S:qM)X:iy͂qzXS 2p|>yG1p fś9a^Ƈ{S38Af{H*L-Vɧy:If-y(|ow"̬xoZL4o`{հk龁|itՋlU@_vS& Z}pQͤ(M>V9:p6\)6ZkE WٟgfdnD)S%> U3nQW.J$w3mTsSmmiؐECQŭF# >ok's}ƃ8$i6MZ>7kΣŇ@X}!f^+{m-/kf9ɮM _N3g!3bw굱!BImkK-Bկft1t]/0\WӻDm"=8>|e%#G¼S[kbC9NBgT^dmkC;V`r Uk%a; [Q|U.L]WYqEwpzHZ{;C&YCĊ*:'k:੾FXqBrڴ4-LFFCC2rCFBh:7 sηƶaQS"m8F%B./9KW`IY&Ρ`>%9i,i+2;KgC{hU8jİD]Wbb -/ac*5XNUڭ2WM592ؚB3v)'q'VKqY([ABg::\{[5ӄZ1R HHY`A0DF!aW bb8D3C xNa*$Q&4hX1+O.DsɎ4$1^j=h@&zJR*jCVč".RZ'q3h,PI6jVvgyLo.Unm^q!L 'H1QeAW^ʮxNj5IX=:bZ,FLBd֟,kk 'w֞,sBݐ,ºa962PE,ZnάmD83H̱Y4e2x.[؇m1`k1i7!׺\Bh;IcVZ]'\!@)% M)..ݝk $ÎC3e35\53]\kVht3D:b蘽b L}{:Q\rd7-47U 4GtuB@Ǫ(9q z80H&)lEnhMlfvk+71tU(0aqaɥP"B},XS~%I!_#!v ) 44 l3S {2ɤ C0'4"PuB#xR>8Ccq EDOH#8ANBE/pzKG> ɹ9Ӑ#A(O'6 Aɨ(89hl1 JQ耤)fWT"BJv,J!A )B i* "!ivrā@1%510&-"%&*) f B&H(lX& ([N)$&a$@E*JXU"jXHaiX#pǷZ|3I} g% ']U蝭`“ HX>w1:!9A,!HJPPE ЕD@0))J_5l#wtBSGhh%r$7vh #:+PXpҏ*ddI"e ݌{SJL_el8"AA-!GP]eyGzbԣm 2`v8 Z6 A"K(.wN&!MOc;Xq1r1 df@`.` 1鈵kD#T*QEdI@jL@ 6ąygW5塬v7-mnU[Xh[cXFVti^⍍ 'DN%`<ثdE@}"\`AmVW'nP 0(9lkf{ffT9 ADjez,v"G h NEȡ_>@C׭h^@ߠY(bDd5WwoWO|d9cX2 4bcbF!YH^"HާxT-q>=fAG$9=Jq2 zC'4tHTr2 +ǀCD~QY0 =՚.Ї͒.ք p^ Gˣ@ h" >ҦOqA%4 t "jP]409ɍ7;1A^pC4RR#ᷓE2\(q#=}^pQcg`xGAW5Ws݂VִdcZ 3C^cK\0:  9$GGsb7R@()B%U;C-4I߲F0&8SDUS"!QChC1.y0c!$\ON~ Jb n;Tēm^<^Tp4(ղo.# 'gz{sSuQ+B#EIhjiɠ ]x*Xg_Ɯ6546<^DSlkm,~{yΌA^|1G&Зy[H @80󯕊RT!{aQXhd@gx';B\,^!?.&"QlੁpS4|\d܁NIREM)M~B!xC(BGEÅݘsߣw(ґD |*XJW1.:\S&Rphu:!xI}rF8\ɮ\c:rxG53fy:H"+Orf;UjWosi`͚ * b>9Wa88l+|SdA&Tw]cslG[n+IG;ʍυ/Q\ΜGY]hTǘ1ȯ c˅4Up;p'xw49g8n"͍4W 2ݱ\G";c@]GEPo^cx! ̒!:0{@0 v028 "O hGC=;2GY`B:M;$\Tdzn* "^;7ЭD͗>Ndcoh2娡]Phb'ƭ 66֪?[ !nEgܤif" `ƢHCOf&l>+=nE)aYWN7e 7Ӭ)AT+St% rwQnid˾e`(B%6N:/1bmr@ΐҙ""d/\JD㣺Iպ 6F͛AA%]Y5!ۜ+Z,dFis ."ckH,Pn[ lۭ h*!vvdzÎZGlViBYE@訨`618!~'`&B<'sRCc;Nvi*R"$gnbG q +*zE:|?|C]HѱzTCb[(#ͫRb9K$MR}R}ʹ(_u ?1~gP.X\Yƨ;_ & Ii X9 ♭$qz`ޗ)MF2+=z—f6oWmbD6>$#ڬ)!!EoVPΣp䑤b`"( j@Ё|6|"p.&#s)<N!0f(q"D(G!:ad" ]y2|I+$@Agy$ A [m\4A(1(x@/ `8 覎stwt, !xH꽸o&:6A{~O׷zY7@R2ONd Gf;pBcǽ0/54 @k6AL Op yDU[+_]YU %hYkcDRyWf*jgr&<$0Cps'AqL 0,(#e!,sXљ)""< rRL-/1<#0Œ1?N_.(t'p,{ >OD8^p?4{JȟqF夿JBOtLHM'3~ Trٺ*GDB?@!IEu>DvD JH'nAF`!ڨBmLmPHJFiJER$Ne{Rd!B LyV҇N+pwIiLJsQǽ$3h F z/;k&/0qË4/AOP>. }8?O8ds>N) "$!bv6T*]E>~YHILNSHPE5Dt^`8PnJ}2Dß)>~}D2>_q@'A}BedI`dxh5C&f fKD\ Qmc?ApDU٤m5FacB.{=',f( RkP$G )C͓1id(my}I!R~.>Q8=X?CzKs+r= y"F"E=\E, 59_08!1:{HnFtɫ(TƂd(m|dbot)8g1QgL ?AvNO՚mpSBDmtJ Mqg`[8(!E,,rlf!0B$H BS˰(U"p 09`#l D@ACA/vtC*k"_jWJL:;;Hvf! 1/>}iw4 i@YvȻ)TGvxn`׼2I!ϓ Ez ץ{Tz%~zz: Ӡ_Pq?IaQDgCｽri]-ut$Djxc1Bx!2[J(у%TRDMQP >A0fNasi4 ϖ˲ #D!H &Rv9Cï]EO>4?@ܽ6K=)<@O lҚlL YGXf ԟEUR?#2a)C?ٻ#~G GBnaiAɧK=kAx4V D2sq;܁(jpkiԽ_aC<%O$'<>x2ZdOAA!Ҕ5P2ǝ : P^0a׈d|މ+1'^ C4C}yO3UY˧Ls;! F)P"E"&$ a(*H?x XF!(z}=w>aNv/[oo0fP8/\$?; sqbiizZ>֋ΰU13d;(dfldz)Mk+[̇tOd*θGө$cm6qƴ샩M-qR/uzHIDxĽS\$Z* `%M x|`f4 2j#AčB5,eNRG ubbqUT8Ǘ PN!F6MbD;DFڭF`FHvBiȮ}8:"$],;)N#~9I13,\΋ з&# Ϩ#֐*ښFbe)(zJ{9Loc3(Y+r`:3-e=z5^jJf\k~C>V[E%PZ rjHi;${rݹ҃{n0M4$ӭi1oP<(DgFmHTt hafQ+xl8硶Q(IR[0+F/lWcx<̜Bs8 dth2ɖ1/Nz%5ɠ>#NYlAĹ l@̘9C w1|DCپh^r4?(7 Fu}z+-DL* D=WU¿),1և #n Kp9<T ݏ<|mx h0l8¬0lR#D"Cуn;U_Ej)7ENJdCΞ·NvP)QP(PE1 LSJ 9$aδDѾH%(UN$ݾlLkf ;{<}׬"xt7 v@ߵ5]!$՛ptvUZ`(9-ѝZGV%CYˀ2LO`dqid׍ ⻳PmάNfy.ī 05 uіؠabj)ﹹE&CS%DD` kpqM3FLiK>d=I9-plX}T8ْk3r.BQpYSRG\M0NV-dD4hWn5cJآ>V fk 83vB]ek6ezֳf L*ȴβ1Ve$@0 X81 ssI%haiBTvNtVȰ] ܙ<˥ee|+֬aFcjre-4$p~6:T4/1U8WISA 7[Eg-t& ē,Otq:3lMk%S0r,0\%[LCN|[ .JhzIM+0B=p3) ,#Uq He֙306b{P~5&tψ!_#ui :Z=',Sf?~vK)x ЗJC8i?]a g_aCæLJ* FߋkG0N`:mEa=g'AˆzpH}DhZJTD)UEIXZU)AbT!BF$VRPUP*jMӑ?wr5Ȯ?eiw!Ϣr^G|9<084oP 3)""P 3ثө ;΂!4~6t3.Pêfy⎟?ܡF]MJ:lYM K{ZM!`wfNQ*0c һSҗҮ~TbD}_B KAqx/W"v2[/DqG\O6Cd5o6%#`;D{͊AR1. ٹWꏺɜжDthp`L0)4tM m{ѐ*? Uץ6oup;XRo^מThbeG\;tvVĽ̓zͣq߁`4C(!ov'5M~r6!sw ~덡lyەt4d$h3 78z,O y}'x3D39屶_5ܰaKfinwsp@`aB/2$!x[úck5-eK/k߶s}~{m=76 hbؒ[2'QGLViA[xrهdpqy06R~B$f~GBӤG ! tey2CFE`bW8BP%/,ĴeR!+ FMtL4gՔwhh Zd*H&H9D?khq*#Q:r !u+ZF H)2RDH*LB H  P@CBЅ%۟Bcho=?S>nqE 塚(aL)?`}ޑpoK/p`0JF!Z@2T(ڨl]p@W}$wT*@la  )5`#(RDY΍ {u$QU֊Z(-ACuC``Pb3[V0 B;SxQ`@1 ?^ݭ- CqlYfbi­\y^ 0!_LFIA~YÕ=rp[y2_hBQHT~# YPZV+6 x9#ҝP.tR 1A)M,LaR<[/VcBsKR؀HxӅEʑ]Lk "{zÕruo?Vg"E GLo썕\Ǣf a  NalAs `,PcUKY 2 I YR$ݱb7fAҲۍ9 it?sLH ib ܲ"179Yw+onQȓ2 +\J?kab$ݿ=?@!Ma =I&\JDPi>!p^5Txlu _5+p5 S51f4GtIH!C3"}QSemQ6%Kv+6&JxCs;;Sk7uς1u\ŷЙ B;ttQ}xŋ(~W؝h=eN|afZ18G ā a1hR Yh:Wsm~{k^O;)fz>g#w#Z0H UI&Ll EckK$;oxt}ÎB>/ǧ9ouˑqMhNcnTX%>%Ij W.oP:0S;D)N(`1gԂ* c9HgRG컐Agl]m>C!-I6`l`y?tX'oSxQ?+Q a? /5D "r, 22SKߧo(y4!&b@F _<DK"` U+~|~)$[B_>8iʠN\ Jo/^"!p 䘔of/ُ/h~,C4,Ms2;qP^}C5)\>ڰ}!(51440t R(`t UrjoޥW -R S@*hhP )@J"^M@iKTt:khIQQP @u@- P MST*a΄ 0`۪ݛH{̝Yɫa׮iK=wnٶm^06A@Qdd (ɋn>[gnZiKa=l 9+{j{uW:޻vu7GjEs(u-@4AVzwvvzG{[/c.燛mQoiU*r}nsӾ{[Q;ݞڞ"ڳ}zg7tGTT;<_^$PzZz·$B)NUy=zlgJ;n;_\(Jo^vNm J\_{ 0|>}5N\ﶁMPlZvW`=zw*%ul}Cӈ2QO;^lJ)CMUTU(  T%J JPdRPRUIR)MrKII)UQJ)˦)K=[wpP4;`6xt{wOh`L&#Ɂ``&#M12dCM2d14iCF!3 i  L4 dib@A)@h!d4L!OhQOJ~4?AOS&#?Ri1G2z02M6ў!" 2j=2jc)2)4z#ji 43)zL14M1dɦCAFhщ142 FЀiMR"hѠhi6LLh`M&iiѦO&&di&L ѣ&M4=LI4dښ`$B&&4L ~FMdC&L 'M4i<4iO'DEO=#@ ҉2&QVdUS ) yUgMhQsns[EL9xi:ӁL]:a8vE:n'B%0Xc*M8aqHNJf9˖(Pby<'v:;aT\ٔ\E[QV`8|%R/J:rʪ@YbiV%`dEZZl Zh4AyT(ҫ}A"["mw jZlE PTJX*+pUܲW(R+r"*ZTe$H O쩁z;a\J+eW*Һ(o+)X@VV$x13]c(^\B%bUK/D "ߐ`X)YЩs e~WȤ *J­*+H+V±+H RJHx X(o @Ek}?ILޘ6fMsٲkP VLp Ng[ܰb1"`P,@uӋr#KJx%Pz hofh99"5Jf{ H "`am`mER П;"*XE%HWJN+I+LĀLBJE%( dR[J/V&0 CQa xd\;WY&׃zHDq Kd.hp 2wzn9#}poO|?ϞEwIVIro* wpj򚪮y߾본1'uüv%fc 1t$g6fÞcI6,gwG_iV9ꫮ & qVQvU2,LsH܍hBH\6o+koUn7[۝IĶCk$7p <rq9%6aXu:]'GC?\GOkg͏v4a=0 {1p%ɟ>wGڍ Z \4*@W/*gE2KntpJ(#V P9I"(A@4i`fjؐ$6%V#clM: j1#Mri4 Xb!fQ!Ն*`18]h& YhP N)ft)h"`UyxTi(D.hVE )\qD N 14(ldB*#gVTiJ(v%QPfjbc h<iV"AT޳OR-pG8ÀQ$ J5GܩnT \j*p R*{{c=(~z3ID#O >SW$*$a"b ١(` < (R`(bBY`b!&""潼!CC!u!B;uz)Id)"C3<3$*(!pu A@{+SKx{:L 1"Mg1dfH`z)Ba {܎$_$'s>=Aa/$ !> ɽ\1.[̉/."/EWj;aKr Y`q %2fr 2 /Fe(J*eMxWC:\R5d{Uy,+R{iW":L+2V.oI c1s1ד= /!~/+ʮ1R27ea%ZC X2VT'Ev?-HȇKiqu>Jrp̩{ˀiU{s,Χ%ZyWή6p@PhhV"(Uy v}D.2aG*z$[N%a` @+\+W@\J*!+*|ⲽ` YV` ZV@/J|V%v^M@a]\@++*_G a|!|Wh@M0FWWH%`Wer|1s**o>91oi*]6F4T*]U L ǡ9EjxCW+̚HUUTPUUQ>K̅O_&M$N$<+,D11, | _#^.wp.!vpMdɋJ(ʤ ܐʤDp1Ո  B|hWuJDD?U8:@32 `s9S 1NH^ʶXE!$%Ar9 #b$ \$J!&|ЇL r2#(WZɠYۀ|xڊRmX*҅!gQ*xûQkL"ʙPߚ撸SAiNltc|⧐@5'! Һ,G!VQ3UjX-xoOUmWю u<<4GY~G~G3I5NcdgUI C|ee0Wu®&Tz5R;vș{_f:dE?ǢN-%u~}\q'>RN>pųy[;}yÕ>G`?ܵwA:cvmW%cxq3X>(Ƹs&tÆ7mM~;t^vǪq禙!4^h`дAUJC+]THWM/kY s%BUu^H^HZHVT6EvPy^ЋAɓ*s;> ˜U˔2Z/~},W^h: .`3L,)B*eZ8P,繣9w9MWq#$t;;x.ыIw(h cϱd"I>։?mn褞q'?ұzur^xb;y1ź|ܾ<z/y;wdz?}`wA쇓GF?w53xb>ywzƟ>_0xi//>|&=ZIl-I,*WfӭBy{Q'x|Qǩ G8!a]<|(QxqF h@ƒCy')߇6nom\GCyثzy_Y䄝&Iz$|I7O ;/G:Q9z~z='i$餞:IS䚏|_KGq 1UO+7o{.&Ie~>O];,ϴ B$5BMw//&IK&N}Lb=|D P~jߡ.I|OYRAK ~ q{Kn_jG鶓n>&o+jL9ʯ1~s բEV:n8Ukd] 'ESM:WjnMuUQ8u6Nm.UWNKi:@1:vWɜOW|Pq҆ɪ4.j4K= S'<]6pr0{~W`YvOOWU&']qXgo`R7Nnp4l𬭛ő9hTdjTkG]*sZ^qg@_ zһQN?WU(*NScyQ;8nHhu?*;-sG{_|zHL&`"I_ E!ac$~oInX4R ۩/|$42LUqQsγ1܇p``GcrrGϏ~sCz]U{羵,yHEXeGS$ Jsë ^'LE=}h2K_p7xۮ/ig~UvP{P +!`` ( mw)$_5UtwNY?KQ/σ3تF5VgQ=tƥ^Sh+T;>fjk7xݲkEzE=%Vw\pW!/,Gy;z3ab$n 0|-Pu]9!tx0)ct$ 8|ШiDBBD >p0G(VQ_+5jlQC-wE8>@OPT^~vшHغЯV6D~⸦OW@h<Y #=Uq@!븸48Y1]$\=7N7 aR: ʼФ{-\| S7;" ֤.ȭ~\cYS"z>.Puod-*\Y>S; Ӆ5&N^8xd>cFۇ;yk_= !i{˔>_cP}>P'Ux1=Q"07$WkB$T1BM( SiGW!p n\L,~+ŽvxAV¬*Oy9W/~ yA7އVz>ۃMv/.Id=8=i}TʐnR{RS &+w'{Q #+#Ԩ\YрIT .uc~X=ޗ5VSh#Nraz!Vlo93h\J䀚UqZWGrGV8\Ⓖm`U ?4;dC'Ii0ION.WmnªY7?X\0yM6pǤ۩t\N{U/7ս4dpCdW-W/ UwƶOi"׻E9<_n]'8c\z5U=W8=^SpVWAϏ6Url|NX8Wh5 Yp*1 [I‡_ !>7*Uն>g2ߪ9Տtu}q ⷀh/\ؤU:z]WD9tf7VuSIUljUg`ƃjn Ƃ8V {Uf\^%ߪ#y[<ʭ\;}ef[K-tw}?` y[VKMd e{n=W7Ê=_ssö ݇j򼑤:[]WSjHUpUrUVCxkv<@u#mVqO˕uUd[*\8`hm˞ ln4lpk cF6XJ=5dߪd;ުԋVk]W%S>r JƮ0 0l`wpkuVEpjE?q7U`r;.k8Xc*eVoZ6%q_~įeWo+qhV[ Vmuo@F˺LdV¡ ʆѳ^}e5_Ƕs۴,n(UkټV\t_|/{u;̊ޛ&cUw{*{q¸=`5ύ7U]N)7>yOj|`qg7U}lx1͙͏F2{ѥo ô= 5:5pzqG+~`pAp=45N` :4ZVmEoO¿XcX.ny/CΎh9<r<}b>f冿6\=!C!D&g;JC ]%r+xG߫ٶ* e9}"A !ni" nM·O wޮ~ҠpU+w.έv+|bW-ڲ>UCp^go n_ 0W* Uˀ&_/W.W܊^C-ex~t8sxzn-hҡ8^{Ko٬n| ݻ5^DcvhFUr _zp*ط+7sx^!/ƫe\Y]y+d :M~y[0~so X'Vݔ竹p ϟ[͎;uV>5'/@NjCz.'ϊϗV<07w^Wao}Pu#k[_!=ҰҦB(Nshjo[Q?jTِʩ*}`f]XW>u {G~\T?_sPWP>6}Xu>0nj*o`|Evi j``U ǷUϚ>vx1ƽ>h_kAM*!OUiUw 9#Ʈ5އp/HXҫ珙3Wh6kiV?{l3*cO[Ɗ_ 6m=hP6om>Hf_ tGOAרjWWVdS@-l*_뾇-q!,k"" DR)޲PD(?fbq ,dd ju]f>=՛=n;R46ٽ3]SSc,3-W݁5>PjBCD^RҢ&E(1RbHAjanڽoEߧ35lԏ˟lkZVcG״'@9h)1j@oOq@Q$txC6 l{",AYTYQXJ2ʈRh dDHFD%dR%& 2JYK (KLF!YJbD XeDIE**$U2z4"I}|W+kiW &$gC$BI2ħJ C$)$bO$K2& 4Dٷh0pA*&OP`|'4 U +D1)YNXB)ƛ@Q@tH VNd=x O o`JAr*vȢ-͕>NqUM\y|CzIW iƪX1ZD`ry8>6>Ըak~dUE:X؃@}6-Xi+&! ;HuCXdwESԺ9Epv`>^,*Pj_@p,su&"^O=׍u8Bir+ Hg9}l:զ7C $@_f%!YG/5>i8$"!yw| nJ8^d.Tu1&RXbaH<;BA,`ɲ#,QcB?ˌ.4^-~&"D+ზ}IQ I5a%Vݻ;{n JvV%-T2", p˟ys! &XPtf{u|ӂH~AI%ْ/ v4wDr1(?|.78}noTzuyxt/G[Cu]5D oD1$Inku7*$CVC[@ğ>wQ9,eNO'<~Vij wnd|ƬMR+Ęz)z֬3$|c$П!+7ٛ66mⶓg<>T45] OO**VP@t_kn\ ES[9^>{_km*}=dB!(~_{/C@Q@hҙ`y?xJn xB wܾvɗ-"+THw0i@Ӊ|}cb SO-!%(]C6H܌ 7vVE4: 5\;zRʮ0=vcwUߌ {SMPQAE?OOxC0n?7|"6UU\"d 0,2­|̸̻ۉ)fHIG m>k"D>[Hܫ 2 iJ@JNqS7]Qh3KjEȐpK@/7J).&r6ٽ<).Nu:=g:c-3bX{B( W^%APCA'<"VS2 U2e)&HALJ&%JTZ0e2Q"J-Fj)ZT%*LBaJɕ%dFdȽ FTS %" JP=p8HIeJт%"ҩ,@Z="U I,i%*HLD8)BRzvQ" YEU跕YfIS,aVEp`ްHULA4JҌR4LFQdX*2Q*KZR !^D{ `ddTadLK R2B4("q0& ,YK d$ HDIX(Aa@eQa^݅ %KVa[SphU+*hȌ ~'t`BP9JH N `xCdxp x)U8S*PEr࣡I\8`MR@L y 0Ȫ*&Q*( h0~F  ?]庋&䭳lgqbn%mجb|Տ5&/sI'U N,Ot@ݧ2Ϭn7TK7T*IEʙmU4'XPLBfDO,kmZ02fL `S@H7Lpab Q X g28[;Z(oF5-oˋ fm:hgt.g}BO]hDehh] ZhcŭbivoDp 6\WYI#$7̎ XdΡF{aID~4Ǧ"y;=(.B;.+o]]bbTfJi\E8 nQSS9\՚UxXjj!s1lL:ffa6s)fsQAÛ,o~9 k3squVȤS׉boKI9o⠂b @КŔ[sUVa4 mV$2(OWq^ezm{SrT-Fm\M3x={g~-M\+P[+(jB??[LJ^GEoaKa()/e+2wJrT/ag=z Bwp9'UD*DҀl N@{@6I)LTĬI1T @*?~&ABD$49PH"PYDr]a}jA@AkM jEk(!Nl(Ք+dRY zR3*C`A YT\(]-TY'UzB&$οc{?\+$ՕLEN] \avw, Ď~+ $oC}|-a .{_G+^Z*)”:og?$;fWozY;{+H.("95)P {ӤQ:YxX+$Rd0}PЍ4SKfJX,Liڭ*b+ۼU(l Zt`DA@HH$ D.BG|֥ƉZ۱[ˉyrjKQ#kUU  \j>z~_+:sr<Ҳ/{ Qi*nU[]5ijsۨ7.HWTc6SNWӇb_..s =R@ +!1QBR$kE~OJjʊ M/nd4 P%bP @bb)}6:7YTⰈeY4;A+x9YCWxpD׌ ^9XE;q[+:tPⱥh~CV rF# _V(J !T!PRD@#UHS Ā"T(,RB HB$(AI0R( 0"BHRʳ@BHR4#E!;?VK{No`́3Ƥ*nPXV̾׬vF4y.lE~j}@$d@>;\@'量GdHR~PH/]f Ld # Vs]C-jbުG~c u<ǸS  U+"%#T| _R/9vkHeNp6qt]qsöo[ i6 U꙯'B#uzH!` < ^:h ti{C6\z_֖,2ы Q B"|C|3aPPK@gUf YJzqB)"ȰȔH pBVC$ҠT@<]t|Wzrkp$2~'$9e Msoq!ƥ}#c`Jtf]ƒp;RX~/R2ߊbV_BGɟap 3V.IiU;Dhxg޹{-N+K{ﺇ-yuO'D=lK>_e՜U]Ő$cjCd Z)C2IIICI"H1Q]'=8{+YMǪ'*k31Sd:` ]-&D`p/!D=?+1D=E# &̱{vf3bH,D隘gWc>%$">~b1B!Y ;ҵ:Dm5v 0QS<Ϭ3}t #o"lj J:!ed iW~[4?>8 E4C?у_O%`ZߙmglzTK%ᄾs*ɉTgmN+0JtH8/ӟL zXD J /I "^HY 7ŚWAg/<>͟e79GPrб}T TiVD@P&H(/vPzK+,WݭT{^';Ɔ:ĸ0r=r |HǨ z$yr ŪIdd̿ÝCjp'֘>9'^S&ƧO4jNNs+"nr.p c Mfvm ZfZh(kFfj% HQL U-j(^A` ]pc{n R @P D~K@A <`&e)h>Dhb!v$GQ,);\D{H=^"SESMU}}T㍵WRh&Ŕ1$IUUTG.?= SӁps}y A=  A4}|6O{R@"a45~huȯr)sUFa)@.Ь6LiqaLQ;׬sJwHEdG,p8L|M|vcVdqnFp\{?6c56ڋ?pS:ϦhX6O\#&w^z*Ƈ%Կj E3d~ lHIAȄ$ ^{[ŢVu$X~'SkJc@ oÝ#nUde)B}&}"?|^j(1}eoNRyFēHe-Y{;_NWT (Ok̉d=BSAH[t}J3=*Z/⍳L"Q=>/AbT;΍ia# q^C¥re18ރ _p Au\,G%&oA4ˍYw@H')IY;_kDx\P_p (} !=}UiG`9vYݖu?h?v6|#%9i@: I% )I\PeddS"ȲT"$er$C JEP=#e0QY&Jj@l,ףh·b*\M&o"ig".Q{$/?A3T2^BVnW J"H( {ڗS؟Ztuq=Cafm'Ｔ_}dOO|ΘR\O]H/Fd#TEhGnvC z'DL?{WM:MXPSH$WyO '$f̻.dZ,jiD>I)w@`j t&Xp>5h/;?äxgCgmoLn Lx[X Z"+J62Ekx3ubP$L<:_u ǛKkɥOݷz^+>s|~Ј z.&'ظ-3ek{oD 2f/BVڌ+S2jnZZHBgRz‰ @`LDRB)!(HB3 ,ɌmqX H9 3GCX`$iY2 2eL! 4L@JL @\Pa 0HSH@ȊAfllpl8 !TRPU$! *#,3ô '_7z{Pd @ ҽxS@KRAy (D{9zOPH$!I?# ,2 o^ǖ2k7I]UPޞ*^Gc;ܔzͲ[?l`H*#wzu'zJk۩n |4^Lwjb/LJIOHܑ{{#uq )s2YFA/^v_iНmG]kmoWRT%p})u#_ U?oiiX(w@~yNț-ג``6AbXr8m|QCm v6LM5λ&ivmzP?\E `<R;gs?[S0a.cpByQj+*yf^VT<-Rfw9XDŽH7c.EjM_1MZtE@ d"pdXZ$6E.@Bzvt_0n[]_jvA\@%FyGU! 1 yo>R]Dv%ZAp`%B?%{Rzvt˺IP\i3{w=Pr@8,*&("컴H={,{$yX^/iΰW:[H]}>$!-ne*?w?j^]E}ZS͙@9ڭϲa\dP%(ٷ l@cV@GDW_Vѫ~/l1FY^??]nr[_owy&э,β ǭzm~_6 88 l ַ̪վ-Y !,Re; m?"E9LHy>hfFrHM23ėVM;XTW\>ޡ'~a[ V/ut_uorޏqK_f^F=}Ώ ]Y$!"(!9z !7Ïo&AJtMDf0nPj|!) If8HܸJcdtW5YGEÅ#KyUyJۏsղxAL8^.7OG"4i@EI!a1^CXt-G+lܪ }8 +"'K>/CO'}Ql=HTWם4|Z;tO-v:ɗ&P!'?U;cr2W^'2d XHPͬE#|7UmztcEuhCEECAƔsoH~ALK*k؍|l-rz?BwDɷSO.wRaQa BrDJ@'WVXn8kbZHU(i]L,QHp]HF7 O'{&j(25=7<z~{#?,Z+fWpRkaؕ>8]XzeO*VLERE\9QU#)XHW=@%س@R4!GaL(WZ%aJ,!qﶒ?`b1@|v H2 !u߽P @+2$>8K! !B`SȜqǮfPR\}e1dO=Cy`@h &:60/#dKO*A鿛>A 9xj`Iglg &U n}5d4f8!#Pb*[E[XB2c pT3ʧNF!$#5&L#ꆊ▸gC xIêDGQy BdG UDD@ `$H]DDe&") UQUD. ,$gE73qx ^OS2"<)?d_2e1X(8`;QX:1 LLSvSSU[l`>Gngj-EKꪊ(` 5S/+ÝM&Hd&\9)cX5Z&Yߎo˂_QB#OD$AB(:h2h8K>YP,Ȗ \/>r0+jSo:%[֚R.C >퍎i7uΦ2Pr f32T]9ص xkjygkͲ5zbe¼v,48h#STLp !:I nDf? fe3l"l933!6t&z%ZgڥFMZ˼5mLy[W1+Dja`b7،i7׺aXCӧY @ 0Q06*49tB|If(q8N* D./ Bk#?cs.&vę[aID"b㕠 C)\hf##7o CsZoƹh viIc]w:-(=fԺc+ _(EQ.)PvxA%qsy>nuH4 r;>[!4m(4\ iᠧ tюZۼjUMf8WMrcT,Bcw7}9hg3iӽ5O/ŭ>ݙ &6iƞs'\izXR@]$xܿ;濦U"搀t$fd',Rl ^#kNj"݇ͅ(4;,}Ѵ#o%HyD`k~\k蚭:׺Tj^yӈäTC*š.:ձ8ǁbs\͍m~97XdǫGm+(#}5q[6srcXB(KBǐ-~VOqX[ /.!MT@ |u]эlcclXÆ#'<8c1g8qbq^|?o;DDDDAC& o5Q:c͚m+9֧qx&zĺ;fSAW_?M\DK(D0 wF"6(* ߈yEiH6d7uYG! pX V{L^7#t"9Yy<Û 4'UngAX $B@@D@ .}hB9!U!:xf*~~gRT5PoS.bAq" ݄M_[\C{tC&˹t$;rL@&PzFչ\p.ֽکBDװAT 7@,sAx|*cxuC?hL6=Qo=Gw܍1P-TWKt. ;+Ia kBD7=kwf'>K1 oihK譟Ga q;A_vu+@ThjR($[<{'O ֿ* !҄QR00Eo'emSTK"J#7\jV]ȫ8,u~,jX$}y߹MS&ꆼnOq3zMwk@Gڞ# SI! @%AC,Y3/b1[?_kZFBT(FWӡπ pgo=<γZ=x,~&_cۈXkhЎLջF+*p4 fniZH4//W8+`.z4/co5j@݀wv(^;~φs[D @HAHBJIB@ D%/Zt,=!DQ%tXAGS}|MnU@nps:UT\kZk^T[X9sUW6mO;~b`Xq~9RfN-y~%X7;"i0D8B B xrf(vk$&Ku@0a~zh1Tژ ^)KaаNa-?;@A9kk5"/4|EKD#|&,$%ɑ<0O)t=tImL.lF*e |^P98 P@-bl肚| ~)ǁͱ,u sAΰ$bu,8WU K06So:s.2J8nq]F@S%jKΔ<=, oy(6[qһ1$T83)b29 4if y@Xjeu wmjh ]6܌VG7hswXze8,+mJMS^ҬVo+,Rzz%Sueg0IiLR֢."&$] b襢b/I|Dªh&if!%nZ^io%f -Pox|w4t9k cfc սy@{'vR;8!.W ;DAn'ri_V bX8fK,h۫cESAv9U5DDaׄP?ܧyVL@ҙ]mͳ1Ihl N=n;sQ,cKmEX6faS?5v{Zխn˷w-G&'hjȆC%;gCa,VX,:BRZ֌*6jѶj5j+kM;;9kۖ+S>3L+,\-THKƆfZMCiyu UxTw0wFbmR*KAD fd* ,"EX)6V>JNPh~!~@I艮nrӶIeŽp1hIS$[C߳Y:Kj@JOVjꘪ7=1yK&0j)wC\=ԧTb> ubSPN_zKrOq=Xx +?/WS;B5})+FylKpbfAҐ)'i_KiV_+v  %%i, b/ָl@$p33{5G|U>K+߻|}Tv;2!@'tK\˶NxbcMrw~vsKѽ_6?۔'MY\mV?g>&qoqlDG})T{wz[u=+"?l\Ur6+P<,r8$ wo4-Ww|$~ =_К #$FFIT*DEю7G#;zOKEQ@EĔQEQEz񪢚&hY*=ЁqѺ?`9ۆ"{Cc/Gb9F*S9$##A7*I %wcTռ9\=>sDbd?o凳ql`no5i>UZ9<ȃ_XMU+T"{jbXU+VTX;(QYKLl>&kwLMKҦUgآX-XU1[=^DRhK+KԴ 5zo1lM+YŜٸ::M}tqpV!Yvj`n۴b: s;xG2aV}plA\n3H GsVs:V0x2?]Ouo57!\vq? {<ڇ]'Ax,W)ss8Õ QcD q40>U,T0C%idיWތk7YIfXB&& +X*}'NwAYW9;䒀CkZ0⻲ݧW"khӫp-LCKUÍ]&ԭ/@$=KYDzQ]IR?ȉ!w w5d2!"?q:.  vEư|$Y`MK[9]%% =h~r޵ N/ZLiV(\င D'}w2Q،ueɦ8l^%D J<W, .ܖOh!z {@pP<#r]w$M & WGf& {E ]•e9s3F/0+'j"&ࠂݪ*Yd#i?m 49_1[>6[gӊh1˻ퟘ\Fyk1gzo-ܦj8=җ[z)kinzn啸-zg=˾nܝwʻy^ӗ[y<(w 6o Wcswwd_n{VVŨ0;ijlNf᳗l٤j[OVx"D4emƶoo 07cepu\5hh_^ۧcjkj%+f>9>įApӓ?ӳ~G+;fl%?zxn[xp Tu}/FWlx ã>o2_w;1ͯ}d6o }.MuzrcʓM޾5n'(͍欰͍}-g$ !$*5r@$ EwCbɾ_E@$ ֕=eRG<<MgmC y $?n.raM B PB $y~W߭UGW9_84` "Z?C6;hE@)-0ذ慗s ?u!K~G&"x‚틅/u=dCZ*8'mtDuϧ[RhKXxi՘gUx=#a|ϵ_?cmCf_ ~e\UDQA &ɐ>s轶jLЭl1xZb@m_ ̖ LYdp*bsUBf\>Vu՝}13AFkpw[ġffY+u\I=wC)콿'O}a&B 9kmbuVnk"T8&4u^7Gs6]9`13=Y?w_[훱QRbU؀E__9@/]F:܏Qo? UQ;r}(tCgɁ$Nt7ضNakĎC%$c'TJ]X5ESA2 h~xWdQT A ".>ߥ1(sikܟ o\bR ڵ:C3<(>s`t$O/.A G.p %4PT/8dJ QȬM-7U+Kc+wPC3uc%[t E7hp੄1_YDJU]P@pdĉ3Q*XAY3by36tFn BE8BV J W _2mV]ݫ Ռv{V70L.3*(SϿMqVK\G1z*v.Lg ^-<S\AFӯG~ I30}=qx#Yx^gXBO1H$PUʥUe! ZX>3fԴp`He V*PR*֢TMա)}[+:}%l3 wp=G&x(>fa~DE߆>qC$rb m'ӆræxȧ q%pdfHXR nmDQ>k]dlJda uGP8(EfENxU #4a$m-Q ,t>{9^-x̼&! ^1<}ޝ?CǑ Db\{|[ͪtzz-O[q]zܫw^Z-]ObmgY6g1.\?'@5L_M5{_be(T[ .} St*]م( ]JG濷?hMmhu/NfkU]A,j4@HnLƤ5T^\燵&9!T0JvTpw"8c"FoQɵ[o` )$! ˖Ӑ޴MX &FӃb^`qQ ۱r-bV4*C]%M^yQʾOoW5&:;b N=""=*)!4SÛ"HCIX0#e og,F~i[<ޭͤH~1-]p^;bqVoݥ R M4ݡgbܨ *يZΕ"-ߔJâdѪ/Ø5$d$$+|1]'mQ1 VK[!55{QG XS]2+ȷ{"e,ju'C=ɷ%PzlM|5sġ@FK7GMc1u,yH.\raJ^_Mzݏ "L)E[G;ރZ KڟQHK '\ߥ>U6dUE7R${ AHw S YɫTsyosgʴeZ*'U2pj3,#l[@~1X`]ij&sW8RrYT$10,Ymu1ʿ<(DOZD9^yOiLM6Ryަ>d`4YfN-Z5zeȲ=6n7ǿvp_w"r e 4(ըoqK6vܶ` iŲNPrc .ĕ $u[xI.AއhqwE$m'G o215퀑1M։eIY$Aեj^/>~ӹHx@,"T:KWBIRIĐ {$g_YE7CVZS)9Mr_?⻏3-dsKeY0f#ojB\K"Ω  aD2yvW7kfH$jM=砀A@`)tKpJ=[ +>b%Gmd@Z@H/P$Q*326NmrH,/= 5SF@N2ی]SxCKS~K4|/.͊ *VCq@ɥT%1K>suޱr<$(P<@/'27Ց-}Q:t&LછHqߵivLJw6lm#>5ilZmz,]%rؙzR=k!Avdui<4%Pq ASg{A $՚vKS W! 7 ==@C2qgWqMm;2ᥱtkCc\q27nM`)֌b#l΄=lY({J6>36C2= %g[gCUMYO559wwwwD;b!ޤD;;rY"owsSL)x͢ ؜RLUaLYJw Y[+SE8hiH/Jg`kkˤ2]~ZT5$:?#KtҳJ8TW'5t ƩjH(@~>5q@:@y3R )V \3 WI`X^X~(V=wiQޮb;tG[vr_9+=f,U2 h 4$A@xn}ԑ{0EҨO\mKFR}TWUZIE0 ڒl!$Q G;6X]pCcAʶhF _R.w09ed- ǁY߹rYdyھFXh3F7[=DC7 RVQ7GX/ēZ0z/ȿ_ATrUSM4TF>4u:ug{7AAAM4؜HD1plg6(glb-G2(} Oz.U} 8i*H!I`Xr(N" O5vJ]C6E xYH|`/NVn=N)WwSOՑ_NɶH́sU]Ɍ%!M|G,4e+x@Pp0Z|Z>2Tfw8.UN\a at_OZo~yTnH=QP;H "Qu힃6W#.GjpqSQ{+\R^0cuB^{؞S@qy0%Fhqs]TlШ{-;{t0sP3hxv. {]H,h,;FTSG0L(CDopx%gw,z{xS6|3ߤxuoNx[?C"CU7_$'[|u!}7s: 81œK-W~?>wcRǸqip;([ҎPF̞9m[~)v}VRx:1c޿hk&6/IywaKF/'tvS265"EG1V9^Դn) ڱ} ڢƒI6uձ Jq~̙8e)![ZāV%osYlRm%ewҐu"A:q=՛7 *iG_|Ӣk4(܆b=hAYS2{`ߦѯg%[nѻUVZ}^t#i<) C瞻aɢfL4LjIH6 Wۅ~UU*)SL%͋EFSkr7 *5+T͊'|z[D6,h%hVDt/ц~(p~5[rG*:lj2g[Y`k.g>0 g帠c:Xz9r?m*+,ސ. uZ;0aJٲM.t5HRq9Z:uq%By5̺ٓnn/XKnzX;e}Uno|5R,u*:*0E,|jq;m-Ff`y;lyT;1-y {vJ+^I8EgCk>,MS4^gk[>rӪL"P9$2;LKu%y2rhȢDcmI.oDe{}X}yoUPi}LzHFe&œB8ofo"Κ4U-ڱF%zT ;<9? tuwϤKeʰCgy^p/s3p=7Uo"O2E_CJJۤn5e(?4S+1ueQry\/p׬>03oug}v)/ +;vt<=O3AV],o*< ༮K>OJ.-%dwK(+~ϫ/u} UDjBbDObjz u7'.fpcT:tsV6qY?m(5Zzq}.oxH6-Fo0g5yfP fyBaHosaUtbr&*jiMi9@gu3|qKsyu7WPtqZ ;:mnq/?M(j9e6cWmق&gV ;D-|q,D/L+oyx\q0 қZPR~bn|3F,vI!tKcx]Üpv)c>/Ѩ)!-}"+oox~<+ /F26DlBڞz5 !Gm| sv6]^51[[(i:کK aWgVH1HCF(Y>Â>vkv N>Z||״tcAxmú0x9p_9ȖHMuG+S rvsbC*ؙpiG6qb) !a";7vRztt Fz:;5s YH--LR$ޣIz^7O7\P*˟7ģtlڽRF9S8YuKsT9x0w 3_N7w+XKP? /un޿H;G6pA#dE9_/"*F;F%ה4g2 A/zT#jb}uwm^bGE_7Y^x-r();?WNMDsZ8(߫&a&_PsgXC1}җY,B>w_èMe?JQnHp9eXƂe#wek~0TT@ (I 4?;bYА 5x\'F~$Ó>`/c g#K%eF Wz]줃PJB;rn5cWi/߼r) [{=@[!,@@k֕/`]gintM H;]˽uܛ{7y^& =1#+s$';P r!ΌS7[o`/Chf F1Xw[FRD(=?}wgh..p!?Qo)ׇwXE5Pd$:5d$K^R?^|UmߙMu׎?~IP2_ ApXR-* V_Gܶ@AKp:5Vb;U!F~$#c@i==Lq|J#i4jk[[!"iu 握etk^ssx 8y 7G GƐ.`P[\_?7pGRʊ}W sp)я^D +=shu5_XC NS[u9EA}#×},Epܜ׈/=cyLz/^޹T]gOW{ZKL){] z߽wE$@͟~o'>odH긹~1 ?ОM^PV>6A oBJ$,b_}wG~5F#/` @ Vgpnյ  o:{%xl8WLZFXVB$dv;;=ͧ?CgϬg^eꕦ?CU6[KTbd64OCl" Mq5^>Qoj?ntyJH}OfވTD>p}33!PqdS2-箟\ֱDs3ClTc--_PsR3f͟GISZսƯ Iz|X0^*%?>GJ{c&Gl0L^_Z~ p% I@T +a*|&D^5ƙ+R0PVq o*wFAp ed wf@A")ŧo'\XYO{W u_s#/lIqm;M -c M 1Xb1+i JU@qioP"]h‰&SV=];QמzmRO0  @ *//o$H%..n$H%ǩl`>&I0eB&@,p:G/-l?ɏ ?jTnJ0boPTB"c9J#k1@!%$$)$ (Ny6Aeզ-Pl]5վ- <'&yO ^[z %OwuX%v<ح~fY<'G%B}4.W;n`ߌd+gZEðRۑ+oq=M.Qfu60-UeePq+Őmd_B >o; AS[S$R <H'Iv} QCa.Nž ܻfsϿfwTg*,whL{0͗`%z(wjғmJd%ň⺒)Y]۴k'ަ_jx3o̚Epsn $ߐ= iՆP<ixpEz[}JbZ<QԀH Uz;B}g~o:GC:hA?sUE6c?yo| ;fyufus@ndq$}2 e$dY >`M6͵۰d.L;5en<2QkQY*'? X+1&s4Yyn(|Nw|9cN14){ o\+Uo)U7Z߁3U+@$Ts_ q6!-=-M R\L ?gFBz>qrX=#z|9|o  hB 'V@w:;qѬ'l齋ugroxX82$9GzXyov@[b_Q#] ~&jfa{d?;Dzz3oַپbvggem_~L HDwݝ+}f֮Fuo8t0 _ zs:դvioF~/-g6S`ddڞޒZ~yL$"3 Ac66'Oj[uRv'ǖc mOG¶@{VzxQDD ou kT<|s8ss|#XAZAW#-ҮĂ7ކK7.)^o,wOFZy$yq B jLVE&';Hkmt4P9ks=ߖYxN{Oy}XFR/tdoV5iB/MOr<܍^6(?_1MzW-xnF;knKWs_'_tjHy^.nz#qV UVOW9?~?|* "^>Ax ߔrV.ַP\^ `lW�p͜ -|(, Pŕ&ҿR^łgfhmZmKѼhً5-k cP>-BQ7ڹ]Jx=KS,~O> ʖ_sIW άV04㜚PϹ-;KNm_ҤV%_ڿs :u Ô5bC'97l֛K\vv2HE6Y}>0&p O`@=.Kp\y]Fϓ)2FO}t: "y $(# SRx&xzB 7 {@z _h%-~jv'ZˆD¼=^}Ɩ7&͗'oPG.V b(å( ӋO2: v^os)aQU*K[}^`*(!E8;4jmdb'bu L2#)"rtiƼuSSUtΝ KR3/S؍m̑ɞTr]G6TH"'Dnԣ-={qQJR Mpt4=0$߷:]@Vy9i թEʊH!%d$Fwq3.(iˬUpwNĒON#]W "1 :&o̩n*?fg;PC|^&K|IB `|s~l>^Δ 9,v=? 6Izy'HʶSC5Z5-kQ1 @!"!dK+5UPWK0$'~ ؾo(D3&iهޔUҥj2Tz'wjRky[.Ӗj(3`Ɍ)JSqy* MuKPHt$e2@B$@;SֳԮQ>Y5Y^|5 4qșrf&(HbMh{f1ApKQ,g<-|egBDTMQ!9Bq0$xX8q褠XA:\prajAF |V,o H6΀ֱhĺlYDDD%(G"("& b"(LL$0 y L]9)G!! q!BW?R}oA_! 3 5u5y ηm5[.{DD[??;__ͶchP/:>B/N%("hxy1=/ȉSE$4Q+*ozĻ{P"A>(DO8x`;V @tC8DSMA<>"=(:1 /#^ hY0h)ࡲ,Y52.d3XbÅ M50PN8E•.&b:Sˏ.--b-0sb:4:?p"zCSʝ)۩(i)~ ̘phC $q{T{MqC!`o o@XT|td.AY9#+H? ҧ!јfMhau")" ktMnwI޵tdUI޵"9wqX>T@{F7$6(י VmbB2 k9<.fC.auդa$ t!ҿ:mƢ9J,̬:D q8A R5m9P<wt[Ҫ纃(04԰-MhHvD y2Tݙh1K[Ց3JH&`v.2eaTDѼ< `ݐ_%CKĭLF:溷DkdcrbHy@2hwwxb#pDE| ?˺^i@Z֮-l2l7RWH $) G ?9v ؔYZi(2kz|! X45&f6]T v,c BG '̤⁧Xt\-ƺLv1}'32o_I$=!,B(bGO%g(NW+p=\Uz]Zq@tM-dHU6&zq`8$7pH7Akp"2@G 6y^m!Qgű S S|)Ȉ7Ϧjvܪ79BAZ3 8[wm[(n"~B"J),PQ{TA~o'+@YqZDιL  y[xGEMv h4D1EE_C] ;d.JJYP@xtu,n/ 򱏭晧sɄ,8v Ћ7J}}TunN*L!~ E:-ye8l@ +|Bȸ>E&49zޘ/8Loi ~pPRarvU>WG0BJ;BǤ\0p_-Ty?29A9rO9)dNe;Bg/Q ,M3}+aJB$Z(HpF&Ǭ(};=]{*ԇHprD[)ڙ%θA(RWw}f pUJvIbL'`'X,1^Q%Ó: c;a,ۓz*T }l|wHfDքNV)UV7X}2DQ+F{w+{s"x G|@}z 6սUo i>Wʯdc &i;'y޼|B砟W6 GiBB.puK/!>}Ob>nj T""|鉪4  &ZRj7@P!R@mT=.wY6C)js̈́wz;l:W*ys8P% dJ`xqM2ȪNpll79\ń%oIlK,Be9=bgpr{y+dR]* ,¿ 挌`A|R@] TJ 40NIIRҬ{-^xtlzQ}-(Ľ݇) 8겖SFs MĈa(| ~vLY@Es 1ˆd; u EO1 Ζ t1&aÃ㈷[ї"xYnō|7bB$ C"tqg9ŮKun4?-jx^t:L4z}n?:q2<;"{[D!^c@RS>;fLGH9X,Q 5-xdA$8ew=-OyHtҥQQul OaB]"+~JiN02P\NPx"B{'Ң.jF'*5׷/0ipB,d>09ݍ>  ΄ayySxm&L_[^$ӓ`Z0pq8i;.yFøjȪɻ*QHkUo^c+pDͫj:^}rob^;CŽduW挞%12Љ:puLC!|3_pX>ϮwT9@Ewd[P 0lI$d6 b01b(`q  f5b24`d4"Pew.B8 ii {Fh` Q( "V 3QH(ASQP$ eA`vj="vOn5F\3)HڑRȒCn^cv.^qeo7㡟$ugԑj4 r9D:;>DoōZ߹/Ijį/2rbC5{cdW\ieN> 0(Q,P P3gi Qx@t"ȓшJv"DJGGҶ;tO^ulj֊Q6hC"q΢p,yZd/Fݗ ( Ԅ|h1 ~U"'or?WT`zE5 @-FjY$d \"sjQhT(=NKtN%f Ef (R@lUJnAu7=&JH1%LF(>?OPj m_)OM~;= e,{0b!QUUUUP*;zޱM7mʔ+9療\*+3Xb BfƗE8f ʓ*ֶm-jvE\+\G9:cqJ3lKxjt( )J:iRɤg;h@\BwgtD4Z3<fx$$!@}Q,P QZ5V8 ՋJvUtaIÍpXB&!$1M T[h)gzȡOCDz*JʩT" 1TSEUIMS@CSTQqNOvb+Sֳ/R6I7-"zu-nky Ȧ{2%'8 D R ,rQhQElƽJ@&)1y7a^(‘}Gq6ɯ7kgyk=OPs5z.ƗIAʁg^N"Z !k9f<+)^|Oː0hwߙ!@A`!Q, jj_+ l͵3P@C{6Pzhkhߝ}误3wCy[:"[0qkI]~]]nz`"xߥe|V8!~N4Ni"uG~"o{~+L<\tYlcc1A&! m`8';D{/c[*w"G8 J ڱhr^Nu W6!ypZn}M΋y>iw^($ r5O0],n|0_#{{r RrJ@;F4dQ 6sYA*KR3  #DE}%яhPbOu@݋Հq,ybFo+cP.` Q9{?ႫwcK:w4{N zϗ"DfjG=z"Ѱi"͑;I*F}ZJõp4`}FF 1'IE"ovWTPXk'VP"]:+P_=MǼk:E'I}7^YmM 0Вӷ5Φ^ZT!HT=/q\}/vbyN yx'g2&d#B "mvTb[hSĦ'[  XN@(nhؼ@H(|?xA%,aʍ5k9&J%ޕk?,q@$(\ۃNRa$"j &;}~רpPڠKV !D+Ȭbs4;Z ]3yď~/{=4S7|@C$ENub;=)+BZE* * a] ;s;$GPhPDpP:SS ,%^=d(ct΍ʸ,Vë>~0y/ԴC ER)7E pңx=8]#ɕEX8vfP"RAHEAT/94nx/mGv7E֥8%yU4 @Y 0!ݍqAw.1NN >Qʮwv `QpMLPoV!9IA@?hɸ,!"~jqY D+wʳD+~漵!*K\*jo|j1u2 LD3" ]x1j* n f7fL,q5GG 2;aΘd( Jw/jr)!C"Т<\D5l&Ww0++ˑ@`#IRT%Vd((Ji}%&%! !XAP$|*1)JJ_w:!AaQ8I;R,mK! pBQ9-ocU8pRbe7l n:"qn1:kT"Exsݦ9\ I‡3E!grwhv+MVS%rcF0̝VR 5 #(6ӂH WwHd% E|' \ :D1*3ʕNø-W$jg4:M٥ C9r[ 2ađa@A1y7hYۼ[#܁OpޠZx!Nwy`X eUZdU^l^}>lEP&)v twgIM)\ξ3yY$YP<6EAz!:`BrAp{Mi{iwgah7@*(5u#3H_+y?|*LGCPPD`Q`PSDL/g0Dp?Lu>?uj8ǝnτr09)@@ *~€i[̏{)8ghwƹsŷ~3tyǩqIrLkr ?L "Z^yG`۷W#,쳀g08$iP(Be,jR1.FWƥ+Tv?lBpn y Ox;?i/ĥwjv谀X)&%H(E$ IBJ`i"'O tCD($5{|A#"u`"'$ d ιttuBZ[Ixf\6/fy0( !XLK\༎ ouN ikc/M))J@߹v x~e*|ibkU0`0 oTD#\$:~ ?~舲Rl6jlj$%ͮGyMqmvV!>j^l8" qHraPx%nM>=jATLM$Hp5 /Ĩ45YpM bht 8E\Xl YB(D e @r0F|l`~?gό)LF8ev(6Hm{Rnռ75 aLWY:!9^뾬yIR9zLÍl҃I$djpE]ͺhZ> MqPσصs9TmȜOcO?bMѐT:@/H !SĺJ(_9EE0 /IKE/chvGnb@pR~.kMItxCZZ* T:..\s~. sU€(!SToh5_/(. )pʲJ&Ye!!@!PP 6}A'<^;tץ9o_[VpBWͮ) +:;>O?joKOQ w!@QT!H^?ǽ>fudvY[dGb?Y@ ^o{6lH6:3,/~V &rfp0-U332c_!+O)'o7ӭ :dv3 ~"R0v(>)Ï^2{SAZ#ߢbAi;EKhyv+h]K=>˱q逃)c @LW .䅉 Cp2KfX 3K$47!BI(Ga7{ߥ;|ȥJq#1F~7/uy>>SYI ( jEf3MsÝ#Yx_o4$.%͗3@=&޳&FP `ǃtup8h_G_o$ՕKD|LFK>aZ@ A rbX? λ/V+`!WY{݌ޅ07fwz$H$7Giv%BapPΐ{{LD)[C`(a 8'lbĐ"C*P.&'uHZ(!obsc/ Fiw;֖@I6# w;ǜc[A @0+=Á FxS !c(RHq=EAEUHQE@D-@XTcdO<dwn'n\%sҡG_>&t6pj*w(B DJ!!8!φHa`8R' Bw$D:/=l:)i ^dO6!|} R$Cv >>~{1>ͬ+/tY<Œ ػz/T-*Bg@:]^7A A@ YQ(V3J)&jH .O4"T?su?lrDU8M^^m0p X S? rJ/{19C+x'TgH7'p\gB 9#PCHR;c@b``8)#9bpM>^]u͐0v:NyN .!\.h- NSP2SuQ 0 @%јɻbUUT>E=Ȋ2"ߛHc2 Ǿ+>M :R$ҷ!:~^ U@ަOǯP diwE'-QꙤiw53L(i<&i 0i 0i 0|CL9VhxQV.@_2wKMB\4IZVBجC$)DEe3vJ0ieK0|Q 恹D>_ ~r52q 0\I iGmw ]Z;=}6R΋$cq0WȄ%mh҈Gzz'TׁUǨe$}]/{>۬᪞}R+ R* ?c.zH|TF78 s9>7L>蜦'sMn:x9,H (H(Jf7nJBq(1ugUT5MST،TD"02@|'9@\LGAd *i ;"<+nKCY@/ǀ/?'qYT 4 3sw`kRz&H&U V8|c'|1 b.5`ʥqjS9b%'ыN$8@!m}sT"SyTuڰlT}?=˾I2q4+X)OExLUnsbXB wQlRx.̙SHjy0݀ZE*=(]nVPț>LpV!KKvCEuʵ!&ʐKѦijE+2QfLz*qANuxP3 ,Q!B_5ZLe2{u\m&=^Nq( LwZ QNLS;үd%z̙mbRVCt/VȽ9ѮLew)GLDl}?;nT*BH(dh@hM>n NB渿ɸԓQ\XVE`7on4'6a >?Nn݇cwZVZ;~`)v(xS D\LYݙQvEgIV<<  I8J@!Ro"-(1SFd8KsPIBwtQ;PUҙl pipjA#=OɫxP灬5K{l^k渶 9u#2^Ca l}?\# 4 ߕJƋ51P-7֌6p8IdXoɰ% BK,\ P|dM$-&1B*Bwө a'}|m"ͩݍK}$MvLMKFmB!j'*mBxfܱ):ahJiĵjTJSE8BQhE-`8tt@B '󟶽Ϸ[˗>^z=QPtAŏWI]~7HѰ`ɦ E T `2`l<\Aa'$́iM~`i#X>a3d", vٶ8r(7 E_at(1I6Zk$+H: |b Say/?T,+Aܱ՗8\JG9aKeX[@@`(ѹx9y+}'Ӏv*da}j̆wtYuZ{ sOyU$2E4c>"`x{%P*Z V"o{Kmhk+%& =+WLE5b +ǖ_O\ FٻXo͠Y7sq;%^^s/OVb'YbQ@Co Nj۰t~Wv@2^,h q/GᜆХiVrNM` &v;ls ćn',/8t$B@ǎS\ ҤAyf% +HH PF<Qʗ[TTsFD=@yHp!b!YDHAPv~ХM}ֲ &32ث[ħH'x0b8!gfy\|f'>'C[K րyzzw+Nj1Ӭo.2Hj0T(@U@يTa/*co݁" e`=ƧM⊸_7owar>I_`h@Z k-vP,{<^m #r~ J^v},_1K6M'm4r,Ppp?ebyg.H~7P  VB$LK+!fKT@,cI!$S}-7 `6:֧ѝI|#k\+h=j` >3]CB:@$!$!@*jܮ @5/YǃzڰOIX;yf6M)L0,A&ȭ7䣦 ?' gs)h?x[d.νKh{\\ڄ!5f1/gtH4LTD (,*BKF)Xra?S_gX6YLuW0.VZ][+%@+woVy4<`qzmlQ>qa͠@E}Ϭ@5@#6ΕeW-J-x6W/soF>ʿ/J02좼"JkZn۴&IhB~{'8o[Z_>YoqAwK$ϥ;xnA9X>`/idZ1QRMB1 H?M?'5Mc[dY$I!$`>>Gdp{m0tpNx71yDI@ P@Az0;n4b{WWϔB0@ena46틫Cy(vtp Yx}N+޻UZ_ҩO7=4ny`o1OuD^r%Y|_3Vl?3?@6$[)jyg٪+S17tH@fI'Yͣ}{Y:¥'7sTkHRkxUkPq׳a륟L8KIL.&bȵYz\?<~R/<%ߪE8L)_xϾX,mU#>H f tׇ/:"?K7- `e\b sc|N&Gt|OF*BU !Z}uz!m+ڿ8 /:jAYJ&Ђ.3qzڸ4k?bs l(>k' d'xjTܻͪǒ#Yk'gx>g%̧%K^.*ɭջh=V'8(lV t_['PS "$1>iژk-nU.u~cko㰻S[W6#v JEY.Nqo$*%.rEl(Ry`rI[fYnNStﰝI1_I[VրI3O*<f3%> nn6cYג })߸oo eVT=6 պblOhr*{5 ڷ ݂T3KaXoBbsfؗ};kuI!ϻ] _6ƴ4I'ؑg-8%  nӁbY]E/i(2qZQ!a@qyY#JU-Ѝ:GLdi8R[亗V+w;/&7AI3>G<."+Ĵ&9K?~láـW94-|OWiY0W]%Jcb 9U9H;UUdo z3 TB #iڼ Nv?ȹ/hǶ)CR`?w/?,{~鶆%e 0f47nMIMfAQ]6C_|_!&d;+cC VQ*:dmxʆ޶i?;cDpY\*o v6ˀ Ge %.pg,K#[1;R%׵e>0Dh-I9opLڸ[|zC|o';^z?k[KcOo#T❀ytW_AH @BH|$ADpz2|6>Mt6qXn-?Y3YZRwRo(Gh$;Bn%IeMv~Oוts!TyM! 3 mzdzQ}dU8Z`[)޻^4Ū4 oio^'&(Oxa&GCXph_3:}.,rhyJ~xk8}>y]t>=CՔPUa@gGX#g[v4{]uNr]ggJ>C4Y0|P'a껱RocE|,4ޠ2r9* MOe@(`^*eBP|Ov>˭% VlzXj`a!]oe{.ۺ.bZ?@4}(ym.IpV2h+wk Y$&L&֛umƄĬѡk;\ȞMS/[&=@EL΄ 6)M}wg[GGMFsU bВB P8@Q,?dש6ҤF(w/fVqKi$cD_yI5$S]oFHÂDm#yj稯@ݽ`diN>Wna1! 3 4p=ΟwPqvWA I7W_x\*cQ!f-e&0mVA>9.|:/Yy.E 44Wq5J>93\707lEa8OpSe%Dr[.gyG;}{xⴳZ¢dk8ͪ?mgᠡw1~NSJf" $Cmn+pr$ I/컗T:{t RaJ]a(RB*[w h| V? 㜹fcnx^D&\0&^Sg9 6$ 8('? =g B%UOY#8m%'^%-_?K::R+nV+)Yx &I ~s|=t)n-@7c~Xͳ:lYt+Dܐ9:l,bY|s#[D`Ksvf'of([/Ef@@5RԮaH- qt P;.''e:5+>5^s˺YyY-і?)bdQu~9Û'w$)5gSq ‡vX}F;ꋷtpX 4jjj]?a[IouHJ=W.77 T.J啯P@P B[PeJeTv4Q-XgX^{cǮYbrMS)EN_q pxZ44T!z~Ww8W5:A%koG Xxy,*DY.pdbz *BFE3 xoaɦ~LZ$TH| $3F߽(Fځ I Db+u4KJ]Ƶ% >즦ǾȆ` kqSٰ^G2=Rզʫ%Qr* o Tf/}*03N""> Q.IB=⸭ʩ=ݾnJ#nכoQٳ'GмRAIƔ D#Ծie`Ju)D{B]?әyUcS̵r(w1Tu~iNh2uSj.ߞ^5q=Cdx+t#kapHdry~h'OAdSr L .Vyngu3o-at2yc]OOviA {m*Zє'^TvZק÷{ԩR:B&3~77E~IHR)*xuGԎ0 dl}s;Έ*B %Go? 2L8WN<1 J+1Mon͸:< ZPHtW/bMiiv,}[=j<9!Cҳ]؛giG&iGL]iZu"Խ5Fg)c."Xjگjœ_֯PR $!a$$A$ܬ ic+L\Zb;6֤]cæ/6;3 V$6T|%Gq'C'wOdV3TFZ*ي(|3A'*lt~FqfʛUivc\\cyvdY쟮xɀH(z3yt].>'?y&U8aA# \eIy)yG!{3^RIF/3Q`>_/_jq}? P6@")H4W0yHOq+W\ ]b-+mb]Kcip,LްǠ C[7sί0dꚪ{8q/ $~DW· |AՍۘ@wن֬@/S?فk Ow϶8@bj ~M;1 `zkw5#oVA'ù28Jxp&_Tzjx]^,Siŷn^:徉ę]CS*eZ9UcU4AtÕ7dIJ?+gTpY(ؙ?[}7o%yoۼO/X//KG.}ó[]MX9_DE%xn庫c\H9$^/QOߨsNl7#V<yCofJY: ,NI&AM;պ;&B~ЇLeEmm{a>BR6,id c̊nΡkkdRRi 9z*g#A Ef:NZ>W+1 P7d2o[՞]17yxLHZ@7.?Oo/4[*(}`t?Y 4LtetȾ}Uޙ Lc,A$`"qLm\{Zl@pY4$;Aƽ&7V$w{ww+/*.[ՁuFe^39LX877Nl'/Ur,K#Q9`an S!=_qt7]5F: ^bfp'bCES>8v<ӿƯ:{G KFP-qֺ.` G܄ǖJEgG1';CbkCZ}He_`4]_eg.q{{뢻yƝcʍd O5 Ϲ3o#fj|H籃{jy4>y Ur}eZkO&jI!^vwϮ띶HŢ/TѨ~:Iٗx5J&: 7?4}ǕttdcdF$d嫟!JKp3Z' RGYR=_cz@'u?,C( 0ݿvV`},>suw @ޫ9wkE* ɱ̌7 D2|&]f#ϒ{L7L1rxعjVsh+Z(qJ{U*= ˡ'߸Y,jtϼrW$tX g+ Lb2z|(v\N;'y{zB֍nb[}Y@p9gg,wt |ouxm'gޞnT|y('\'jcY*{^;cO0zqs?ݩ醽h/!s4H~ZO!2)PgtЩ+DK&dr6M^jq2Z܌ 61i؁u#ۜ"_{Ӝ±eRNyv3|KϽܼz $F׽ٷc7:OY+:c'fi@ο ||/e1ֿ)PL+ԻvQņo- T@_2ig7}M 1 =BuJi$]>銐~Ju} S a". Nn؍K'!+[ysxQ.b9hTj/_A!z 71U--mCJ 5۷YxBz_zv7?4nMnvy*uc@LYP}C85RY#&L):RQaM_;ekVjMhp,>utcitEYρy Tẹut}OC~_,et6U}~8:9C\[9$;>? 1X T;_BR5Qdl-ZRPyҚE#s>B+/ RM}ٚFY>ylC.ЅP$>`.x}WH f JZjzijbR( `iYk5zGr@)F'H%7ȃ?~׺-0yۧb~VC!"*#@K(/_h )e}EsDI&9PwA2=@׫?a^ntkm՗y7iӞX3]>EH4-L$>'xhC`͡ s ,E$OǬ=)_9]r,4r[n"\cCaJTP@Ɖ }K.T*e H5&mh}"|TS5v@Nw#;0LM%Ai/Q̕5neÂ[{UihA/d,~|Mt͏RbA h]]!pF^32m W`30csUCeΊaqI!.PHfZVhW*ilS%DŽ8S# [ FD"d׽mvѺ>n]Lv\Pu= g ,}̧qmך{gzMzN*+&] ߋ*D3nnL` ھ~q)3 ^x:{?I? E/!:i0K0 pxΌ`MoU^S4tj&2*5+rD㜗bMxඋEAo59HD+C/XGOr]{CQbHR jRN5~{z#pg^\KTfgt?̦PHQYZ|i_m#w<=iI97A'@<ܿ#w1ҝ{9\"M#rf8J.dq{MB SM\%~}3qAZWTI-z?+s0TJYl[a|Ű)77ai2C'̬ >c^ǖ5􃷭‚`* i©~"&y5dd;C.lHNW8_ȡffuzs#C-a\D;y+څfɆ؅&hĐq_An`=ڢ:F&iD^!;Dͳˊ_ԊgސꧯC(n-S|1R:KۀF%<sr8C \ !ґ;KX ~gam,'@ivTG:Uk0v3r(csٳ߰vBy5|ns: [ʽSm[Sx;Z_S2Bp2+٩;^Fbz#ٿYI\[V5r BVZcbn6l/cU"VZjJk>%ѽynST@g12KPM(J9}2JqaZ$: x1KVqI`.ң)|Xl:NEG`-7v{͕*l& [0j'mCiSq wٯuSht]Z/ N{>|dj_~H#V?9Pn7Ð8E̓ꂭU!)o8Y@R}W~d~3$FʿH+wm;+57[3Oaڼ+Y8-/c6p3٩S#׈NWKqj/}4l/UG%%R^1d6ܲݨ' L C^A: 'U:{WθM% =w*,Ŧ,;j,ژ2If8Y`#_M8ٿO)ZP(~9z ]aܙ3q^7u+jA9xtZ*ZEE*N(ne^)nJYuSHs5-zO8/GbO0gYhhEr=0:ݦZzg8'c7rms`2z @1CJAt\Rɮ.|ihc~%*Ge-gFy\i;GxQ tsdޒZZίqB;4 z罏0M VāTVT%\s%SBs^r?6To1nj?mT"&d8^oIP{"6a/GLa*J Z3xWx+Wpr w?ؗ|#sҷX2E?N~6m,O\:J &M*٨#`Vp  dC@|pܗs"؉awhPLBъZc:''Kp!O_g1B9+>P (I &ܦHۍӋmلQ}sz+_FwlTqfh>I)!QrHޱ[2~g?A2Q'5訕upAR/pjEv+-dhѬȮ=F cT@7Uvj+UСiGs!c,A/#mzTT/4r`WD`!-;;gиzz B.l6uI:uSTlU8[o|AoZ1bEs/b)eW2']ZN宰M״TxElҔNÌMo 5EkQi/XQ6 #<u<ߋh?EQ =]B UuXxfCz5 ZAn_u]9(XPr5i[Vѓ>drwƿF @eY=-FdԲuy5Ik%jX5nѬ+w,;~͠Z TVptt=@1w"ˀ5;;T\rt+Ju{1$vP6B@@ E(]1U~MH܂T+?KX#P:RTFьzcZ!f{yL6 ^w6}Rqƒ@XY::ǥő1w'bcf$d&(^UU4.P$ T$] i5v64Z,vվڼLۏw\QA/NnEhʣ\\t|@V:Kd+[s֢,<aVL2+ I2sw!ܩPVc]By_`;^O . &V'dN0#$`~-%#ӻy-;)8w+/ͣuqmW޵oG~ ͊GAVꪓc{3O*W)10`% VU _޻z1{~ega\(/SzC#aH5z儲"B/Lࠦc#;lR{L)[>Xʌ%e\_=Nw|Zr2>f=VQSc7P@(@ (S'`W"ڞ61.}2OEqꚭ2 dbZ*#]aF-(&U<9r(Y*f¹aN4\R*2@@)!"n;,b7i3.MoC)ߊ#Qw_N2JX$ s.#Ufwq6+иbyT-.ox| }>^6V>`tl\L~&鳁hͽ.Z*8v 0 >XK>c}?cZx\81FGvm"Wޱ"@>i`IQAۼc72ae} cIqۆk-Ǧ.v gl^p" (XX~!em9MmGꮎ~nE]㭰OÀʖ\SLj7 fx8s 1IK /ʠhн# b i tF2TZCp֒y%((+]cROKQz &h92C4J֦urI'e-86G|?&g.kuEkz=>[ؑ&L 9?>t ĞfcS'nv}-fPlKm|UbK؂fIPlŌċ ߺB<u-)l]A N|+z"Q&-^[igb(TmVKD;%kD qwUo`>яygWj  EݔZRuտ0]  iA5B盃u_ůkYU+,&m1kaW$̆D4So(lVtи[.PTu];??ϺrjF56ş05 (K!*x<={@j~utl"4VFDŽ0VQ:iaIс{1S7f RhFR:1L}̠$J@BWET4R,IfTѮ}N%"r/񳻆a塱ǯۅok\7{?7p.nr!K'q36D$k< z[&Ih6?JqR?2j-CPId"N@P*"Ar ͆f-ހ-1 Rsh {YQcX5g<2/3oԍICN;Wx^Q@,C~M\rnPc1Qwo|$>?Gnzj4NN ezՖZ.%}|v)SH*T<)%Ee 7FR:Iݻ?7X jtq%5e]jӕ zР0.?՚z)>Oa*lWH /dC3FtYGRk_2] 3JX9!=@$%u'HHa@8 'k~ˮjJџHص g<"9{=")$լ>O ('{`CJnva+'acS}\?_Es %G4W| իa Twa"*yV03G]wvhw8&#\F%+ Nc{g x-I5hZsmUPq8l/4ϓw[v+t|PPq6O_&ɮb5xbx/aؼSXGPMp#853|me>uLeI4 *T>2jn,J,YEyc NU[5Qggr`8 bܓٟ1^V&ϹvghjV7JN,w^+:Չ Rk95p?c8 m,[v H/E3_%wV*c<_򝵧eoov1V O* )8:#:(v W{IlZFG'r"S[跘 Lk-s(֯Tn즩y>;#!df!b!@`XNzȕm=H71h@3%JJľC!Q(H@PH v^ Qs+-[+z) j}I-kFU#P٪Gn]{^vQAi1U0vIجjB)R6l0u@%Ϻޟ2[䳯@F$^Ah*zP(0/yə TTPZQd"qȢ0+Tpȥ6l3q9jˍ,]b(1%5bPqCj8/F31Lcžn!xw+fRJ@m qVӿ}MVUh x!ǩ E"< WK1U HPaFTx4B&* 4 LJja$  Z))y.gYT *.I@=eD2(SHP#JVT Azr, 0  IJ D(0д RH  ) B?&W+++( @”Ұ+ J(t+G%A;G0L=r@&DJ% BR!*A]P J%"HI$PDr=[eyo#9_edc lw4%l W.LpypCc/}'捈ht/y]4b@ mo}-#<:~h[7TaO&?7zjTZݢy*ʍowo~DWxc |AK~?<sχ,䎖j' Mrvy:!SA(6g i,l:_~EZv*ǭW3wS],ܧ rwߨ` %~P6:N~R5mYj'<,GA!qPl@:Cqz^ExyDړn_lSE[-!ߑzc3BBؓN$$u5_~ uu,^t Ҷd=w7֟]3a/ [,=a]2X)t'nwWN?n:$]š( _"5q?=:`AK~{yN7ӵj<,lsY,TGH&/y?\{Ӭ <Ǚ,\9fGΔ'$k:!('L(ңă>̐>SKYW`!:޽T0g{tO^ gz=T`H(QeppN Qc~wC9$u0{ dMJv?4#Ǟ|!txM0:z]ٻ<;j|9+JDV,!.~"1"^Bc|/048<M&ƈBZZFN Dv:< >=Əa>j>e_ uV}>}qzdl~QǾlEdk78,2d>ߟ :ArCǼ0yяMI3*Kd|lky,\BhpgN5UY.,},&]vJ[u{i]%zl:up6sQ6Ô4:a 㻍zL66CP8PmsC|rF70uC<@7"9E4%6F#z:\pC###p#H.>y!=tsDxtgR7k ;d:FChz(= +;zʫt{n=&sg6O=]#0xPG)9ZE;pǏŧauR_֫ +F*ޯ:;YzExvm-"N&;B|~ibԈGuy'o~YeBBGgof=v#| yi2v7 oF~Ctzc!:Q C0$D"jCǪ& _ N<͏+*~U= Uَjw^ێ K AJ zj&qdDA~ J|")A3`ameq"T6zALȏ:^Yh<nW_r?mIGJnug=ڴ4YxnDp ˝ &:AzRLJ2јQt(1#Č6z\26H`bv2 u?8y$tۏHcFW|Nl Nrt9eK OCdhg^ cYʙJ(!B8=n*MctߝS7pwꏮ[ }& D}J ]!r1BKGUKb+6ð}7k6Kz9S$񼱼WW9#B}4KOOܵ/Z/kҤcT5E:Z#@obPQT5\`78^\#E@CD_cZd>BYHAsiO{7 F:yNj$arNaW/کv^{qsRYof#ң9tIi5Mz_Gmx[ݤ\ht{?O6=x>h8ct#ю֏uz^w{_m̍\o}XcGu ]?uA;luڇ:=osѬt<.zN{o0?Ύp;M$~|89C:5mw <Gq=_j>?ގ87 |w6% 9LA'@%)— / EܫO8v9--]Qx؉?Yp  92Jw!2#}I)ȢR-"g. )>p Xb"G"h,#~Żs9`Ř5TCsa`5m@E! q/9B= ۲EP`SHN>r Br'9^C)>k%Z:JyIğx?9ǺА({<њ ^5~gmVU8K(l}27̎_'ʊķ$m&j/Q\8K9paP9 Kl=Fg*X'zyH9'G3hGa v:H$5XFљf7Bg9Cf/Bj ^DaUC)T0-`zh.hT*3zb7{Ƨ>qC_ b!}p1@e3 h kSnY׷ʓey-ۯnw ԿR%l0@6nsxMrl2tj/C i`jNK2xCfv7N߰@[K+Xb~=!NkA:2 D(MFȱesf-Wz$Q%obLW#i|>,@t=tx0m(XHVJaSl*QJi&T[H4V LUEP- /kBTNd}PSX=M_r}.i` κz@` Ra^%qS۳h*UzҜ> 9O8ƀ#o7:ZEy)Q幻hs!%.l᧮Fïu=Vi8WuE׭= P%Afhْc;W^w>RD hL&A2bOD؆#Md4&OFf@ѐfDde:`C9n Z*ݹ! A5h6KhlͨmMCgj60hp3!7!~͡423A5 mֶx񁜆51,=S9ʃxc iOߡ]3bj?xrN m up:k)4FcHڏ83CX0flL03 5Chh0mhg`p;ZJg'mAJC}#%Φcx;ޝ: o,n|[S5jmjdq#ϣb%.Uvj:I{Lڊm)qjG0slқ0`8bVji s0}NʓggѠo]!SU]S@zO\U溇S}ISD$'t PҨZIeKl+A})9XZ 0}{-AG|@1LC)hIe)e9F.Sw|p^g( `C>m@}E>X9W惮< o6WDq-]ox^ŏp-HFh:tTʞc*SqS=O! }-aN?k誔h8Op':COp;ʮw?Uq(d< Be/6^|zʇ|}|>xn7;VRj&SèuD2 wA Dt4 wa:͇hօ$tRC0*`* bdS2']N8)\mJʶVd[IO$ljmT3AM9Ī[H[TO)WE}HT`O'8O,v4'Ov +_:̦5\QecOQpmOڵqʩ1kD6Sf&ef̱9 6K6Ԓllқ&Y)$Y6-)&S32RM{n.-eڶVYcZ4ji 2C~6l iljʹZSwK].W5:5fjjՌٌL}=f)J6Jɱl3i\z1wᴌ .$dL:A" Z3ON5u.秚^z)YWץ񓻶id֦}8,,#Oф]*'C>*<H" &FAJp^jQĦ0EO[]d3#d*|.r#JeQ #y0̴aXbj+5)fF38èGACxt:- CCUfxAY&m[CIl+Yjj-L )X5463cTi43p3`230kQL556 f&0f& 0`١QLCX3jF !j- İdh`j.#A 6 C##CC90m CQbjRԪNrΜ%t˘I D6^s|_}S:ŎԥTckZZֵZִ;.C%~P}z1l'=$e/W^`bbI0~ʉCÄNK ꩲd邝0요ȱf1&Y[,SAk5MSI&T YYk\rNEfCM3eMTWԹMT8r~5U P5&J/WRU?30*w)ߛ.2_*98xZGA$)&ԓmB|mC:WӰ .6نaat$kNiuև~_8wTvA?fm.(_$Kץ>ʫ) }&j-u#ݴ݈,%db~&~}=HJ? S{ac#`>$z!8#H-=flaTaD*q};'ʅo=9a] J 7 fT==нQ Lm_/; UV؞p&«T=c؅0a"0JuGp>C`}m}2N$bD"I]1E*S#~>{Ur#|*"-H=ʝ5P̋5hZ.h!s{{>jD^ ˆt;z 9XPzC鿥?>e=0.STޮxJ~uN Sv|{-?Bux9D0hԗzs4̇.u}OX?Gxɶhvyw-P}Ug;CH͇($72xCasra ӛR87Vx Z&زOȹK퓔G.̅ Ʃϯ_y\xUt٥r yL,D0qGщ>ݢx}$iDCcR?8+W?y>w|nC[^~I붹Ogo,C^à b ]Cv p` C0@|Al> 䃲 @{AT21Ϫ"og|м'䤁S9'=' Tߕ+@;'ZD=Z0Rd2 G4 eôrc`Y}uO0,tK_&y4 ^_&҇W~GBv=/?kÇևKn}xGֵWYKヨ @Xoݹ~x>t^]w_Og/:_YD?eP%Ql<75sl;Xᒂ"aeeZLXd4JS3UcٴȂKJ,KMk'Z3F,HTKFh.O=ڶF D6# (=u?mP-S=vypIWTYS4S)TS~\nj=܄K%.šs7 yp/T{Ecߋ'Q|ۧ8:2/aMGI RB`E_ᩨ꞊|4ӢZ)产ʧ)eOp?bSx=kU]ͥ/oPL&ԕ~.Y"PzOȓWUU~!i>2,fOU1|`pn&Eppk"jFHDBTgj9ީЅC,CR`vH0ލ@"D^GVG$oF<*:”?mOr LdjAfya6RI #G:OC3Ab>ۏl#SCt{O|̷Vf<Ph~ c$"O0ޑďgK^_JF`) HI6|Cqdw#4W>yOX1itc!cz;9dv2fFHGv: `b#s t!A ^9.Omȅ)̯P9\%?Whi#[gF?̳-ޗ X[_6!fq5{- lD[$DDfUrx^T ` s,}xz6^}s[=tB|tEϮRD8q42]MJ}>ٝqjWݫhbgy12T{vWf>YS^¯|_gSؿ}v ]#r#p<:Ȩ4C ӵ y׽7"G$%O R>x]>;C)rZS1W)ҙ)qLܧnf'wud8r.S]Ӻn9v.1`M-1u)S.Ys ?|3M p5U)r8sYӜp8sVfG)N1O5> 8aiO)>OC_aM~v'x,ehæT#*SeN2(3T|yl *r/etXxW9W^0Cޞ`1ad CLIis3*՟y9aoF`IbGI&̅cْ#Nԧ$gHLph./l_ݷ,ق*$wg * ^ZG*˓/R!Al# ƾ(_ﰎ{3,X*VV>vB7h]X `%rP 4A_^~ ô Bϝ^us:~ƄQ Lc8Фzy_tت)OʏvNg0<מvnG$Wnj |G| :$!x ":)=[Q:]>vy.K 5}wzjLN/oG|G}̓tꂤ4 & Qd.3I[p'1BF8` 4m+߂.zgCL P,Z-0y=rY'vJ]$"KTU䦫MFFH}uBRA힊CbE<#,=p~uBz;7G–~zH\!2"65ҸPqI_C6wH;ײ6\Í :cC>")0 wA9|IOԢY! 껟;+~ "GIMAW:S ~UoMȑ޻:^Iw*DDBŮd{Xr ]|"%ڂ0 =Kۉ4@\@5Pl(|wNRĪj6 RBx = Pnvw^r{4"0B; d:LJ۸p'8rLPRVt!@"f` wA󂏳fhg~HIb1"p()#MK:Wun}#qJ {O)CJkhͧf쬽Ҭ ~M$noo=[ ?N'j^nS٣yu4*}SԏÔrGӮnq~Ñ8\2cuMIѵfsw(<5 N`Ag.KMǩ?b״ּ5| > ͪ>@;</ t.?XK&>FY uqr" 3qII<%}2<$0lDT&}%wঽF4#BQTِ-$q$L|4dd\byUm {ܤ qAMKd/pM?hT^0Aۨhǵv KB_$#w)̪aٟtjUtu lcuoJT J:u"'? 5BS 5 DVjHs'HHRFBGZ$yOt{EjEAHЈ_mg7q\ AAd4 AtEͥABU 0kkKdj6r<<&$y/gPFH9h ,W =܍ ${5OB&[й#DDi")l]xE1- >P`X`G 7EDn"2|_':Z7qD?w?2uK LsoSvjA$QF ^/֮1UV cg_uI3^] ⼲~8jXO"II-=uH}blPbBuJlg|&O=IU[\wxQC<ēI|`Gq4i\:(^"E; XYWH[m:I.`55?A!t-z$c!Plj/+y_JʵS$=,2I1gY&MAd2:tx_u򞪿kWۖCh0MLNs µ $/) A>RO\bIdrH4HZGč$ssY WDD.9Ń _z,ZS~IfiiDr]LsU7*3A<{oVx<]a/{ u`]7Pvߒe @TQ=B{wA vId'ϒT}B3,@Ȇ/|Bzgpv;ߑW=\N1$I&&|l* qd[I64T䂜34$ / C]q_Ve PFfl?yM]'I2<0yUUzjrW2xN|g ]4?kBe4MĒ%X%V3,ܩ&(MiZfI \sWU;!$ٷB $$I$ɇB Zyu00[Cy߯$rl$1 Oy$I-$ A_Ay?7go7UZÿw꿗W)>Hr1 Oё U$p!8Y'6K$1W rLLdo$׎Fp2I0[9>#G8K$By!O?ȑ0JL9VYIP2IzH=dyu<=g*b@#?EM.fjNY[Ԙ?xr &5by& | S z%OݒsWӐ6p\r0I3% $x!ϧŀkM_+,T`$EI0 o+y'$$gǢ(.]ȑ d-h/`PzXmڮjԪmQv`I37E'ł*7}f^VH!d;?t鵽CƽRߨG.{P㑏:m7ڛLJV :؋5q"$bHK"&T8ȿOCUGy *yE|<#O32̏Q:?(@ E*C(|5X. U(&6!ĠT<`=H?8tBз<eҲ!]!;?^=M4U5H{yW@U)?0Q%>iB (MsC [h,М' P爈0_~cg&k3,d/Fiyj;*טᝨs;δm>9ͮSSαs p4/Õbۦ_tģpK"mfAU!NSs+z9LL1–ъM1fI"sr]ۗ Ks6kv>tsӒ)v#Ωuӓ-Lcunͩ:r}t\ 뙭m i1M8uT$a&)8SSTuӉj`qD䗃6k !W 7EuH4VnXdJAƖz) ܧ5873 gW2pq̙qLź|8WWkA_? B%Q%u9*D/:6?C#{N^l*q? mMY`G SFeO1O0w5;"9͈?'9i&2y/aoI};;$]Kj+93gQY05GN}7%]l|ا׽ke䵝r뾏Qv@t5?"s\àl;݄SDGSUқkQlf}|O:&MiUt>^o:TEzW[PذݯrMYS)6GtsW/fȷa<"9vj|1 %9N;>:#X>E`I !.1(cHkHc+Z3?k)(:T-e#[aUH}vЮC&B$>-$t,_PxbPt[~Oդ9i'H5?z!lb ߔ_|u}i T+󸠾^ҩMSdUTsW+>1wQ$*"DGÚ+-P<{|Uko/66.! <z%9w E빨*64EDQEDQEFھbn۶/e\;TE APDuz]8եq>B::Zb=̏@_*qzwsKs6Mq6ɲlk5\*(Xhǔ*(T_YTq&rij4){* S8S0, 8 ZpEʧ*V_ S,&?][[PyT޷yP<]W*VEΕszm˨XbRSMy3ׄ6[Yu{<ʧKjeb^Pڬ`/Ta)".S~0GiwλHF752_E 1@I*3r."—Y\) hL*5uli"US09! K2q!UVPZZI5Q5&5I%c䎥I٩'U\YUXAܞΨmPڕ@8)ȸИY,KK] CJ2q%S8e0TʘHЮLrM'*S .vj31MPThtӦTi:jEjN.K*S)jL%S$ibXWi)4YTZm/ Hҹ#&Z.QԺ'GItFƦ.Qq8Quu.eVRnë-t%di]ˊr'%R.CU)qe0ptN:u'L]:L4piTBqńKEqa*vV$A/""!m8:qI) HċZuSV |Zo59qzkS@ivdZ<9M6s I'~U|uL 3&330q ]gdO]!q/id«ĤGno^5੦oٱd_iWmޅ$!4@2fqRw\:fOUIݙ-s˱e`ZYs !^ G`7ն{1kew TOH0@:<)Adv34g^0bi!gթ}JbɡRޙ)ĸXXP[!R|*u)SRL#5EXI!,XF $Բ!Je&dY̰IO eU- MFbjNjdMSJ Z*j 9d3Se#fZSHZ[*fllTJLa#Q jL Qڰ2)jeZY0TS)jBAjUEM h L"c*jUSHhaaf&M26RIZ415jCRTa1E*5JYjʕ,l4fQei4CQhhhhhd26EZj3d ʬ+TP0`&J&!,0LK8Y#)jvNʚUfdYHQw5(O5B>Rvs 1DW`Dhd0h!K]D6 ]Q݃"xaN;$C=BMz}Hpis8$~Gu%Gw+~6jxP%УK)gt)њҸSz784?/Wbץn>yf[}]wW]Gҙl؞s>h75l{r+i*uW3zv\w;ݱ 8[yzeJV b"&{ =Aܭ5B/&+[FD7s&b,xɥ?m<Dn4@-[)je;F~t ΃RD3OBU%R7t1m8x"̄EE%B/F7mk5^p8KJB<N$́h)*mq|9^68:ta5r&ETH"5WJIZ-imUlZW3#%iõeȬIy0s sH l@~%c:">$TBIUέ۝z soqQJaN ujZ>]kB=<""߸|O xq)F ;WX_.V=N/#+z}˫,zw΅ζxryzKU5kh0[fҪqjIP;:"0o4 fg\g<:}`zMI`tZY*LTy36џ{u#=ѷia0k1Y[1CA HtupdIufbaTΠY8=nʗ56PՍJL3)m^]9]{8ܲs.kg0J4mm7^/a+GwK-'Wg{S< ՗,?l{J=pjeLf%s1y>tK2_MZ{l_X8vjw(lܪ嶻,ٳk+{{U؝cf"4j;Zqt*8f;a jɻiN@"'K `,@,$.K5BPzn2:C1k~nsn#b'(.-Tqq[G.M#Nuz^/K.g:WꝽ=']wV-p܈'%IS[W}>^Iɑ4[W67$TGCQyώN?$>d/St̑]_O[%ݺ\ٛs0!#RU d1ء}!~CҮ;( Ж!(bl Am*W.(X 4Lbe p wevc+ !LH0HNJaЕ $ooHM&$$LNHR)+Z"2+)=f4uE&l1;RJԇy܉&D Y^UfRxr•K 2^~ Mm0Ga?[s0_s8H!L&E*k퍳nȍHLdT(H .4a:jU JFhʉx d$=>©ڪ,TVs9knl:ftv)JE.*!ur+&;Vd_"7; ZCq.FCqFœ|]ܽKT `6ΩW|AkgvD9|E%=w|)))1456lt4sU\\⻊U-- 2}9z[z(m\}dd`yA./Gکi]TMlٟ!h_S%>k7qͬg6ZiS\nl|qfhi9KG%UEｑ} ऱkS7—ThCp4*'}X[/.̬3Laʇއگ<^LC5\֘E#JJIul6Gvڣy͛l3{'z3Z< 3ëSޟTDuIJJ -"orQ>nE!IMԥs- u'g1y>p;Xg^f)uvtRO\vP [of fp}"b %k khsƪS}L/xx|+rRPS"Rs8tמ]Tv`va $S-URDUu^7T'U5B^/MڒrL*G4v|%nSʙ2PkUflP/Q=Nvk3v=ꏻN/ϟLp)b` DJ$e:tsm]r6խ+ҟ_ٞ~+4,EUMf Ydkl4ZR5XfM Uٶcz_ٷa;ni6L4BF0 i6 rE%Hz"s9jSڰL7Q:uә5>bތɴ3\qBѶ=[#^Y ipT όI|ntmm@v =4/tx+RH)Q$RqH4[Zit=Nmyl{lܝyիhg Ԝ:USR*~f/xmɼr&ܓ&L6nSji]ޭkϚyT4IAHPq aaƎsF8OIS-0 P"AQX2C; "LDdKKu8h(񺡱;m[m!,zGwyrSRw6d _5N&vq2mluUJv ?k]3Y^mzԟ+h>wꜹ9 a='Z֦Z"JB t zx)JY*#D;Rگnx߽'kSj:Kڕb;n^+ª,!* UӬlClTԓ}OPzQr{cL#!7zZ|O?m&Mnl%-,Si[U5^}m>G9aowgw]ӥA*v󯓎 ;,#r1Q¤JW!f@8Yd%5(r3luPYǒ{սsr=j#2LV^C4)Jl.5.zI5n=~v9|T?UIPäcKo{$BMכXVmڙo%9 0r'2^ʳ>Dp璩&YI69E6F.8i&FB`"9MCiɴ HF#[xF:iI|K!K|.0f ,kPcGz/93v - z8 N#nX` 0dܚqsfɹ.>_:.Ӝ\2dьe5:D*e< 3n! Vʑ?VF̪FQRBb%"9\߸[#BuCd ÷7:=,.7[|%p4Lu8AOJAS-^N*9k 2H&NY|D\IJfisTnrۉ ]5 F:NiI I}d&-+ADF$L-,Ȃ$>܇8fT)12e;P];Swvt Itɦ,5J|~*yzV麱_[9DHv9WFEmIȑ}(&1GwK!RFN$so/F|9,D#>D./v̘_&P=qUO;KJbŪnC®u97<;x Ƨ9jw3) 4d6<`q^1C ų]2XbZDF|wtUbŚ8ebq[}1f7G;jL3݁lםK Rʸ5(ҊhL`YvXfHy&U뛌[GݦjyhO=G-8 &Q!!hH 'VOr@`ؒH1̳aM^jyx_Aq9㛝^=9JUV~ȄU:-w=g$YK9fQYi,uUr.8ٲ#. h9!=/*IHdgHG׾T_>Hy$5y1(`5G'൳H(WJM>rW?8+~S/V8뷂FF9[ umO!ӕ`R5 ؅D+Yڳ ʏ=L9 ƅT `G/WXbMN/_mݜ̉+xJ˶57=K*ԙru滆(;D7u{`θ]ersEA3s*;o;=@!`7BA:~,첩NcfN7 "KF४ ÃBYH&uս ~zo@(OQ,#Tz},CS:m TF!=(D6p^lea ľu4iF-fԊhEGG}SPU1; uN-,VXX-d20PM&ݫfa݄XXOPK]~w$}ߓkنĿf*r7k/(vlhp;pvY&G*YeeH,>. |,T(9!<`2 8\p\Ab 9ڇ Z L   0c$$!ÇdmU& 0hEzMc27%Iw CB|9sZEO*FV~%8VDs [WyhPz`Pwp\O;n"x4sJ`Yk ki>+]rVCy%/dR*GX\/+pT8TDL`dC0/TRHE[P3/A-a#g՞SC" $d:bQ"ߞ=SC8o54& [\_e{2ew3XMa0vH'.m^%*,C 8_A!&0&P=| t֗P[n ^HhY׹Apz\C h p}0Ǧ 0% ǤP@μ& =XU0BhZapbyPׅeg25C P1:S?7Oݥ ~z\|k9KgRb_Y{v?GrMTm=yÞӋ*(O[_3b9 ;smDS\H~B[3Lϣ?Rc}+IGzJ{S=r]F}8ʄ\'B8> N򚚞s<_ ?dTڝWB"9qa"!Ӣhw<'gSg,fS;I;iØSʼn.ɒ,gGud&Нԩ8͓ٔ:r/: À0q^ݻ֦G0}Ǜ=+yywKȎo}pj$d=Ijk,/{2^nw>tT\ꍉG*9QҷNgwⓖQJmo>rM Is2KLYb埌paWďSؼI/}HTHvdZGf iD'0fI!qIl#5"∅ҁqI hnu҇vyAj.jAgZ,-J~ ._,ly y9jPuͭ]%Ry]/*ɍ l[\\WQxky?^0wQH(b+.,Z)PRб tA:07gJ ua`F'Cɘ,a-+®pqÚ sA8cBAeCF4`|P ϗ< aP8WWVvL_jx|϶+~Wf?3|#x=_,ٷ>*?{_ Zb-L8S=ڕˡX^o=iP;H[Ix9#44 6$Y;D^+Y MkUkH98ؽERQ%ǧ<.y}Sy?,cAlqJ$J4BW񌵜wo,S(`WeӇ"TD"?\D'"A#]K~Tjs6K)S~<>!R)ʇRZY*!H&7JH%ep "~锴pV1uwOc8Oz[mmc ~d޾n_|;etӰlR<υv_Fʣ^;C^Wg dc4HD0!4C7C+D7*nCbOD?~Xr: PVIHk0Qu π}AMp"`:QDwFb!EPkQPIH @ T&J4;bPj)P5X TP@iv1 $( a@@AU@1D#`TP6,̠(H() 4i@FZ,hv}>EH@ @ 4h A`F &hSjHS3M 4c@=Sj3MOJzM=O6D=Fj1~13)*=AU6SGCh 4dhh4 A ѡ1) 4&L&z4`L$T$l~S@d 4 LhCF&ha1!CCChh LɐiF2 RDI)hQ2hd2Mhz42h  ڀizJ &&@dɓɂiLhO%?OJziOTOʟ~ҟC*7MF6Odjf>O}ꦤ6m(F)-F_ ԧSTʙ(f/8^^* ^U/MT3*ZyFP/R~F2:4to)ԗULjhѣF#DeQT-FYL5-غ2v΍#dd)4\tMFo6GF4hѩjZ>+i3*0NNl0+[GS)ԦblB6ѾdnKFhښ=hё#G4tz ѢMin}:Jmإ5M %4bd{WA~lLI, K6qG#*xT*i~a_BRR5CڥteUڱ."^GQ}TTژBVjn\bz8}"6 NJmŦSJy%z=H<~$x=(;n?Ǖ6[#s08w3qHZY(B &. bRz_:wN7(0RJa)TJ#d{1"t/ݡCC3?b 27QTRN,D͡!6Gǧo,qGǏ>>,zÎ8Q'{e}yqڏ%Sh?5,h)*;a+G nwԈ3a<@I Bi)v ; 6ٱPӹΊ;;]RvTͻ]v +dҳ6N͡Ą;v*s98V kkiqmU6o1ͤm >g$oǘF1|O}Jb)G:U\u8Y% "*}LJbxyܴJmILLazRtb~C{ƻfj̪EEIQ*WiFd5MFY(dM5mbۃ|tCdiS5jƨFVƛ6WT׹ύdf?5=SafSM)IXIwɗ>gҦPꚦ5MLJfjع))6ţKSSSF2dɶ&&dѓQQSFL4f54dɴdɨ152dhѣGZ4hѩtdhѣhѣF15-4jZ4hѣFO{~)GF831ՏF6*e)f^71b5f"LG^0EfIt$g&3B6,$&J5L-*̙UiƤN]:R4}T}fKLj SjZjը#`ډ)qqi+>n/M+L#ؕ{(=r1D*=/*x!KJS*zل{S7S51ʧ֔S_nvnY5tq?><"9uCP!f%6M\(d'}*ʠ:_;Ģqmn/U[U>Y1)}ϏƵ8%S={hҪ8ZtGǏfJkSlUI{*;D'!;CCCF U*Tז;׏/>Gv~׏ۍc;tƞ:]cݍ>MOpf3-Ocکw}B^/R$^R*[/6M S &"RDE{JE,RVC[dft*V*X'g*;HRS%>vTqz)a5JaETZ+b*a;U8IM0E**pfTlB{!Cy1Tꔽ1J:#Fҝ%+M<Ԧ(Gɩ5HۡB rt1wvD3o$7pɡCC` laSC: fy 9fY)M8HvhL/u}# 51-.] !CBYPYPBKENSNgBƶTfU+D:N [n<3aޡV~8V!C`1 J$6lC*$'az ]=6JyQz5=4{Bjw}28ͥAJ!cCCC_r ^d,D /PP!!!⡽CCCB T;2!qh<8~?ϵi0l̘¤1ch4eEaTmjk2 f*MVjd$̔8ҕ̒?DʽMJ=~^dXOeܲC1`)Nd H"j C^"v/U"ҘnmT\]X*p>zu`J}_IS5L)ԅa Ω֥V*j0ՌI+Q*JR!RϭהiS^ t&T>VqF%:]ҝD sW,NRZ> E-Mm`v#M+PrTSTXL#:>#֩b9$Wpu)O7T#z>W`3NMˏcNGYq'RENSaҝyO=NN1*Kc̏:8*u%){lu~/b:r`K50SSX3(y7gb5  }*%6SR>L\_y')%3 rꦛ!X1zz6JxZ'~ NNuṒLOj E1*THz!8BMTNoиΡBB~$ L)cnء^'kG1Wq)c61LGq~tJk'`OB *P0pB}}iSFnѣFS#jV}OW2,*|=Ǹ )9 -T&?NЎ?'ҝ"p',y0pSգť=/:l䊜RtV̂аg۶!/\AxLLLN[a`V\&Y')4& <IQ\,SNS'=I'nޔe1MS6&&Jc)M ?n/MҚ7UjhTY>z:v6F RS Lpg ԧ##c$yJ<>l)ocmF5 X!LC`B=_CdBBB$=0) <;oe5({X!r  ?~T?B?J82WAz d>{]w?S-/9XNGtEIV'B4`% =D7UL!C!~D0HiHmt7 >Z~~4~|1${(𗊊*: "+ k/ShCsijC0O;!B=vUNaSG^J}Ӱ_G8NeNt x>xS?7J?'Z89}HB9z ue=OĔjnr=Ȳ'>qRS1J(HMԉ"'w5!bRB(B x$hQ'7~2؏ތGD~~w^23R%6Y/R=F*?Ħ#8Qp'혩1ŗ'LƱ8cEfޞ$nMÚ7G7mLq&rҞOs4a9cSLa7r&b3u0LƎfܟڛSяzޟK)ՎTNj3Ki9S)jc)}>L8SN/E=$^4m{iOS8=)ȝKGpryLt'㞧=L; NK8iДnPzu%"a"YeP8"nAYSTtZz6Sˏhr~ݩڍK>7eWĞBS>dxc D԰N#c2l'OM;'NDut{?m=B1 ^(``h%"M!jX: y\|XJWNDok}o OxMɶ:cH?uѤlw~ 3&a7GÍ;;#1٩`l4ʮm2;]bvӁ2TqUpGțj6G:6sƑtjЍۣ|f>>ʟ[GV8=Qę48brlolGrj9j^7FħV9?<>Je;9Mт{ ̜134NLֱإŶ;x9~)Gqe;c"q5'ĥ7cdl/UjMS\ƉW[є:Ԍ] e?u$mR&e?” 'DѤe?x9#bST'b>zŸO''0)c6LG4|ڟdMbe7J;i)Gۏ$ܜ|&S8Qďcdܟ㜟ODC鐜$]X ""w]*9$Ռv Bu#'iOhО&|.8cbp#1G4oxddh䌧21=~e7類1,bq'iUʜ(lb9#dʋ)~|}|sGW0Q-PyS"0aTڧ"ħU?dbvI;Q<>ja,b;L'>:lR5Sp6b;Gb"Әw!""/f9V?αz#1f)a1><]ӏԏ>?R?1ljF#шN=xc|oFK?j]񣑑T}tY?K2?MS=G#1|4iMqT{JbM$ JѨY$t~Iٳaܸ q׾s*Z+D,m"ʘI#aK&є,cRԵPdhƛ3Zi+TZ-,P)2QKTb -$6&ڒ^S*}]ߛYewbo]3iGM[EƚfC.f}WN wiZQkFM&R[c^3+k磹z땛.Z|'s;cƳcss7~3Öf3c, 3qARMsqq#RY,f2ps6m;m]%r^SmKiE\-ɸjOW&<4_習uOwS㧶%2*綾3W61TVj[ꮯmg<ׯ1mmF3Tǧ<33)]f1Gj sNU99ޠN%12owmy鯝hqw/%/6+{y'UŚ[8xrF5Ōqq̝ܧw)w{=We6̩̦}*kq;ѯW:M7xΨ E-|mQz$dʯ(*0C`KDB !5[ޫ?rT13HĔfGfGLi? VQTU )< x΢,c|fW)TmǥG-,4BcԞ̘>t8gS5&q'&,k%Ĵ¦1Ú Zͭ}ZuK<>M FX0*es6ћ -Ƕjz|uho]@omKbM6&m&sZjVM>?[wwꜫ^ʲel6 b,/r1ՕL_92]GI$ĕ95L4S`>a>ulբs5oc7vCso>X2XSu\?8Ę]v2]0ӵ, * sI{V[ZrnT*V= ׿Mh_'}4ci{q˻iʊ|{gP#ZOvWіUR%y[YJ*꼖^<5JԪedHtrFX%A@ҋQhMJ`3IʋJ:<1* *4>fU! y)^*bE9^ں4T*⚚KJSBQu(FJSB)fƏziKU&M$ʵRz3ES5 Zh1OO$2MR14a11ȱ20R4z#0ԆG懽Jɕ#ҽW#ޫGCJjO#dd<ũd\{-gtNoK¹MIUR]NTt:xSķ<##]99"] :HT k7߰|lmWxo6mKn.&R|qOySƹO8L<'g 083ND1+Mb)0r2m@5/QzSGGOƥt{GFW_YJ֩|Ʌ`4>mM&ͺUNѣq73Ӟk秳Oorv5aòr#s!:v1boklˁtm[˕ka33і̸6a]0&9Fud'W_7WMZpoda.ev**ߝ7oz r\ TYfd:춣RԬDҥkTL9RV֌XnptqʥrQt}T{?0KU^ Ʋ]:g G3/)Ynlψ'3'dWF\(KmccEk vUa*jK\D_DKK/2^ռ{y.^UR"niTe[WQ!V^RpNa髷zMW'cC%Оpϕ?yU8XU1!Wk4uy\J e4S%Q9.7i2g,peZ\jKjWZq0۩< %v4؜ӯpJL^ ;5v3p'$65,cY ӬY^u UG;R-Ư8M .mõiJ.F4Ԥck9ǼnKX fG{)fόbbRc-TeW=Jzr+_C7W!<+pRՆN/rҼV;s+u>/ZS;cIU=K:BdFl/oWZR R.1OKH."%w( ߔGItTGe໯Jv\\Ti<Lsq"JhZDO1:saRpTXhÉ)|NSudڿF_u*R\oh&'pE3ߝ^s yH>zwvY{7(ӃN"G}2Ul0*/RS]BR3 &f(3"ԭ7 ^gI/+5o,2YDgϏ_)4Jycm?VK7QBG.wS~fqu||{wV\+$"*M^Ӻ׷uuUmꝲW$n(ߵn->_?wKJnZn1X~J-䯴L:V&9f% 9%JϋHZqlٮNl-KcP2к{ȵ-hZ|7 Z:_8ջTvx}@1nw;+l\̃ͯmw'%TW:6 a?{#o'ӉԱ'YwKiÆRnjK:[MQ/%[>F"2¼Je>`&*ĥr 0`ׄkG;|o% ^eMϮ:e#T:ЭSbO&8]/:ז^4];u"9oIMPc`k>gm+sn*7r6ͬ9ł-oh01-b^;L,ab2s, i<]sW] .KJaEaop>mj|0Sr>g]ݘq2ɘ|p+ueL^qw:q>SXK8Xxׄ7m;f1u^|.޵F\ʧ'^&ˏ edw,sf[5dwbLTVssK1p+/-kWK+:Iⷨt>-9mNXTwET펭iJ|,=PI0U6%o_7B-<ԻG1c3dc r5޼v?=geY,/c*^YZYnW-wF:ӽ93OTxx|<5p3ƌ-lle 4p585kx5h߸pp2naĜ660&}@[KkIuוfQu&^hru c5q[[[mEl65hmpfEno :զƕ=S*j )ڈ5M#1JlG'oM"p/``0{?% [^p<:7Oo9 C:& 0g{lb6yo7%Wi|GbW. T`*K%9Er-Y VM$kv/puؘyŶEu+pjquDLUbL/'BU_=1UWи|LcuG%%KboU>}V2M*{k83:i.ci|_%}+2"b23$IQVIMe=Jz3 oc=5t]jz -{G4L>L"rIq23tp5q^Wa`ɏ%*/O Kֵ *kxh˺^:\JX.Yܥjb+mcj<kT4lh|7\{!^`ao;kɨx̷]&ʼnDy il4Ֆ(6EфY x=4]WD\,65}K'(t;J0>ڥ<bM͔3i,%[  zvtTV o0e@Zv,Hpp uUWU#=v_q|`RLDVx7Xuu,JU,F =\iFdzW^,HLKa1=i*ɣY7;0Dpw=)/Mbė'N*r1\,k36VuUzTӱZv5ɋ # a[ærs01^( su8kKs6Nz;،,wbK0RMK:.J➛ $M2s'ḉLDܥR͓MYqV$}:IQX¾Si$ѦL1_?Lc')벾ުG#Sg6mSlWѫZ)S jM)翊y!Y۝SH76cISUfL۷N^{{x'곞÷c7G3#yژvm (\ 7[[I[VVɫoRh416SYp!L-UWdgԇ5&TL mN'yb.F2槸>$5Ji.R&6g&xEiWʞ<%;%.Wy xZQGFySJuU#:/e=hqCQMB y)>BjlC|/P"E);43[RmBI>YcCԡ*PF;>$xqyQ}b;ߎ䂶RND. $z,y BQ]t9e!0I݅_-K>ie60G2Όr.uKyijcϿ/J0ic<̯{z mrϖuS&T-0:T`7k@:1V\KI\n"Thi /? 2bP tg$"1 ZUљ |}f#4sm}E~+۩ddV~e>*h؊;xWe 稯*yS%2S ~ rD5N*S aL)S>=tZ:cdp#:nns9Yx?w}QqtǾGn1ߍm#4iG 1clj#֍#(ԷGz2H/{3cja׍c"t4HCi> ս*wsB 6_^ ['VteP*(G+HcԏF=ΑGV7'5cSftM#۬iǁ>iG4k:#Fw#1}5l=c1t|F:c#>\| ɡ5 bM:gj0U2 ti.Đˊ킛PBfd_/ 1 A'j?~{KAHĿ?`@%Wd@,O\305va~ xXcӌQ٥ɞOu^_vwȸ=*W`&C&N*ZRDAgaկĥ% c0S;i2SjҀ|HW+82j߄[ "KN^>:[)y &gⷽl"UnI,IuK0ʖCT!HKk{9!ʈDE c!K&t2W pcIrLNON})w"_25tnߵ%z)6M.lӷgwxұ%*X;c%q{Xb7sz氠VD8J@D$r(썳!fSSt>ft4 `Jb)LMr**R S j/MN.OJtG%:8Jt%2SC?~,_]HhRZ`5 EjR"=?LjhE! V]!!:_ҡB|[=j?cÏFc1ǥGxcF~gՍc>=ڍpa:'_9z>oǴfY0b$Ō*0u+߼SU?(gEb1њ߫<1W'a_^ ESCᜨwNq8K.\?E?3@7f 8UNt}ż_ ( ';jIk0V+ V%.  Bд, , Bд- .11cQj4Eԓ}Bƒ$ckkkkjkkkfa*["""""""Br&dhp#7)㋌hfmhfɓ&Ffffffffj"""""""#30b+)eP*ZYK*ԫr8R""#V͛5j,4I̦6M@}GM_qJHɂL  :5E"H7}GA8(׎o^o mrCBa {LT$>"8<#e؝s!}}|Cjs9/CPw`9$L!ziPyLCC*S( `EF|Q ^œJLzJQ㨼({ZC%܇bqH{JtzQ= WF*zO>l3RU<2!K%&(oQ~J! Cd=t!!.QV$UDfHD*C m y&tCՅZdff 1dZ McfHь&2Tƴk1UPZ5FfԴ.wUpۙpMTEm(͂I׿.[USW8AϞgASC¡s AG:Y]u]PvUs.*1U1T2 QuP_I~$†*!" S)& RcC X"1QaC! C1 )1!He!^M1LxmApRsVY* r̪0Lʬ@eUPUMEml3c2},qPs -d,Uj-WVV ZVjۙmUr]D=lj!“֪,CڥOZCƤ6JNN$NtWjz:$:'$")7xwJNCݪ,Hi.5KUW4"CDCK!HhCf]= Y!!xrC)#Y]HJ!;?c9*‡I:(Z'ZCHzȆC(mICCP%v1!C!k*4Pc&F23$fF2ȬwX*1)l=VUo2U;^R¢QbI>=OR!{) \cCӈyPȇƈy;g I1zU^ Wᔧd!8ڕbHy<_!J*R$YeWXT UY62J-ȇ\ChnPx+d8o*CC!{*pB.H~"Cw! !^ߒ U?!n eqHgRCa! !ʈqAI=$ZCyOa!Մ=T0KꆢX‡C$6Ȩ XF$8FZ񱀖RȒ XYRU*, a% K%HIRB;|51f ,M𵌆]X 5E\7_qg660Jh0ܖkuRL]'Rt2@Z-QX5IsT !e!RuuT9{zsZ<:11s I>Xm[[[31fcf3 fV;7xo6*V,cYR`c1Utjqi ᪯؎xCUt.msKsfR*5E5Rq\FN-կ7k19jem mČ /M )YkV'0ceW`[aqfwh{zGH:9cHcZMj 54ɦM2CF(#Fm~c[1m3ʪN f aJ"Iuwi 20!TLUJޢζ@EnJ&UTKy.n-=[*q"3>.>c1fYXJOODQEDQEDQlQEDQEDQEDQEF 1f[T}N-p%DeVV̺"5XCZqqx_pʹj=@`Tw5Wj\#|a-)5me, 2xV5*K%X!V{e Z%EEEEEEEEEEEEEEEFn5,cc#!; f^ 4i$l=PϹs >ѫNE wچKָ4ŭQ]\GF B`!H±I)¡N(iI$ȄƙM1ٴ"&V+(\8)1K b* qSbh)s" su.X8x'9uzn@-\WnqHʡT.χ6~1R0 ZT:{8_\PӻfkZfjֳkV3ڜg#zf2ӮJ|3,a;1Pڝ]"WN(Ȓ$;;zz~ {<ן}uZUuU[[RlT':g }UBP/%R_mړIN:NMotX4{pt}b₷!hJ/ޗod+'`Uo"Defjg΍Y2$9=121 lhWەIHsy' H{D>0 j N# M!M B01w?؎M!HVw33 e+ȼSuhpZx"|TJ:Apw+߽K.שews{z>EJ~/|<]unwgu$䙵ZIIl^ ؉<AۗA',JMġ J((/d fQQi./pym~BRz^kıŏ U_9RŵIC'x$Wʒ>UC\SKN3O.'כ|x[g*Ȫ< / ߻%.OR8KR\Kۀ[6܃ߋ1=Y.-&+;tNb\r˫yZ3 :p*bWgN^ >z]H%j5SA 0`L0` 0` 0`[,fdfX3a l٢dCjʅȶm $.}x|;ƏcDy/~I~`v/YU k%N(&+hF뢉״ˊ*}gᯞ';=vwwIzRqVUh`Ԕx.$[[mrۏ \tHTc?spXFLpUjhdp8G.HQrY"a FAF@F}331slmnm:̗KvR$dNf0ЇIw{R'V:91̇l>}VUrsRnHv wpϊgdLĦ`TiJ'RY(u3%z{Uw#fY}|#:nUeK_e/2a;aUm 7fUFPԆd!e )c^{D`V!XFa c1nfhG UfI%+N0SkH!5!&+^Ycs@uգKMNΔcGSb\ _N1D$Ap=Og๜8qU]Nx$ K5e 1LC*]nXCR2(p vb<;c]h>ß)x/K)/A8>~zoiK%јfyKTg(W()wކBnv|IoQ=vϮ6Kޅ8_u;ef= ^.'>Ve63ێtoBdFUmcCm5HLeCBLf&fikBVeUk AMF dȊȪR fP&d@CII5F&Uk &!Y,B,Bșe%j&Li8pRj5aUpۆjd2[Pˊ3Yaƨ Tba``P* BKkEŅXEY0J P1 V!JLL> SlWfa6ɬp͵DH TQfEFbV!2!b$1!,1k#l1MfddT%LJ,TŅ){?x)? !b(?֐VʋT?C_{E<-0G^vcaD.r4cOv>'̍g4i~%$ڒ*PDKDOxCHdC"$9 2P1iuCOT PJM(j4*ʋ4/4$;`N^qKV [ f_WzҳC1 >}l=$P]@~8~P2b8ɀ?-pĝŗelR q[ɹMd+__t9'G#  Pa,E Np9lO_#Q[ kM퓪 [ji]3;MI{`"EjI_jm @;YDu'BȤ>mWG?2Oԧ^R0+_Ax}f+_"}j^$W}WGeL5_G((߰~,rT.ܶ䃍֪ :prM>] J'`gҳֵ/9zLE4?>,?O+uC O/ *|oʷCt? d\ C'f(~ W$?z^y=$/h[O8j64u9lC~Ӈhg~W6lU.oA[5TFUcD BasW;j)~ef5,vgf6$A /|PB $#\Wh\Wq|=0wrbZlpC a5o-4c^VeW7 *Z }4jԴ֖4ZW^x+Ls>rDL|HRxVo/kY@pd6]L̆6&Rm9 ,dL ,0Æ @(J% lD dc8$PVnB;<{882#:뮺뮺ҩ"Dfffffff`K333333333333333 """"""""""""""" f*(E֙} ֍FA @hl?zʣY~mmo^>y+ZֵkZֵO(a?-17bJ̑O)JmQ 8_cރmvd 2UJ/6ZCJ,CEPȆQ=JvKCۈew"JNC,i]avw5P:CۈhHw& ]CJC׈y Cʇ|߈Y]$)"C;y!܇Qwy_@M!:j):R!.Tʓ!C=Z͡J;dCtCCCYvh1WC21*"aF "5H1)l=V*ԥxz%PIhzChzb"PGCHxbCHyu;5 CRa*١ކvN ‡](l2] $h6 0 5a 1iLC0F C#P1Cd= P!V!bLC(XS|&e4&0X i12Xv409xdC!HuO 8T!T*>CuBzNjxaIC`&1 1 E^ZsञT>>7OCH| Hw0ֈbC!>$! Tq!䤝>mTqf;bZw(UڐD4 WdCg$z<C*ˈ{q #t؆0Iq2qZއ!Cu D5_mGŤ:[:LC! ` oD8w*O$C!:qCڨLȆRClJ"0kDDC1ɶ')&RU1)2 L"cd%RS*XbD򳖴10 TpFG2.c*~w=H66 * 06%J:%&WJs qVeYb# t*/q#T唆b:evI3"ޜְdf ek&cGR=F֚CZj i5ͦ(-2є1##yo1u.)+2P8x^=9c"BzOE!)呄jB++ VhE)TؖMx)Zx\ p*/ 0Kc.~7uq],ߞx×Yt<փ<wn݈μ/>OFytH8S!}Pc̃MyS N*l*do#$8c|ӳŷ{\זjm%}#hԢVKq% jiUAS*iX*MrEo/ID1UQP2eH4Ͳfc!-3XU`5V$V q2bL,c+g33F EnTĢY3,5DMf5$ր59-NNmLJ """"",aFY01fciٶkx2jI`XF[oQ V!SnhC $nF&PȆ tAY#Hm֒D̀lE1CSL V),fYIH(`-q\ ل粖ŪTզN8afkZXɖ5(ۺKJsu,OKzT9m1,B\U-E\:2k֬MH`KC ;aXj!485DEYHZy%;WKZXNVzk-%N0Y!& &$Qy xX y(aM!1!1QTt%IRT%IRFM ` `LI,9dž#,2#,7TFFYd,f3-@*I .BPBdUbRUU1%RL!#ȔB*&*+aQR0"DU!ra(TU&)VU0C `b,DJVE R%&C*#B)01$0R`K"*JdC)ED2L" Ć"S2"ԄA`(+1*+0 afbɂ(b*!XSt !12,`Ė!`0 `2 LdLP2TT ZXYġb% * dc˜ME "X dJ b+l TT#f0̢02IcȈ1 mXJ qV,32d*6U%%­Kj,#2FL&2d&L̠VUKkYTLfdQ#$eR )W, LIH:RD1D2Hfe D4h``bJ b#j̨1$o7EkHR"W !z`>W|w|Z;MRe^ %j%VV $TTe ! HaUVʨ5%U6)2GJ0ҋԦZe+TPZ$&QiEj#( QbXV1B%0`Ɋ1 $`IjU )IK4D-dF(ɖ,eEZ T&%FlHcPFEF-4PkJ0 f43fKOw`[:f&$wA x.6\*v> p{=xC晽Mnp]7N : ci"9䫆p :bƭT[Łd_IzB fm rݎM7pO*Xeݿv)IU|pBA(ᤓ9 $kڮHXOhFea4 &LE T`$H"'ZZ d" icqSQSjPhKݞю TrNT UIbCu18W$?ִ՚cD yRQ$0AڝԥRtyŃmL.5*lSM t>'cQNDξ)ӈutxzppּP@}H{lfInI~Зk_,jRaRa<"^/%-洝]ܭ'޺CwI7O̻/*q/pW|'+u:>1.+_-~:e̔9Qt,xo^%Ȇz%/ꃭt.x|B\V]ؓ&Oaop\ezZCVU) AoDVhԌjК9c0L*߮D>]w * 3 c;o޴Tޣ C/*wϙaz*JWKuQ?BEO ~GyU6/0_0Wwrvfeaf\&NT7u*?,}"uԿ5ii~_vKIQ{'[K*#B]*_C>g|NZ^Ur'ݎn7Mݦ9n^n^n7'7Mߦ3,13,=/!ynUֹInKs|Senqaq/klB'xw/}}d8Kyp.aͧeb8%%ueK_"¨\ ~SAlMZ>s.;E/lTeKR+Y*M۝͔S|8`zKN/qݗ5VP%ϢIRNv{ dV*}z8e*dR*:9N{}X#/{ ]kK[ J߂PuiXb`h8@j++3p^1.;lDܨ EPk·Ͼl-VmfVY7mc< eT`]R]Jtʸu{*ڐtpqu[:jAkh-w``\ꈺuxezm7me-$uZmkN[l`B}JsZX B%Qxq\ԝ%Ժ-/wq^֯^q6Ǯ)qSmCbP"F!eB#QZ<\T-jNk2^rꊝp΍igɩq,({a;myi.d]{2\IjqIMUFsߴ~saN)t;m%;%\ʹͮk'fHpK]j㔺xOpefffcBk:ޢ ڪZ,L `dLIYIgj$cv¢KomB+oZIG5|_h:*n#$Iv}ROT}\ڪ n|Ss!2!*\*\\~៽eeN<̀:k.8f,Z]mŬw+NYtvt gޙWUG=ȓԾ`>`<`7 ݜBB8QKN6)qFJ._{Ͷm%Ի.]R!_t>Ć}T>!ϫS*% X#}! f2i&mL15fk-L1ACUʪ1XQaĊQVefR&Idc effTLĥ3(Sd0SE&!{$1 )*QC(XP¬%%#0G6|fl7 Q"UQ5ZD&bQfYd&bHb(UʀYbF6b15lU)ɐXP1`*B+*QiWȢ+{O\B^ח D> Q*/ Ν_ziuM??HAzs5̃b`р(b򂡭,+1D+ Ta~;K*&+M~ A5f4q d1@:!eύ0Q"6e۞(z<`~z!>?F i!|_ӈ̍e|v~\B\آ\īE:-yICR);'JO HbCh48b!28O?}4;')=Ba C$ !CHpV xxЗC"Z}7w~H<~=k>/޿Yy!He O FҔZAK4 ܗgD`趋xހ i;h )$k[T9rSs9'ї\[I˃㣱b>JyFc0 +uW#|N(abaR叽 |G\w4t$ںAW]S~mT\%%\Jllw^cJԯ!P^N/_I[yW-O-UdVS:WړžB}'U?zݿX9`YgL~@TEKm Cs_4G" ID-c0:}n⏧>'.]Y-k"?!,{ʡ'C)'OUT\(~T?e4>D92!!ܔ+Hҗ5PAZ Z5Or0 m0%KZ^)AedFkdgԏjC^ Oe$}Mi M4P`l6  + (XkWַ.V7,u]u]uT'yyyzL $DDDDDC33333332"*IGG""""""""""""""""#\;"dSm1lL# 69b$i KmM"ߓ"dpqq&2?"""%ZֵkZֵ,0V8}?6{X|mldS*X>~ mf̃0m#?,C*'*jz??A ޿I#? dcԠF}wlbNW-%?_9_\_퍴zj@+R?z_~@4"1TrT.Ir\ߎ#@##Dc1࡝`_)9Z!} T PBlB@9EDɪQ*醝)T$< (Wgxy@ 5A@$6P{PDxf@ԥ|vRީgzRQѠ C@ hh4I2SM4z & ѦCM44 @ h4zC@F!AJd4'C 0L0`dh00LL&#b12i#$ DMOiDyFzG =F2?T4i=@=@4 hP=@h4 hL@4 &LFM e4m=M4қ)<'QSj=&jxd@z1I*)N.ZR6$1 !7qV%mi-[Э%iN"%\"U+XRq|@)7(eT,C8[e!,7!䌪T~XHdC C Ro͐m!!!- qf`2}FVUO8, 5U؈y!^EMż*;Z-!*seI CքqC:JyO&ZTLCCBX1Cx!Hb!R!ʐؖ*S0mQA@V!H:UrW=d*(tPT_5RnD7He$Ć*2aH`9U X i !C&RC 74W}!l܆QSCU[$ ed2$ P32AlYU6XQt̡0Xo&Z@ k\-)H*Pȋ!]!Cr!HdRy,C*y*w*NGSE+T WuZ9ʤ.IGQ.!Wb)7URKXWa.T4H{lK(iRvӤ<㡈u!iS#"Rxr5He RC]WaՠUS fB<{j!ΊjCJH{7!؇OCT!Ɛڇ$8RvTP߶!چ:؆ϡF(R<8u!ChERLRr /jʬʬ*&]eVV*(Kh1 AjUc[ M7PѦA`aVUheXUAcT0z*7n7dՕS"dJmb7j-٫L-LɌ#+1֯Xm2YUe!8PC ʔ5;‡HpppnCTڐͤ8'L'HwrQ~MԆҩnz꒬꒬(z[;ʓCߡܔCڤ>E!uЊԆPi%!CxxpG!]THz}!Hzq;%uxԆ-!:TT;wPC䡻bHaSU K`պ*CCn U<ԇ I5_FCPuC{THs:bCrʋu! ԇ!x=JCpRCª |}PK) 1ɍbLUij[G9IU9G pZJŖYel% -SD4P‡ CW^J1Hp&046&wuc0c,3Y3]m& |`[vV`8K/ݸ6L0-eF'MVh2X9}ljl6PeIY4<,],0e16ƨ֦k*sO2ֵl̜&UrԌkLfٴL5&ocyvmA/}9QݥM2kZc Uv8l ;}0ttCZj i5֛&4dGFnkf5xYEbJ̀m}V@D)ȋ* ;*5RO#HnhB [E%jU* ݱ,%Zo[ȋC /91fYekfb("("("b("("("(6(#qWRZzMu 5xcRV* 55=&k-5`W;֪7%s̀Un5NVŲ{aS`=j}Okngs ϶4QM\<" n A1 5qRY)9:QShEG(pV+tŷw[׎jm%|#dEDr RVQ, EYj%ZUdTEM,V&d7TnK"UBCXdfس2)5ٴ¨U8,X兌`Fa33UFjV$L2K#C&e(YDkBkH! bH&fYլ%n3DDDDDDR* KmŃfciٶktQI0,#s5*&HdEe 1CqI 7*H`CH7ј jBXi) -X25",,ҢٔECt.n%q87岖L1Xִ,kdzQd9T:*]-MYU]d;NKn*V!%RЫ*t#˟^jSR0v"q́dNJîdj+UГrV+-H7X>_#=߹|:zfeY*!PevLU"ʕHbPCfe! PĪb2` HHE j%4SZ@j%5Q bXV1BȢXdHʙ e0SYa HeJS[`4(2%#DJ03)HldJbR†F)F*53*0D1C2X l9p`v}]y˧spq OpZH^YnePVE&Q, S-ٌ[t UdݾJA[%Gw&3EDp4Јq#0A}{XQ%y8tQ"}8'1O G Ӑ:"f? `,9b3X*ZZ m"VI` oG>Wns@iSHd1O&DjEO{K!si㗻‡S(S**jz}1‘QB)aC PӳfkZfj1 y"@BBFH ٵ93'@ N~3bbmL]w!j ҅w<>[wq N$n i]:o7] ϪҫUmlHI_Uij^ ߕwz- hQ/kĽˮ"]dv W~ML+MM`Ǿ8(/J'U|ުN&ԝ%eX1x!;&]e]^񮥥ֻWRH7-Lv/x#(oe llQd`q>v7nU^XvvBtE`әXĎ*nG N!vH_7:8EY{Q>SڊX.;)F.z9ӧ9)p6FyN}Nޝa9;Ȏs_B.d:#;Q쨞~^_i}DЗBCeI;DK jKي{own7&MnTMI$at:k8QmI䗓x`e|R&{vN_..![p\出KKx[6ݖޖqKin it%K2/wٛ-5ع,Df/v}oJ}ꦂu~ 3-3E.l 4[%k# 79B_%Ìt: >>bw_xׇ@7}E.\Y-|2W)g \~;TmG-/#}b1(,S8^$DTc`$F!F$E23ʅ2FPMH1B֩4;7Vr^LT"MZhO"Q !2C(d0df1#`UmTڭ6ٶs`$e3j9^8.ݜ8e'Nr=k4:4&.cIڥՒ_e$ff,3fJ~%Q<*u[Ueྐྵfߝ{^N) alʁڗor!zNҧ"λH:tX2ʺI!:"'ϩyOK*^*TRn8K=ecw7]i.EKk]È̪<Ձqu(.Wz}=lB>~eIǕ 9:f,ݫ^ͻjCUbʬ=B=+UU{ސYؖ.˃ڊʭZ3*р3[mmkjXZe3g*^gܞY.-ܒ窞 [o Z] {*dTP<[/Vo:zC2[NnщQ$.hTEUQvbVL2i.Ge]/gޢ\ʹͮxNͽ;$7Xm)w'tOdefffc|(eIqt*GJVRi0.gw\&$3*#b >=p9>9󊚕IJh&ľvLBL y(},ٻwJ X_-knDS^֩m$@O :R |woˏUW)1i"rJc[BSrA2AHrRocY6;l/1][Mb-|zjsT.GXZqCWD/:x b=@> ~uFi/vA7K9tU"LYnrǻ.`sΥ_tIR'p* ]J p^׷:f/%R.>;LL3I"/4>CH}H~?G"͕}Y3hDXaZQ+iݛPM,1d1nŰYnilV+6ViXcW -dhCfزhZ-h٢ 5ִY nC[DZͱ6Fhc bf ƣP4Xib*1JC1 !2K)̃,32De n`,yYK{ 2)BT CȨ,L&d+٘Mk(JkI@ReLd),*ICREY!Q[W\e-Ukl-ZX"`dY`aXGE_E|j%ܪMY*¬T^JCzΐrCuJUU%U~]^Rs_UwUxW^=ih*V),! k]3h![$ KqC#W^oH4qp­L5Mv^_Se?#mPa}+WtxeJa`I|]0IOᪿ|{y?CjF#254jj_2wUU'l}-܉}*"\IIhi 2ڐC 2P1T~3C)8R7)<T1C(pTP !jeEJMԆjCT2yؿ ~UkބXg.7s ҳ,MJ3!Hb]?aJOWɡ)$H-`87PUXql .WHYnfD>yv돼|@0 #8 DΊM;MtB9$v78+b'=Ѹa .6,#f~9"5 By/8?a/}_~'W%yԿUBt/㤮9xWKrjK+ޢ|]z9 EL3}:v|]\ lofj}qA{8AUTNb3 çݶG?ќz-kOd~cߑa?IbjU?+H~G܇}Ԇ;*Cu!CTRMȃ}k+SHk)ݗ[:!SU[W;EdIk@65yIu_spq?kBy} {[@~o|_.,m4=O|Cqi^_֣+vwD4w_K>ZJ-%DzA H"\u?~rKP[cCTT4d)^u^pE5`/ᘠ)3 ?_:ܿ ?|( a T`:P4$ @46@ҽ#:;RTSAOLGߑ0#jDGȄ##;RhFhFJGg=)#HE<5Cު<#*mU^F<=Cꇞjp,\J))#|\Nhׄwz:|JꡧҎ#G`GaħG-GFnr$vvnG09q4R܏FILn#Al#>G莯r<{tK%#8zH#܍–G*qJyB:o=ӂ=–) KJYT2bRX#+jխ`Ur`HX%2J )T1T10*%* %2"ROЩ.ZF3 k2Sr88k\' _m|K;pomf>܎j֨k\XF#L7#mx[jt(<TUwأ`⑒4Fڂ2Un(mTA"=)2DPކ.~jDJ3##).[Ź 7#jrYEDQEDQEDQlQEDQEDQEDQEFY2ԏ†2&Yi#SņS5Rspy@[WjT9r0̪i `1c A%-S0*iЮ)m\ZQQQQQQQQQQQQQQP3`Dfeeu&x L4b|uwwxc51854[׏Z <DSC CZ򊘰Ju%M-;ovk|y/3=B{J1< SPƁk@ELbTILVZ(RRQLU PMR0!CL3d5X\kTɊVe8iTʌÃ3UFb[JI0ʊVj3,5DMf5IIkER!#>Yj$81f2EsŌmoII0,#vk-Mda0F4PȠ7FSTPʡU #8 kPI%c6k*%0FaaTݕ))J*F游[*j' V05,dPHCHCrCچpLh2=mPҋ ASR]nFD`Pab i$5J[KE1y*w p ՜ 6ۺTne)I"`FYHyj* U FJjF )!1DQW3***********4r;U8qj5FQj5FQƵVp$jhc`̵J#aU dXFPFIS*JFJS2QRx kU"(\BTY ʡS2K2 b,d,U(b LđS1JT(S" CS$,QLU)2,1T02ąr4#*S1(T*S*Kdda!P &UfB2(R+"nȐ$0A1CŘ21 d Ab*[m2Z KjkMdER-P+J$TLISe$0X̫"Ī&K@7# )mS mQ D7bK*#!# ,)L%3(s5 jjc3RI%2F(UPڵiJRb*X3*(F,#$1NIU)AHtaT0e%QhƐTڨ4mdU ~#UA: Y#cxƄ Q">1ZSِ98fHM{!a˷(M7(x7%45O (jUҡt9EMߖ[x{~wh~G8P>qJSO~)/އQ?4 ;zhqxhyNKuuO>A UFU[cABeFXF2F]A#2OR;]ufe0GOيv㼏C/5S|?eZ{⪯G><ѡ}:4_B;hl[P>/OCب<~tl>OCHvZ =Up4>P2%n_& 4=f9eΗe]]]\ xxxYnH3R)Ř=ݡ~#8_Uca?ܾ7w;q͛oo71A6ld\* H:+WQßYu-z*[}ءuˍ'A!tk6|v?N>EriCÈIe ViңS#jl^FE/"GPc?:9Cw]uHH>`F.6T8էB䆂mCCAh1\uTQxAUY 9C A7uP5ۗճr:t‹OHk'GLYB^_j#Kڀ 0͌vݙs6ǰPsmF3*(P#*Q1"ք[ٜ:}JNѭ5QjzR;F0F3#(e ̑qԃ%&Adp&0f[G҆Z-6KENU fnjM))Q1fX2qk8|! [ȨjOJZۄq\O(`=2>CyUӗ=]#v$ࠦG*>|:M$x|;Y5 T8vՎGtgP؈:aCcGag2L՚48 k^htP(bTڮ[rյڡuu]$stxaC2 0` 2` 0` 0d Z}&1u21mY$ RjRh} }ϫ 8t4{8}tQڧԗnAoCHRnu('r:،E\!wrG*C췷]uvqP{$ h ACDhʪdQ0UMm\%#&fHh0;MirLX^ƪk'4WdQ瘱$臐$`L$ꨛܭ$J%k3WG=:}zu")2'^ fY:]g'G7+9A1.iSRtt os#3(dS2J-PR:]M7W>g,_a7ln#vk 40kaGs$j(f5NkX#x7k4 (}*W BFH` 6T&,i1_ wMGf:/1CC2P‡^"PCGŕ:9WUCz oPn 1"\Sɬwp2NP:g<3sPt|w>P}[(}s; D#߰]=YϵgF?dCII <6=gP$Z"""[/{; F Z=ew)~GG'``j&k_FqӅͱ0Ŋ|SOE;9qK4JjL D)4FU s#FP0#ߠ:fI-|w<ͣn=;n|;$I2I?:Y똖`=௕D`4&SZ!jDinjFv9=ӎmYWej5x 5KgZyni Yl70]eYe]uGqmmqHp3333335kZֵkZֲ"""""""""""""""""#333333333333333333j:J5Ǵ OH%BZVKY.NG`J -s0RIJKM)$)J^Lj5JR)JR)O(KM%)JR)JR"3 Tb ,C1@Y ,>[}c%cj-zyCڅ҇JHsC7!DlC e)GtbĢZOf&P|2FgCPʋAYbe Ab("("("("("("("("(5kqm#t2#2$iۆZW$m68mڲ==!x- j anjo-2olQj)2P Gql[L- X3% oAX0FB8/Pd)!]5Qpr;Ն7G]GppݮnY<Gǜxqgh֋<N[uFKͭpiZ,,<9sSՒݶ&"""" %lNXCn:61wdo.w]w<TmI6aVݚ|Uzbb*a HaT0IPȆ v#*8 .d j"Q3 15d2d%2Sk)Q (Qr8w<va;6IŪTզN8afkZXɖ5 . 15*< 'ˉM] !CmCU扪&*@!&\*̬TECi2pC4)!Ś\$`K+,rr#zJXvV!2BOj!EQG<*+P%&T YR(S XUK dIdT2JVE"XUI BLIȆR!deRDaL(Y2+,2 Cdf1U7b(i I bX!a C0!1[Rj[jd5D2eԵ[33TbL *dV AK2X֌P!dK*8RfD 50$>mU*N0B I\3E$Lb1JҩIС$'*d'1G fffAd j(,#bɊ1MiM-mQ5ֲ265+mژF #$eR+ L"QʛƠRk #7[uD1 be &!*!QQoB TpHeB>|尠/>^~~ԇkxr;(FȄ1H4V $TBCb(bfEV)VP Xj`elV SiI^Ṿtlc3LnV ׄ<Ǐn<>tǎ]'dtV88_s-+vAwz]nrᎅoV*-a Vs`z!LwKn.LfnA5˥LutE/tv4Kj5$WI9=8yZN˷c:5:[offni+,:kϛs9RЩCm4_?v~AqdQYULI4 IuLqJNLHg$6qvŵkYm~>fG3^Og5V^0˄풏!);X1lfc,t:w.+yeoH5`f¦nGC|3LO?t˅V mNIѧZ*]lbzpS Lכk_YҡP=4ܐV'։/bw5}@)<)3''Л 6'Nst |LSsMB*r$N_!NO~v.T_N{?7t|Ӥz8mx^ǁnxre>GCp#ڍj#3R_V t5^\FŲ|XN2ZKCrh֡2F0L>s=,bx>:;k?~'g U}Hz?>POަ^/M! )'(꓀>n/y^=ʓ3  ə4kqImE2oGlm>}=}P!H i=6ߤ J܏fet/{1sωfVVV;n!"3U^GvQsȏ5:gfGzR8?裊֕(<5 Z&U8N>&E1IO> ȚtӲ '_ o*{sQU~4Ln ?WEډ. tVزeWZ&c'&$xD=Іc {'MkS%N'Q>Un\3R>eIc̲_&׎'ʝ]]8;[e?~CqTu롢䆈j.33)5gjRBZa5iX]A —7dkC!023to쥦kz4M`1moܨZiTaKT{*:LU`C ӎhdxj!|-tDEx5L uDHˈ1Ww؉_!l٧<&m7ݵohCD~m}e뷎5Y3t3n.{˓m=nrol' ):#17W6ϝ"v#RsIkEbB"<,cH$-$\zS_B}CbP"FAfb2F*A JKZ;)ӿ۝/CTY08VОܪ~E00#$b1#Nd1+KT\s33ԶjzvN輒ftUy4I)Rqz1's&$b(LCu(Ĉff,3h="sE_ ((]^\[dl(@+؉b]DfBE|w%%tϽ=eCϾmt}i>O<`ybzo},ɘYР4e,m~p>fD/n'MW)8&]_+,mG&U~Gbw<]\_BKف|w;8U`Czz]}E}MnGԝ鑙D`cЄ.O,śG=?S=XyI!=Qܿ +ؕWO'Ԯ&8=SqiLli4[,k%W0%aS,C>31.'q o*DFO2}d.]aZ='8V$։׿E#rTڤqHjg=>xs3,\tt|]y\e,*9366lO2y((]YFUcCꡄ>0\%H]vړ"j2LUuD&D*l9J9ƔIA0tgaR8q VRtV[Ԏ$ВhU8~>LLϫ-J$7~nJUϐâi^;K鼭pt >۩5R*]6ߊœ3蔟!z>v(ȝP8sӾ(IMG>N ;6RY#=MN2uiua>瀋4L'Ӝ|nP뉕)q}^d%(^O]ǙwåCC(k0jq{tֵZ5iiuNHyTWd´WitS!C0[VZ 0` 0` 0` 0`n2YYQ30lE*12FՉKM=>&{DӊzUO^$N_N}j}ڒDuNW\kCov&D+58(m7G! REy^$${\ŜbfDP>^ǃ'Rzyn֬cFP Cq4pT40Z qtV McLoadzM Hdq͎%da118N4~4:fL&O>lr Fqi6YQ2fgPQ2&3Na4 2GK3͓}7ErYIkoR`w+"ta VIVF׌&PІP2$4w2Cixf7^$gi@Zpt%eIIo˸׍O}}u}nc'AyguD򗥨EQُ3=MI}I-~,9o >`!#؏rcm"~$m>Rs)?bR~W lI.aբ\bh|R)?*dC"D9 C(bP9?~;g;NQ;)=;P ƒh CHpVT^X!5Q{!2!{3߭ SAf πq}{0HxC(wS뿃a O4![ߓCmq.=o$>%siiIbL~^U,+$ y-/'76&< /AdSq4 gDd<" p$迍Ia͗ϲä]UL翺e89+7"+$6^![qo A{du] 5Z{'C̥wWM~\\ H_ ~j~ e>.jWX57r?`Qf!YGﲍc;7H}.hi\3 !G"3%[ra@ugd9r9`LaG]&hn _s˶78vyI=o>.6=3Oe YLH< Z8qKSXÓUM,sIB)C˝5Ҷ8ǢG³s!@X8y]fYe!3B2LWIs^8ׯt &4`zztQMO8Xh+bst*kSAZCURQ|i_ yP :m[{ ?ژ^c5|'))+|ϗ.?+7ʓ)D*(v!G9C>B"딛%؇Hb*Re' x|RK.ڥ܀9$C!!!ޔwR↕'yW/E!=JZd;ԧy#et ɤWCTu2C-!Rν*4Pc&F23$fF2ȬwQ@f PAfCj2T#Jb*OP.oHix%^ɇ^*%Fyi!Ί!Rzw=܇O5!:Hs6%mj686.!†B]wA*5YDzԇITIֆ) RbX~.Mh````eFA`iRb4YR*ʯU0ކ[c[ M7L2(eVU`h(dh,jMW 5eTș5$7қ6 )V%ŇZXm2ȋ8YHy)oPRtr C'=b槂!R\\[*mH|R4HqNԤ:rIJM Q~f|CM!UCP[;IhnTC*CE^!5Cơ>!5HpN4QCƩ;>jOȤ=>=jC;vxZCI]!:vT2mp!jސ9] U_3)ܩ:{Hyhmj !!Ĥr5_kHq}-P^z:i Hw!7Ct0KzCt79CWqI:P Ǥф=,b%uCQ,(bf`e$C!!pf36ҳ¤* LH*Rd0P1QêS K*B~9ͭ51f ,M𵌆]83,f/f#S\lGrcj"Uij[uIUМ$8իX,`mIs.bnSC(aCS #ܕ&b.LaimkLֱdgMvlc {amlY`,1czL[uZcfT%,7w,!7C*LYnɆ̠23!T2p]k3,k[N3*4FN-Ӧ3l L}pc}夌-U__tFg,Ƶa'1X~U];>Y#HkMA4Ӂ"Pшcz#Fm~c[1lj]RVd)U`*B",aPToIYQ$2U\Pr@ֵbniozᨖ11Xʬ`1\", )1 CU~2|v*6,L`*********#0f Ph2E1deu%|aրS4bv wuqݮg6o/~;ڑzʰ 1 I) 0C  1C)A TK,"IxɆY iIZJ PQhd(H`*LT ,  ISaIIi-bT %,!Bi42eKbFM*%X d R06#*QmfU&`c1C2x;p- ;`  ӻm/t|:;cyξȶ['w;>wv87twZӞ&34Δ%0xy2. 'D@A'h. B@KR\.z ai~cpf0`!ЅJ̠*gJhu͎='t[s:}x;Ng/wS*dTʡEMZ]^6{8TqJXP}PAa@AHZԆ*٦4}Yc}Sٙ:DXϤ9V9qZBPJQSp>wT/_-~CD"^F%R}:pֺ^0=ҫ*[ܠam'%)3ĪS <^/%-%7|'r=IIsT.^˚_̗yTR[nh/|+vPbe޺\H +eXP0OC]Yb^5%]kaԽK]صJܲ]~NNV"4E_^BaFF2dGM++Kː+]mRq`X|DTG>/Ӹ|J1_ дulPpEO |_MF՗T;ebp$R͞I_K/uKG_K]+)}^?人;QO2F0wF 侉/ЗO_('Ixv ^cy;jj&&&Sq63w fd)$&%wٳ&Nl*[VɾYŚ#KM} xߴw}}d8Kr\p%-OrpKys% GD)t??.28BR3MRNx?M*uxuM~|9. CE/mBM'qo%kD[\ޡx$:dW.~q: v_k@7E.\,\O v}*ݔKpTaenmQ|w{}{3,V#o!.U ;+ˏA7ӾCU[Phy. 2fYeZe](*ȜJENU*|YmAѭUmZ͙ZffZݴmo[夺Kط*vJ_HtWum%X}zӅ'.U)ǔJ̕q)n6tfmmBmj$tzm믎lMfj(T2j4!`x*IʣC N꣠;!uK}bFx{7ǎO4۫omr2C3ʅaicm Z#NלC2^b銝$UEP P1CP2 C3GH:@*K8&ͶZiVo*JJU' Ru<.{dD%K I+`YI0ݡ.P$ʁ'B>^N+!auSygY\. R:p[^Xl 0ؗn̕9 /ppK* 2Ud-K*p#fafR\T{\)$q/bJ\&g~^X{ KzRZ].ǘfU|UR:=\ݮĪ^!ۀ]FY$eDd'CjsYf,Wy檽v/-muWX:9VL :ҺO)LKKzgb[Tn*u'^XKMI`haf*⛨ԱS,Qx1xKlWS^'7xO{T.0SL]a{m\o%d^U-]P*]dTg-OoMNR%wzS8W?3<эdݷqZd UKv팬`Ի PbI2'f IJ`\ۄ&$"6,ߵQ'εMPEoĖ$Њ\WA>Sz92_yz^J)W=oƥG,T/"GF o>w1% RnBO!uaϫZ8Г&ԣ2RyI}2]{=$GUK20'K0x괴ihVv"u-8߿cპ CYAsFxIĮw r =UJjM 0` 0` 0` 0`8c3'1ɰSQ'KĹubX9t4{8U%}SK{t^|Z&JHJJqK'sqK,}s]=|D5y4YUjIQT&\i 6٫jjF,1i,4ZZ7N;d"* [,(>(4(p\ֹy31 NY1s4% zIs缷`e4A^LGsMW Wb }BmUIo<'2K dzmqc?~lϵ_0u|X:‡  }Q4e 5eV $;21iNiVUflfwgp{ߟ~sqUs- : F-4_(9Tt9pWp/*bH1H0Q n8lv.=:\T8CH}JhPo';eSA6&hXV8hLK UX-[L`ʳ06lifіj3YQEmF6TdifP1Q@i()FJBYLU)CX̐3 L̃,30IL)RjRde.Yc EF!QV!X¤̑#)+0dQfڊSX*LH#1 fYa&e!,(0$0Ao,Ŭlck3&3[`Iibb&&("` W ¯dK C(b|HpC綤?4 †UW>^=GQ쇡U~ҫߧwJuCY_߽o?[8{7? {DgCw:D2 x=0<2ž:AB~OE3~;-$C>pz/T?ԇykznwVE~fF{d`9o pDE`>pӃ?ڪ|_ш̍e|~}g O/9 w]]CE';P†ԇ*he 2!9R@rة8GRy:bP4!5C`/k>/sCߴv{9IQdF>KUpAf\`lpgQ_̃` 8AYfVe>ٿ7Jn[j9t?dG?zߏCCDIVKRpJ~GHn5T> † (s4PR~qbe~*i e!)z)5?+}[xy]o:=>uGPOWVR-tv@ԗ A . R l"P4LLbQa@b['B˙z*l"ڿciU軎066VXA&_&ǰ@A0z?Wя*!p,R_-kKQ AZVS/_5J;?C@g= &jn ZZg| t?kw;l%m?{ou;~mE<"B!(J"` ZQ|˂@q8c'xf>͐\9s9s~N:tf͛:򪈈ffffff|R""""""""""""""$@h_ȸsCK߂ļ3RAwU~ t>]}r{o~Siǿo)u]ނbL+rR~!! -@,ѰihPI`(jKeL+` mR5`;:4 *ArTli) *P B ֚chbіZb ْe@ݝ(4WC8J E65@E@d*E*M1 2ڍkDT *DVF@(P֭[Q;8ـ(JFi$4ziz =7L)h)4#z(zSbi=!)) =FiMO( hS@@2h 4hh @ IE4)i)ҙ1S&S&=Ld@#Sj FACLM0ALC#A5I"2h&Si4LH&i)螣M4@M@ R$4 =4ɐ4*o51=Sʛ5 NHS*AS60*^X-ՑoIdҵl!Q68"0SS%R誯gUK_oQoEEёgT;ȳ%,)kW0AK e1RLeLKmM)z6қSbAN#y댇6ҭb>mo\C@ bV1E4L7@4%WS>qNJ^O!:ASN۪_kfAOp>' =kJ)S6A=ML |SE:tCP ̂33EY%P,fYUm\rJ/X{Y) f*SO'Y5 _OJ~S8yO<>BUʉFmlӳXVQdHf|d:TbXug]m~x[lmh̛#Y;>vv&R;ANs9{} y9\c5u'6IN< Ԝ)Qۓ*21I.{U.U/ONLTS 6-TLPSIUo(2?͜6M b/~d')m)LC*UOrSFhJLJ6ձme[XmTa["{Ѝcgm2JR+mJR `;Tʂ^ LJ}NJp,E Uj/n{>VU.?KK輊Ix*;PQSFqLJ=Nj' }z2=\)=5I]SS}B=uK mB=IM"JvJ3}"HԦ)SvSEEzE="xS)Ibz |OJ)SEKSJpSKSAS8Tz{E=o:]TN<☃J~rMkEeKc&13Y3le0nbXF+Tq0zJ|91LS/); b*|S)9 xҡ|E<4)͠="+0f_*Sҧ8|QM zJw|rSΦ wT)9S]p=8My52A]Uξ.hħQr ]:HE*eSׄG`2y.Da0蚓ʘT`HO&e(4nJ1&)S)81i)Ib## 4fXdR"޸K(b1,k i[V6-+3MRǻYJjxdXV |0S w؊|QWY(T^ѪA/.NqOT ~aNuxxŵ@zKSAC6~!LA0)E3ޥKާ)JpT㾞)ps4)1O|SQNAp2ڥ⧗Z{yx}?) p S8TE;8Ÿ^*݂S~))OE*UbYYZjժZjիVZyٓὨ41II``)1VUؑmU&3>7wsKJ4iu-J^+on݌&X/ٲt,m-,2Ʈ.ʖhL2s:ea2MRC|Ns,Ҙ%9vʥw1QrFX /-BZ tԽwW_x77zxUleݭfS11cjTİ-cjXgdيxcq.|S?]]6LCS%;ܲY=lD)̈/>[!gsfʫYYTk 9km8-I`2:`9MM1M[tS^ܚ纫rY@EKi-i֚KZq8aV)4\Hp#݌i^'x^5U,*ks"{|U2Q.{#$@5T% +)W |r I)aT8nC$:ZS\{\8/ݺGa:ڪ90YS_G :gǣVV[,i>RQ[QJ)E(RQJ)E(R|{F=OcIeM>ЙdkWKW]|03S|ټ-e,/'gڪUUUUUUU_9UUUUUUUUU|IӤt\˖UrM4M1c(QʪqBdYE+ %;M (PB (PB2m"ֵ̜vK!S)bFiK jIz軮nwy.\>˧V]wkAͱgͽsi׭Qd^aq3$կmUb1Rw`1(p>ss'3 boNLi.CxOԲ,gRTg)/3RmTEdP҂XPќu[UZ',QR a jRQL^YR0rlc6{DGa s 4&ƶj=Jmn8mrC)əajeMdDִ"QjYzѮ}UZ{6mTMJR)JRO72ضLXv\c:298EmRޓ`XG \e\PT&)0SU!L MAqEX)&lCUZr&c5 eQ dK-Y&"6$ElI L%:ć>'srk5`; qfܳ6bZT*[wEZtΉLIҏ|MQsdO+U7d/+\||5|VX!c%N^,jj` r(p@wSKŞZIH:} j֙S3tϦi8! 0ZPe0(UzYKdKQh-EX c% !,eA|SYGiR)JR)Kkkkkkkkk*{f1Jr̸U#Ɂ3 lȰȲB,bī0#XO2hRL*QbZ,f(bDbR@2 U,S #0J b` %PLAYB`ȅ d&%EY e aRX2¥&,V `AXEfHGbMLS2,5) @T$42ef@,IdHTL"& LS Y2d5fd 2deCcIIX4*4ª5T5lf[F&H6f#5̪sXQ$R mmL٨LcK&(]0IW9czI#h7g7Ma5i&پ}F=3H$i$HM$vDZlղ#&Fɍ~M%Ɉ `rL,ib1I"IS&s9bi&qsb̃i$I"'w/=.8ͯq*ו(;ʏGun37f׬ܗmhXXٖZֶ4ZkMX5֚VYdd"v=W=nOmweÓc4]8{vk-zo۽^;as]3ch^y:r^ ;3RW{gWPNN\o6ޭfU7K.{\ks-:bb] <mݗibU_(bLg0 ;uYg3r/Y=qh11mn۝ܹ91xAJZ6=z.| ruB2j\Kˇjӕu:﬇/QtYC(|rZo8rZ{97}׽ogObG6l7lFcLV>J2iaN4)+mJʟ)+&6ɥlҴɍ2iV2c&dnѳf7iճf윙7i6p|7ѕm⯍]Guͥ}ƣNݞrviV"kﴽ'6{~ pcW.\զͯO8{ѓXirZi=9'foIFF,Erue%y+Q]4cע׼>3͗cNF~\aeXy8Z ۴s~ǩsszmCëɧNNlpraGgWli:f,Wy4s`;<cO&iN:ŷgF166Û}Epcqr/E괾߸wWS;4x1b1 6iQнיw@6|[|.sAыL=GcNK-$rr֒I$I$yD{?H, G7/imc\ߤ?JlcM4f#rr-i$\i14ƚiN16'Ӟ=o$ᦚiM4m4yQŃ0{[it:Ǜ311ȡϵ\k=WV',R~:i.@1O{a0Xɲ{<&<mCt9Bw=oim<{m62sp>dLD"' va%<溘F}YVYc1C;vO]{mm16Ӗdc[SyYhƘwM4iWni0ᦞM0s6 6mZhٍ0٦ʹÛEX_kV^:;ë-<טk&ۺQ1/iOWID|& 6ƝžM<lӫcMd2cG/ƾ%=͘ml=f܌\>…1Ry,BW8h;o1"fUmCeGyGf:)|{g.ׁ)}nÄʫiR_cl `#S VO|V7VO1'&8cn֟ѧV;pF96rspồrnӛv9NSv;\96trsrsiLn6998uunÛ6l4ƜF9te7scSMNM4ٴÛfNٺ:ɃwK{/$zO;NrV#_٨&FmUDis<ܥK/~ E6ýy1hzq4c֌x)4i_۽i͕9-4:-L0}snNlcmә9eWl{dٌXӽ6zVmGnp6t|O'C3*7m?FܸjWGZl 0ݍÇOkxI8$H9#8isDr6|iyzZr4tttsssuJn]׽6416ᆖ? ɦ'{N'CI+u+L4v˳t`٣>' 8:::62=-61z.nx+\%y'g N ]KKG{o'3cn4O1ܼLML`6>7ʚip izVGH^c=.XцeV-rƢj w1y' ņ> i;cJkO9[+@WUQEC`;J~shGb=@p,>%9WÙ2NF=S*6|.-<m0ۑuG6iÑVw 8(:zzKZI&ImŤd[d0b6_N&8s\ܘc "I'qf"Dd4I$I$D"DM"DmI!$Re6IcﮆCWa}}c^q d+o194Nƍ,=Yaz7^5$3$Lj~բƞ&1e~uWG:=ocy=4~' Z'mE?[smv[/2Kܘ"NOIW7F>;NcWE1:9}شrIvxx:,c}O=,ccx_f>嗇sw6hz?ic\>V>Vczmo{g[nouÓݜݜmL=e'AOnW{ =?H_CGߓHܼ&a;p ޏ^_-kܯ)'IoأJ~lb~~OH|GOcOlaCB|{6r63;HkOr#> S}s<~'TFe&X>Y ?!ӌfrR8H(UWWj_FǪɏpv5>y_-~5tiMLLLXZ^&Gz.I\7nrsi;+9ʺ,,.ˁ*upӥÇ# x&y:ݙcFXW aUwz~ؽCʆ*<*[!_,8u8]e1k֍Ѱd د&0coMUes-iջvrc94Ӳ^rܝɉd`ve>Pʶ-CrۛiQ۷n%KM#W -1jѧ~ݻF/=z\mL&N'w/1ٷʻς<^Kc3m}c:]8;tvtuwYznvVc&iM' 8m6bvi2D$q!~u[^1SƖXX1p:9;wzOBv:;KKؚC<gstvzOSc˵L[;*VnͶp ;:46ӫW7'7gF;Ɲw; vstw.We4] M4M4NMM4mM4M4M4әiiiiZNN;ܛmëMpspƝ[wNtvpm;9t;4 w;ݝ iӓgWtsuv99ӫ92vzrngW''{0wGC|H|y]b'Ӧ1d sgcl& ]+׭kfz>챧7}7<G{|-<cG1ܽcpv:6 tairtikNwF V W`x}Ok)m,Y[ ľ;LcHs|m[[/E m7*-:r66SdZ1 GKش,s 2L$i2&͹*h5TX"I菤|n;i_?]l=mֱ1<>&kI[i4M-"5}wKiG l-1i'W%p#hp<M&Mi9qǰ<,ihKnNjF9r1wIV+ r.LUC>Ć,Jb;|w>]m&wC:})eݴ`  XaO~Jy_q9$G^/uVӢX?O~?Wwk S<4??>7Khőc"2Xk&ܘ ؎|êip%{zG~D }_t|x|{f^&d@ψ,@ff%υ^;f2{' nNRŌ,m6mlabil 4Çh9;>[7I p['cthӑQcٲٌeBshd[Ͱb:du+8Q z^I0&1hƘ8iV_/ h>MDZupJ$Nê|فjC߃WNYp?Yt4JyRv2D1}\=_!?O_\3B4gCa `t(~;?ͳ|WUJjDR(U{F3m_Za,XX YlR_6aQ6aÛv9NfiTwaykF4Gͺ8iâiÆ4lm4r0ә64ᶚmNN{ܺ;;W{rcCӰv;t9999;9:riыrw89L10p .N''&9к;mN˫ѧV9\w:6v19rmhѷ:98;.Fm:96ۛgnM9w:,w6mٳp] wu,]kfMLJ<&#u2KExOQq4h旔6KRp{WD1wዥ< ݘ !PUlKB&ȯ?Hyb̳(SY*卵z?Qa  #1U{i\俘zKOͱ5jĚ|{$#~'c,Fx!axoe`abozq*{R|5Vb *4< ùbNi J=>/ ,e1-E+[S1U`U^#TOGB]wmrvIE踯h#;Qm}Ѻ1GeKŅ|bI`K*ҥ^L >A{:{ґ~ؘ>>n֩solh+EqNMH}OpLFK r]Z 2mFkN܍蜹k ymt.7CI9p]prqr+hInlN6k]$'`sT;}psGKQXj2}ry/ՄO+)K$E'pz|P滈wSG14aԬSRzI/)nYt)++KǮ WQ rǵwkIk%v'w.^.8ϟ'FiȠt䓄M5:/uS# C 1L*fcd&TֱWu *ː= T^x$_(ش?)U8En|Iϭ?}T<x],=Jx"j-EeEX,Sij1FISGBIx䙟(̆kbؓnE3>eVÜ|.hl`+Pr>G)=u! ^+ t^qOKQL)zf$[/'[ʌbU/>|E҄1nIVHC$Y3+3TveS'u%."2^7G%)DhU  WmOb-ʈ'#,.#;R^l6jn{Hsm]ルc;XɺѣM4q887&qBs2w]Υ ⃔:LH?YjZaYd췚&TLYʲr|.c]ZpxU2{}H4.8}ܷ2x)^.w9y2IdLGҖ}E)Y*^*#d3 0 {ՓT讦[/w|eMO1jLmo_KN&4~Ѵ:IG M30l|XVmUGZv\0B{&X'BxעGpգM?%S.| ༌½&ψ_iY&W|K==m2U˨laV &<*z^ϑ^Һ%'i)c|zd1 }a"!R׮<={wɊ;="!Kqx.|DaEa/,c+Zbbd^KbOMN2JxLAcTF+(c,*eOb (\\\/;1M_gά~vz2SX;nrǪwWrnh0w%aDa9Zre՚\apɫ8\\V[Fնvoܫ),Sw?ۘ$%uYZ& R`ia F &4Q-RiXe;ub2@DCG~Ru.w1x%ɳı.OJ E*x׎)w%JUbaKKȏb[>$W-lŶ6bm1mF[mf-ѷ.6acG7ӏIN#7_5M_b=$^ [:8oW9v,һ>=}2I36eZUijUVZUjUVZUi0{پ#v1cGͤ5֭-]<9i6Ɩ&EG2andmeM5&fIrNkfc,ZsljG+KfZ0*.mzq>H$H{ri7Dgo o qxM<F#t: YMіThm1CE +pRj(ŦX>'ބҥЇu~s!<&TiI1#XMþLǎr}7s7>rsn=!G4'&1dy!?8/Ō1i26q8/'4i>#ЩCckAdfY'4Z(Լ%x~t صbXWt05aG5 M-&mf1 \ 4pmiZ6m994ٌ}o ZE/'#Uz߆ ^؟b SymI;T?3i4LT[ޜ=ĉ#$,Ğ$^Zi\W=krTe)yskLi=A .CubT&@p1U|;|+u߀,^ϛ^\lra+ 3GdsBnU}Cc&Б:T${2RÿW%-04cL}_TrNClpу4lC/jKŅ0cebs_`hNe7o2Mh !Ww6VIDLX28"}jD<,ri"G;d#D!6ZDɤsL{=y+z7 ^`#П_ ?iU!?m 'j-B{O'a>)NsS1LS:?#uSR)heETZ(bS(RSJ}[`g6}' |5:ӠQ^{fU-Pf Ȳ.S6ByjV$b*7Z5E)G 1"yx'yI| 2Ubg>iݴF*3@3U_E~sJIw~g -$䂒 +ޯWsK uʷ&g{\a\=O|䟹{'ܗkϲf=ԋefáfmT]$_"K]D5u, ~HXE=]6~lϑџom6otm$!?YpYC%Lrs$v#^1+G{ êM*S;<5!.4ɦTW_h R|%9u˖d9lyw~f?xpSGvc-$zv4 a#y'{?W_*,Y 8O}OW8Q}g".; w^)qR 'f4oBH8koV?*1d}1j}6Q$+xЛWo+Ü@Xi EDmo~oz~ړ(?$3dL!TdgX׏ccP@C BՀId c;\AzEJBޗy jbF3^OGz/;y l"ƣn!d-x̉#\b ނ/Ў88`WW ˂fUD}d^;c}#>'Wng )Re5] =aEZh25 ; Y&_ )deHُ}kͯAs=uS޼8 {k{מp{U61 o|PQ*(4@PB_.[tz OmѳMӰ;Vt}y}<w<sp g x=z D_Fsͷ{Y707ulG޺Lm{z{]zd ֗4;(΀7ht_Yx (Q}`{|>xooZP å =o ^hPwh|ܸo=wx{BJ$EUPQE PUQUUU* *JTT_mHTJu3U*P*C{珽vfטj@ 4hрF&&F4hddɩ`F& 0L`M4ɂ`#F!&F!M4I&LL 2`FL&CF114 h 44@OɠhRH2d=` ѓ1`= #0O!4`40MSz$ԉ w7A-b#kv M2 -@S (*ѭildIf,my|{p+?2h$gBY i8*/3Oyح4*AmsFJ9zrJ4)ԣRZ&̨D*$@NHoO\zz~_)-+6 5V¨MgVi] 3`Rپ|5H*d2BKFE+l>EC=`$MI $PڥJ4Z. &D -\vepy *i>yr4K HS-8@!a,sĜ\\qFdIE b:vV [)gOw7G7leK@&paŖ-0`O{"%;S3kl='ؕ,T2CV"|y>Z/FE_-h[2yX{,tlc!ʓrSnLumZF[.P@1@!h~Z6\-1E|]|-4OG8(7 phX*B)H!DgxZ&z ԥ(őcoͶLVFl1t^Q(_T' Ab,smFv xn"XYA JYNp0]Bpx+'4b [M&`'-sccr!=NT8tSNmɜ)MsJ┯DH_)@P@RjB\A(TXQ ^ކk>>1FE4@lNJ r6`fASn~LnX ,!eaDb%`$!%>$- IypHӗXGoZPf""!0gMEܻQ0TKEJqGt/(8e T[okڷ6a*W'RRɽx$5clNܐb]H"8H2kt'R2[;v'Z75&./jZ*6VJP+ K<,,w 4WJtRP0$ X""ut-[; JKRش֑* |u{u@J8fiaS\ZL[Pֳ½ Z# Ja)X(j&ݽI6uJ#5+Q ҫD.L2a 1OEh3uSG2k\ଧP,Ȉ %i1,hˢcfPw8*pLi\][a\H0TRd$&0d HhP+W'Y_ϣ>PЧ>I3>9*bCMjh fLs'NEV4WB6mA^ƭi35 s"\Lh֢爉F zZJ P eKB\ӐLH~?-5F\U>.=mhm @IR)!d%*,`w IQ51\o9"GbQfU0U *f(a UI'!UrK!lQIQ猪e~+ &c@|I;$=T 3@&Ws<3sWdrlk&ĶםG1ݞW:e?a P@IX$MQ$ XxM SWFee+Hʦd 7B&[Ҳ>; O0դ0|Wt;eH>^=fmVk$غ1~Qi^i* 6=W/rxa*[! eY22R}ۍnIfbFbf' d 0}lnqywC^$$9B |dbgzf/iw49vJ@Qu a0)0Lde%>BXX K*8c&&ec adbYKc+YL @EHDQ}D\hJqʮXpP@2"2'|&*—z\R!z,_u Yld@-G!BR krFH¦e5TO!pw+XaŌ :iщEoŁ3*LY* ,:%kūEB$ľF2{`}Ks0' v>-a\ %ps[$]t[k*8kLG'N UY}YGa} #dG 9d;D|2H)\i;U=;%Qڼ9'S?1Zt?Y;ԆQ-wNIz&>'bz/췋^ez{Q?#'u4g‚? v_ " s u>IAH,Xȑ$"EDIHA@$TIf)XS2f# $MF[%Xv1$yOV #a:&D".>%#HDADDb(C22&2 !Ll׆BfVlt:~ {EC*JR> $lhxs_9Ŗ[o_ wvU>}I>RYbaaUe_l[?ce$H(ŊKPcbK2j>O44j *-W_L8;5/_SkOR3bcC .\CvPa]?I x1 ݦJ ?41Img{ܽy.kC \){O'[k >J>i{ uC\ _f~_ीؙ:>TtVtWvOv{]38]K:/"\DzC!,c•Xv4Pyڢ h/x}].GV1 GuxnOh'ͧn+)%pB+ζyԅaJeD# mLsS2 ` , SOɄMQvÌ'l#DJ+sd1;H#(4XIgXc- 1vbՀ+B{# .8#$^A>qD;bUYnQ,؅kzXpݧ?(\ߤ bP/`DX_|Lj s~T u% #%+WvS_x ce>>{ZxMKs ~eU,/QU'H1N?>@aȥXZa9KLRJd `0HIl?&¼7茾g8;;Njrh0hhfn*h%L0 D 2 "6t]wCFGB-yO#Ν1М.\F*6Kl=_ʟ2x(s '3y fxd-, O)Kb8I+ްRE@ 0V˭,3lC x1%¤1U>G##hZdqF#qHb<&e0*>a#0dM#&[F#EGHin5$VFG蚥26,MFbbq#H98M&R_dTFL.QF#ǮVVUd⚚&&aIF) 0qٰ0mZ04 $le-YaeF&&͖4a h4a*X`F00F2` ,00F eZ4heT(jjnjMN 0dL0S$n`hFa&EUEhŋKKKdɋK-,ZX,XaKK-,ZXZX,,-YVa #L8M̛F4 nhbiF0`C 6 +HV!4`b1,P䌢eSV#j5 8 FK µb##TUʬF,0Qdb,ɆԪ9v 0Xa`a`YVU 2dbvL4 1V,UaK NgJZF 2,.\###*NQ9Ƀ&T\0.tFG Z0 a L*цL#щ,Xf 0ыE,X4h,01)e,400`0ԓFeSV0 0 0Ȳbœ&,X0ln?I+\Rщ-n>0~ Epnnld hl FJq0a-"ryO}y4eaGy9#^ 5K;~.ط#zqGȎ|7V,XG8U[FGKVFKn9A8UmaXik!X:%j3tujcs<´Z<|QzD/8BADm >9fgvk, uhdVFC8=G@B d "԰/_*'cFN_gӛW2=s;छ?*0c ԈG[VZno5ߚ?ZPA(Ũ[aTFDqT[Ck@AfEnwvf9ڿ G;n"Jd 鉃tYB:;sx*'I;ϧЇlg Y h)VҦ31 R1B,Ta' 4]+F@ !FϺ:EuV+zW$WC}DKB+Y^U.Vq=~&R#cVa uW ʺ3n=_AiR`r$2#׎ Oaq(L\`˱/.%W9Qk jjkOah)pArqٯ213W"^`S3+l)|WP9AڙRz,JxX}ɣ׉sRtQt`@." jk~sРD@4U'p__nx+_^Y$f@wh XE+ǟ):pR 9CinkP Λ :,"W5׬ }/ { w]f"1$IoLщ2ʞB$%,D `FL01d&1XY,#535`6AYI=I;L,VaR<;`t̮q ߇$l A=ґD@G@5!N|)bnFf}R:yjlq;֦-W6E/TYef"! AN;xKݞ*xB*s?h'@ȃ90Inu{{FWjNks>F+g+98Y"Cblg(z(5wp+̲~P0Y0eۋ jH &< {"`K$>Dgk>bnPPaGR? P)#ޗXca'XdB1,wrưuўambj/-vۦ<^|38+`(P\ ŪW.}hk_i s"|/gfYgywV ݾgo *CxenJW Z~V} B~Ū⾨yM7In.1bŐE&牍ox^~"" "1W:,I b^L5rߊC~7>R?HZh:mO-3 MCV %jsx.O[ 3 yyUL{gw''1=ʚusg83-O9=Xpa _H욤W_oݟBD6'mRoCU<̍"Qw^w)äʍT|fUߝ(.>ݽM47t};xx禎i,Jp,t@tB>ZlVB SV-!9@9+?US{\3Y^ m40a/:A YN2fs< qh/WCi̋KoՋ)a=[ Ŷ+ XӘU?wjP(L|Zfp蟪 DlhдuP`fB&C~l^k~'c|Dm\.VYJWOWŜ*ƞU֫F& ?PFa똬xp@ynirܕ#vdiC`܆k*kJٌ+7s?s1-vzU;knUa03?9mctg۱wRwU"`4$-`-8DŀjBȎ[m['y!S7(47WM/ÍK1lo[sߠA8؍TׄY2`k4qK9[sϜ珇f2&p!@>돊µ>:q"۸5mL wE~lڐ@/&R}<4 }E/w|+}oSۇ68nhմk566U}VcR]KlJ1`j`zme/殐ās`BL* TWz%/Y5SMS?mI`1dF$;qJ7(|,Ud eYPª%xbEjI'eU WIJWw/YWTKcFc QR2 / FB@^~*i#=)\rdVBF%FVCJ,8SCCh1S,)b19W̥;z"_;D~QQUc(fS׍TGTM^0 6v<lnKF߉2hz-i?^Ar7- C9^5 Ky#w)dFEA\<; /6-F^G#R)-`NgCG]e9ٴ{fCGp/V#1d{K2("&ZJ/~|vFG(ؖ L0ñ7$e6Բv]<%MZF,$b0aʫAj 1V#FV YJЫKA,1a1aLXbT5j, 2# YHjSUhd`ņ,2YTԚeXe,2,1eFXYaae*#KFFb,2jSjiV2c&1YV5&ehES}\!Uʏ2Ea.r>gvⶒM&MDM&4K(ܵ-ZՊ1N&hi445Vjh-KP`ʲ-Um#jQhVԚ-#V&Ҵ4ҰeQjhj45ihwvVjiQFF&-&XVeYHij4Vdbdb# a`LU4--&U1aXXV,L,LF!KIeXaYdeXӈ/e(.){"88?X|ajaǕ68la*H^ 2RW(d}a]xGLGMڍ?ĩ<pUȁv/1Gyܼ2a9KXm9'`9H掑rMKFL80a]bC朏r\LX:/ܗ5ShwT`m<3y'+Crxò1b1r9 WH+uyGtItOi9N s:<;t9<.h渽4v܎+y/K^G~+t>YP283ugRd$;Q\h,!#[+KrU)YT-=6_:uw15pjճes_BUɪLU᪭vevcth݄4nll4n~llnn6ᑨTjN½ ƣ# }#;dM'tuhlIb8Jp#s. UVuE]t2JO##vwhx#-b1:8d|>n20FRdwn-/q A1`##ozƍeFXnbuXaN0,xl:=NDlpZNõ 8- =HqJj>$u)0 !`_V4v0,tC<øyW%RUTXFYVX#`Y F,U1VFF,XYb2ň 1HŖ,X (XYV)e,XYePw0xj핢0Gط",uAK0& V,B!*vǼSp;^x4wŎYKTG;c*zdFRyN2Lvчb5498pE.Db<Ѫ7|wg$zP&2r2;Nrǩv=x#/aKK$T㫫}ll`T8p88䮇7mNFCq?|ux4x.E>#On=֣#w(ܝyFFFa(fOq4Ʌ٠:]a){v:RUK#bSb쁴iDyy^vG|I]UλV 0UdZ9R;FG'8G|uvM;*{QbI$; gz6ڝײ>M6b7in-_[n#VF_^ɔe2ʚc8 d4e1_ŧ+RKjLm0LdSf%+RM1Lbhek\kQ8rsrlٍrlٻ'&Mi8u\֖,X^x׬G###M@KshvJ_-scǚ8GGN|xM\{{oyE9#Hqk|0*C; j5GA r9q2{bidbL+#QӕZFQʧQQa0ŔOB4b,X I^ÓI|m$Gd|G8t|'4QPC3}sh Go:7oTq;{.pIlnZX49 40m64ij~ٻKvihѣCFUFF 44jjZQ14i!hM&i>O/sb1b1hц ,0#Q0a ~{laxF_ԏ4ɨbő4a## 0,X 22d 0 0hنcG# SS&TҌQZ4Z-0őai4M HKEo!-$jG҅FUL%_MFуEV CThphh0`lÁCCFIhѡCC0pFѣCCSIRFmMSI4hhhjMhh4M&Zhr4as\$ҍCEсİ``b11,F*!f<߮v̾yKN80|'Gn+{82[k͘Έ;v[EV@\{̈hEQ<ԟIA7(+^0jd,|% Z1)막#6tyE)߮s\VyVfqN,BtXc  Djn!Apg<6Y^c3aX ̬>Xb LSP}Ai QbaTن00ѱ5Kr ZbWv}rK6ѝ~uڳpMׅ->zHp7X9Y Xjiʄ{k^Nש +*=/"<РX{>eK@ AH'W<ڶr|*:Sl|E4b/+؟e<1`@c4LﱬD݇73|9evC<@g##[o]u&BiP_F!L{Nx3^3FLZ T>jw}PB n8⼣EPC> 0qZ|Nr`s+uT%Ʈ HcsgOʕЭZUIߞ?CvӊwmUL6 cf\=\,s}F?5"&C @l@P90@w/  C+U>Ŷ/Qy# fi6aYQ7QK,,0Z0у## 0,Xh٣F52ijjihѣ hѣFbNlx1j@_>e<γ&΋N½mBQgバh|?4>Xٱ|$es8>%2LI& & 0?ß 'HnV#Vp)E9XyXd0;De,XadC/tv|N<6\斋SKQ4hѣCFK|ɩĸ0a '#Fy͘ߥh?UPr #LvUq0! /ȿB#3'Azq—^=qME?(==#LGz1G̯ +ʩRbsM!EFQk(ђhʤ1LGxs羈o=~|i|s> O0ao~O}`성.a[n&oWK=^زW%u(8`G{xDZt|E0ߐ**cʘ>0FIcCo4" "  7ZȳQOFt׶YUR19d|MvuQ]?esgig`@ 2O;s =^zH]v|xDo~1\OѮmG2:ޠ;DR !=G" @>k-oLCG֊A Ok\>zW;5vI^DcQ.#_F9"}da2rF/[}a.QSZ۰l~;cin2?׍G2?R)F;##7;cqj1t9#sFQ# ¨"=}zuXe,,XaYaaYj4 LLA#( 0(ai-F;beF&##XU20ʼn00ń˺0h b F&C 01YS# X0X`10Fa&,`a0<N#i< yGTG:Dzqu09'y5'1SFGta sii´92tqGvҖFGZ;Q2=FGq|]8:RwǬ<3XF&HCy 34p85F?|w @2?] gg)2Gf{i,B%j+ 6ف !Z?Ӵ$@I \eB0@qO?:?G*ߚ0c% $URK  /#rOyo nBtθgE3!SP`sBeOC{Tdv|;wp}}si^OZjVrVйFOrbrv~ҌKLmD{E [c0Q'q~Xd|ݮׂP@A= `8q3*Ie6'oM}|X0N+ {ҽ%i2c 4o="1nVI?XhY0U,d۸rlNMӤNQii#Ha V9l =-!{^:ಿC]7',/dv/,^-*Os-Z?Oxoas;f:^ΜF5Κ`W٣]S5hn::$"b\hKE/_]]&'DO>v,cav{q}E4[ |o-(I)R`I0 gcv=k㝠ə BO3KNcb}k5LQdy`?\z/Yt}OoA;G}Kմ cnnʙ+wBh`0&wBj C# `U$41AxidܑPSG*@dƒ,ĩQ&n9N&%W̷e]r]#vIX5:NiͳZpts\;.*;xpX'˅xn.80SU9-ժQY[{+͑-:2mXa0aS؎.S Iqw$eQnZ`X28P\-$­Yђ]ŋ/W5upWc8hmlG+s`O\6aWAGqN֢bj4f-Giòht))~o ԌY/Z!2aX^db2BU!B,x8/нMGOoN_?# ̒_(2Sh |[M$i_r2H/cČ`z1~)pсFNU{0 et>:]0gM޲OQ :n3mr;6pva?D Xh䒦1YVYHAZŖTG ^QR/19?y] ~GetB i%%U`I4ƒt巄7 OdBPŒm63r~t釟K^{_9XNi4fKz-XW3Xeb9CfS_c7]g62Uگk>SOe|_dZQeK,[X4eLe CO[YhaZXa ƍ\0ņTvh5+U.w.8[ӱnը%O@߰K5k.s;/CM=SwqN' i͙+J U߹2yd=cwƻsϺ4M&7WQXVL֒5wņ_5J,42ȴi~ F^2j#y-%nb8AjƧEr; m6-Na-\ghѵp&8)4$a+ƯioݯzC.@ p"bnXݭCwK+ئtxX`%Ƴ=Z5I@}HTCU{΀~^DZ~nzyoyI&16suWV&M/JخU0L1YXc&d{6l~ \`/hbL#FQ^Z[09bчQVYbţ-bpyNKihpr89.K"]Cʺ.vѻF[ ex0, 8q~m_04P٧JuYRAy7?Y;-G&'Q돷8{.8)9[lW1oPe htcGtCv{ ]={MتdMS̛M9O`iݹ:M2it_3W[t#wx;X-~n[e'hL2ʰZ_$pb5j բё/6Ye4`r׈vXb̺S=&rٳȦ4FR 00@4H) ۷Ӵ=jIwh:z*jtjF >0/Z߇mb0]d>an5<bcb/qk-TbU -< ֈ^V})&9LcSONٳ&Ɋf>Kr+vz't[9Ӂs)L&VE*_qS>.ϷWuc*ʵde7m??,4!7W^=Z\N[ wz=e uGky^F~QingoC9\::SN'W'F&7ul8̶&Q!ե=e#Z[2.*e^,F.waq:,4!:+v\ôs]g5s;g#G%r4s9kmpQצ|<h?n \.C\hpypWa|^ͧIɋ:ԮNsi'?8W5޽>1UΨXn|,{bߑȌ끂@H7d@NzNM(r *';P3yY*5F(eWG?1PUW1Kh,qI{6IN j*`_؍G:\Jup?aPP!p F]%8TeO[ێi)c//{" S@=CgEHTP/$?bAc~!o'q x뺠H&9ew2<@Z?5o:s{>+pmɎqtPQWpCC;Q܏ݗFbz|hdd1a4Gj a 2 0]c9Sٖ!̰q%.F0e hå+9ӑsNkii6sZr5^Rbv&04vtZ ӀMvϰ.xO ڰaZ]n-#w.˙hvXaepLZ9w ÙNkkvL.qe廭ڻ-ZL0aέ0:5UffNFa0a,2jJ600;Te] :-J贴-.;֖, W;vqjа dwYeGyu %F%0t.rvڸSNwN,.twh.Cu:y;CsQxFc=G*='la1v=M=Ǭn^t;YKQsNC˴pqtN;GH4LhѢ4;l̻M9NNr79..F Le+wr G6ՐQ]ǖwH]"̽βkUĪ`7^?X>= otkg~s'wZ?G~=y]20B5)q ddjzS9ecIq>-p.WBJ_:>WR\)嶤I?D¯^Hӏ!:#Vȭ![WC$["k%31J>&60|WS^3mkG?Y 4@ AF0j#j=h8FH`ieV,  &L0Xa0R &#Li2hAha%JY5KJ>y ّd` <,T+ϸ46'G k@LGOl/L=CsȈr8rM"L$z>ʃeuU9?n#|rO:ACy䐙aِffD jl=/  Xr_bj2S,ū-abŖXaY020 e?*g'"4drG-I4an1i`b {Wa; ]ɑB9\ɩ 00 ,5FRԌ#!LFF#e,UV$haL4Z?*=U÷'x& *U~Gp"H 9.zRN_k5mRPP#rM-& @!NJ(rA))MY[e\iRa͵ ESw!>drLlDν#ÿbjG`I>rMnr4ӵ5[ZpEL13Zh3)( |Hz &G/xp}@ K1˜)&qOytl֭2c٫Xl2 MBy:C?DPտ$ˆF+aN!F={B[F}:ǿy\Ѻ|G-1,5#"pn%m2ᓏA ],]eT*X;e 0#f ^ 8D( ܤ8yBOQ!4te)(w}?&}?: 7h.Fo_MfjL{$q[K >9H] Dφ25]~u%"ZǒI8Idz8 >wvϴ$|ef̀g*(6rhfSx4pnSmjf,&;/u|.hhlbH|o[u1F׊`f!sBZh)oh؄,.h;߉ *0]ݯEȒc)_<==hau,t(`b^M^M8wK>e[) @9Gs$uA? {Wnt{wwBc2č 鿰p\dDNv1T~__v,4C;UFou҄sy9%xvٴGL?koptI!DQ?C9Bh%yX\л S_BzTZ,#ٛHqT؆M^:;iC3v0;L3/Σ7]>苣?*ĈJû~N=̈_XsbS *x]ʡY6I['>ކ1 v֋NV ,6M6"}c/3 8_עNxB ~szFi;bap0>W04'/W9i,]uL%6OG VMZk|^_xڵ;ߩK&Kc,,y6Jz5ܜ%aIp g>ؖFs O=ePyB8[F6EG4Ojõ|zG <\هzC?}g֢yrӣxE=8JQQwe 5~@9sר\qtp~JumB?lҜ2'CPT无Y裏KjP6D!wKGdyi]gه#Hp>1?jcBW5`F'H8v~| :|㪉3k{Yn_aqZ鐪죧gE[[}S1}F(jB2[emd}{O6r&19GtfnʍځW2YȢυ~u80\6ʭ 6ϒJK=ijw(4^M3(.{dJTu*9jH{_fo}l곍sڱs=Ir'O'+/ߪt-vVsF1Ϋܿjov.m)V\jRgno}mʳυg{y|2QJv[9`acԬ`힝w< & `Xj}[lDΕsVʯ[AGthKSz %mWLRNV0xRRw_v7q1o! )myli B_EsW U(oQ~ceE\k!`nuoK9\(ѫ( OϪ oHsHA?clZ\@uR8Qhғ?3cS-xz\sRHJQND"5gӪ{D$МJ,2WnsJis:*Bӌ[jGI#Vm^2ZW4ňx!x^K7#hK~$a!HyjsBfYNmSƘ}Zpx6R;CnJv[hHMWc#|>smICDCRڒDzYs`r?o#{⍀Tsm5iTAGgNFH5ȁ!2`9'ӄ=NѼa> ˇ(@(@"I`Rڭup]ZtQ#D^'{HAOjebI'l)l(X^;lDs#Ç"  o4ʐ2ȴ!;A鎴}[>jDe˦>OV^q7Zm5QKL=Ro?JQȟ01>Ϙ5 a$ W gh} N dWQ]OHp 0-ll0p2`/YOCc~w`l~|~>mn^SF,N@8vCj"qQxmY2.\INztDO)ޟ#B=^iHlI6ǢQOʧ&b1?m80كU쿥..v.0@;m6qCٳP}@d;Ƥ 3mq(Tx˫Ux . -a:$ )rQ?'xÌo%k :f1ETX8 LPVF=lUd%N ZGŒd  00)~:)4\LQh0eW>?0`ʯ!4rXQll_)޾UÐ<> 7 Š 9HA@\ᾭ{h5YdlXJϿ/嶳8C9b\G)_=Ei٢i[ eeЂ4(4FQZFF#5FFF`ZjD?BA9b$$8ëYVN|2Ѓ62cezc>jVZ>M>vf_e6_xn#N%9e8SfRo됦!8?9MiQtLQbSI^6,DS-&D}u@xs{3nKSx= 3}'i]V۠R%Te3fD >jY:j5^;/$H~b>5 Sdb?"FvrE6~:ߟD! KIF ˿i=o-R~W[??3=~4yyPX XG Qc"D@W%" [xz p(%ꨘ2q^X7:WmLZȣWfѨ  @6ݜCF8Oj}wC;XG|܋ R2'^ +*ʁ$>u(n~ok![]"FG j_;!V2͑fsNWKe <\% ڏ'xߣ (, ""LZ } '^Y'C\x~01@U.&cԦ\"%RL@bj=ufO)}1L}7P oBex I==$ТbZC!]mB07tS(as0^"a=⾍ o_gtfǷlL KySSl扡`Js{v=Y'U;q PVĬj7>޽i9JrAGh,&埒 uDJ`JG.Prqi~ZmsNK]\CMusqȏ"=KJŋpZX!bVZ: 0aȰaU9f-_,s99/ p"d {޻=|{GhJ/Z%XAI->G@8_qކo}{糼oCsB<[\Tkh"T fW|$$!.@1< :\ZC_:3ʼ`+C: 3ff n9tS|Ld=9A:^vLk|H6%-޷0,\ʿbqʝ!䀲 ,!0 q1كa jLX\.1bkٰ@5@sa^ڌap56l!2,Z\>"tRBh7Dh1Ml;Gӟ>`haV2dLNSC?L8̙4h}9Q84hxxY9I팎)]5~<.Ɩ݃C.P\hBQB'XQnϾ7Lg< $@Ș}_RmmF P= /H01@p$) C >-I Nssgd>OkoAE–#0j#*JbT&!'¿1KX`OV )a e@ "Gpe1܋]7d*[0'NŠƐ#ӆ8&M8,/qF68ȻOaCj?vy-9q'wCiGg'h ").E"HR)GT\?̟ЅVLbZ1L}ڶm'~d?q.n0sbI$~g>L@! 2`ro߶|1nާw١n[9 (oj́c~&?v>2a{UE5uS ;iÈ;H;7KHduNbNGds4vGeSQh9'#FNf#[FӰNc#莋f 1i6baFMt2d;.a:h;:-.:r4]q;wѵNiNaN3F60v.GSap0XXad.#(Ҍ\þ:g81] 2u;n4GYauTu4u49TsN]vr:20pvgU&4Nلޘs9QL6a93lt9GjVN8;lvޜ&;tuȮEȻJ๻Uݗts;gcstuw#0Fn4lddɳ#HLGx;:MlrCtLH10G eNF:.#mG`#c k1aE 4Z0hC 4`jF0 0З@ 0 `+ ` ,aX` 02bʘ0bŋSVLLLYS,X`b`ɔٱwjw.(pgHуg3ssstZ\G89QѸlQf256n4hn   1a FS ,1a ,``Ń!d C ņ/}W)=Gjj=Q*gEq}5Y[v}ݗ{ =Fa4`Oq:ЪwUV1pἻBW;xVv /<=_ȅ7$dF#B %2R#W)#tuNP8##$#I:i"r]iv-Jn6/Rj6|xcW:0-I.vAw}j^.G# F&)Ȩє1a,0#—0lFtL1ҜG!UB#Hs4L%#JrN6VG|te-'TPp8ЮqG\0 }Wy_kkH&EY6mmX1ndMZMLM,kKkU[M+ &>n>^Un8/y#Č k]4ZemF֋f& ŹibŹ-SKs&K/V i- ia6x[)nr,L,#Gm?BmNq\ѹN)Ce<>4NǂG^҅F%Xz{_]<לF4{F4yir[KGu:ŋ3ɇ3G(buٳF4t09ƎfNFNKrXS⮶5Cr:as0u96j]GT+YX&KHj4 v"PW6IVGtz-#H)*vJNdx{K9Lj~@0 zxFQ?${\y*ҡ:wC##up;s;inmK0ny#<|ddCZGJ~:RGQj[+)[~ž[)`00`z8])<E:QZwH|:9lu ƾ0)S+0Bm'"M<|h |g6ha0F6paFh`hѣcCD نGlѲ٣G,Ѣaa`Z0at,0aaae,qbt@Gj<^DQS2`MRTjNe,'DrG+9#S.)sx<6Uj;`{@0HZFB쌉LQ'\Q(9SБKՙ`e'`RSdZS|ӈ&x3?~᪈Ue_jv1G*ui,0a½KSFKC<@aL02:"ߐ90;*x;LJp|^*§lzR}AFR7fV* a{.k>=U: MmGt _+ pSxČҪ+\v(3R!>lus#zeUMlmI|ξA*مz[2&,0]/ 1,10ث-^_*20yl>ў*G 5dFyp O"{JK + `,$0JKb=d6r9Uj1UBj=S,Ҧщ2 * yjzQhr##GFNCJ\#5GB(ZŸ+}/vvƉ⥔cIFQFG=NnhFat]׍WteY&G2ds(ZgmR4J ,>TTzol- cTh4Mecu [+Ect60 044ZhZ Phllla(a6lmd284"505X5-%ʼnje2eZ M44d&L2aTnjdnlٳsF2blh4,1a ZFt7Qm6-ņ-Iыhh[1VFFh4b6[6Gpaa,1a IrXǢ>5C]Џ\q(.{Tˆ\D$A-z-&g5zmNc yuwk7mQh=:aɂ 0 F y*Ƞ#Az_Zھ(_bU##R~$'ݫT}:d}ʞx>_/7P]} T}g ;_urϻ%\{䤯>Cqd=oQQOz9妗4:2=x$_a|^^CW ~uЁV9 a ,mXu  %1&Xi}\geq^`BZ|*t  VD$4afGk+oK^D%Cq*xJa't&Yҗdddddd ]CLbpK^\:4MGsPUte!6aG&\i(˝ (G;ꭥ#ddhiߒtm+ ^•Ed1}]Cm; zrTBxD!ZF<&*U?o)v?6^~'B P-/UAꪤym6w*IS[̣LtmYEؔrGb1:/QKv#Su_>Ds`E]Ǿ7PKN<}o)cϣzz 9Dy8Ul]a+z&o^"cq=>G<;#Ō0L(&wTy\O2{w54F# ;$2)j0UI#ח3)mR&ShK#*.۫3R#CRNրF:j]|'axiuT(|r|?i1XGT p*꾃wzy}##Hy~v~lw|ip׆ ` 09_e,EdIJ`_m{9/o׹\:L㖵wvvw9BXlT@l +O?4~it#Ƒ5hF#fo}5ʗȟ-[G V{EGkl^H}o EڢPD%HÚY_ǁhywΗ=79VtЂ|_,dyV?lW@pfꏾEI<~KDO~5T]ӛ9q QH~^0_'~^(;HmO̪d<Q"9b1j>]ޏ̓ ,+/Q=cŐUyZs8^ @u1Q"@dșYfLV ɊX٤I@s8OO?콮U($3jYܢP]]eF*X∸=HCx8,X%Y͢?qsKF2H `{/?Bء];wѷeyޢ= 0v@bѐ yd^T7i R U|2o<H C"!8AĜ !uUyrKbg#1H~ߪ<mKH fBJg1 kv!_AA7P !B*τ۽vƆ5Qio; @ 1AvP\jS$<"z 3 Z ("d%V_tӭ3<q[o|3v?hrwGN =MovbpB-+(̇BCzQmCPSxf0s$0G>Ҫ>OG]\mO'Օ ɒ% 1`1b528#23MKNLv~eB*F1>Ei+=Gc%15tt*GaSb>h J;=C)qȴ_ڶ?-[ =5#gb&'>+DmGoaCm Bn0 3zo#_3aa z`oG{?W:F *aYF@iKl*9H8'c,//a х 0W0l¶aXra 0XL0Xa_^`aa  K.#E 0``كFҿ&}#lIM#Tdn.-SU!y_az"?ixKWjjSljT'|;ݑҷ~?n6l+k¡x'4ʇ},v, L0` e\]x5;IG*GFeqlʰaKp9Kkbdǁr<=:\+O~1#>)uAe/ F,b?830`>25RO`|Scyy##Y6&o7]N9|(q&Ƨ2A_CJȫ {=; 9鉑!{FiJrʦ([|ߌG*X|+E;LFDS{܏a{~{MC'zb;=G|bG%=_:1K%Up=^wz&U.L ZDjW!W-5CfLc XY`IS 8j9Pi(`4y`h`Appt_qc/]:G{?pa~~ҡ>Eٞ̄ BȆH@qϻrb[?sa] :bKU*9#"tÓ?f` ƲȪf PBu.'a;7ַMti\)|YTBCZ~6^W>gԙul [+iyI.C4`2O_;zq^^.~ui$|z='en!(ǯZ!KYPLw:nG̷-/PvxpNt1IiB9x꧝$nrvx*ø^W?qF=PLa409,V%l+$jL1#bddddaEFF##)&wT;Tl+)K%ع+bByc#d֒=~=qJ)5${ǏNl$x[6hlal٢FkuԷ7[Xc f -460l+N\FH0p846L''NG3t#hknSW$i6ahh`ѱ ìy^7# ~/w_Wr ),P+x.{.AB6q߇ ]:7%N+jy yj`oeFckqVcqG&oYF6/y^{9]M'A]|P /݌DNeU=ژ'-claJǽwFF&KOQ1Fу)e,# Mьe,2 %8-8 [l40h~qN)5,Omsb榥p*`Y@KhFRU 5I{[&&7HMS {{g{H5+q$`eKZWD:E6z9-{Y/ip=T}5=u{{rB9EkJ|.tx]*/ykHwj#%2Nڇ -FnE1j2iKNw!%5MSV2=m]d9U r`C9#JNJɇT%hkxX$I ZE#ՑժЏzt{<2='Ľ.a``<0/Sb>̖9j.ФȔRުOɂ6uzYz >C# Ǻ\#yJGlD0@SoCqbӬ\se?9 ͡{irqݑnf̘2e_N)OWs*P>"'REJ#ђ(S điJ@IJfR tSUJE"JdAH!N+'|{BG'<GCQܜ66癪Kq00;GCbhޡe,FeWv=9ǟ?!cAy)yƏz9tp9.jF|7V|m,|_{^;Ka<4,T'9E/' AH/>džl4`*#bo2tc4m KKH&2-ɛCS%xVL`zqV鲜F襗k%UM//`ꢧhp".#Ca[:~^)O|pY[BiK`?F)  ĕ#˰V P]tQ[l\)|E=iI5$h$n6$ԑFk2kYMdNg蠋26Im@)RRPS6e?w9AF#UR7J>o ]ZJ|-G}:rUG?ܽ|< Rc;`gU W]SYn<=%%u7B=PK8feb"\3K8jG8$b?ͯsJH#Tp>Bjry |632 GR>w!fa{>ЏAL|{QWܬqB++)wE|6NӯbŌI:xS2 2: @[C0Z a~C_F&b1Jj.)?i(WJ&x<gߟE_YG:_j.]H3f )βCCdΧ7GlQ;qD2F'X*OW H9Z@}GҷU`OBڄC@V@NxHU4+߯vzR(x;7 a,01&Da1-&䎑#y5n14*cEAʫKU2)CY0nr g<1:!mT %i@zm |P=b#PTeQO`ixXm͈ ݣGOHJfóig3onv'Ze*]G$;y٩e7YOx9 Eǽu{%$Ad` dS< >(T'ЄhB2y@B~Q008SB 9= 꾴:dt#8f)vF}4m"7aHA3ڵ#ܟV|vz1QknG$cUu=|."{yBDmwg0x8>nHbPEF5վbKLX!QkLzK$R̕ULeF$ hscC֧5{W!uI=gՊGV"Թ:8N̏­F߿h.,2_O12/ZOs~,Pxcg$iSU}W/OS<:it;jOkpn7@$"H:I!y\9$S|aQx3_~ acxgUgEn?P5PAKϰBK~1d\"ALxeD^Dzˉs}O҅"xe/%jV&#j?qI$_~}Wzh`a`#0b"#`!=Q8nl7tOWPoWlsba0`(&`Rĕ'镊S RZ>2I_Jf!I }Z|1FWO/j0`+ǁ@X" b}>8hmh?.hKVVl4A O\ 0 A2|  Q<$3$U3=} [t'T7骷Hc\Ia}eJXJ6ZF/*ʷ\/RvܜzRV OlCPߚi??0rϋΓ"cР QFadb20`[VI `&CFŅj5R˜#$2a0 d5KTE4 =?._[JtR-OlA0 da&AԞWBn]ytuzg߁)^y2eX,@d"bRD 3 4a- Ms9qfd UG-;6Syvؕ&~Db|L.+8GHL\vQ߂Y:Ѥ EgA,s/^&?)K(B7_3jeL7i@Er}_i.r԰m%5pr7?U-Ys\9Qph# |ίYxϥll{q>d"*p[!D@P"NH`f?b}䒿D7Ѵ TBV si&\oCAu)ڐNYO`KHtZ 27dM[3o?b;Ci=xb1鮛۫:ExBo/]}sR녵 X4C&;ƕݱpU, *F {/OB !iWdV(\׹+}UعF\oדZ%eF;P$; Iɻ2{N=)i}! #{PnГ=?Řo=k C$~yU=T;'X!ÔGHg}P1HD7 |2>Fqܠ3Ĕ9h/.j񶥋öQ#E6{)ᙝ6C,o*xo?@sظzdIs]6-ueBΈxa1)doazd~>25=%"( 3)f`*tel#$&"l)xk.b(0b5|~JGoX=$wlmfe,o#gYLu$}Ko<64'k盡(5U %OTlj2}&pv+C͔ .@fq8 S9=b.K&qWqcQIHM+nRZ~dlMl-9+Gnow3ex(q7qf5jϵRb>R]A~'HkQ"ic-ƁQ:#tcOַV~Y,X0 [f5>iXM&HHaVΪemFq-G2ZDWO&dϣ@"y Woe3C2O)?0>H>{C;g"6ǟ"݃_fq {ۍzgW/ ȸq${O_[Ohq,i`85yeǥ$wT#^PmձaS9nsӁăGBV1Y8a]P-|7F|\̀%~p@ 1^̀mu\^zc E<6W~މc"Ԡ=R~c2>bI|l vl#'7"mAwO6ENꃅ=^M#:;>ޅRgpfHݫed"mB{ÆǁTN`;B\G MX1=_Hvq7ڏ!㾩wOqD`KNSj7G!?jR2yOq^"qHE|0 9iG_\XfPGgms6`+51 5zy$`J  .܍&Wܯo̴ ]%g! >0SCnˤ^nTs8"k<5,9oh|3^g'r"5wv@-M9-"<)壑Twp;!I}& Ͷ BU/i^wL0HX`R3WlsQPk)TB]@=GY;ɄmXfzrj'!Ӗdg&!?hʪi.JsxGȄXsy'n+>L,"zC={Uh!K?5"WKh=U6#'=q Ju6Y)$qM,;teV诚 Pgw/go8@כ ouP>mɔ/YNc PxyVܾZ2:o=RWs+&jhOGNQWz7Y0 u8 e9sBpkF?':(J.:% 6:FNϷ - ǽn="zа6y1pCkz{jޮuTwl=`h@2?$Jmu>rGF#ǩ~;{W87`_QODB,U1aV"gܙ5Dh@lPF0LNtIP KpRm(3aaaJEUC6BA@zAC!$p*PJ1).-V_2ϯ7)iFŦBl-Zn!;cΠWFdǬR.kM=G#o>d/Q/ǤM p%8GHŎEs++sojKALowMʇ 1I0t۸Prao*IޒWc[dI죕ƷY(%Bn{_-GG]wd|cG1L4l􏘾E.5~Ļf#ͽ i宁Qi܌ͮ%P^Hevjm78R=^o6/ }x W-2(BӺ&C|owí9Z"T#dkJ}/̠WB@lb %^V׾h&T[X;]^x|}^.vWZ0-UX"t@8r뎆o L᷾.ZITC6SgKiJetJl-7M)W>Th,yN+e}Ck@.KYw]#4-4pRV?w]>6]nI^":T/y3Zv}{I؍Ѥ|1,}EZ1jR)Aף VakQāWF,c|Tؙ~n.q{58>#q%vr1,lw047ܳ]^d/Q,J* k[nw8:Ub9ޠq.D!.ct+3 THa%1sP8@s*. 3ddq+E#}\!TV1|%Y{R<xr~YF[!h^Mտt~.\P nx1Z]t(۔-iɣ`縿a G%kI?$Qmd$%6;4C#pbdU8*%Z"j50X-7:sd Ǐ߿QrqJ~B/O-HKyUv@DúLQmT/3*ll!LI4X! Qu:v]i4Y]ߺ@cbhq+0SQD_+# Y,`}nD{wk4[%zH71UXC /T0tؘd/U^׎WJ6*0X,+9-Y'K$=ȱmP7\c.p*eIv*0|s#=?dARhN5ȓGFd0P(!4}m5x.X`#k^^ϑ#@a !CD8Qòȡ6\z hnx|yҪ̓00;5fV < u(H;W7(%dx)hK9| gX}Ws<;x/ChU+b<[LsңkI\~ӛ2*lnD~oDiOw?j] =~n TaSnn.G>ϐ=1 ~ٖ\pEV`J-GA}bgOpv £F庝T?M;֡ tZxi=T}>w~4"{WM)5Br& 2?#𒹷,I j#ghiI>S;R|s`WM};VWGkWyP@ $GCRLX lawP GW9f8eOxꝫںf4I"$Y_x[Lur2+l-O尓Cˮ/L])AdoǛDt -Yo a[|(.;GQFz2?D6&>i YG$qCCʎia;ܟ$.Lẚc#\_O|Ss:)3Chw f@F.v~jlBG1E +1>eG;-Gho=0p垰=G=мqtPKY!*ޱu&OsG7wn1a="f~wOp;<%O+jyJߢǖ$Hp] eɅIB-q 4AXW/^ a \ad1 A\!/C(Q]e_30=b;L#Ʊ! |P5Cby7MbHsD!_F$z&G0PPQ΀T^$pL~!sځ~K?# T,vVaOv)Y5Z`$Ih蠣R|߻kSa\?%/wI5"o5c7Q0*E֛}Dbv01HxlbQbK8w5UՔ`Zz/3sN?apS%J8&x3 TC"F!n4ٌ~-,m>CBfP=bl^`A*j<<DMpq_bD2c!ԥqrx]^HYnZh  5br.'/0Ax/ǰpF/uua>fU`4VQSj#N/5JNÄǜhN?}lg"{- Ws{V3͔:zBn׻e) @Eg*f2tY8K37J>I?y^MM;a2&U_ юo|xJǴTZ;ns4kj} za+ǟ굸|#+=d3oĩ˹(\ !x^ƤDJ>MGD_Ʒ3eЯc1vx*1bq_:l?͛BަtԲ 782cI}um% GPM#vTߡURonl^5MDӲO-@ V6>n\#p~| +rm/tϻZorsm^^}'ߒI:& Y8r^+g:nPWsv/kCVbzu,k^ sQy a=}u&wK u*8^F 1s7?d=rW~]G =2K'T@j%QKMuT-9j"|l#vtK=UE#tyQczꦫd!OQн֪/vW$kS\ش%1EZRvCK+:_~Ov3xy9Ŵ]?M% ]6ݼ*+sDn;8F* [rD{!td۪܊bf+j+~a0/" 2)q,5| v?4KbTEr*8 6^n sWQF6`:/cb?>>P-¢j)Mt|rwȾO- 7p^I^: pÕ(.Vnp:?}Tt"x̤xGK@a;ҳm :(:s~wt48;2a\8qP?h@o>`MM19Ho # ' ޫO :NOk [ GJq 1@ߒzZG |bw٤ōkޥ8FDNA{.'zyi@&J(#_~1TL*5 #W`W6cEJ]Jb(!6u]|n%z 1'A:}>Q({J䒫DԔ|p:meͳs,PkEX0jצҬgݧݴLsV;SN {{&mp p rOx`G(7a4ufp` o/_c/ː2s.aSgr'OلW peY46D!O+c-, =R~xn俫zző邖z$!᧕(/r~F0+0{=锗"zϘ0m?\=B$d-kbbiRô];ɩt'cHMӘ4*%I($82Pv!Db`s_?FfTͳ) bvM(0KW;s? 7'Щ01<_A:Τ624!L<,72j]8)|>NcEjorAF TH}hH* <-ƌ0 F7Sc3<7yr6n0gdi{>x/yFk|&u/j`-HI~SL853'_V MZ7/G9b(&3 wSHB,UL,le Ę( {M,0yL R &YO o ؿtح|5me"S9KiC.0R$i!΍S0/I=4 7S6W} b_d`4~~wP t['uXjDK`լzQ?lQ,Sz#yu{rM̌U"k;ٱ]JCheMaӾ- Öm"L >pÿCF:䷊4k>luWPGsɚ?to7MSJ'7cwzWp'Z˲!m+H-+D9WS}\PEUfSNy0w>g,v?*>dok!EHwӀ\p9.I}0JMN>K}$|tڒ@lLK49O - LRMǒܼ};@:^P`< ;-cfM#fiL],n#BkOTRq)~W$KLgEN_ƩB%<{4 F:Ja'`Q,՛ 98 ‰U;>Rwԍ C[o,v{|z䒂D V8~CM~(F:]괱 >LjžVpA߅%!ySEbNI4Jbrtp]Zm&Ҧ %}iӾzEr+0N ,jOvQ#y# O'&|}Fo1n4 +G Ŀl7֩FNڛ+*}m(Y3x.A%ܘSck~e38O'mod38g i;tpBm)yYgJ( $~a΀Ոxþy[^G˔#8;GЬxHit(r(,b6ۄOoBDLUiAl 8Oy6PwQ%M҂M[:( 'BUWƼ/ kJF jS^\޻|[B x޸i\%p1f4zCLN}!k~l՘+(#_OM1H`n*.! L#r*;*!89G1¡T?NnNB|÷6NRE\yʍ;:MyN=DXr_8<&.⦞U})6(Z O~; <+7Tm\[ɈbEa(;$uv%LTt&jC8>SL0xS~RjL`<7hXά,1oΓ#;Rڿ|D$Sp Xʜt?bH1@:vv3SG駓xFB+ا$KQ^?+ok=U+L }oӈ̌i1g *^QήVʌD:MaD'љ Z~tuNy}O+m˩?o '1Wm< nVp;Ci)[9/+c g +cPBKGy_v&$*Lf"f10cVԳ,JI$o AC*JPu9a*;%cL⟬;?_+ 5/qy>4VAfV?`hzB =R9ZV;;?4*M2 O5sj96Wv%]C@A0 DaE {l[t2̹3ډM7t$[R|: G:Qs/c,Dž$~}4sCڥ .EGi,4iRڮ nPO4eN$rvJ`4 Q(i*Z].g#l?GkMrap\N7\5I$ $PXM"0!O49C,x="t^OԟgS-*ᘳ h4;`7H?s%8T` ;> TRp^RʒK9x=2oGh0`ĥ9*_)Sh[xC-(ޜ9("LP^N֮#岐 ?ʷz-VeFjOFaD{MA1$K@<)֖h*dvTfC ʄsTt'҅AyȧO^Sސj< +v{9M%VlqɊ&cGs8bmx蔵Ɲ31Jl"fC,1N#ٺAYHu6 ~ӑJAg_/( J(ZI;jo RY,}#ezhX6aE(kG,Gz1OƠ,GEx%+޾[̼Iw+a&i6PK5"Kq=,~=ٛNdܥ1b}1 @㜛%[A,pF;ĎU)Tvoo҄}~)*YЎ)CۓD[A|@[ 6ZL8 [P;?a <4ƨoy0z4W-NJ )@+<`V<)|3ج#u8Ui$?U-AOgU9y[#b8Gp-y̟~r=S|\BFIٟ CCgM2[¢OI-P1AsU: r.VrAI0=gШ`qB?1 })Yʹ<ԏ&BM-/u{x {=ʪNbN@U*4XKj1V>l9@P{Jv=1mW" heDۃY+r cQI3 }Uv6/^|0>Vog7[0}} jn}.|Wz] vK6I.SdiH3؇QH3!pMj-g0w==om 羳45{v7yQ%ST4BC,XqKQ{݉a ~F,%Tg`ί`Ь(㊀*n A7DoZBEMHD2kL3c720qȞ W5qeOn@n57EX|Xoˡ~}?hJ_zy8]'Cɦߦ Z׋7H(nse(<-dȕ0͟1׺=kzFG .I0j r3tE0BA~Cp^@KJwcv9 >hBF\oEx'ޟJd )ĔDTH*@+%aAI!T@ ]t탣:P-0mgHr3e5+^g].sd^>J@釾]ͭk.w{ͷ}S){6$rͶ]f J&f̊TQATQ (Qe*I g{aWT}i֕M}}56s{znP[v ERy6"bU6-]򈡰1BOxgyW;|W=ED+羼۹{u}LJn7>}\}q}Oy>wώ}&_& @}>]wϛۇ3Vƅ(I@(*/RR"@R7k̝7qۇZn}{ݝ|t7MǸ̸vzޜv+>/V}i|^5oz*ET@:(RP (}ޫLAOX>}*㌛ }($ x쾀@wK\ӷqtPF>@{< }}e^>4(c!B=ٌ=@|wrxgw}}n}-R U(P )Wa@ Ъ2QEJ"Ģ(UJR*[4J٤)JR" *QTP %@QI,STm%"5E@II6UiaR%Z 4E)t4)9m#EI@ $(hʹ`thlnt롮>mύ P7O^"L &LѓSL0 ɣLLC bP@#@04`&&@ѡFiC 2 4FPi @ L#iѦha@1@I!&dɦC &#&AAž&L&@hѡ hPMR!hA52zk<^mdcᲦ193{n|ѧ9_0}_QG4_Zslժ 3]ÃN 1±S3 Lwr_OK c`fW~қ|J+0, Ta-F SCca0%2dG1LlL̲X*!=e|Mֽ>Vnp+#}mk86;^oQyz^j_i4+ X{y4qrώݿ|^vT9zղ~,e*@! DTl@" X5b8h{Z _n{G ɎFMgY~zS'\;J/:$brEX KkZ+JeNC(޹+,H} H|](?nQ$VzY_BPZkY"?=Uk^ׇ͆Ego٧[&Ί>^XLTf*Tdx}, 4dP2%h-2ѓ<B}94w|_ǀcy쮎HEl8v~p;m|E!ݘb0j(cwW\C^ysvѬ\e'# pd1kDvQih(Fs'3+:Ww5>s[ ~D!5'`%eWlF9 vؤX@j㥶T٠Cn 6 AXV0(@:}K̕g;.~~MD$v'ʵ4Q%-%D;ͬZര`^-(1R:\U8{gԫ ;VϧU]\y(JI#>2#n y  2O #HB1⽏'Bd^/sU`#O*\ɽVhbW15>D:!R?^EC1AK.a4FB Գ}Ͷ ^'o[b^PZ\U\c0Xb̙ 1bl7ቆa f'F1b1F1/vɱc Ym]l,b=D~WZz{n{.slE O4(>0RC]h+'(HәLM4aicyl6lY81o#_rXɌrd=;Mm^ݚFcųv4ŌvvF2َfMc1,oba4:8a !+Ua@고}BA&~y'ТS b:~t9T&N)WHJiR?Z&U/l 6Q5(bU!#q :bts%1NMnű MɌr4ȵiz|4ufff٥&6zV\=${e#ڷȃg(6=F%ELpAݮ r2;yqL1-ՙ՚MΙw$Wz):W9ٽk4ˆfr#3ު,4YV#ot#j>tfq]ڞ֔TS./xSGi)y߭ӗۤ܌2*7e-%#8KS Ȗ3b8zt\d(* bq Hz).Г妲Dk+b+ pWp'LEF[=f EU"v0;h8j 7uxz}sݒH-2Ì-rhp_zD-Ic $KpU9ɘq$CJ(A"^@< aw[KUHcP9Q!3HMXH_؉/aKm{e|4v19Q:v[j}oNKr,/֗8QqubpqcKb"u3 ?ns R3F)bQ#.ğq|3+ֶufֶ|kVl5TRQs9ȆB%BT)KR4b+h1jPDL~+Mm=}^4X V;6Vم--M--3 :/^9G^ 5xZ1KLe fcX¬w-W8ɅT5Ũ4[,Yb[bpSs VSaL4BWzl,elĖf[ 59'5\ҸZ,XXXX0XNFX eDf1j0hb|k%cL%J!l<1a' f8L0a 2R:kso+uNKLo:  .hvE6$qDyȪ"&X(l,˜p=22g%: fU.UBa9 {ipdeu׋Vngj&jm~9wnlNt2tplصȚ6;(R~+A+7iͷ zQ@KBgO6y.2eGbS݄AT`>FXA!w铘]\' AYP ؽS奎vdk`R˅M@iY 6aBz>st %˲ٳKSm2]+$E4$EW!~]gݟnJDI'2@n~oV %(2 $grr$$>(GH#x0q%%ddsK4Y\~;ʦTbQa%оO_BZx% H~BG{1};ܓ❪9{XNd,} \1`Q> 7%M}\|vY 2s}jNoܯ+(pxC%іr:034?$i3"5j N>Ԙu{/[IpM0O N2-7h1Zu}cAWsvԱf3LNM7K0<3l1+(,|L#j,$^6c3"G#~GUc"_|S>_y&JǷJ<ABOz@wuJdqJil]j[Io q3dS}Ϙ6_#;r`M Ujwjm r1rqP/G iX|Ӈ{.}|wó,ۥÜɒ*=.6E⠓HÝ.Ae4ZcǨ!$Q]͹Pq +\ݺu8?څFst K24]DAS +q}TL7y97?i2 r.`CK۴XҎOvHt}!.QvUBjW$<U|HH6_/z# ~~JzHc7.5{{XAlAt "Bx?zzX`ݝ໧odۙQt3ia7 J,qd4I7o>SXcֻC\\84 kRޮ 3gqa:>Nt:&[a#pE1UQ2eh!M0fd7Sp.*v.?q.̂zs$ Š5 .,[2tQ/*nOeOd=|ocs2wT c>"br|6ZvqkYM[7jCMe˜;p"wnuT-4@Cޤ$ [JErS w`cƅWd>HX9,ı&2~%6f$_x!֏]pS1ď~p!P H  yG@_2ꚁHF4!kjU9_܌nB2vdccP)N<Y\&?x { \Pa )ɘfQ?BUH{eoB@|zll\}_=]t4mD   n}uoLS'2ŏq.mp,r}pF/6 CܹɅ#|ujHmYH @Zm^yt:cxrE3h%r8 `k)q?WY+gpr~uko%\Ida*ܪ6o5b ڱ21YjQEeCM8*2Y8 mܧ_[Ki]IfO[uS#Lmv؍va.>y7w.Z2L*,u 42El7h{"{Fu92!tkwOծChr)>y_Z5]nGUי0bTouoDF5z q1v,{T!P@ ƾK<˪7^"ʋ\ajO+q% y959G8]/}DqKޞYȈa2vaǷ@eN}N!!E8iApo4tF!,?{! )Y^A=*%zDr`,ݿc v3{Ǡ^ k3I\xrt0YUC(IKc2An e|Fۨr(a|[ouCƹf(QzHj?n ɐ sj {ݜ2gzUrWr:6cLhk\wW[GeyS [NI#x 2Yke#-ݶi)c-[92|'B4rxYs(edf](_L#W4@| uJ18]{8|b $!kH"@Bg}+,?Ho xBq1/'l~e]aҸ|(b4p.tԪgTc]?i dp(o߅ D͓`?@DCy݄5Dz45=ܳ{S'5b~>,B%`K~Q9V[BQ?M)CbycUa\Aj~4[s󖾔J}} ^B?D8.2,{2ojR``%h^_ʲ4{u/iVb좊7LU]_bD}.mew`0IOZyk'|_ÙtDC6c 3$ɔ=ү 3_$Tc i(Gel'>W0[`e߱v|hqh'R a}4!j-ҏlFd`227F#TgY$cwtj70nF# 46FxFrG鳄i U}Iq& FY6# 18n42JUVLxJi`Khb402cLhPuݐ`qVc #db5XVѪ aٺFBM.֥oZCM01XeFUa 5SVbYeYS 4e0ц2Xa*X0X̬&45ih1YYj i4kRұ40h` Ai1YYYZVffF+XёV24hٲ[LV[naMĵU± do#aʔ>ᆄ˜ j-ё-RbQb1ZF!ɨʩjԘL"L22UQN1o 022&%jKVYeddjFXd0eXF`Y 0 +*.VQU7`4F#Hh:#HkQaiYYX+( Ɨ$dn[21ѣ4kZFel+-֌т3,e`e`#aa±Uaa0єF"YL$4MV22325}ʶeXN -RږdQ2X~0ٺ5Z4j"2FQYѱn~s֦cc1M1i1yG#FsƩm:c%v9X9͗9gp c4pV8ŨшhN  7idqLr!+^w~? V4b荣.Gkݡ" &c\1ǻ^25AMOA[ 03 G}jeμqT^ҳ.870 * ]_iSd$Ht,T(@ar9`٦ɉ9-&o@aASaB2EH8zھIU.xt8qo4Mq\S -nFk\p&baOo(kl|eZogN htBolI*w+" hm\^Pa3X1Jph?Q>C-Rc}sgrfe_Nض罣sb@JF#g5P2 M׀Dê_,#Y϶|⼲yO0./:7r1 u,{ӌfV6"|wMDDdd B  q)y[bl:h:7;]i;gsV-O=l}VS |KYKpnV,,9j$hvo<:=_]j;'Gwx,UQE+5_=8@Rߠp F|'$cԒ  }8?B2"Vͦv#<_ 80b0@0—g1pьpnƃ|Xajq+VrəsfVc=cLig7y_ 2s~|s'+.ȽӜr1ȫLju1KFo(g%T)r:Z0Ц-cwQ?HEcm:9N疓+)y̪s#=Ӥyw 1\Gx2.S@c/Gno/QS>5Vix_JnmD鎈,# )7Vz-Yi=űXwP*})"gYِ&JD܃pAOW0& t;I 5s3JāۯX Pwm QrS4r!v: m~ff*]nW@BzCS0 BcӬl+Fޔڄ k)TLEH=y3V8IlTG?$gq}mwG:ۿkYASr)14&qE0{ín]a/S6 v3_2{~Y?_f]k)!Y*|L_* &]J UgxC'~ nAXW˿O1' <30у1 sfL !NmO8uuq'SDM'O IxԶ?fPm8x?@nLW:>U|Rߔð%tF-.'Pq,>Qe!q[xi^BriRZ-5o^*И`3.[?s#0Nc,xU1@'ݹc[%.qѰٲ4pJo^&_^ozOspgxm6+&sCq= >B߻9 }Nfv$vzpI`-`o{>( r¬`RAdz3$.'a.UM,2<ykõ+4̒C܉OzV@1]ZIGG{ɩk %ۋ=ܨA9ΩΏ5 v(L|D{e@@=:u)  jM?7Dˇ:Ů5r(]edK&[2Xkf&c5,Le54Ѭh8ppǑśA:vn폇s6\U)es1-(?PW1L@.ś A8!#xy[/뙾X˃eJN(X*[? ͚Ylp*m=`y =ӎ=#8Rӏg\|}e=%HXs@ŷ4u6p(+>N0-HхڍAݨVC]'# DI~d*aEC+$Rj_J 3Q}sm]}݆c$0 PUo\kiI"c 8p&@[_lc0\GUdģAwU\ݯ)𪟹`07Z'Y>FxGu1O0)Y쮛,g ?i_e s,X/TPGq!qQ6K#FxaFM Rs\c܅| ލ̖8LdtZ>c+T*-{*)Ss YbqATg?L7o"aC0qfJ3Qgs}o{׮nhP@#Lҵ:RqpA+YOBg6>h>5.\~%Yζk4<)UsH: ! q>aޏOְ .K Ƶ-jow+X1m#O#g5 zAb8d#N{3"ǀ-T'=_A&l!*}Ex|m朖`2lmdKB0;!3X1yjDPܪ7l`~4IbN-:j_囷IppwrpOFCm9~^<Թ.{i2|O Fd1lH4\k`RsY٩j; \Kaa74ijU?3zZJ[Sf::u Gm`﹓ qW<=7ĚG##ZOQJK͘zu|_3 bYMp#S JcO*4'~'}W3ړ>Oe9>LAK~Aq_#~cvjC7nE4ݘAJw $E)eb`A{1;e]~۸\ەW[7W;Dzv\=&[(}pC/tdpMvs%K{됰ɛa xz[K꯭mIPi{W( Y6>NvfNLqݻGCgP. 4h}+*t|q|CE՞EQ\p#С7#g q[O1Gܮ5g򉬣 5t/gP{D9,rZT]O|Gݐ"”iإҧ9n Zr Du69&D€ VP l]T!o:8&iiݒ#Pg!gL?{ _3b6\MЫ vzc%2,>Op~H\7/9'OU>r5;8?5j"x{[ @mf3(g9vbmam>t,2gc#^()T!3t!oLs/br+ V?9H 'g.鰴=Ծ| T fإޛ1dClE jpGoe!(6=nJ T K65$169ʾ͟V5E &W, 0G䏓iFi/{D_ _S+ApUMtyv^r}DS}OzZuo{w1ȱ cN>OM~WC5aj4E7&11:%ّ pbk:8(]ղv//vyy-f4E{ql BH*Zhoꢹ}Ӑ3A5u}~Bsڂf9)+Ln't<癙zBA&m2@SZN6W TK~O͵İCMFm"ŗZ@߁u/>{})Yui?襗 7"cғ7mޅ2Wuiջ<^\gC.]v<{pzfT+/ PӇjtRנOW}h 'N6(&V9 2'`qY\)6-;9 Z.8 }PR3Ơ?Pm)lbuNNLo=ά%;"gGMujy;B~NlOU]gb;ʈ7w 9)NCĘٮ=K0̋I3p;QPH_YzaW^г #o}24H/|Ԡ/`9HKZfLgd{\4GG+t•ёr&Sp+2b>Y7 1β@gEs@!%wqG]!xX%((KWJHR0 UX# Lac a13Oe>~Td\fc ,V0a4V*c Q0X±XaK *b1R|Խ{J`>W5)dAYVKDt#`7fed&21IcH`_mʿ?D'*WOIRߢ}ڻ5^,t+ AzmLKj(-.1?38=V|H/[7-+cG;FXWRS%EDY"n6)Viz#ezURZqt,c F't~Mt4wk[UY4G^rt82=ܫ9D;wO)}%w} vTyhSFIb1߱T揑h0U}+iǽnڭFۑkkQWkrl*#f^QS9++VSVY,2YIhZd2d333iMeff32ZIJPֵ i5 *5 CHZM6 $É:[SFYK1 9E?Ζ귦Ei4CS+A44- FQ?Vض7EjFRZb V1nVQ̦4Jhj45MFiCgqm*c8ƨZjFMF)ej&hhj4jenZV֍MjZ QhҭBʘ!7UI6ha0-j4h5 Pjh5Vgj4,dLQCQFS#(h0cX45 V C#*` Gnzlzl݆+#%XlVG_iXGS:yф'jvBЦ%ǩ\= z'{WܑՑv*!ʨ+R䃃_v?p5+9kƮVV)eex<]8U`a5[f~r;C~~ߪCˌU7O벮cNcX:ҺFJx*XL=͛;9zIٙ0i篙n9nwZ-GGWٻFۿI\UMklٻv͘av͙[6nݳfnݳfffunovZZqg?$,,b01ʮmZ'iړii6j^>z8+Q@c9Rq~ꮩ9WXdiaUtۖC$ K*0aF (2U & db3b&X+F Sdf2ffHU%1’&bX[h ;q<$qVC20ebsl56}/Y9Ѹ9+s4K;0vwt;#kcKx^/{cybb:K{XK֗CȻg엟ƣh\WV78x^;s2{=!SƗqTv*N DO:1r##lv7e1(科G-lKHZ=3qʎhsTsId,d 1c")Y(̈2X%ʳKv^7T9%:ȎY.#=sG'rUyp2;#9\Wq1s'ٵm[aiH{ߝqGDx#s}VUo]ףpܶ(˶GdwKNjUpGBuΌXm[ڵ]T!1hqWht/6a xlNx^6F_ií4cEssRjmG4u;wScrIr 9cw]?~Swպ:a n64FhM.Yw#ì \擙rf%گzy|G^yvCz;w Qejٳ ;+|OjepetG14=x#95:2i v[ ߎNy.xs#: !Xm%–҄dtqV8TmcFXzV:TdzR& tF%WKly2y'4z1t1!/xTYY s϶k?1V aff+ $RfL+g}-m\?d5$b427c2 mVhʻuoխi];s5fkFe4jj0###lxc;sRq9ߎtԎiprR枌yxG<={{ )b~w"QGô|v\]Qԗ|j8 W"m^:#W5 IJ1K5- VєƣMFBMea,*~]XZȰʩ ri/s4V i9(*={*E'K9:HO(2 |3 W& 8ۻBg+F,[C/t^:^،0 Ъgn/pɻ(ޏ 8hK㙒/,|UYĽ1xL0)`0rMa &dC#ƔV3Mg,.bCe$.8+rL38lZz+$Dؗ{;]%X.3#9+aJ'ACH@!?v/=T1&6ݚٻR[#A/V%ՂBE'kuR |閊)>WӁybf)k2{g^gW' ʭuuh7hja=Gݔdb-ҶV:+ltanיV^G5Yh0,oz m=&+ =?j^OG;~n(fw+dd[# "Zp@>ҖM++T24d:kak;_\w094iFh19;JRFQiF*F4IhѣJҴqhp48g7C<+nVIb0 1XRHVhGp$58XvS"@.3m}s(yJlc@ })܌l= k֤]l@#1ܽl:FCoӃ #G_T0O}7Bkٲ{xL忓WHc8]TK S+J@Xǜ !ѮB~+Y6Q(0xLLx^_8Ш%?iR6sJ1y1UObgׄ}Zh_}V} 'fDtωt5NU[ﻠަ+_v=r :t8@klm.hvzxx|͊:nZ(DʭhvaIn6 mZmXhzJ 0 0hنVhjҴ (G;*zZFUxYYX d9ёn]"e/W)[1,L zID j# iXA)0(@+y|tpTrS ~4^jn07+ĤcgU!,}v=7A"{^.m9$2TwԟY_F#Xda*+W#N1;hxj.tKPCĶ+*33dCޟuxNُÐwkWakVj #Iz ?ڸV6qb 21df3c3ЮzWTZنƛ[iƣHݺ[V+\7i,G4ds+|$YvGER^y7;HUCHeJMup $i=uZfv5`q=bÃ[WCļUWvv]۷=z#9_<%~eWe~n<\1%ȹ6*ʬ;j0њem<¸W Td|ٳ(͖,na#+/T=`'*x(D|B W=޿꽅eG>2*qt>zKvGR:b7rc1czڱ^j.zRY_ԃdچV8RzP`2AamRm XZ7tOx>)փPxi`&@F-6^܋|H&i7 U%-a뤚no?i{6M\ PMX߂!s:<*DҴPʘ:̞+Swdl)4Y~}p0`O/=?lj j8_;P@#30@gITp$ O6_a"zDy=8(iUNvHu?9H(of:W%& ٻFF AJl1RYXĮvԍJۥV:8ymqٝg=k]xݚ;MxƸֻg*UqW|oY9ߝѮy8U֌8lL\o <Uߣa|s]eߏG^;Ѽz8gG;yrw;ou]* v5ǖέWnGu}CUy9H8C +q9zm4ݎ*yFƣq/{.C 1Xe*ё0j25XiMeVj0Ҳ4bXaj41ʹ#{jW#M*FF2Yѫ j0&FUaѳvUeލ/XՙV+\Fzq[[2=j;Jsn]9UtV%O7=u@ԛD]ɩFdy^h{`o1+UVу#ybԵ+)pbrscw3M6N*lu=Fstv0c8IwѺw| ppllČ&"-)FҲ-]eŏcaq:p^e& w댌I6ODD@!w}t+ ;to]W-wy{:SʪHXdIXrk}6{Oqi_5Z ma^2&B_]]#R1XNOz0s ͏F>~5qQcx$uFFF#6ںcGlH1j5$`rUJ+8l.7_::AH  23++QZVV*0`24*XQٛF5m5e[V| u{j+cN2}g,6[~OUãVZD'n~Na9WjpA1vz;oʯ3xXbjчh͚;'~|:ʲOwёzqqʖ>:2 ;&Bjm40(ڧ!0|Vƹ%DpE:\QUF&/`87d+TwP|@qc3N3@.5ݟϣn!$.9UwA_mmz]~nQA ^pRSOƐ".ƤV 8(R ,Ek;Ѝ vbyL,A7z8FW&aԛO* F_X u9*]'?zZ @Ur76͐mo&1j?ǰF V{: zBd+U|ϝ̡={/}~I_uCxGj7qF_(d}/wI @Ьp3 hnyF;MR`{OFlCQ۳?+UJ͝ujslb(SֿTwBV0pMKG8V|t KtOs*oCV m=OzVI7~ Rpo\hg`&f2ʪ{^\?zOKWt.J=r=Mٕ.nʴ1X2S~OoXԊVK[5kZ_Le,l;_8d~I1$ dH䡳m:Ff SD2I~I"_OSGşऒ,5&"hf׋͛UYk!kT!CB zp!! rIo[ƽ(M*\ Ϩ9x3s:zq)H3b=~xT^6wp|6^]껧fS,wࢼY6ұ7~Q5ѴnyS))^pF(µjh=rF' G[{% -3 xm͘+ VmTBoJ\  zŒkCoj]Uw{Vn0 01VV]̯7+q %3)2 (˕̮7G8=1Q׏ucGG'&S9+\c?뜃'MdWcsD%A0 8Jՠ ՗??\U;+z2ti6l;qיoMp2S%(rNJZItͺ#3Xp.m> Q2N)J^Sݞ<xbw줪{t݊ԷP Zz;_vwG2u$Զɑ{ cDEa.EJ!x;SA!e+ԓ14.#q0r<sj ~|T+d@쟀\PѪ!au3UW= _A>RÂ_@ )Udjx 8/9ִθ'8I=2J ub3{Ћܺan?cZ\G]SixF十e*TWP +\\BdZ2U}YX5inȹ*d=NfJj5 +,b!_+ըRq?죲թ,RQ4%W_]f=δwÝg]wµr맦_ϙkԃ:^X2=}Ë*̤&6t& 8)9JͷiF [׽ZHǾ4lc*TT@J"Ě'y~. ", I| #I\ WZ DE+uT`)EqWD"gT?"K& z'گ04vEvgE?Ԝv.ԋbB/lW*5 ԋ7{؆8u\)]nDxT-cpP&( U` @p8_6dT  E0nk-|_ ͸9o}6+Vt - BLI#2?AV7D}~[1Uu_jfl0 F)Nq p w IR%='jmVlZ}9@:F {M:pn{we).wtZlgs+X?[ SEkQSO/|›H#w%VWٚ81P$L)!c$QZ;3lT=O Vn3*]PYnr5]^H´\1 5@b} U&jO}oZ0@2AGkR~ O]$1ȔR$蒜J6P@I4"R(J4}JeF3( %BB<{i$~]HtPt/ |1'%CvsRSPlw!O!Yrrc덎c5J_MvÂw!hn|s{*k£ 4=8nb+4g{؄))#@C1 a }zTamRS_j(lBVfL$*mJ{xbs4lA,mqw 0 H<CJ-*P%SP=Fdēg("MFAO%ML#R|&ӯU}R>Q&){jU ~#qKAVegsUWvƔx ̼ƻ+fcj8SltW.]](ٛjK~N"4M=[sufty>Unw|c--"\G m nq@#c6Ny`@"(íBHIw]ChLx#%qؽ@+N ʥ-uPS_{c<'=ZHȜr]y޽reХ>$ "A ɾ$((Gk4Vvk =$'U6a0.%ϑ4>M?wی` \|#z LXȺ>c2 :OS/&(dE-c=fX`tץS(zW pJws/ %Qn5ڢXl7a9W8#Z2z؆*.7O6>; q֒i=\TBT</c8P!tq̰762'`R+k(,)F,TEQ?J]|"YDr0Cm˭Y7ǀ9pEߙ|OTS;I;y?[o H:`O@< 7v<{6ťܖa<ef]A LDcKa@IzE-T@@%% DoJT{҉S㑵vx=]iʧL#揟*؜==A2NR6+ YS &I!p X /4to_xw$Zsz[7÷xla?HΪ:YwՎx=cUl]PZc4˾6OIWgzTq,o8Scl|W{y`&mTWHcW;: 9s?}۳EAدBeu 8Ѫ0e$Pe@ҍy 'fZa01;*XJKyu`LE^L=0-^ۑ!DNub]!1oZvU5͞fAOk0KkcxfԩD sf÷c]iЁʲAZ6OKA 2fʭg?> :sG'L5jwHT' JWk%$g)f #;;r~> : [ptXWNvGT/ð[FjH Y{ Cܨ^6^jRcl2 `|ޮ!y`eO4DO<3ZL@36R(-?E ` S'ѸXp'7m5SQ;\HU5*tcS;-ￔ;Oߌ)1A32>Դ}ߡhoxF9G֎}oe{s1c":~:;:qYYfTJ`229+ {':՛σs'8~n>YƹVeZҸ;jl^ 2˓G#Z,Gx9|DIe hI^UN895ֻoN{Ug=tam`s8;y[We22UHSOQѤ͚00߃*ё56 Ir`WK4\pkhrC)2AIc++ 8KZF{:(\<q/k Gm.cخ8V+"MN.\FηjVè>r'.䭥F̬yGxVy>轘σ]994:Gsoz\uʺ6rrs֎w36va+Wk^RupfGqd1A8W&Vec/*:ه빵>Uzxnۉ!T?w;~bġ{)T MHֈ?h닞n3s,<]V>r Z8%"'D{q-~8ו;΅-r❫x[' !!HplS;?ϧqKBQ Z"7]gAfś\ ڒ+wMQM_'ҶRՃ~px0+Ӭ,:עI/2F5!$+@ A67.z*WZW}, 嶃Z9 d ;K%_`d_9kz3g1F É [Y[.sq_L0 $wb㰿8׹c!=鉰oW[U,(Xt0IE-;q vFx#-E S/fݷOD:i: eCD([jo] cu?F{оVz{QnAw30St;7ib !w7ą'6@!};) opWcyvCI}{L֪Ys_  P ?kG>.3-- R*beEIDrC){yg+@`jꯨС}AQ•-Hiy'.ז]i e<TܹVNBo]v4R{çjsV}4N;嫗ȓX[l`\+RV_r53qFn@5[ovG{:`lT%lI; vB_Oqo7>HP*8lEy8My7(:dD#*aEdVA#O'.^3?e}7 ]Gn!(H23W<.f驻4 /Ȧ}+}kjÿoURg,1t~ z[3+c1$k^ykSW/xG,+Q9o]mv>ߌ;Xm>o!t&\VU-- . TyV?[< 3hN]uMaovag>%*wov|S;frATW5x$co C NTgq&^laZ".F_/v` ϋ0J0ns¨ =$|}:K>uS75dX/[)E{KyN=;.>i>ZE=\ZWMއE:@uo5)+ƱH&2kY}k_\]U ުېP{7g'5YjaNp<\@MϕVݪ\or] g ?Y?,9*ŕ4޿-G,OyBn ,Cܶ.JJha6-H6WGHO9?_A'b: sR^һGO~!y"b~1]c Wxldg*_G>yVѩ#qblerE82y'4։i[?/>+-2IDhnp|p<āehc[ V覭,|L%߬0@Yd?S5m w6hmK,^_oa G14TPAVZP}ͮt=z7;K ڰ&[<+< ڏ$x8Y$U l)ZD}Q$r~C` K ]MN( [퍆~Cr %ϖwĐ&ʶo{)ȘXWr dB/) PI_Ŝepn$癘bֽ\'R8"X[PyERbMF.ZǨ(#dl}('c;%?:8` E+v*G@J Gp>_|¦^K,h^jVe[eNpL18`BH4ch&toPh )R`i< + &H+[N;,<0IJыh;<h6|M (3$MF'*x4T1X]ii0=OsNuCo@J1Fa0ӹ ^S˥$~k&5dz墷b#*ֳfJ.-cr|n2ɢ3/_(|zM-)cO V4WuO̺s=$M!VxQ$4E=_"Dk=8qIZZ{gOsS?i2>"\t?#v182}IB洗r4=$ E>%Cm%1-g6>_ Ō;'#^m?^(elxgr/t3=er{k-чLL ׆[^AXܘ$3 vG*CK+˰Э pT^fԩDJx<0w|& wup^3B-wp7nNEOI1~f#ce֋VH*ip:NX;^jI[08=FxnN/V'_,!fS[M6S~' L`9x$mUּX>ăA˗4R߼wKM[sO\A<ۖWu[{e ;)ש(<Ɋ3]?.rRq,g4HTm9uYU 8h /[%G8d!^³?GߕVo-s0 "@~4'/zQl:u'!S"6 ,Vcb,L{ EimlQ7b_.*[w?|H_k?6j091k rN8UdU zh>zLp0@xCeHW>?=؈f5"q!Ҫ%b] qHx. ޠaAHBﮆXQFm-SFɺѠbddBOE;݌@&A -mvmryv:P4ERU  ZV m@gȩ 4xG+-OL&DDȄry rv'ەe~&1>,Nsg53K#vokC)q3 RyB}/3Mˉ ]vSr27?hroW+&SSc2qJfzM)qf͐n?vq vCc5փ"v)pdL(z9ַ;@(ᵥ.ԁ9Gc<˹Dwj u~$%Dn~^so~ņ%{ޏ:]=[ş̩\ OKz#;Dj|klOBS+ok,WDWs禔:l_f`閲Z&wppj\gՒS-yj_HR\>'Y$^r>)[۳Ŝ9߾!x}GoL}YYQ +E0ם3] [8nVX8s?]75/_kq}h|7s֦¸˸pA]?&'W}Oލ9sg_"~_!(v ;0ޡ?b~^WOG1IJ'[=\$ |BHRl/G Qzv][VgO 4[Au{ɳWsvlsuMCnA"Xlo2qxsEQ rI80"i/؆Be.>~^RF4" l}<.o]R;E q]|%|i|ʸ>Y Kڕ3Jt*0(u,/HY%y--G[L]sxu_-VY(rh)(1QDETag-Nγ ol#}E3tME;w4sp̾^D[I}<쮃.gk N_h;!{ ԍƢ[n7eRy+ a9`ܜ!r-;uUù8k 50f9S~*>W-L55B 33 3/c5Xq.De|ypa4ʵ\(pME0>{J.]5dj>8I[kвET9C>iDH*nme|3UPIb].c-gbsn֤O9x4X %_o Vx#R? ?4$ۘB`i{nRyat69֗~Vcb ;AEZwds?Ƿ_x8;MGr<$v*(ͯEl Ⲅ]FI(AO9YP8W&t%g]M4F.7,Watbew/4ғ i Urvg/cw^9DCR{w~,~a/l2Cn̨}x=ugu:vm*ڭh:J]0{d,c_qTe1 a&}"D\=.uԝ7}vCy0.(>ޏ-$$Ȼew@6ea2eV0d dhmʧ/hH {X?|Z|&'[Lt[`^MY.Hr 0DT1H,ZB $8fȷRsA?u!cMA^lQ4k Q~o 56(;(>v2p3-ѓ)n2˔H ǑAmeRDqڿXM[o&_ۼ> t Եuv\,T:-0TG+M\ϰ'Nx {el"~jȈ}qs]Q# ~9 '*`3U~Nhfg̓.7:ڀn \UGYJ[R(bZ Y@)rWoM&VuO{A39rcgl`X_1*{e|G-h?cJ>S2¼r9ZǨ^_ZBAH,+)ԂwȔ!0ׅ-MSu]|qc2AeɤB@ ACۣYH׀ =:߯ľJ]3 ˦x eE:$8kY2W[@Fw`H6R;뵼aZ"mY7HV،uP6.29w$:?*WX*W)'@dˌmAxuˍz#/Yyۮrs;:Uqڴ@'hNCz9⳾n-w/FiPi Ò"@5!c^p6qNgĮHaЮj -% {m+1:Wg]A(UmwS7i(GbC7<^WփG:Vyݧ1JJ@ScmQ!Jb\XF'+Q($O~ z~[ڣX@Qt@Stqvuh.jfQ%{zm'YrtDt SK%tMޖ͞w;#{koaP]=$_SnЅ?+sf #B[c KHp ]R71=bt5akH{:=l"rB&=9)OD*y|WS][?ކn FuÈ9k(7f,:Z0Ƕ+joZWg5ɇ&G&pe?} ӀWYvj|3L8|@`|ݓ?UQ ޮ}ka vXi/AϹDɗq{x@6qx ri 3 C֑V\7i`/QF'doVYWw+"93ׅA'P ]*Ӂr3Lv45`E.*  Py: WۘQG.͏e`Yq79Gg;}ˍ8ssK*R21:j·l&LkM {ګ-%&IѰl@^wcMD%: 9)a OrWQvr, )d 6qϚ'R)O}8esxXg޿hq+&1kN,L v}m ޜm&Ymz]:1dx3[gGnH qQ&EcDwL4r,o)n|zO?#ٿJ+iWx& IMֶ e4|@tA}^zP8vbSkDޖIʓ"20'µTcۅPܓW_'vPVA"dQYX[/{Ca1>-|td,?`!֟MU|DI:_$/( lwL|b45m 0FvoK>OT@$Z ׹tŠ3iR @~a\g#Who|>/$%8bXX493zɹ>ܾ@ zi:N3V,=Vs3(* (pI%N0#K8xѣ޳:JF3#z? }_˥yq,CY-Q\'i_SkՖ,LJ*zu|uc- i5 snY !%f?17.kDL)bukoTG'7+rD59E Y1왰Q(O2)3P}hH̟ A]1F,Ao<𐗲"19Ā`rJ]x)Wn"^23%`Vc)&58Vj ?aQM;-\ZA\dcN G6@VHZ""|!t%}HB{i6^ o-hdin 24W2E쀷o}K/*נ @kmhWK^)覵[s1r:-eůԵQ0^7N'*{Ⱦ?RED j, 9TwwyD}z Akz4k Yϧc!uZX exX W\D &&_D?``y1^T ϗB\OꂩJ`#rlV4EdRa^^.;yQbo@dqEGA?! x+Gv 0 sV$u3y-N T7ÍB.S{3ϟ\C5&ݭHu ߮WTo!_ჿD5/ﰆ5(-aE8ƥK*fIbX澯V=0o@; V 狥QluIw@kK0Ֆs.]BL~iQB4ox~)/eZSuz*m{Ɣwt9,bw 5|+dF+!վfvV&@2$Lk#*L !Mp$ [qzyMzA3'R5z}We .YNt'3zC5Q0'GR;"5'YP9D\Y#4궐Go@ȱm:Tp|k'W0B9 U`b@@?}ѮeGbR v onYf=W]]Qp2xBpb&#i\V!M,Ec#! țAYob*E@BBa:g]H `PLZIpj?׳2ccyiLښat 䰉\N]exbV+X 4qV=Dߏ_cl}S7T@uȌn#%5r,`˱qTJe\fw^#9~:AP. C=ZRSy\zӫ{[=4kvg*]o]rZ4-$fs2Ƌɶ{ߤdI0_y}9fc!spZMI} H><6W)ׯ)A1pҲM**?)REHDL\mu w(:qyE\/!h@l$cN%拵$Y_rB]MPÍ'Pa5`Gt,k֌.3,>o<+NG<}|ϵn≈gVXM" ס|鞑-%󩛎h'߸wL 8_<0R0-#'y7n97ekuS3n퐃EcP65VP"8U-*u5HGOSYP2 L <'Pv?%۪hޥ/3wXHҁmMDžyH+do]0dyM6IǏɱH"v)%#]+ϑN-+Hɚ3)0{$m^订r6 (KfjQR0FF1 I-y^&AsBPD?MD@%1~ft53% mbq[0|_]QN/J"%p{@\H]Zaġ7(}sP/'MzۄO;W[Qa0%`( F#,t\*Z_r4Gpepے\L[s~}ۇv*%SDq!$*j08<|청/mGgѸ_(&+"/K"f n-kǗ?7kV?3N=3h2̖ PThe:)دȆ,sewk[f-8q!oFd[w0@5)$i0Rԧ4ZK'iU}.v /?&s8m]I7&4#S 3` uFk45Pw {|)~DݢBO2KMx1ƊjZ Y^ZqK7i~q4\񮧤!aY]Q9Ë$y5L[VƟv/YJuRDg4''zTG~ˊF۳Ǣc^4T>>NW5~p_>>GVFV͚26i H&ZmmR^ʵG az|*܂OȬBɓ1nkݽU[N-buEVQ8̶W~º \s$s̿,$4ډ%&(tn3kϞsiAf?)).FhT7fvBў҄ fi 4"Cx0~n/Kem$O |V`OV;#7̠@0s1y o/C^IutMp,BϾ#öw;,5t-xA7ll,=1Z];GcJ)>ʵsαͨf`LZz('d dIYe99lD!KNj):8LVۏXcltăJ%tˏ?cȊH9̊/[GԕY $Dn;E鹥' run 1[8ɃdIx]zlsƴ0L@&Hb>Dաh4}B<ǫ1R(;o굵a | ẾVei=Ogvu q6`0<[n|%~cP(>4 ʃLIP;_ `l͂.=IWeEK֟u~H]IǜGeΣ\qݔI.DImg{Şj;:)|`d1 :~(ڧDn1]n[*wتI='$Or1Z0fG~hÓ5ţf+NNMFLkw ln} ݸx {h&p _r{d^R\iz5G_x4g<4/2nqgiO%2}F^oS!kjz@R@Á&NM?eH؞$>uB,C4m)lz} װ6VWˇv|D.?݃Ef"un@XVa~˃ =ʸ 00ūfY~lkF 1YUe:6JI?}?rx`:ns& '}u;,r.VCXÝs99s=~ G3qqWLN.... pppBB,Sx DDD@oi=b&;2&;mHQ4MjA@+Va61C>WOܴVAZ~MpO^aĿ Zcëap=c0|8Ne0:U;Zh&jCWso?z)~X;_DE.\A{STFjݺW`yv`/|pum|O5VF* pX԰q#>F_&{P7LR1Nr~õݼ"BL٫MѺXѱVOܣ_bFr}B)0,Rbg{X)S &@0!,!,],'Gxhj9 1+~FWn\!d(oJQMRc'-| HsߊbڂNqX9Q+&׳3-Iy몌 T(0. A`?{e%뺶ݛ+(elZV 縹Ծ۾3<{ ~ᙙC 1F$lu_ .'6q4VvcߺQ@""!KG? {񘶤vh/{_>'z9SZ7~ޢWHSƽ}ݛ3?M-&Re/#HpV#iX0(Frʵ^]rx77n9ںLrÒrَc3tojܬ^yʴMJѥeu='*8yyjXy iX\[7leʰsb c󺮪 #/#OΏ,5xWulWFk{3fa/OOOc4B.^,; wV;:#X鍨qG ofU&FFՅk,22Ƥ6C(h%ٌm20IrҴJһ]\*љkW*]jV]8<]GeaY'(pVL]MԗTm82\z=J*~UsWI?y񒾿"Na)Q}YaұbŃ',+y_IzD~*kU?Mx|3e jdʢ2,aeR+)o 9e Hs P| dG\p tp> :T=aiȥ֥ʤpɕf2F5edS+#tS(\KnҮći*1dm)p1b\rQZ*]NS8Pm #Q EXrKLZ#*peK6уDp\B9$qc9ôleS#9CXN@r69:rK47EYѕZL??OSKoFeo)޷Y7ajyi56MYLnأ鏍hl6~)n4:zgKmVaƱk7f-YoMfjXo-&FcsʾeգDZ4n#WEƃO%E&8*6Gdy-#TuDL㩊\e\njGK9g)v-g'B/Qi3K`]x,x9̷_^qx*#t~UL$QmT':K*v/J:>҄D2Kzo /$ߊ>#,-m^~(+UPf2m*Yz/fr8.=Ң w@l&gN'o<3m]SZ%cb ~e \?$^fYp>ѹڦۣrZ^mS׶~4t4"5zsf}l>%ZF)I6FJej4_T+7W#K^. A"v*˞o%FNϸ|mɶ Zkd߫C 񦢵#v$`aNx}0=2}JkѡXWsk&ŏ8Z珌et.VmDVFPZ_}n;D]9 fIY<_mXIXRڰhf_(.~LDLƊ[&@0@9 @E[,%@B`=se'*D#b!4k,EA?x^[mg[Y>-[h8G~䵠1Gro`_7G ׳2I[Wǭhbݬi54ц͘ౌ7kpMM4af8>Jq8V5Xppi/i 8z/G߇ΜNUWɰx>ۤnho>%,L6j}8FEĕ1#K2#|?QVVѴb5F440h0`0`%ۣ*v9Q잓v8lGX]U fˈч>|E^J@UԔ&R^neF={ּ .K5|ur|;^.`݁Q lWGx n? K! s1yE7j̒=5 E6f@Ýx1 %#Ɋ^%qiy]<Ƿ'Xe/Jə7@s7Ȼ"0 3 ϩ)ez {Q]w?]㎛yx =O.C͍%r VHozIU(O[\cuƛ񕡵/vGGWe?ݨ|onL+uT D1QJpL6d ۼDk4(֣- 5"xDۙNP%Dk ˺ a9VR[h(“ыt>n>{to%%֋J CD!E"[$VD(㕸(5zwi'xW׿֤k:_z !޺'桦(^Ws˙0m?EKphq>Oj>?*^x|ۤ~s?_R dP;{vVy6!ګdlTb5 mQ=ğq_ˏFRYe <0 H2ҖFHOT%W1?yx=N2<; +xJ61GLFDpaȹ~P]\{ ]iv'Loig=v-jV. i%zqZgU4f24K 1nZK}ܣ:ڇ]Ujz;JٶMfX-heIPҭVMFF4YWu jdeXqa7a Ԧa#im[іjZ#Y +*ecvl+v4MUnѵnVɴ47nVɴi4M% PlږiMMVZU04 ᐶI^D{0)A?gh.Cť鍠~P1M˷ݼ{+Tle]J!W/[K.[ok|3JŢ#6[nJeor/%GZQ1^ҚKRif(=joO8{&X{̀  2# "7'"e3R bJƔh_1kXj-TY@1@DZm<,1K 9*Z}" jlpB36Mh؈,1k @l5v9{>}P{GIp/CA_p!|Yɲ8ro;>1Xjd " H|"4l _4֋mzx?w/p>x>ڂ&#~'([ U":~-G/0e+g.v!3uڨW+mQw+<לGˆar͛5 ,ddU^GK^6/T^М;Q: Uz-Ca;A7aؼ׍9U@ Nj01uĘohPyrO ǧP\|P3ǝm ?| /M踋UĪ1A:6 D_üS{k UʻrxU+h{uBۊacbC;rE+ԙ˔X:7=7>iLǷ9 cpd\I@3CBP2}48Aj }^-J$%I$r a/9ĜWb&U>:iZbXCeGǒ&>ټo#gU*9Y'D`[[dJƇlWkW^g>z:)ʏ2zt7H 2&Y𫭝{şkpo?LJwmr.ryf{N^WHXk@`'M=ʰLQ%Qe aFVYR`VUaaaaB/—l:\wÆpM4%D}a85TpG2A=Q9.Z8=gOsCjAb Zen+o:/vBG:\eUzR _ylǖ#F&뉳noX9tarq!5I4Fc(ĩ&M41FHLacVͪ8#bmIS"'ꣴ&~tui+ Ib)n/=ry1yªb2RfOXHUzIiwR;)Βrbiݱnf,GrQJ("9%іS0CiM됝FIv¹ʿǭ;+d'MG/B5V:T7MOx۶l0=xN 'CCحV*`j*9g!rN4N2:NgC7i acg b:### 5 ,22EY,&Ք wRYa7CnV db#;6aЄ;zt"%@3ߜU=}WވS%T{{ė8WǨzM%? ^TNcw^ ߭ ]B nqmlz3o_>IHWӉ$FMg @Q>A^jqWoVٽ|@쒇wO?lҲn[85\{3/cy =f. Y3;CvkzB$}#y} @ ' 8`NݣuʩKTI*I)HB%~\=ւP""g1"c/_=Gܵ#Mf4r>"_=XQ[rpJrA L!‒5'  i%fhZa0GۤL 0fm_*i!;QHM[Gʣ)~ Rxr&gr9ُ1ڎ.byw#HhѫFZViZR4jJ"Ԙ6n4r^wURL~??N*u7*]Nvƒ79=%ᜩv ؀B@ue/DZ7Y-4*G1[w$ 5@)\C@ҹ ~?;Hִ@#Ma2jZ5!I={0p&^kwwQ4U/_%X1/J@'0B`^F}6OJO6 }=W€BOWEcV6}C͙zHSHE( BDHA EHAEs{!.ǙU+BSb m;ąVuW&6탎 w4؂8MKV8hA̸" 샎D/-[:j6F##LF&ҧR|JdJvb0/#Q-J 9pPʫߙCxNgG?,|x##U\OvwTW}|H|T9'c`?<K8(y^a/=NayRF)NS7GNCM8Hx4V {,ӹ. @H~Cy $\EKb.Q V u#LrV)!F7NZkkOEІ$1x %zm!9a[~K@l(N񿒬r'*hⰄeE6]fy  D>@~CR8uۭ=af;=t6z/kBḹ~ ϱXV櫀GJ6߾_ zMX9RRpJ2|gu@U}`67z^SW}"``q旬WXggecO<ɽBEJVaq|QX}JۆKۿG?$#B;x8;on 8>2{O$Ҕ@'&u*8أE@bz4@,pUgrX۞w7.<~(*H{\QḘڜ#&B3`J@չI#>dGRT:x_.HHd6H ֋踈)13YKs+\lv*.1lmiӣSGgލ,G烔25f:s!zamWIcHRi+߲&/a+ae'AF0}::69nN|ܹyޗKV#h*w|^/`Ȅ8GRkHG̿>ڣ城*]*P>a^< 'uGQMIy*^rFsʼSz4Bn$W>BUM)t^CxbLU ͓vF e܏UWJzH1 WHb2RuyU!֫%*Cɑs1ڊ`xl`7ږ@H593y?VJv ]{O^5 F#Fl//#Tyc5kobPYthScFw{/嫍C*0ʼnʱa`dVeċ`L ^d /ZjKjүLb9uEStNrHٰ ҡ#QCOTsf枱f0\#eq[81e NcT,UV=E6AtJL94$G~卢gS@w$  NFZᣠ0}^1|=ikwx_= /FN"r/A1)Xm™g5xvWWͷTLC 41 VA*{MvVbHm{r0 v!FԘ.k^rb$u.}gY߭Vt)-W\tA.euT4 {@T Bjqͷ_" /E%91Fl4/4H@TjNg|v@PMC!w$/uMUF,SٛRqMrdGnW,y=)@?Vcs awG\EDp$;ۓݮԁHpnpZ^qWN_=T$D*m@LF"& ۾b%cg}Z]\ʹ`k 61DH{݅†%tȹ8(ߎ.LE##Vz JD778^-8#`ByK+:f?融EVk|8}5.]?ٙ*:9a@8p&107a*ΖI C2V%m[ %}=B#tUJ ",[-) ʼ,ryu(~V [z4km5ȍg !!ﭹʾ펠b\t9 a\V7Q1I]Tz 1 S_I9C_CdX8]M_r]!ta:r"٢۳S;7K }]d"sXUc#8l۝ܥ<*蟽R%ai%]sLjx4x+LvH=ruڑGct;ԝ5U!,bp[_>ȿҋ~z<85zK~Ko=yu{Xԋ%zӌlw/rZqGZ;v:Kq9!ܝ9 TWH^FiJX{%-<ʮg~5."K[~~9D?.Er͔. űJ gDk4ߌM"$.w# ;_2HVC%lyP̓]aC1hRAC~#c{ *KjCĔ}-DL4L#H>u#TBjm?CbZõˬٗb9 s×ZfX'HWe຾q%wL?]A\@WA 6\{Р 26Rl$W4#uBvkǖHٻJ Aj^"w$߱DG0ZROC`vs{r6)HUK_Z3ٯc1 D$!Z w UL1aIĚ碾D=u'ϱ*[Qv|ߣs> 9^5gfn6ڪ] q{JE!dXj5yMBR7ug`׎$2Djb\e%vx*DXe߆=INo3*|ޏ00sY0%w&Ie~f"L&1?=qy h21-J_^5Q97PPdH!Sb Thnymѻ#wS 9 x>ckF\#e-+FnQ{\ۅj8%Lʔ0F Rm*d`?SWT 8)5yD@! siC;=Y OBSK@|ׅT-8kϓS~'jq nu{yUUxݷ{WwA}$JS T5%0T4OdEnm" QzYs #%8cHOʢe/=I/G22330`_gzRQߍFF-COWcf1+ \DZƎ#(REiOcQW*<[TteTI#i-Pj&#!b*XD?R/ŽhwdCsC=.i|=ɻets7ҿO/B[[/?*u֫4l2ez'lb+X8Hh0;t[-;%hHDNd |B+*}r+5N~)i )HnwHSc[[a7$ƝjГ%BN9W{\c`zAJUcHim*b;Hp' z} #RiC:c;)w=WrV"ds_/ʗd?kw( {/r^M>F`ڗ"1W59C Z;pU#^I('K!=5RC`lȝJJl2nwVq+ Z1C 0//US~/un)''>4v=haal{qGG,x1cui_jSH4'lFҿ9\㜛 dacJn +aV^J1FѼ1v4ΰj\U'ea `Sȩ'!v'ĎǍbv'?.M"HO7Q]̎Ny|<>a.\fZxQ]x1S6ɐXOF)x$ZU4w,НM Tn?bw2\[lbٳF-4ln7nnѻv47hd{#ddbCQWyk΀vDX2dW-H۞;:K>;̟="-Tx#CKKƨk@Tu0}\Yѣ}|ٱ<շTõJ. %}QZOqNh[íuwh=vyə7{W[zTG=DF<QX~Co>ISǸzayQ>]ot+5%r(J6;P p</[>JD@~]5z>VSTy.ϑT!]Pwk;aYEF.g 8t94]؂$ D!%fǸ`Tjzܓ,|$(ͯI6h?b!>Ny. #C/&Lז`$VU|tSJV|ܰ9ݞ(2ǚ0^x8 #cSX>?8 |_ݚi|㜛t@I@ `a#Z4ac1X/ b2)wivpIJLNlTZpqpG2%| <wcQynm0&'/!/9z_⓬Ki(`ҮO(?]mKvSKC0$|j3XkLnY/O7xL`Z{'U7pHKC J=Sb8pJhd^ /_7j]QUZ}OYjHvKBn3ΒёESMC(ƍ*GQ^~PJ]}# de,X5JbT"Fj^{qL9'pY 'kq(j~jVƶ@쒔>-hBxBtc{pujA-3Z^7;PCl6ּ+ؕ}|Qm:y Ye$@+ @@0C fGĞtQiHs69Zr9llf|&8dfg$v>Ã-L&"h'@hiwY pN07qpp-6l٦8mL8W3Xn3/QTo˂pF#շ9RyNy&7yMQ5pl9:9浘 у~n֚W~NJK#GtGch7nunARpɎKZvMmޏ>ڕ/sSY>e¬ 1"'?B=8kO!be/1n)w.$O: .a0L$ ;9)5mfv=^a-QG2Qa0C Ńx">IT?Zdb28FF+b5RLLh@!tfU^x>Wz J+ruH9-i b0gDr*MtUW~/?~O|OlSf*U}}G ;-_[|j}4Â6j0UN1c17#cQ22]ipUч**z[6aѸ WLjScCr J[n<[Ќo?hG;a']Jpx{ndii1N5csvwN`ήJQGcFY%n6lC";ıL4)iZUMAww )KPNMʿ7~r~c;g=T/Ia%aEYd, e EaU4VĝXީrQ̷=KyHt(KЊj<6CH5GhTM%PaD=W\Qڏe G6_ml.z]:9ts%4^c9/ w4*(;u#_K218T;E1;ie*12Jw~Z=ݏ*?:ڵ-n1-߈cnnvGHFB0FHL22D2< ުB c6o-VT]Η>* ARXvy-\1[/w5','ZBK j ~¥OlJ\~svWD@$ϛ;I`cy6ҠJ= %[#ݿOvw$ F)JY VGUY{5<4bG4ha1Ɵſl-\.gb <ҍ'$FSh^CK%[MhA^dp+=뾹qvAkU9UbdCTR)7Ub1/i? *B<QZ7.iVxO93Ȥ}]ьc a-Ia B6h`\A 䧢kt鱌'uTN @P@QFӨ*{ʥc'>D)3=S❛SYw4$ГVs ey;Dly~ݡCܠ3a]u3jUqzl܌\Bw?e!N7B]W rmK?@Z!XBOơNPOo1[si.ՔzԵ`~ .60%]y;մf,S &4 ΂ʸ'(-=K̪OST_nrʾ/1L|Y``ȗKzWuT$AqHUUnn(VWb;獐Udp2LqC&ۣa8]*6i_sr..1N8Xڍ4~Ëd>7v Sj7 2^ݳlqS~“`XHGRw]T'n`}X@9uVrM^vvMB\ex^I6evzj3屒1,Һ O/bZ*1l*ކ#;8 a6='s(Uw+˰irxy.cT;쨭@"DF,=eڑxΞtq>섏١ӧ歋ips L偼s0bf 2\Pk|-R%\?Za"w4N˟ljH/(G%OR/euDD0S#d}$^5)*;cSyOBzURj#FEbi2>N:?l7ިفFw;dFɂV а8(lUG~p_b㑇˶Tx߯cNU|W\9^THuyӂ~C~f-^'}'s:ԆoɤD,\,R-_EljՀo!#=Gw>5+ݖ yԮ_Il ;s|ۭ P 9c5PH>h+Rڐ<Mt_^%h˭hۮ;tuP-Ẍ_}\ݿOÿŴ[&y@j*"5KdO5osA1|n.^;ui?Ϯu[%A1ٵ6鄈d(BH3C^*WܓA `Df?9SIkvJ1 (]sO_*?ol8QTd\c8#rg3lb<^Pٗ3=Dn6@&.xKvQzRdsp'gKLiĉ9_w<>h`hv"^p'JC=XXd a Jdp2:,"=zP,/Kq^ٳ\#HŹ" }w>ݺȸ+z;5W%/Wk\~ivk젏MI$PBhLĒ$NEn* w69``8: /ؽe$@BN GG`:!H ȋxaorL"N`ٲ_@fv-:_r܎7,υk:p27ۺ2zͬSݯ"=)4wItL`  t1_6}V/ u`WylCi@Hx?͎vB7Ѩ8Z"ukf \tyU4wއ1[/UQпxsezL] C}e;vע)RHB$kH 0@)/g_V 4JطDdyQk'f`xaz`ŎX J]BO`}k zllhhoie% ȃ^XZp`Nwc\I-"hY=Dh4(2bA鰈C6UPw̄'&k]Lu&q"''׃5LY!{[\w{,e!0]]ԶqK L[^~H=!mҽrK^ɼO@7 0D 0DҬd~ hh{Dݽ(VX 7'80T&naұLFԔ繆y܏Ե؎kZ/5~^3c܇v; O[ z˓L n$+2AY[Wk[g,妨.2*L{R۞jh>LWc`Y@3Ktm}MVK/6 ZU_Ҧ@L3 e,%##*zXGʓ=)?-=i1٬8 4ggۯo~K ͔Nn`_s|Χ|ė40?hEB·O EEk :NHz {XbTS 1`D3tK%Õ17rR6`D&*MP<@AoI7.~uR. vWY'Ǒ3۷UIT]/#HjsLޘG\eF/#>qFȉ0ֻo[Ar\Buˀ[ #|lc0@nLhے@$?X8yݷ!;+>╲3~Ѱ E<ФդRuT~G!D]똇@S8>ñ %sJ0T;Ż+Dg?Fx:=qgg>e~Ks0I|9?&Y7~>ǝ  5|aigZfD,?7XېfA;b-ﲨ*A̠<*wd{VG` /qFT|YiFi+7VVe -ʱVd+F 1+ȘV b)YK&ev]SWR׈ɛgӻO-;7*}X)p@7Xϖptgm=&@ d@,OBA_Y30 5z|O,]^|el U3޵/1<y #?B)a=g  c $.ZjwK}o=rO%ox3v0yUp @p -F>`?vvaA)O\U™\=B?۝Ηuju 3Ṳ9Dm:PR::YƤ^&']W@eqQ]@.1B§ϙ*y-N8)p ;Ĕ؜F|Jy; /~|I8SlҾyɶ ߍ>1!Ċ<{@{ENi!@$)^{?RZdhݤM!j=(.£? 9zzozQ*0鍍F(XJ#{ts=t1WԔsDp-AYxBi'> ZjwY>{ d6I4|/H$<5{Z; X gUQ:wFzc-gݍ ѼFdԜNSA\ Pq Tu` X[nXKX/\@lɄIT&bJ/൑]rtzGW80q+ogX?T?"E^C޹~pLͲ }'xW>35vj)2UP8a1LzGg_P~*_q3S!5KSޖOg>o2h^bP bu 4MͥGy=v!3i`6ãC5k&FЩ­r0_0>~E4[ލ6Y_siTAj- WDt9|[?0ģt9z;m=5$/W nryorC#[1uyT />#3e<`C=(DL\&Y@1pLAם@S:|k xb_DNJ cKW;fgA+k~V "v1ŀeᤒދo=/lfW Yo^ krkTl8vMi+瓀s''Q-xWq}'%1rvo!|iZO>eudm|d߈J*vHx6~:Mj\'m)tu8AרpH5M-q/5?B@6d.ɞ H=9CQxKCYf.X!SM|11 Pjd̊zPϚKDTߑK j!u?.r1=ȍ_@tZNs\J|3CPUJ"&"!zvTWO+.by/o9V9.(+ǔ0hDpAHKwzC~I%}]ל`Ӗ5@ݻ'D#> j<[yFL;B]晘0.vAupljK?EEP5l5Gu۬p?gPT[$A5,T kJ9/YL0i`=>^ů~~4G;n u_D#w|&Ս lt@Ъ0©V߷$OU%` =<.wƹ)N˰>uA_̴$͟ui QS(歴c+YGD_wp4~8AmY,c.d5~=)#@GilNnTd/?X|ϕ ,C_h7#:,ȣK7{,1RNkNEТ_#ඊK<ŖF^Tk,ZSY{g'Ke*.܍/!>d˗@'C vlj |ƙDكڛ+)ClIj.8Oc"8Pl?gzg:P0$iqA?wa{N[l/(`=4&kG9>"[&5G&倸P1+B[<˼oy73XD/{R ih͊X<' V@G] ֒c_ <2J߽sk-ON?lKPqZbBCwsYkA(5Uv_+T@vRx[+%M/~,! GSPiXG1kl1HQ䰛N$7rv;fyS߼HYmS;Ψ{.1D_@zZdjb⼯]k㣊4D7nhp**;JThD;N4?7DW;ٝ /&&*5j%9|V2_IDlN,Vq&ۿ }vz]_td A|QvŸeR\ y$/oOkmb=;7jm7(w2`t3I5yM ' NiK1a;@*ÏIt$=F!.?--)Bˬ}#u nt2cP..)gO<hv+B2:7OjQĽ<B{.)iq_EL]c\РFW+7}i*RmŸ_63=Ʉڈ0_֓2Sնq~s:9 D!iNxBg7ѳZ;\"tD7jvgveNzjZ`@ LU9+[& q(cFcW$`P)!CXݰ>Js1_²UgMne '9~s6嵑YF}bU!-88Ɋ^TtSBKHWm}s~&G)$>M,8~g܆߾T/e=JDpkJҀR8@ \PYJ]wV.KqHY T QE?#0[xHvsR?.ƛpRPSOp`D*t‹KCMQϋ/%m"zʎo*wXظTv:m;}]hb{-}偲h J/QW!cc[Utw{ ;1B3jό{zt˯(`"VW=|I/`)"Gzuzt(]CF{> oTH?X%w$mP!R:,_](2ۓu w}:64eYZ[~ ouJ/Yd T]I~Qrxp>m~s-j"dѕ@n,~ΣeQy-= .gD"Ӏӫa g@UO>ȈʌL}ur(P=,4nh\zJu$7A ؇Hc$)REsu88Zޗy_fԣZDS=o$BxT_0KͿ2>!(Mw\ Xx*n!ZNϤ3;w|Wҿr` ND|,YH˽/3rCes6T.wi4a`۶^-Feԙ ~@MUL Q/PA cPиT9}lնu":<|ģ 5=yJynjw3X*:1g s2 alT?҉f[` { δ:8sGyjTsc^͑fփ|r, JHn^`:+z\`88+uaQ׹"9905#xĭ/ <Ё\c\B_J}&=)k;GBae}vlI^ۄ8\X0#{+(L3DEzCn.aΞڑwrLl3 6[ՂBvCئ#/cH{l9,FPfwCHg~?_pE:|*??|NȽI Ha a va(-czƱYKnmcMw)-CĮXlAX~ȘԺUDUǛEz(j!ωJ(@a ht.l;=<-_`8][d`H?Ụ̊hܣ4;~ F;L+*\rԵly%^ "aPPJP ooz)zr<: JrMw/~k1PmC"gz\9n26PŨzΨ]w ^D8#~$$0W+cXe%]wk UrP2ҿHL.98(uVDAn?}Ǯ@Z :ć棰h>݇GQf>+5q_'@"=G0`oX\qhH|]CTE֛x;+(A؎>n)뿍YR(Tl{IRo̺C%^gAPGa."'x'H׈gK3#; =b_xv7Q 3:QYCl֕2] rnn>lW foCۚPUi]MBW{̊!7UU|c.Uvk ,eO/E %uǛ Ά'[ӒO9ǀ$鄲F?.[$AoGH@ %*;_qpTKg>NyT)5 B-l_j` nr?u w.w.DbDh"6CYcIwf¡u ăb{EP+tפx"[_t$a\qݛ;uU؈70LbQ{"EK9j1IMim 獂SuFWu{‰VO3ml!orXvjdO\(@%Sg<y0Χl]4[ϤL|>^͏e@i7JycK3+#^5 9+<^WFOBwd#{B]Vvgb8i>ҥs_|nq\Ac`wK cJdry:]!e1hwn_ N.jd,' sXysW{?oP1x&:"/w6;}^R,_TS!C욮H5BUzNE[fe;*-o%K͍ILz[5[)+2tФ7o\&ȣuQW8,t8;Q1FA U%@,T 8/󉠀Fk@z܋,4R_58MNZ5UT:}i5;&xL_~50{VG+*ۺOTgOE3+_fkR;~n}>h(̕>sv|Bf4O+#=pȫzg #j?J*e;vvV)8Kw4BCBˢDހ/Y/ ;?}GB+'-%.ዐL3FN_}NDBIa?8Cސ %,`\8EoNP_d=u"VO{Fd*뻆\fшq` ~G+aNd޾6m($P#;| &\Mjd!% iѲrR(ܔ~{{[ SawJYXwqSx[ IY{Y&<:Nkc)UlŨ5;poy+OW?PO>4$'|y;(7ygmadT-1) x/462 ~J_W^ȏ8tX//h?[b_^mgBWdZX֧Pc*w d;D%^DPūK)QL[l KFq^؁Z읷mx"Hv6uZU.%yUbynEqVК،XN,+Lʖ"!M6hoXi=4c0m=<-u`cobAStupį*ûXV\H[p4_!EUyE%)u~!7:ªOg+[[5iﶾrj~߿ǠFIcXdɵ({RoƲebD,jfTPe+l%%j25paeߍ"{izjWHhu!CL i$ rp]+di5`!Y]hVN6p.Z8ՙ(0UHjζMiP&?Т'n [W`4wo Yd dpP$_}{bļA{#2ifO?)TblhuE?Sݎ9e D!N}}'̶q!LJ&̛8Rna7;ᣉL f& d:>?-,[kNKK!LO.T0A2KLFAbja|8䲏k6]z\ ؚۆ @r7庨"n`̾<6חRjh~j>sEhݮTf/DʦT GP-I7D4Ki2]~Mˎcj]՗t?6WWQ?trT2RlE_, doPbWl18zJ10pIZ~`+YK.pAu{$a`9ܑZUU R*M9۝lmEضŠY*2gvrZ2eE,4mCڧpx"kƒ\i, ̾j𬼼{곦n ؓϽk@M 5g$ sWG&עl }HPr܀ 5乄ԥ=/0}f6P>r&Ec1GلUmFomiiR.pt%гw8!2axt2QB4˗mɯ=5J;Xܤ^c89Z&znx@v@{{u掑7S#*2r^)~oroxM?PzmTkǃgGWTkpO0_ET5ʛYrrHգ:d˼뛫y1wd(f;V٥A -L~&ܛчCؠ}KoZ[1 :=eՄToc}̬5Kfپ7"?PZn3ˣ9m8ƖeAc,qm]LL.r6]Qr3Z.HjP`c! E/ [-2"I[lQxhjN9Ø4T*Fҡ#k$.B|d:of8Ǹ;}/ݞe }C7f|Y1YRK@ME5/G3bx gǢ4@|k(zQ6z%Ce/DoHKGht(c ڝ +~^LOEvݷKFJ+Ǘ$X?WR#29]g7z갲EeMC"ΊbAղSDvC "KED7$bNN+Qbf(Bu_`%2Ho)lX{Eea 0EOuwFO?ko'Z \B5 JYkL6a+'bT8SOX̖>a|?uP(6$/HbvODUfLg)nyO~Ԑ_4ZRKiNX{lE}ns/Sᩛ/zg.qhi.-V6352?cј#s߷> L<{ؚ7i6~mmZ_ل94uU{mwpQ) cs }`"N SXg)A7&!E\?N0ꁖ8`*ilYȈ/KNz*n5Ip{-?XoL6*g߽د[y)h uԶ<{gZQ|^ߗx/.ԣ  `L0Rgp~,`ɚSP 5>S3E1_rv۷#EَiQϕC淛k$ ]_& $ j?7Y #4s/yOUo!-pz(,$ߝ ZyӋ-8*C"ZA~hkQfGg U!{u ërb lGO"0vڄ.G+0K YA^lG9jpRKطrBUL|#?WTHL" KgA22i$5\,9jiZuTk4 E(܍Q?$4^caZD{7Aiݰ4_;Os`3۔R"|9 # K<ǂŠIFvbKBqB5b甿~8X,m@[刯Zk!qJvjx#ޣ^R|y\1Q!g>ՖϳWzF|FuݟX[oyqGTV>EKDQ"6)_hhuiA> ܣqm*{ k#-fnQRͽ_.ec2lޢ.GIu#">>HG'Ldcq?](t(Uf2lQkU hpJ#@.9<*xIRV{3eZj伙z3_^Np̭>C:H|xh>f0ZsZ5 TwS W\vAߋC*jpXo8N[ΪN w 0sK3 dPC)HHc 1._Y2)ۜa'Oݘ7h|Sgd?/͇GO@{?f1>p{;aj*ӏh2l3EK LO ݘ{ RmY=|u8<G,awl'-1U ?M,^+^l>H|SJg{6v{m!UW_q2m~g2QqKv`ilS⍍ Zypn\f* 3ϚT%U1QV<]Qd-N0܁M 0hk1Cwjippo~l֙1 8''oHnnNm?لVrre85-PS&a S\af`#udM7١[͏`6fvRs-O;/ę[X>\XSi԰HCMDӸ~8{n0&2cX8LA1΄i K_fK/EM%y&F.x=mH\x,n3EM *ٴ px e@Y-,E>ߣ0uL[-"[D ,W=*D<Ћ3N-l:W;,c#r(gB(;y3$BǮ=1_6G!ba!*u'#i`ƨnySCVq!睜 2h$3XwYwCPI@@Uv3^?{r>Gi'[UvYs\F6 xonU~B% 32RMEN#WWqLsi\Vw88N _ ^H_|@ Ro,xf(=~>ֶWWtlAdGN .ߣߎݿr&W\ĝKzC;0su"oW?vğWOWf Gcb Ly{ Q f.xd]98pʸfcGJ r[`yoK^1nPɢ%&4?[ aW^lN^FO KM'+H6E9rK1<ްP伟)~: OZI8>YC ]G ~ǜPJش>|"#;Is?ZlyAvz6 5yt?BapI|ũ3Z 1d_r |~{ WE$ߴ l_wo~~B},@NapOOh '_d>M%*yu:c :]$3)lQ ŏ@}xǜu ;m01[\_![ ev^b~[P?m.p(@7谿Zd~4r’>JOyXDwqe*C`4'9t--JCMNk4O-{#i90K? (!R>I7hD?Ue:M0lX 7 X SLSW7=/{`WOf_TJ͛F+EM&)&"+e|pBQVg,fy.#O='l_uKkopZo}g:S,JLru%nZ[Gjv8UE9ͪ8'ʰ/,BňĖ ~m]ݻ͏q~xJ4Hcdw/M1ene0Sz~dSUީ[Hyt^C\=mNJm?+LAY8;e:QVK;RROvKf/a]-@,TqﻋB3;њ;4HHՙ'v+U(g^_3zslg JjB7vߎSjthcZn#.G[xn"ݞ~;~ho }ʂA.֣mP`O'tGht &^%Hz؈Cf9UMJ/=eEɁ&L27]+iJτ2մnM"nkT #jL½u64#-߅'bZϰt) 4ud͓pW~۾+ @I> LY|Ufuԅ鱵<>uZlB5}Z2*+.nmѿ O`ٓ!#<1_4BQ[HYϮUB= ^%^v7.ʣi3>z?llAh;GL#׿>MjG@l}mZ4Q5htÞlXBcǬj'\wOߑ2witE|RF6N}-;iQmp髶Ő@g1eom2[*ik>R=X߂/7)ru>۹Y.6k/_ bZݴX]GF 뢲G d0@ȨUJM9Z60y=֪?qUv XWV5ϨIַsDBYP%9 w~Fw?u`[ h{0ޏrДL}ipZ/f'Gïa QR@YF|!]uQӾm`_ Zd&J}YCe6鬞Y"y_՝G)?;EK? ϨHmw \*}/IvH}^ʎ=KJ>u}CoZI QSs !kL HK2bheIaCuS=X[ڹ-KBFuYtk\8VWk!qe6,wݪ7M b)6@"OIYɓ9h0%g1 }kv4S J5ʡ!f,ݱ~O]i7(/8Э%fj3%iRK]Qme9f ʉV=roW]M:un.=* 5Ǚo6iRgrA^e {a{}m~{mA@RmJi}\48$i馘]];(3{@-Y oOZcYRԠ"y8F L`ӓ;цM~$U3Ԋ|õV٤ٗjen:)UD5/`!9hs!5d a"](^\0Ȯw(+Q>;tc(#it/Sb2í\ERXx4͢,9Co:M>Œf YBߟSEeCd[ ɁX<@r1r0E@/k5+Fy.0tzmՀAP|34^o~ # o<7Nej ^]l r)Cf>QN_d|~E 9^]l%5AUɏTow> /')G^sm%*%BeKIcL&W O~re@[~mQlS7 ҟR_,mG!W^| a-.,.yh zk,sy@qW]h 9J0WηB iph@԰q_/@Wq>d^?㞟"cP9o ?S(~&\{"-}W4Fehcm[+vlZx|AP2A"`?qIP0k?0׬(/43phMso] [͓1Z}ڇ"I9lRܴgܙm(8١Dn,©um{7\ x0LK}M,5-s|K( !^kh`9J>u Q Sx e'njm#!@.i NںY ]܎E>۴@F>flj]\e@_{W5O竷Ǖf2cz|N.-uuw-\@ Pf{9LQ#u`! je!>S%*ue>X+مA~  8'j`}>U01a% `kov/q OCn9 MI*I Mٚ gYqo dE ?c]5ٻ/d)߮lQgAY3QQK).]7ϩ'* $Ќ+Xѱʤu䋲C5RiR Obyۀ ?K*wjT# l &A  ubn=a"# kkyj>(j8⎱RA =M z9`6Q| EͲ;%KYI ÿ ֊RngO( C$mtqJgm --lOO킓po^. 4|W\@:q`@Y !{ņ7xPDYK[Ee;@uYI2Hfr.~ A*):25#şC`;m[Yode7#hf(xbd_/9H=j恳~vRI: Dv49kPMCn bgՉ=Dӱ}Qt}jӋ;1ݶ0'O0;Ã7ҹЍhKgI/EJp=;^-Y§p*9\/82RڽѠ ą9[%^Cu)3Yɚc-wE- j Y൳4H.N~g~ٟ]2x\6"=(u ȘLҨ]e_>>Y4ExP|W.r.MF{2rXtI"e }hR'fk!g/طB+ۇz_&@zC6P\QV[Uz4UeʿE6z1F o{r9oÞguPCu,|z&Q5pCo]k׫ ޏn&ijKN;$"HTD٫}rߎ)\q+%֫qR@lxnvW/7y =4!i9 ZV@9gfO?&Y@9 2?3B,5=9b" a;7e̯df3NO/|;=Q?3 !30p<ļp|{{H /2ڞg/uY3F; :QmW| i)rݻ̬V|'7HӵTLRǔz'eZU1r+1ɆtZ=g+EW m6(tq< \퐪 \ JZGHԜ؛uyEalzsM꧘ć@З_şQYrd$}fx\P1^&6xEY6&Z N"Ol7󁩬QSԬzOs>,8\'"մIC=^FVt`.'s29%<L0]hIm!:OkxNN]}sJBfbl:[k;3aFn:Z kT&RSd07`펝a[cS5Y?Z/Oܚh[ܿ|>9MoS4ڧDwuxy<΅*XjלZ GE GM 1$L+F.p;ZEIШ#5F'Û̀W1CoWQg>3mr 9@4~Yr"P m|~wmN=[ZMEvVA>.cQDԼž%`F#+wt'P0.#'7?AYQ& .t29e2Ԋ3VJ^Qݍ 6q!g`s.^RtE}z/T/)WAXHTz 8oN۶8QxP| {%DFJGETw̱n| KW@Olj֗&┮=J172~)@Y^2Γ7kD}cuI_)N 3+j&uV\cf&B^=pgv@n֒)%D}= C`X^ȴ0$J(=m^[ڏ؆&.~j K] k*-3$pVgd8/7.ّaٕr."̨b &tGzaK|al.^b _Ky= z<e Fi|JoЗ!)'Ov$)Zȁ`Nr`ϏMX(?p $[㴥9>A#ߪpMwҶe kAjҢ;1Pi3'#20V?I E<XGKI-`,;N|@OԶ]E:@qAƨٲ ,:pܞrkQ,5&3fT&5|UPk-gW"iп`[g_zrq0MA֮1q_^7 'P(_t Hvou p`2Y?0ɘ֥φq"ӋD:*ߪz&'ձɾZbh[Jsf&d@NPR/vjUj' `.̹?zi4 9D.F]VcwZ'=n\ߔjN.cX4+ŹSa%'"X7|+?8m)Fm0ƄO;lW&ӎGǚP>jQ*0TFY$}]>![|Yv >'Rc.i1OOF^sR{Q&wܲ#?0RAޏ-ϖbkƮv >9g0@:h S=OWb@Y''B)~V6xvSPLrXblLheƏxsᵥI3d v8xmXuowRpCrSܿߞ1 x2( ;b[▹GZe!{ۓZ"gYiJ{@  J{,ಅK]b$NY?QFe03-5m%( یPJZigdAMr QXG(?H؞@`?B کz|l+QbjjQbԽoqU <)_f_-ŢE{XȜBTtM̓AEtjEQ/ggR̤M܌ɛmt50 9,XM5ÿg>Al_!U fJq =yY2f/~4 pu壜!s{#S# - !`~ZRa*3W6(EJC3nyt! i݌`y,5)C2ePMڢ(}8l64] UTAQv<:)8Ny+уw^~},#|o*%WςeۭLfCRw댣"ȟZ??Zt\A'kHZMTIR@?P1%opB~ʱE`INx2dAX$E#wƍra4kn 7m{e/"E@愞 O[}b郧5t2}DRʎP?!#rj :efOEjc4FŅ_>q:7O*O#dA1(0:5X|.X+-z\FO^^KCfw;MN:> ;#.s?t*釙R#:M5%\յin]>ZȚ&|y x jX|RANְ Xba譸!/Lm0yq-;tSžZޡ|+Հ@m\C(y}dSNqǧ/ ipm޾KRM5WٚMZ g4p$TU~U_ | DSi l m~N pսjo!(UӸD V8o'ͭpXMU>'ӍK-cc c'ʁ}4=3z6 @=1&1V OZ|O#cfE(G!VVeb&*f>IexX,B1Hy0LTD\zĢDB:*4H"r(MKX߁K*Ri) hVdiFXչD*?le0[Iѵھo825ۻMbulwdN'~vj]'j442pv]'LIS6'Wխۿoэx%4;PE,d<ÖϾx@R;Ρ>=8QYYk?,Խv^쌵65{98\tG ]chB}Q}]0.8ś`?8&t Kgܕ m:\Yɰz6%NdxP- 2`RH`S=0u>ߑL$j*u(w fƼo|y ~\}Xoda+ɧTa:k_WsʙX!>Vz`k2XMƧb)A%`;&+P66@\bwTaaw9Ψ/w}k!CcQO "'@do %Ş/T|߲8LMZ9|:iv| 8T˜|E~]OF5h0|U\/$w̟}:‚CuPU*Sޗ+ա^R[m cQbՔ<Bf$pM8|E1TɄJ N+L~z_ѫW(e?*O:qﾔmo4jy;*F#(K~GxmAmM o+o aU(['vyt>2_]Ol#8_F],-ܯ kweeM=;e AL,e4q{> NZ{'oj?.[e1:`'w .&> v58E1ً4U]m s-aV]p{K!k2R^P1d~g0y|D"@瀮m8/Gt [Qi\u><B=~=ctaPwCE]0O݄_YNԩFR,O`їتye~%#V!KGZBac-Ṋ_{&Z-Ys=.egްvDpXvk$, := e4g9 |5/w7SLA2l]{3p:Ɇ!&WFq GY~ ]U|(]-ԎfV& Th$/kw5HL@ۦi3Wn% yQ]6Hot)"6Dہ{O7W%s}:(HQ1j7/U9_o?FOڽyK +r"yb TeeBKW+DY< :7M;5+qaiZj!bT2 rKnxm`~ |V32|Czp]^aB,s'B_rPB$v~x}8GύS1xeV$z<_6\3(ɾlS`+?O8eqn+kBm#)«k&.Z~|q0ݹ:VC/ %便"e$KҺ7HRĽ9nS,鮜T%@Eytd ٔdހVQRF)WY®iζ:6H ,i?aX" w̾ž3'G/ZWc:͚{]I\Q4|B2@1V%VBbh+'3KÜ' eJȌbkB9Fw(`W'v$]ggֽvqyvă ط4 T(gw\-_7YuQ"'%dTgqNmUhz^"@^*_~uᐪs1IT@l;Q.PE_W{N6ɲQ_va_eerbE+iq(D%Pq>}lAqBfBVw-6c @N/shϏ;EP >>$`q\9}3+lZ2Zep@Dpn3 NczH5TuP ,VbÇ۩y/rO<V ڝhP`2pLlŹjLCg2i A%21)gwEb N!UmrXX{QI<ê3&KwFIL!s0b.@R[RHѹtF9ǹi?^kb0[@ ^I}0, d\,'kS$߻jnf?#'8|2ter嵫)+ `C*|qk$ "һK|Daa YT'81?ZȤ"*6Ǯ-.kfKEPǸ,ѱә01dv&yz쬉uNyu#B[F[yZ=E]qTi>y2 S'C>֙cj'rh@1ցA2fftpNoﶶfC59ݔt3Xj>/S%-{a`flM_;c:[ԍ@sB4JLEGH-gѯSnYNFe-CҔfSɘJ.1;c̊O+ iV}+;ct<˦UKO8{U݆z<߲R~\Q"WVӦ)~/Mz&4&Yë?W9?  H̞~˟hQ]Ε;"5Fg۠]k]_,6e!XqWF.x7? -RA{:HUc(rg9 ƟfH7I}\2l` ꢕwSn2Klqa16%1M:ϷFO#˨_EOfIH\ch崱Hp"L!$`R}]% m߰pt} 3C~/H\*R̩LRL=I3gPGzʋ?.,S3XiyN^1=YC/'g?Wy=k}Aś[;)T94-զюc_3pΩ5Lğ"~ť.E(f]IXŃ$s\]$od }~ E? WLrP͊LY׃V\0ǁSkN$s=ߌ?Zi϶p@=Oo?[tgj\9641Ncp/G0]R[fV:ެjڏKH0f5NFػVa-@(փc(HX~xrH LWxF emIoDLRz 爑xh6Eyw2PFϑ,27Bx𠓑I-q@'%TP6i*'oqQɠ98 8[zfFئRfg |{jvCim,Sz=fs-=ON6$v)"B]$[iGSJp itgV5t_<ȹei䧸FB$Ҵ(OIHFG4qƯO|vRk{.nJ4݌%#@(1ZD ZSrBcry( ITMTpV&j$ÚE0<tM[w̭ vL&th+lYD7tlM+SB3_Yڌ   ɝKErSQHG5>b'0 ^)#Alj׌$jC_ (i͂hTQW7ȸj{?+5pʄY$+s>B#o'0DjBxG"/ 3>&G^I/Ṟ{n%'/EPEfYUоFo01R!qUWw~f$cmuWTWdoqkG}9U ț|o|;3m[Rܳ&6(aap`3:#W2Lzc}$lbDwFpM b3xʍ}OhI嚻恶1~)dak،}9fvβ %ӭ3qgPJ~k<)m!h\G[qeh~ޙik+F2*'vG۾,CkA 63A]yj}S؇yM( 52?36}\[kG{;hVj`=Y?ߖ=.\y.I|f, 07U̙gm(>V*nTzS 2i;yJ rUַ|t!uXyyGU6 8UBgW.z9G#^M[_L!iŒ+hC0*PcƙLUPʒCmMWzzزw=C4sڂ==R ~u^9UTjѸk;~rj7KZkj&?ϿNW]7 4/ϸimvJyoL_ Cy[6++e/1:@IMMn{܋s(j^s3 F?h hVa:q#rRz\SC{]kKx{j5SYAw ))"41HeZ.?*{gm&[]V{8^u7R=)h9h]%IyxvY K)s۟0V9/M {D|`B֘5Ka!jܢ  ˑ!,9 ᎏ -Lk'_&K$ϩǩrx0 O:dJst4 ĺד̐9puƒ@wHBYc|tZ?Y1ۣ+^fh%89kqd[ܕq`yrbU!0}M:T3z,nY=V鈭ɷ| dU7BKnpi1U|>KۣIՈg"Uɥ/wy*m*2u=1}/bLc" (`sױ e-Nͳ,P:CJq9|r}n A1 ܮOe>qt= Fߋhq1<*2=%tPLݸǝ3Iwǎ5}\BQ狻֙Pn5=O`W]/j^Ts}m~ˇ!*QTo!9&u%{ƁZ*u׫赞wq%[}Clp3 hPp^=rg8majbW|ڧ2XP&٪S[P:,j2LTe1ɭéM-K@1im?Pio4>']O}2 | R}*0fT4aaH`v jyŨ߮IGy1V`7%㽿^qq_=3wrE'1SQ={ H;? 8B$xi9&s.[GfD>GŸ`9t 88lX/&dAlmŠQDn*wt~ ͽi p$0^'s~09 Ƒp plS9y3x=.bo[Q Jw> . W#| 麮@ح9x81W?ѲӖ;k'k~\-oT6#nLc'>7I D"uQb㲝mcG4yCyh 2~$i{ڏbE L%|!Z4[1{}eX$ӹcZ:54.g.#oV%cH%ߧp0v$f1njq)w4=[EERg%929nx8bHuz{vRi9\g01ܩ11AKc%|֢f0 (ˍޞy 3^[dBddUU{N*cLwiRb"` ;crжv'/jz{XX:#t(CL H4לPpi7C`ԧe>8bf8c1;n/L}wtd9cvuas|Q3˧ oX8# 9^yoO[_(d ^֎]ZatYL&E' w.}ysIv{ i() 2nqaE:gsU"JϹIo,;+YGBeIҡ+ډ!T\P7PLBӦ9'L1گWA]_t}L8~-;xˇ@a]aMB E_C~R_וcxK_ cӸ-9\fLc,̝}aLjgSy.86U[0 9`%q$EFe#3,BmY 81jz=,^*㙽h{dvk3U\ᤀZp/4Z5kỦ!՘Qy,|j̢Wդs M='\r=QL\[lIlUӜЧɡ3%r9LoN_t1 'i>MЇu=IB 8'_~) d81ÑY.!^/V_u9_#w@*7fsolun2.>j[;+|j~[/ ͌x(vnsǪ/gKX꽷{Lv`z>C0eWotP( V1$ V!!_#8KJ~d)P wZR`(#e yYѻi*s`Z@0N PO/uAp^Fu|3pc4Zk6'>vLtԪ< RBj8O!Hx3B)زR*!=*ysȪ9DÆU\}_hɣ?J@Z)!A$:<Y %ЬLfvZ )qQ#sB;*2:h:U>YNU{zICLJNbny0qohnsgZm)fH lRGFyPIRdÅ}T!$UGÔjFN;ԚAkNtĴh_z);m+a0naړKENqVc|$0`{AlUK;%w~XjZ_i<&L<>o(/a*^|޾pxMo-ݮZ$s@@+2`qCXϴW_5yd0, /HsV;vbóUͿnyaXLcqk~@ BC?50| LXGU_VÃSy.FۼܮS10YnX)̸ԙ55 ٙ 2>lKc}+bu"9e&*4C<2!`ӅG+ BT-9G b;[Y.3YhKjqW7 }X#/9?nLo%+2zY0C,];;G*M{J۪S[}h~:*{=?hXb9CA5(1=4p$@#,;8,(aNZ8Wҳk usN]1^Ȭy5ZSfDg++޶{Ж;\q1 |]d5Mjy! > qfB᪎:8#L} &CLɨS8Y:g]U&|ȗ1KI溔)'W: /#Ͷ1$?sà6unnx?fe84BQ0ɀ!ն#r710m_tҥ޵Ҭ5⍍ ~kg=LiTޒ+@Z%Rޡz!U.i>8R+/\jmٵ5 #mn4&<ׂm6av,a7E l]̫zMfjY0LMA\@]*z}%M7 TuR͉g@H@;OrH3K ыƁasYDYsѡdaʓYM4%AowTX oN|gà /x>3h5"RV רT>w0ze~n<؊Y%H. gFЌzR'CaH_쾃vUC`pк#.FgXkOQ'6XqLy,JK:a(p_=o? `Jr5yrMiY]qG7p~5̒\mΨ#YS.|יqȱZ^a/-rE3&."WAퟦZI}kHhjhs|AV=)V^OG_j*3, 0=gճO2˷LBjUDp6߭}N絒A gR< ^afy]ڮ}0KˉфWlY2m) oS6a|,*RՒH;Mg!情"a|ѳLߘ1)23o^~0V΍CwPE&(c 1A:DrJwtxC|H Vc{*RgF\N~8 `+xu.]<5:RB> HAͼxzْ5l0]oe;v {Ef ԛJ2"9P\u$~L>e"4&:`DEq(YނPZ;|lTEXWR.8%77߾1}ScH4{`zt-KVzo0wn!򣅍I\Jyû;Z{ISn]'3ik.LA"y10{Y fZ b536&lR|QD4څ̪?}bWp v /d y_mο|t[EܙG^P*]4f!n??B,s?qB1zCa;If UaֹӊT}!5-;^S!2Q@$pHE4P0hfE!2m6W>û=^T_XZNJ"n ɜJ uT,6P;VҥI9KwȂ zN*fyG#-9f}_$mgMpKm1V =Jbe-p%7 lƯNs#0|oưH}%K CW2c#* .5V=}iUхA:eSJΩxVG(?m c.\ 3 1XJ4_`\3&92)jC}NuZ/:3K,t%N1dL|&V{̨6̐jN17ww5.X[_37 n >D2܉EżºfM6غbZ]@6;|0^5n1;| 6Rl|8,Me~dU>OM mX;OybwvLR)UGV|ŝdIg-N|~{^re_ac iQXb3j$JCũfQ%) 5N]\bbB N렖R"S} ՞3|٧YWZv=,6~=waEJNFxֆܠǹگfUۦoy.РcYN3?0^%;la\9Pe,VWZT۰yȠJZ/K|~dά*` |t}b\T2L5{*+NR+8MXT9Bއ3pW(~:l ! S'¾" QhNЃdL̄3 3lZmV/>id؏\9;{ꋭ94c>ߏyx ؇D6f ATD. |b7y`S,efS͹h%+ Y b/LO=F?i>!1B U@`D`F~oC{bXl 0xA:$ { ,k-V͇0f!h,4   Any.ʕ*)>YTA52dӦ`sهwEt/'cܛhxe~J ͞Jg?X,,wW-48͗x]w ?jt݄ xFvDqD BN'/&f9<)o[6c1!4=';_ y:=1@ >5SCLW0@z,,֤HTe]@3 Fѷ>S1Zqg3 ~-cn|}-ct_le> kV'P<)}pB'Мѭ;f3\Ac!X> q2\߭.4Ɵ)̜c1AGۚAɃB.nU|gt#2SI#34*ű_y.b!pF9&l힤:`[O ~2Ƅ,c%3s}6N7q䌩ܜ/%ѓ,bhjzzzz8kI-]=ry33+l.\r~ku:t{S d>ug϶2 Ϲ8Jl=OR]B+?ɣmtTK,A1ӂobtd s7z}/leC [`+Zzdmќ 0 y ^m*T{U Z1,#ҾY21 ϰK] Xқd07F!m'OuXچqȲÄEN0>ֻsG'; vmßWEbLH&gy@[olN(ɔ3}힅(`Jko}nN޽obDTtfdt|v`"A)P* (Q)%O|V(*BHDB% J DE*nERAQ(Dn΂lf{f}A@wf׵`oi}6ʭ>ݎӣbtJUDU"E j"  D!ѽkl4nOf@hN;pA@Pw(@bsvmݡZ4P@)T)_JIwy4/5"Hh&ѓ! `L!L&M2L#L Ʉ40M4i LH4 M?IFL bbѓ T)4jjcU?? {ISƍM=OISѵOjy? L*g5<"a?SmTI i@440LCѡIdѥ= CSLɔ M&@i44jlz jzʂMI 3SC!=& O)44Ѵ2144 yF 4 ihzFF lP2z@dT F'Fxz~ORz&LP=Cj QjzMhfHڀh4hPh@hbCA4ddL4ST&iIzS4&К5=Ojz)e<ԟ4S#jhSaOe*<56ښzj=J,$ AC@bpER Zkae s8M՗ȷqiypG/5bR i idXkZɪ~y,!sC$=a`+^:$yS>wtx[\#gɳm2FL_(Ma P"HJ0h (fT!i8]AB'l՜̫~93 rfn/¼C-ĿFi͆0\q*Ȍ*J֖R12tod,zF'm5m{Hf], 1gnͮis)]X{'|l7ijᣉ;^%$؄k W8jN)^9e dzqG0כ΅*rd`{lysz\}uo$""`+?jq y 2jC ,Q*HZ  KԢh2јr5Z^L2=\1UhV2҆䓈'-uCB:mFmc<3P9yNRRy}NI>KB(B)xd;7F2"F dn,$2oSlWc2`,QADO*[.)$3sCGʀ[`͌v5E`mg9{$bz%P OI-7n_:'>ot1>qѢ0C",vQ,㝛cԢ(t"LDdFsdҬy Cٲl $6B2B0X'Y),R 3<_y ui%sbf'yO ˃OYWCvX-. <54P48<8K!v%`sU6%s8gXY*ZF1jKN%4rvMznd%b&5䜻Ft\W&v' d#F: }sON8.N$EȭTg,vd*DaLMuSD= TFjxDFe9G rt6^{ugKogO1t:o|IcKP"xN8N@C2-MzNGfCӮxbV8׎r10FL2fXY0 x ( Vj40@ (ZMdXSȿ Ѥ`U$:'<}rY^ࡸ~KbwtL^] &5snj5>1i&tIE3H<n C+ɓUژRh~,^fsRJEF8.(GET8DjshTqitg )benʙ^.g7LoOmOsΧ&Ci=Jtg{9Po+_1Z~Z#N!M`ζ +.Я|,&C%"HOʋ_L ڨxs(Ew"nx`7.&Y F&O1jV,3}$3RA9T,@9<@ ݎ((Ue+V,fi!$8v0@8@<O*[^|D׹询{:?woМB q%5fgi&67296f x"&aoK[C8 0JʨcG/.kod2)pX(dBranX u_i!ZdYIIgp\fQFى5Layʾ-ўlsve1XȈcC1X(#̪ɠ(c*9#(笐JӪȥO?6䦊QKk4اE-C&3Nj~2!(?7skXCH) ~'d8 cwyj?'0,ʅ$gLґg4YLa%L`S2*~Gpo f,"mץHɵL.tN+iSP;Wa KA HlÂ`w K"V KE30UV1,L12T\ÎnL.L_Ʀ8.]5դccR ]Ag`q`110acbddEtbI[ad2F(L?sőJ*ʌ F,,01,V3)aabɌ5jr#B!I>u%\HIIBpzg'v/I;''RWrT$ޥIh(\4b jf*}[_is|oBLS ,b,csFXU*dMUIG1?Z8W_(~V <` #* + xn~UelzPa@{ B ?`KIɪ?#Ѷ$(^Ojf8Nm;y7ix^|_s}NCzŐR((#P"(!3fJ,Aޠ@)$:P$e(a 2)jЂ ,*Q$n,P$D$F@@XUX,Lf1,ȌbaSbŊU0N'KlvU9!2=F9?@%%XH'eF==Q>Fŋ)_MabC/Ѱe>eFFL ^m3MyONxϋF|u.#RÏ $ H.!#ug`fE97:A޼'0a ̪Le`X @"D #%0j~W9vI?}ӰX;)j!W !y @>’Fw:ǯ{R]/H2VP"LיzxY] a tJ N,a%Q9*؉ i:`,̿i``Կw7\X/`Z-y)ZZ-ad,,-jł6. 8XXnX8ՋdX.*{[#.bش-2#TԱbłXZ, Ql \[R0/#r-2XFB%XXXFŢjXXO:ԍ9\,XaGSKCg-F-FMSu-%I,MN 8XU1d`1`Ņɓj,ZXXi`djSadXi`ibťiijQ K#,,Xih1Z2bhɡZUaHa,XXLZZejd҆ ubeiXr[ rżI&IдSqa#EȒ؍ I/ȉL& UCDmU,* ʪ_-VŽ!X;- FFRZ0ŕŅɊVL`d, 0ܱJqh!e+DbtӁanjsL+V.he9[IL%0lF,)%bɓ&L2L2dS),%5D Z-*b%T|+%ı2dɓ&La,UTSbF̐&LOLGjP6MV2!Ua`)8;M _l^G嗌^Z#b(u unzc iiuȸ3 sUĹbdWe'eSL;e.xK 59/vJ1z T@KԆT>ѺǪx 0~.'c++3y֋nNZL+]k`<&oܴt|ٻ`[D0ef@3=KrxȠ EWxn݆#3yIVඊhQ2fR#ks DUIsʴ 47Et>ߣ36鮏.rǣ}&9߷I;e~t]l' H52pt0v~c*soMUrzh䯸*d#7L+- gxfWk-]=j0v$H( X,%R2A%$8"d("SMA 0bULL%-c&Y5,LƦL0{-ߵigq|$N  !;y «{DNU\zuEMJǭuiBamtX,-hL+/?SA # Y"c"8h<0i7m-$[im_7+]ǷcX}P~,TY#uZ?GGf_}e;(9A-DRBP0X^ݬy fw?#(u?~ 0T?oIAܙyvWd<$Є`Z.rN^0+102j[IuЯkx>9.ς$Gc;Lx,3P)JDНAY00$WqSm€%$1`eR:{r.eɚ1 !M@9@yL8] }c6L0LMv9LUjVz6 ΋\lQ{LN{:[|Nt=&KY9jkIbU0n<ާˏ|ͭM6!65y $#Gƀgϓ[5vg܏FؓO &pp" h`1nRapBnH[m&n_քs>J:8Tۓɤ83VmB=-BōG3WwQ2_&=WM M.`> ]S< KB  M<G`8J}MsEoDBp}w"!6RQp=Iy@ })oXkSdOoezLRB`p Z?.판0i'ԫUTK.pA1sI}?M;HշhZcf\87M{7TbȪ IZC֛0&iRߔO~l y=FpUJ8@r}?T_{Cs㙲*J{R|$"UVr7,J,X, ]6h*V *QXR*XX/}Y9G')Dw&1X)P*5X%Z@G?0BډZAZ- u,&)YC r4LLKܰ[#ﾡĐ΅H[tΠb~jG~2)-)bXF[ŪCnGxWGLu5 zrK U'x.e_/Hs\9Hi^R\94Kw1j6ls!`b( sY2 r~#8#wz L/eq,V#a Tɓ%dXbŋ,,Z 4abŋ ,M-iVBҖa`#BдIд4-Hґp.SuR:"nIE6FQ-EZ-#HhZ-bҭF!E\Rv&GEihZZZ--M$hZFH4R#tX-BhZ-L,,FU`Z- DhUbŤijCE-,X-BŕXhZF!b2XU£@Jҭ--,iVhZF# "UZ*i#&,,F$XX!4,$ab1&4Ib2XZ-ɉ&+ V,w_r- V R=neX &P Szˤ'Mbŋ Q.#!tސ|5r.qmqX!SmT)JҚ/I.W3Sɩ$<\CbW--K'''''+Kü9KIzA=+s+^ep] iiw-,F.k+W 8' ZKVb< $`_ Iн2s*tCro:m<ܷ̽.w%-+Z#̱Nd4[ ?>Goq~Gb/{ (s $#ePвTab|+.a;퍦ɳ up-- %257nsv%Z8UnZSwjq88j^)Қ+1Z9KTt<ؼȑqiz.&Ϛh>.:[x)zE,.zfvzx^, .i.XļȻt+suo^g \ؼO3vn[TѪ'>({ڞRzit%MQ)$Su\+KSƼ^y輆ceNb|lZG}nf#]-'@:a.rHqV>is1U1;:dFE3;︎#######%b&ﻋltb%鋰.:-av[+\'1s$Xy B看Be&Զ/1{yη"H.b犎B,0[$p#B\][J]%la̮/a|"IwĮ@s: :ͧro7 iɕzBX_%> abğmai|b e&,XX&,GlӗZFsJ\ihXX.ep[--KܴI̎+Ņ丮+%θ,X--.EKw󅅅W&Źy$n9] ދ@z{z\I=)zDxȴ/L/vQì#*'м|w$ض/<]bѢ2F -KI0\ E`LjLp+>1e(jdz iabyG/r\yKxMmw^`z_?M.Xv422ܬbeP~*!:̡5`oV0b{w-Cf0(>p$ 0y]h,P&\}g8SbAaĐ*OWtbU~JS ]%} ؼN/X̛~{ss77=Or{j&Eba7__~7O QkT4WtWd6qs ޟ[Α2^QQWY-'Jtid7YlwVSNѥK蘲jzWb]:e1q]ke;dyU1uZ[8_a8KE~ip[/[V'HO94O%E,X-'zSbi6O_T]k·5'Ǚ75598N&L'> :.v;haŧ3O~.쥡h\hҏ0)M ؟ *zk[.. q] l]kKKu,Fl]Ke_R?_b/XB/47//fNiZVIIi0^-KKEZZZ4ZQhQjihw_0u22 ,,XXabд\}M̍-,Y2d2jjjdɓ&L2dɆL0ѣK,Xa're/˘$4+޵2L6#E]#Qj4j5-UjXLMIZ+E)l˒0ңaMUWFd1'Jؒ-,,L&&r&KibXj5FQj5FRj|e, -rY}}8Ȱd8*1`i9E- & `$BBM%( y3i~uUu$xr(\O3I$|q /:6 aa2FW.'jOm_Em^ @,@RUWhZǀ }}iWٿU{Y~~|_,ԉ&DJ?rVB|SIt=X] L O_XUFF/[@_^nNy'#Xk-rĕBCa p8woZ62p`r5%O# Q  H@ @wZ8 #{G $A;G7̤sȥx L̾B,'/*zŋ/Ud9$Kft#``/bĠ4&VL2~)lXa&,E KKE,Xbɓ&L2qM0 ,ZjbцS/4SfqMJt7Rjl 0 0 1d暦ťıhh-~tU_:|&XX.qft_[/?_ϑbbBI:E`[#S*اϧ!nJ`*m"t򖋿lLxIQ]x<[]-E_*>?Ew<=䚎rV<-t7MyɥW Lz?Y A1bŋE*a E[[K2V -,ZZ55?jNnabŅ LFG4j4jbhiqs.Kw%ɕ.%K$`X_5ڭO"G!hKDaanHG:E%HZ2).ňpFZ_]5NǙhѩTOIE}dKfV;]gh,]v+!sxWJ>/H\4Y*zz̗O9Q7n6ha٣q74n0lܱml̓Τʲ.s`tcg&FXSgDZmp8Ӹ^j2d$R{%I } Eyʪд]vq4kaܶ-K=;KWDqyȶ/{ X,^JK&9$(_"f/9svCs X fdf+H9}'Nb{O'i8&&&&I^ ̟=)8*[wuh'>^^ /0 ]bjI㹝EyNta8*U0&K )XZ(YB>YX> ꋁiNxW[ji|5ʹ.En[KS'Yn};Nfs7:NSSq58gYs2dMNvS9Nv5O9x:Sv̛S:δ8'juwfSLL:MLښg3;LNt2ilbX&bⰰɹdjw7L2tk껬y.Wh-.NWYnsKMyMNp*K&LX2EoVuOdq&*TjaNˢѺ&ʦa*h⩓yMō1gQpkCC[w 4LF L+ , 6Ve!O+ li: (I) $ Ʋs_(R !dxHd_K w6]/ѓ3N}YԔ9 `vlB!!l/-!ann >?#ux,5uYR_I\@y$ Ύ HB{~O.gB!?w޾G @ xb8xne{-UT, ƳOjJy ~1~^p\(aU1eLE:-\LE_\ brIn[Pd#Kir[w5IYdɣT\Ҿ?/Qaa`b.\N%\1p-E%̩=8,XbŒbbbbİL7, ,Y -PhM/[.2Xa$aA*ɒœ L0 0 0 X0Xbdœ+$Ł+)VRaaa,X)2ċ]elʰi?bTZ^1>aq--,\}h'5,8@ dV+ZO)n* }1Iy,1mp|m{=iZXbŋ Xc$bŌF,X2X?A## X^u".#W(/ 靦yt|Innd2j{d7:γtfs;LIw&Yq8'idd;әv'3sd9Ydɓdtiq;Ӭ:γTnns:N󼬜Ӽ2u)2wu2nv2γs7;Ng35:&N2jdt;N:MNӉ;t;'9gywywy&N;Ns9JvS59f9N&wMivϋ.sOT7>4r`{Glr]˹p^}d;V v/P\]|".B#S·.q/3ԽkJֻlũ^#n8v=cݎ烪껯TD*=T{"XX]EZZڞLLT=g{|E=eM--L^njs:~nnz'z'yg5u&b/ [rGIB@A6=U@(1$bnwV0ng'ڝ7c=.%/w녏:Gэ_Cq5H7I^B0:Io|]Y@ DXuG>:0_jr__{&@00`%kڌE >g{S^Wv^ uѠ,6O?jzdy.r &E>W'%}B#]%.N?aq.ԧ0- fgp "OW;;a/M7k4>vdvUs&0/xa˒;E/i#[0Z W.M1ξ Pk 9g;lx\ JFu8<vFU|#?sAO88 zmY7Zu#P9GĿZb,jEW5fO#\| \a}'Cso-4`aMψ,'?`#ط_N\,,Ii>}W">ZQb-~"f 2sc?\6O}w;_TrI* ԵFɆ,S!JiXXV4Zu*ѳwVX XY0XMQS IZ#&LUSdi,XXbe50 Y,#߮Ҵ,\Ke+suZ75EZ]FK撬s!b1aibŋIɼibHlbm6hXb\!ɋ)dI8EdEx"ҷLJɄ9tW_LNg'uYu2s7;X,Y,YUbFU &*>.>y)s撮M š, ʼn ,$;)ʼnbфibKe 4bŋߓ KF-"bňX e2wdje/UMaҺVnZZ\s'TgYe);Ol8w)d2nOpZ71rned1.)M&0b–S)&Qvq<)4IeS db °#aJ~?oW.*Ʌ,X M&&&w| -e XbdIJ&L12a&UbXdddbņ ɓ&LL"aD0l,, &̙ &"^5J7ksj(xPjЙ \?F(0P"teH^9((1J"(d=ꚃK+"jbX%ŋ$b%S5 KR22L9ZZFea&յi\#,\ --eKKubdևB,YWˁiG ]${O}qhϋ^& 2^.I]Jˉɓ&Or9Y:N%bũj{OwwCd+b^O,I$؄ޣZc:[OnztL||OCԀW&Aաz ,ZXb掇N'IgMNS)Γ5>,yuq6]0t\ʯLr/.$z2s<懜󛩪znu5:%茏\zӴ:%捦2x[K]N;[eN eriw6(/Wn9·jFYa 'P{n Eˍn^ntkuq\E̸.bq\p\% At><[ҪlPK}wa8&e'2{fs.j7/d&wE-MMSSKI<'$|J@wg! .l%w9#F!* WFq)g(s+.aZqA`1{n{LI<8c!7$PD -/X[^}:\W2s:ΔvφnuM$_L,Ua_iૣb]Dŋ2{&#s9=3jjMOK|P (Ⱦw+NK;]7n93x箋 Fۏvwo@00mV m[+ ,. /*ฯV:⹗h'3uiuvB>VI,Jt%nZ<3s짙iaI}S!M:}m@Wx?Orнx֖u.ssS)N&s:M. = q\ ެ-˘^?C_Ed2nODɺ\UxA;N&L955OM=+ss&Zqͻ}j mޘ[N!25^k Cw5,~\s}+yHHIr`_/ROQ#*Dl.PY<T&BNX[U0GGs$l*G$rG12Iu*d>u}uHL 9p Va@HI$0-m6Vx-ֶ$x? /qW}/Qi7e`_JRÜ{Պ/X nXʤ_v-bɕKeҾ|ܰH?|ZTyF,*1e*rbʼn}dÓl?#M,I[a ,/eVFq.DaK` &8N[b2L,!er#J-!7ȰT]X_EBbATOc].98X"mza5&P).突G e5v~Z?uaiꕔUͿS]A#] z|`v|~EA}׭h$.]<6G(KeH2:a郷3^qC/hh24M!N8q2K^qC2P upǐku.qX]"8V.ޫmY tތ7y?Uǝ]My>z›1?Ny"}tSB:Sc3!/ؑ=PZJ1" (Og)aZB-I "=wkElI~ߊ]&4=p9z#_ #zz0M3vNkVyVfFTw}'υ&Ci*~UP{N`c)q {>6"~wGޚ9c iT|-\t+LC)Sn&o4dbKEGY" /MxXV~،Qf%R*XBN^rVߙ:D|Ӌޫg*C!sQ\L 8˛vIW/oU9_4굝#7"z0+ρ'˺8d<0òU*q,eE:"U1}g#$)~;dVufCF1~)/zDmI1˖ta5Og91+ $mksٽǞC?wYO"qe4G溷m3]/e3̇802h5 dGr]\Lbb q Bp1GI,sve=+3c>)Cm28?Ys9S\9i8JU0Jr+5VA,z~HhSߞ Fݤ<-/ ֭աJ 0G+ed4~OykZ87 fz AYSb0u'F:~ᆫ*8BeD+\6ca9 i ?'E<5q[2C~J.yw |GB=ɐ皷kWow{@cgi8L_"׏gjM~ U^M{ xCRACqW1{R&ro9A!8Y RE}=y8嘊*9pF_K$Fϻ|Pۃ[W.X0Z}qY_-?m?>8L81{JQ@H;Hߚ{+3 Y_hq,!;@j!X^Ud~#sNq??>"dH:CccK䛕ahLjv$ZIҰF+Ș,e%~/_,[' 2- R*E?NW랓ѺTqWo$.IҦ$y`%w~g/ʛٱVŵGűFŔMr4%M%8 N S /~gKmB\!`pEٗ` }y ص/v$-r?/$~Q~t?n/]18BKik`Bi[`ѣDzEywHD{Y| 6=݂AX 1]Dm(ڃꯨae ,<9Xu^OXsYue6uz=maV$sK=w- 0Da"0^.{EgH$A0p0` ` \0Te+Qz(6ȣ $ N*[|rNQc:!?k#]_! + [8/?+lq \?P+_ATA dХf/6$Hۨ{Ō9#%H'~/[0Z HVX'`{d@ Պ!:!E`L uΠX^.B{آB}h zzggcatcć%?߷ium'@Ym}$}2$5 r:`0dAÄ́#p#HÆt!"!䰽aԤ|4s>^Xm_ZIH.sEybK8/U_b=E>fqޗ?>*GO@^ A9Kh$nZ!jo41HYgn^^ -pchrX\N"b ,{Q.*tH6T"v悼޳]ڷI|횣VhLv/(.s_ezĀAG uTuK_R~YB$"NV@ yq_A{ fo㵡QQnOأo O^0>ls hu!ɈitʳŵaS.*k5d!J%0N`_WrtDd!^Bm2_7`u.Ջ^Elxѥ-1hp[Q&YdVSS'3/Ww:㲚,[XbܷH ˆT]yc~g{s;9xY[V+8*pT}(K [yA a`E .h8 u5mhNSvJs3=wV[R&T  T[失bn[,-IbźnX[ŋuqMI'ٔ⚓(\Kb!. PD3 迏iyvnƠz<~Q;xťaxe]+Jr>dq/)lѣꮪ%aaw/7,cLO 4ؐ l0+bc@i D64~/^uGQy~0,"` JG?T,  ªhXb0 DBA}pbrŖϡÙj{cz5=vt{בtP_+5EкR]K9!۟B ~>ڬYO2)b1M4iMia$~xrU82P9 6R?+ ?+}@  O w|sw(y|=5[=%3,ς+%sZ/s]wgCAUq6[]3d,̼8*o3Ը>%}vjF ڎ2 I"g9_+ \RhKK/6iF--%!qL z Dsr,ne낸qe[rط,&+&Bnm&ʼn:NSSgL'I)SW@)7Mkb&i6M-dԵ2d)ņ,1hå1MN'SSqÅdɩ jزLN%j-iVt+4H\l8LqnwŪ*ɂ-SRdie& KTnbYF%dbY ´ahW4a7n\N-4Y~qXL,YY1,221,Qa LC(ɉe0ɆLK&FLK!dIJd&%#&FF%2bYL2aɑ##e1,L2aɑ##ʝKKT5L54d5MS\LS&LY0deXbeʜDO9R?딎ZDxS Y[E?31cG4rFWid+ufLѵ,1lܰٵimlԶnXn?vKïr.YaqwIGD *K{=S̪ł!h,(jRYX,,)N%t)taabC䒎jMBBbKS.ރxrHas ^e #2d$Qhʦ *`Y nFVyĶN1Vd&&Ua1P]KaltM.tr.bE]%5.pI#v]_GEl.CyC.B)4N*,J`\Rm-qd4.8'.\ Ead]Ey!]mH^2bŒd0do/G0Ԙ*Z_q~s 'B.Ԣk  ޹t++ޞz''.Sώ=GNf֓&O׃'Yjv特x't]cTd4yLͭ'iyO)6YxywΚsWJزaul.<ܡg)d2ed2edܹx &yxe(]%=K*B/Hىӂ9be]b/d< )#' nXbY712dɓSuqVIYAqj11z KdemLMujbɹɩ2[Y1d2eKv[sdlZehciۭź6h Iu6G4e1rbҲX57-L\qMSMKKMͮ&LL,6bM&Q Zq6p\,[L0nq2LիV.'ź6h IuV剅N #^A5JvTc-u͐beLLL'LyҡnEu9QZt =Acf-W 8A9hZyjNx '4S#uƑdʑ6:B{$.$qK unQp.aaatq. uZSEY#q%QBH@;ejq>D,39@r"sv޼;[ ~ x穆z<*u0Vfɧ%m1@8qJ lɍb#BV,!,ܤ}l!5]=U& eY2LLLLLOE Ą< lk6ΈH\:`[\EڜX$#Acj>i)~|]cta<}YϾ׭ޯ&qUQ@dNA$P+دh39+1X+^s 4^cFS[85h*N:e:]mNW6-V֥K+N.ire5 +%͹t9\ض9[Z-,\EPGtAq.BQsZN5X } Wʼﱱg{wuw}+F6{I+f}pL20Y%0bbLFUĬP,# xIwL/Ydض,bԏʽ?O&&Ib`]Id\rQ^i?d!z9=f):O'bG_e/4\$K&#rz/UWĻB~:4ܻܶ6}Ony'Gՠw/1wJw*bF}G/v2}۹.u D^jηZXbbw9/Y;Kd92.#1ij5(ȶI 4\d7L&npl_D*Kd܃Df?I%UxN\vJNu!GS*>w#'8U]bT=K^dQX|FT0VW5jQ9^/wF.}|GZqaá^=uz>*9T 2!MxcLEQoݠ7S!E_+_>6ݥ8? rDb0grŸ7߅qr|.,rss&{3 7\J]l2pAh# "=IȎrȍ۔i[J ⑩ rԸi[h-! nwWYunQ̲x-P\ZL[B3Y!:Iqt~{*_,tȏnziHR! $/5|棖쬩>$_2!z)\N-MZN+R)E\=at,) #t9UsBۃ, |Z#rݕ v@GHJr^7?n-;MV-ٳBF744,9"YI97IXfLřaiJ/E8l ,KL0 %I9u:EWOh/*yCK6RilBaJ91&k&жm)SSBx[֜G1}ff3WǩJ[;8HO Oc=Fƽ@ڜ )L+bŵR]؊16,`9 Qt,%bW&=Z?]ftfl7)zƋTtEĚM$UMP-ԦI'Oqv;Vx8_]Rs!a Blʏ^lW~%zș0,}>YBJꐄ=4 )ʀ͈$Ծ:i]=ab7GçOߚKa|bJؽqaCw7-g-V nIpNayjfL 5jZ-FZ0- AZi4+PjY)lnww$k>пLf~=P{{`>ЂP! /cFg@UcYIAYEAFaۜTȸ/G$UTi_/% BLG xY?hɽ`U]_E"!v>{/P\v# 辑|=F;ٱgW/Vԓ}6j17]O9LcBx:$u9$y+x0 ef@0 BN;F}}6FOU '@L~Y=!#xrH@%|UsAWLNW8HE?[G\Vc¥+֛RҤ|G~@@R"F qDqu!Hu_T5î)ys &s uU[YZ$'~%&Ri[ R0-7[OnhxQHI%yI}QK0>‰ʯȰé\2UtCj9Ѵ?Azm˸z?Lإӊ Q ~OB,RU.k O-n-C]IwNM$^E ynu%H byy`M GFJD,#20ɼY'?bFƣzgA?a]2?b.光XXL-F*v*adw*`%w%Xyaptܨ.h]ibMBR/Ao`^ߩ:-e& $"*V܈P@=!@)]Xя G~'$-])~2ҝuCC/~f(_Z_Y"DpU]ާyHOYG8_6M/[-hnN  N}$Q.)܍Gd;%m8(>\.RI:Uv5v;Trӳ)Dcɱ~.&,,ܴ_ _[O\ˁbd52q79MUdaםGqb%cU{}Y `PDzb Pzu\U1^;"̨¦&L0G Ci&Qʗ) "VE]V!aa(+k-,,SJ)4~/Z:K')DsZ&9jnWAn,5n.NnA౮yht 2a_="! p s*DA^JJ%SIҫb0tq9ľEm l#JBʄލU-Xb*0d1,|U58e'#qrO>. Pp aZxzhI{;A) ĆFU-ER1 eJhMl԰aG2R>/JpX/yJU'X+ Q+.h0)MlҦS D¶hqeD,#*CҚ_``Y*9]4EarW=BALFTF# {_EΤT<BU$'9abt&JWv%9cR< .HUTw!S0wM]vlXjDRdn.6WqVd&0,##*%3$LF EToRK_]I< ,[طYX+ &䮴mZZ7.̔1М<l? Xb Or_LNo#o0V ۢ&IZS+-͞?"sa\K<4BQ @KUYiطEb8XgXRi1X+M<īѺk*U5K"e u894v ~rRMw!'L2]n4[<x +#U*p`Lw/]2.ew:7LxॉhZbZ#F"©X,.F$h& /w/6YQ;Oi /=JcʏBNgY#dO9QG^ا.cGK X+-N6.K:oTE IO{+b1KBp 1Wq2EH(AM'ZWH,` %fBL+XMn7.%qKu?]]{˼[&f[B, SM\[Žj,FDj/)>y J_v-]~OwTP}G;xG%Rad糭;ԥwry 1UtIyd /C.z:KNNaSF*<iUk/pbx$~i]wbKKE=b*'zĶ5,R2_1+w;S )X P-r[xalX VP~UT>;ߤQvߦR;H_ B)}E;TR bьW);}WTWay@y] i#'_qy^'IUUݿ][߅tpB,G/|Z,# NIс3sJxXsχn1ULTWbGIɹqK&3U%fzF*L-? yp#2Ev)8R.%42]c `F*-Zz2V& \GvH?9iOW e } >Z]*TO YGB4"al[U|ĸM˄, FM[W*t ݽ=}yGZRdsOBytw<\=pۦ\9ezk%܌X_bmI|:#!G=BY:!h ً^%V'Ibŋ 0*wH(UxKEy~п^}|tb4][ E# rд]EZ.)7S։,Fzv jW_ bرYTo;{8X >[asJEn!,$ mWQyW]sW'1 D}"*s+*neS` CpfNݻȡzCҏXt^C8#[Ŷs~]rot[994 *KZ0 ϼO: 6M5*0-ӽ&eWE\ e rtBd`du s!NދeBĹ'e]T5&Ah~<\S ' UM"U&J2dT/SWOv?*_TFiQ4TضHi#.l5%wӃ-MRoߊ LĦlAl-djaV$eb0Y̐b}styt$jT$tI*7d=DfꗐXZ}o9]oeU RILJTe(,ۘ^~t%>Rr51eVX2b2|zM(nZzܛ6hL0L6M--L_6pM&M"|kTUȺYHlZZZ,yHHTWZ%v;жRpHj88 j2%Hz&&톔7d.ԯK^S©˔^T00TXXYI+] & $}Zp /THa'ǮׅTwCfz ̪8rx1S $c/YERl\Xgb9GENIF:@ywW[~ǣmeIRLNHXw@(| IZ` د8}7{tM\Jʸ*qt' @ *ɐ=.]f먱ոz!, >. zؾ/S*$ XG|Fo m\=,@JcArO2$z|.4G~@B@!`N7g5~U&Jd^w&Z0y :;|E $ %ŤIJ]M .0_^LnPrzo۴1KiAR?{NEB/ )S 8? :4&e'1AMȀ5GK~Pdzd^~gҜ]` +@G2Ѩ# 206- Q~&R7pq0Xuq3oF}˧GZ 2I!bX#ĆUTPp@z[_q{a~!Z+hXbUaE?ڊn}LcY=? 4sKCPn!#<M#ksځ /9>.30#.;λs(v:wÈXԋ{_hc/< IX,-Q)bɓ)! LU)EYőXb%XLL2bV,ޮK ?}G*XJܶ}z% 1bœɕX&"x%` `!@$QX櫥/+Xp12 W@C{z;"oX{>?[IcX,`q2*Up`枾?o񞊏Z܂Ĩ/G fov=le,rr[3aC*4EJ)UjONu a2-鼧>`o20̓(؀v S%h<χt W8I\OQE;eVv}aMew.P 5 R&VVo'1$Ȉ)c,Dgm C<$ψhgX= )90c5L[ڹOg^.>L\6+@=F\`j 7<4oRKe,z@sW1i} Qxxz> '#q#erB9߻1t6|M@!@12`H <*g= ϲv&s )y 1I2צs϶"TB I':6 $Etq(AoZꊔupxH P(bFUGq?:Z]9 GFT:N29Hԁ/6о\mL 4a/ay)'Dr059Ʀ>Hj]h1&e=CQzl 怈 &W[gPqͳλyBS%0biH2\Я~TqsJ 'L\[k-b!f$xCH.hX%V%q>RC|0"@p;7"  %a[}j|KOpՇl.3s߼aePvڨ*L'r K,Pp̕&ܭ!OZM3x0czrZ֦LBMdM:9uo#FMVC>vth|p8uo~HƯсG$2%ЙkeIGq;*JM='ެ|2}K%0ރwU YX(1l]pC)GN6'k`p}rK蓝6տ?˵])v`X !Tul&.zmK"5J`쾠}0.O"  Sm?сS2zS.4l3ބ*oF; Xz*^b'\yúp'PO-op;۫7 j-qCf[Up(@_TFa0`ALkC  +!s OY/' g`oeޭ6-II^*7Hh-c>芾O  ڇr<6ubi A+u0] {:yZ)Q+>@"Svͽt&Wx񹍵[ c,U. ˘Qb( 7@{x7 J4Z.?>Ŭ2O4nq*}8xh{iƢ.~dw]I!VL* t@e +A4v~,?-l}H^S3jp;FsRU6ƻ,=6A]7Jdf[}j&zxa8|Gy{( 5c KBaZf#D$Z' xd(1_4=[󻼜 KvdWf e@}4[Ζ_%"~C"ґXs>_Zq*|L5馆|3h;OvdsHZ(?ɺtNy"Yu0;քʫk߹TGq}łor{`d]RƊ"a[4iz{Z <ތ.3;F͜9";~7UOܖatT鳚{y/"0}"c2թvwe3P05n{{`ߒ<Ȁ&5%z׃<|x>G"nxxsLg ǟ*Y|NדkꉆHQ+Pԣs0/`m.!`?YxOxǛ>LUl>IR=;y\w:rwk_ Hy~֖]F Vӳ!1bïw)㷷~Lٝ<I9y PM~xBy۴@1q ^mǓAC'=mVGO`h "=+$m\S\ TMH}Tgs^e,uc2ixr' v \fEdt{\ 9m 4{шIW\xGů>' ozX%J!*ru#xSt|\?5)5 xEIUulĥ (|IWbs9z3 ? so\a;-GQz[ p2:%wͫliRyt#lg͡%f*' i}BΣZEC QSG02HWrL3z4pKg-|qPs҃Prp%_Zs*PQ3=:>^p"[KINﴽCо_akU9{^=ߥqWPjWN=p'Ӣ|幯a19ҝ)+tL<0%ePH{K7O/.$$Ǜuc73?ld vLTYaN?k uֹ%C it"cH\Ζ(&C:p6e//7Yx,gO$ykK{W0]"d Ἐ:" p iLJVYz3"ӿKWxA;T"p #FQ5 GkFDz?\#p~#.F A}h$ CUܼ|p\szkZW N /jC,b<ysv-4f??٥ˢUm{kFfQ۩T/ 2xzhJ{N0p~pWZ2xUpEĖb%/KR`^IY*vyNa%bk$wI}c^IL󏯧 ZjB0ACܕK|!1D]/rvO%u1-spuy3n;ie(KEDYc((RЕSlHbW.p:*Kd3_o[Xqd99$78x! mf6S#*N? HmpoE&x&[PDL%KPH-[Y9v_z8#+ºGX! -Շ?Q$8@$"F 3HGyÝU irf=zJcOTxN \#! x# 7pȖˣUraz]Uc6Ԍ# I$ ),] ԡ 9}J]:>L_ /EQw'bɠxX@CA=z뷪e Cbm,}7;M{hk/_ 6|EF c&5By|Gd06HW:ĬDBT t?t8q0_RԋT仒cV ɹѭ3LٷbFc'cK b0ƋN‰@$^mqcNM%J8nSrGYp'^s+04gs?xt4 VdLMe>v=[n(?>IyzmA{#͂ D f\ӕSDWydQv0ۅe=}m)Ϟ vR",NMQu`.(i뢵ʕKiN_F>קG `c]a| XKè! L$ѷuq~+dbJ@/S@ӣ-0utQn&L G`v *#[իrE4X}rCIsO@1&. U2/t7oB膣8-3.td.!WP}9q>_w\yx6zSfuzM$ ;fzmA={ۤמ&PRvKͩyCM3fI  ˷ğ7Ж^F_ )=BaGOD;`'Ĩe] x%\*sp)}($㯱_>38#f4OLYwˌ8sJwxwa mt.m-٧v진ESBt 7~61?I i2XJF(lO:G^0'J?xYV\"L#R-X0 -rQԷFeiF[G3)^yD~R͏:ouAUFW퉜ƚ\N*􈘒mQiڣG<݄Yw}[OJDM)L,iATQ[1dzwd0LC~2q,;yL!00+$vcC2&0&TyGԒYވIv^Q {oĩh)lyîȢ0[\Ibq$+zXHdI鍤.{JUin4}'v>&ƣ.<МQ/2#B&*Q{B-) <-rA@xu{j%GD_X{Ў`tc?{Bw_FZ[3͸-0>{/-#5A:(Oj;h]>)C}? Y~;`?3u6Q!V+7~v#{GY3OÀ!~9TH)ʿn##6A ! 1$4>֙ºUw z$ !+Ze.X4ÆsOҋ؋{y5s4jv$꺨X;ER#nqqg&ɜ kĻYJ4Qy;gu>=Qbk{38އ}E~ +Gj4//zQcs1`;S{ 2T -h0JғC*d$!ذ ,6a fk5S<-Ȟx?䕪 =Ca񎍇@l҄Ǭ 4ȝG5_uʽFKq^HgE 2aG(̹|єª@@$TUِ`e@ H}q *m(;Q^kUTH8J($)qHvb%"JUzϭ]}[>"E}f6[׹ayu_ywuz(@gNu=Q<" KFQEH/.;z]o; g6[g=z|=ogf( Q(BA(;lӜz!T (=h$> wj (nw@ ݤA@t h(HoFt5 V2$J{=AF}tjۣsWV}Ѫ*$$*"HHHT*HE%ETRP@TREHB(ɊF%Y[ARaʻ2mm5'LҚqU m*y;J !M&ɈbdiLFFLL& C@& `SiF#LdML j P@@0LM0 0& La4 4FёT4Ɉh4h2LM4A$2bd@0``&a` y22bbi44a 44ѩi RE=5O$fmʟLFS?TނzSx@zd򟩩(11OL4~T=OiO2=6OSj~i3TayGOL⚏F$5=A5DD@4jmM24OTf&4ɣzFO4LSO5Lڞ=MCe)#!(iM = ѡmOSh )$4Q&&5 =`&` lIih a4ɦҙiOeO S{I?@&MO ~OI*pXM4>&Vf,~k6[`sycF cm;6nXhZV3m)YР1Dc ; U9(X1!ݽOfR$::t(i4&J Ŕ{߽ݿ^ngw6lkfZ[22MEˎ&c XFK N׋u q0̨>(Ur-c`jCÂR*&] s:z[7ez$fJ']K3'WT,ơ,ϷQa/D20R f7ao|e9\e23j  1~vj8# e$7HɎ ɫ F٘ffYbx֖9굧ilcl-5̊ߛk\VfXʼnb`0110z}p/2،v==/s>\9qkᖳU8t mFX.}䐘u e $4B!bD@@1Q%Pj42000QC9T{^{*,#bf-Ol淗><&znG ]u,UZz;Gm;,wd]=u+v]<|siԌf/Yfv^t8];ojulx\ut;^÷ØßA{8rr79 aX6La`a&;nv.9=WoϺ@.9ފpA$ӯE\cswM~8w=9}/)u l[#均k]˱#qQigz^W`{~>g>K5m}>73 ,IJ `t=7oż9/#ԍÎ w$hNdA 04e%WHY"T*DkS^w8eF)IWG˭a6}wÎ9E6}K;7_kzj*W7WG`PŁke$+%*cV$Bsf8BY1or#|'vDZ٤2*\gai?v{;lTc+V҉ˉo7{^~ϑsnfIXoa11N>/PݟyS8ˏ/=}xFO f$QH%VKX]f?B_X1y.nWqţ~r)'&Q*%AU((D>o`J)TOQ&%y<hu~zUOu!b ܑwJ3(ńD@BMXB&$+-6mpmQqtUQpb:ʀ@'`LR֢=(c yy]]FkMkhڲdzTF1{?f16)1e"+cΑhAXUb  S<7 +˹X45Zi1.^={1cq~ySe;f+XM*03 d9ZXŋm-m&XGVMѣ"M@vY7d6*hM+*;'u]Һ60F%cf bѥVaTfHb[,F*(q Ź͊9L ! /B莈LPNjgtI)u ѵ (b!9Aqք 6ҬE 8CN!% 8!/:E\4>LWI0*Ĥ Ds lpGoemNvM:mrgevv-2_7krm&'#w'VA$T$)DCS777m; rdΟnq8͹sxNE{aΎ-N;m"%sbO|%G0$EZV)ؚ(a.v {' }Kr=!0;WDQMU/[@}E7Z&bI >įܤ 0z*=KVɽo?qE$Wt!Í>XoR' DέЄ0$LcYWm6vd$.> BHo`Vʑ F0YXaX BQ#0e K^qtd_'CA(C!da0ٻQNجޭ_r;O!MsA|Xo/:D<2)t"nF.?ʹY>h#xiX1bL BZOn F>/6izrO}\|!M 1̊`` LS,b߱LX22L%aX,a$b0)a,FL1`dVJ>;/ڶ! Ag %8I((Ү$v&Lf#!JU{~`,FeS).>/ 5?]EfRfh ;TC$̨ez#EzҖ`O$mH}9*hŽO2.$bvkL-R'4$1qN蚽zG9*+!#jrK|MB${V(I$HHCwۋ@˰)2LH|ͻ뺬"y:s@bUmOfW޽)Q:EC^}M2~,8~a]!20f0yxArDAVog Le?Į}dNb0aVaD:iMzo*C/“,̆aUFI#HIK1LdE3!@|EyyQ `G22qĊèEQh"L0Y1Ѧ&0bb21)ʤ1Fb̄2I0*LF(V0FdžykaD?͋Uxgk;ngxy^-?ߺ1S.E:KE1 u)Z`1F/SRbK +Hdc^G79@NYdGx^-QؗҿGB;NV)Z-F0 [|#=(IOAa L/@t|u. YYzIt9yoWS*1Sh #d#VBU;WEu;g`k/)$϶!]S t|bS_6Al ԾDyu1, b(9OClWIZʈ)<.?@^F -W"Ѧŋl#EJ %b`/l>b?Z͈$R/?,B<ƔAiok={/4>jiT1QYFKcJ LV`XC AI @?l}<ɳ{c(7qJddS$}U-[ذxӶJ0Ulpؾ{3gyyx@u (rjJدnQ^Qu>:#)x+&]Q P9ݘS$2H!c3PTWF(kv >3)ÐR ϲ7^һj =V()8֍p-ϋNgV5!u(rh~n: 'hHQ@ ?~ẹYMGYE so;Ɯ*m?E=*|[vr($5:%l:Wk.Чhڌ,~n@?$I>|Uy ߱l&OX'$ďVTsgSt/jpv]^iKJW/7J-jFUNkXIL! +$;17bhUg!hlL5BY#(9 P['5Z`ddn6YiTxzS9'8 P$@  u?m"~BS;vT%:=ZQ;y\ݲُ˱Ő} GrpK%Zz iExupGAoDzTFI$|9pH I *3yi&ܦZ@P2vzI3gCHYPD gR! xI l=DŽ<1CR%pHRĻ|Kx,>W܅ġ)ؾFq#o:_{kK?VC00`SbBafԴbI  GzXAv͏$4@ !AOݍ7jrp$޼ iI'!zG;ߕk0Ƽ3B8|36>] E?y HnP).ȂJU ^5'(TX/I/Luo2 R1YMf{n͝<$B{7,q=miq=-BiѢp|go%ג3)_=TX^C~͔w Mc T9O6)Jr/|-Z],53)zqʶ[{ ȹJ|$*2@&R}-dV,WhZ1k>F̩Yc6j2Y2edY)4Za5V XCBXTU>ߖ ;ExOB"@qsdx|*%KID@x[]|%yb 'f_z h<Z}(⊫B%'7 =6=|8t^ɷE^B{ߝH KɅby醖> 8_{:cy>[=PHXpM8'xqXLyo#R5N42`S Hdzx^:vN؄s &}el"Y! qdJ͙ASX ș>18CM6J~q4׷PB A`@(FD*P*B FPA0+V,»QSo٩Q/V3;MXY[O|5-]ՐğA8he&s+]BR88Oya )pꤐ] G}VdNܚvgή mYp+̀ȷa,%:Poz% ;,@WyK٠"}\9ad!ؓ:3{E/79RCk1I!HE No,tK7VVRpc1n=.@0C"@w^UGF̕cpkD5 .Nzm3")hy81'r`n[ʭw“Iӱ2pbw(ZM?ݜ?=D νDdA_%?YյgCϒ{=(:K@8Y3|^gyck+૬x1>Op|%$rzT=bxw5X%}1É(2_ oDAIJX7lyDj Hx﯈9Ӵ_]OU߭a/fHmچRg=Ǖ |}\ IR!SeU̲ga1I}ڋj!I_UqX)zxUn.aԲCI%22L@U"Z#AC Ħ2U|Dj dS2.#3*wV0aa bJ4#SUXdE*01ŕTUƔ^Z+QYA}$#r0ʓ0ܬ)4400қ#;YKBÑ\_q~FeucHm)(_Tq0yVv(cOnVǯ&1>eۍ-?SeqTi1p;eʛ i9+NמܭMƍ-5&m_|z(cPzƽ0>E%Ga1;x *YE0YYYY$a,* d2a,)ba0b+&UL0,,0&,G#wYSYM0;l0mCa/<^AݎP\+ʙy.olWUy3>*gDi@hr--u#q^F#GCucYx7O-VՕ܍ǟj5ZVW@`]NF+j^-e79 X7ri[JV㎸ZGGEtUk]Uڲ2aцnw\} %|~LuwYۗ#{m6Wg.+*w+|OV0ͬi.eדUW :66l6Lm6䯍x6ãk~taÅb._5.rg9mvpW0U}jr0dVݏ l>[a69Qz7}%Ka׽c2˳Xtl\K##UG[AѼ6W/T_gדp9Ç9t \ħIį|?½(I7Mǹߥ25]?˅I*L$2V8 ?ʜlil}cF4hѣJҴm֕j4L7mݷM445hVT5Zկm 64ҭ?.lam20?цGFejZ`1,27-# e~Ozҿ~L033!#L00,eGIr4ÆUmra 29[.\XYeճnaDŽFƛZцhҵ&iR~ᱻե d+rΌ0u*Hj2VFѤ`j 7++dJ?RwaT`>Uzf 6:+i6V4+JҾ|2Xhhr7|7ƕ4+Ri^ONFa0&H2>q:^bMCZ۪rBu2bH_\F"2.R<; D:3X&䞂Y6=)=_m exG(b%\Z>)Ð.h[\w[  t\̊ D>sH6^΍dX<A{nh2/PD?AU[quiER$6pg4UZ@@ 8mt܀ k1u3ǼM6k+=Eg@嚞4k\_I hϻ *ZC7sNG洃ˇR_[/%s}!ɑc¿r=`+I*\v>UfMhq}<1Naee92ީ;8$ [/D=ofNSGUM7f:jA"^ųޞ8$ģ (K\F.G$$$aI2RZ]sn{m?S*H7i8>BBA1 ' ^#L^_.d;>+gjYּv] l(^) Tֻ ŀ}_2XRxJ])ě30~d\#2zC*V_k{+B;ę&Kd&Ja',030 0UifXd,20 0i ܶr 0ߢGPnՕ6mm4-êٵ[mM5jZ{+~9]u_qrLdb;Mr3 xnGGzzۡȓ+)i_pdZVIGt`j``bB iOFՄdeY K Sq'_Q|n+t2u<0^X!};41cX$ FIF#$B^_ѽSNƚiwO>qyXElѣԶlllڷ7+r?y<1A\he V$եjQ䴞`bFbb1,20ʯbX Ҿ߼(|RZdiͳsc 2 tV-FC9VMVje2>ZnY[6\L2ZUrֵaѴxW##+oss;>/MYc*U\0M?Uܾsi Y* *U;J+)j0+iz/'uv}ϒ=8V55F[?=p#cτ|/?ϳz=$~j<]I.q1׀2dͭ_wq/:4iٔprÇFGQx计7W^SU ^o RDZTҚwݳ4ps4h?\ 6 CFmW+(y5ٳhٺjR:?)Fvqb{'|ǚ~;]j% ҋTR:E*-pIҕut7MwʥpH^"t> wyʁk1||}`CCu]ߊ1C®eeecOt}\C>pluiUQ[Mlw++MF9)0K+a.9,eb?mc#uTdc!NV"AێHCTt}?L>ѱ퍍4 ;0aٱ٦|Ό284OóG8{U^ :0p:=;:4M :=f0#y=OG'=瑜}U~u箳}mYמ::qfxϿG]ϏG=z~9Ύvss=VՆFvm\OGO}*r=2FݭWZc}pU4,:Ք4歃Ah5X]\#]]ܮLqVub(m&eG9GcUlxiGU^Ir&JgpW)y<-rQyNѦs+i F0lGq,ea95,htaĮ }櫇,vvm;Np7U[hll +##ɉvu^.]Qප>{RKLW*58}UbWGڏ7.XaG|L*} K sqZSO]=m]{M+$7G,8W%muqʕZNdȾKiFۆKcMFmmaXineYmaemKQYae*'PK]di껯IaYYU+ &Gf{s37*g\9W4ʷ8nk>fձ׎6Fβb^ѷWGxWrWuó/ǽeuzvz;3ߨ*h;8s;]IgttuΏʗI52Z9Z3_k.Utim/{V>5t(uhܦFJjͤytЭsuѣ硹Q'mPbF# Eb8ᄜp<Fs[c~kxS""e `$!*nt<_`#<Ҩ$Tc78$}oZq&,+kA*6&w0i@Ҷ %_~4yr,- Y}y_b0}OplHiLUE74mQϬ$$ a }5 i`Xs{92[Sr 'JIq|iDD[ |IQrtb>~ҘLfv7hFk@HInGiV_}BFp //k}t;V%hBA<.ol=/\Yn3+ƧB9? ;+_L"bCXp/ WVH =4)V?^J| ?Ru(W++&JO)2?GbXU|c_{0䣍`rW"!1j c#mtdWf٦XxJ2`0ꫂڴa?8n29#ԇQ221#hA#Qq1oG \#hj5DU*#S[o GB#$0d&0İc1,22S*f%QfIaa ʘ2ʆ1#e6 +p5Xcº 3 bvM1YYL# ,VF%ņ% +,VF%XVYf \ V[|. }~ W 5ZK9^'uM%hP_mmZV4JW] l>t5+h۳ NXt#{effg 0XVd\0%&YTe`٪?nz]=izt]sz ?P}g|;׃ju} N{}OɖfÞNz?OX'g/_6;A MsSр,uuHD dnN_UsRa EQ8xxO#NjZr, Z! gYa<lYjhݾHH,x0ʎCd8?$ā99}N ~kSR3qkCÕA:L7, /-0: 0gỳ E%n|֬_y&d?s\ ?c`va_2 `h5tHйex@`*322FoUم.Ujƒ IM{h%QM7FFGt/ubmхiq3Gѳ͟D68qu~BWŲ-M&E% ;<x\+ZJ҆GGl8W0|-x4F. ld~l鏉^:;Cv >ݤXpÇ 2D oGU9FU>OU-E3?5C/")>3Ga49{6]iT.vx?2pJ$DO;}*p-y{Ok=&T.v%oQ]̿ҲF'- 4 $Ay/nsU$w#JUr\ruH1?;r_N~rǪjfHbGڽ~'Nz;4ڶet28IG'M|e*ĽY%?7IGP\GVա]U\MPJU(rHD!A^|ج|Oմ[@:;ЇE& $n|iq}P@ &G̼Ѵe/Ҟ~nJGkciţ;f{8oZn@ e)Ozq*pP@` (DPq\o[f pA_zƺ@x֥[ rMs ! &[214ZZ1iZeO{e|po|63ȳ*iFF!ZV2ʦdYE2Q[Y +6eW*,zzuy%\i;,y{ګs#iG&,M0lF̴[۫m fT AX赤bXU8v+f[A7!Tß7:tu:9D%Bȫ(SQ2c*KȱW  EG?=ckQD|:]?_B̓z+;<&|1 c5>)9QV_GJ1XF-:OXu { BHR!1yjiXc+fѻ`fV2~(q2L,0ic2DI`D~;`9Ytemi׎zժف5iuYd&5ɪMy<'#s4WMiQYrOǁMjjGwQ/r;2M/>%~jW( 1]ؔpr2XdadVVUxc0,2:AU_>{]%txuznv}/&i1_m;7b()a HOrޫri1nq?]0L4@c,W«j0"'!3$.*|J~o>GBo=|E(hm+ҸH,uޜ!~/&mTQYx O>c/cx (nht4H~##:k<0MKGFVe_7ڹrUU~'sOL;?'ay2'FXzU Vdeb/Kjldr[C돐ʹ#[zڛ^>]I02NHa([?zse-l|gt@ߐ!zB[K7W}VE0N]k|CdRřt+px;xqVgE42ԐCA!^3FT/s/*cч;gdž*bќo:?ix<|{Ăܪ ϔĬ3 0%Xla /Q#x-3 VF%20*L0%Xm+B?a6Wi  WU9'ry'I9*/mX/_Ǥ߰IY؝b "f~~lmn q`[HC._zÁ4Ḧ́I>4r?4acU|t~ѧRtx=<9zý;7Iz>>}FGU>'~/ 2 _eZaّjOY0jee2 ?aʴ20qKш_:ɇ'}Fx.8}Gp>Η*V Y\VVvYS}?zD0#h6r'64s2{۞fWd1]>Ih8bSɢσ\` SӻruD3ܣe<x@K{LJ\Nќ:>uV<{p:W=G {s*y0aV0ʦFFVQ&}/}*J>0iOށr+%~Pej}o[fW_Wruw_Ax<y񢪤WIi Zi;~qy_uO_'P Bw H5w>Ct| ͫO)|V<<^e]tڭVsMl6s/|w3H(bH !v;kkNjQ /m֧2zLN82[cU騯*տG?^*IG߅JSE&IJl[Yy<0ldooz6gSh4yh;ޏ@5xE`s/Ƅ}R!2{EN(}ͯ2_P%PN{c^6N5Osd^%A MO~~9L0sNߟ_Upc]z=lawG<__& ai*ĺtr԰<pΪ 9W ;tx0(Q+,Eos6.!m쾛qI  '[^n7isc1?ZTx@AI%tUfE@ LDpH 9rZl@oc/c>4CQ"p8a,Tn h`+)Vm  U0-FQo 7 ,6UQQ6 !n+U\JnD1sG~d8W]Ie4VC6>I MgoIXo9VJ]I$$Y! ->{{+#8|WCw؍Hhe.УFp$a^3h5Tl 3w/[΄Ha|@⼖٩v|zDz G#J_^{nﱯU\Jz>COٟfWW *U]zW 0I ++*31+*D,,V^&Wdxgџ)a<ھl:>Ǐ'P㆞iÇSNy2-1r͝oW5m=::{o]{ee||9s6>xx:y;߅]}GGG<qbV 2>+i𫇎U+ ʝaܩ>;ʷ*wUtm[KSѦՆ a\ 2+y{=adW]W<1Yz񍯄x6>꽫޶9vu9 ˇ%l7KcKy9ֆӖq"=p9sNs G9ٻkÇg[Æo}gVzج:^>xVڹ#ˇ aXG0hqvǪ`UqhPm?Txuƚc lƞ&cszn_r엯x:^"2WQapW^cco79:0ʼݜ:×',0ûtr!%>#$nW=:60z(-l^:FlT@$mr;ˏq󱗷t(_&LcFzq\?NG O鈻܀A $2]sȏˑ4 (`8rH#ԭ2m:clWzWiGw* l=g}FjpKrKSw* Ij*Or>z1VÐM?~sr<:!g~軡ve,#w2*ɥy] ?T|VQjq+s7XBI$ ʿM*°JFQJ*`$ma 42bf&VPaJ(Va d0QԘɒ&V28`'>~`vt ]h[kzP~4GBߴQ=+=3pl?keoH@rC@Vt:5b;șZWnt?Y܍08 2_uZVVW d;mV^22&Ȉɒi33 2aɖ%f%?>V6$EYwrY`lWˉa`O$]%x>Hn_VՕ IL(0FJɪn*őQdllrSYUu%G~5 eNB4wS9U>ŽfHVN '2>]<K1 |`92`T  0oZ,ImR˪Kޫ r\.-7GA+qDK軬A5CBZ|@ )'BğbyO11F; 3g uV _L1Y'fJGT?%c~h]o;%~ )׋˭yXׇٛI:H uYw)7PLByFK1.^? R&y7<_4b>_'nZO_{ґ?bscP`m0wW3W5C,NS'UQ޵s?7Lz i&*vWҍ }0B/tfw~Ħ3ωw4*Nve]BDM^o?RV/a`?9OOO1y ]nJ}r=99Mq+MkGq~Oc{:s;َz{HRt6y{5_#>!^V2Q:z6tnv*O=6#5cL]6@`1/ԼؓV)hyfQ$[tl&:]͝ <-toF§\gxjV wBN}3Eй誫Wx0*zSq{&&V"ɝ'.[Q֮~=!߲6ziQ,28!qj{VYIr֣ZG)8jCr'u/^ /o7ȶe4CKdV'ˢsPo{y)$';Mv>cĽޡn׶~Ϟ4LvP0= &8}9 }fa˼7$V+MkEԂϦ2QH5Jj1rxҾg_,fNϷֲUo Xy^R湞Džguk}L3 Შ9}G]MY5mޮvb[v!r&?mʨ[`Zh/`7 x[@تGQ|0?MkX7?ieIw/770uRס9~Q ~ٓC'Ju?)=EW\UJ#D.Sp7:6m2#"'-^r'z>tI!;]ߦj\m$͇goVN玽Jʀims mv@IJbN7ZmmC?1! qLaczhӼ%yN/su5>޺ dgvhhZ#n}<ėu*Gy|o&o"P:Fɲ+xw5,VNX=EveUh[L^Lhؗ;/WǤh(ELPrS:x]\(/5kw2IxW+i_.7|ՇK2~GZ0z6Zu(OX{sR/tPH.&(P skg-_il^d\"ba^o練C%8'$!qJSw>yB6(6xk†ˇ~!CĤРY\Ȟ.~Qe!!9&)TWYnO8JlT@ !G.akXrW”-,~nu^;'?}ijQ5[2$OgtAkW x"dLX!FNGv V) h{nuWrEkԡzT{]&ji^e``H&=G䃇6BWJs=WhV³^ZH}<=54 S JlGgAXjY\@Vba ᣷^yO[+y : "qv;D<7z*KR A7h%"pgIOztRw$ ȡ> _- ӖbuCnVOϓپ?s$8ήZUSu´ BilGyd"IqE H~X}mDKH4v^PO_^R2~G}z}/H4H*W/noA*$zҢH>>{qlZi?^>$Jy3Q;Rm>|Z-߿ZuG)||h Ud2+ OI?F5(II`  57:k.ӓ)-14Ċ]V !jDTVmVJ[9'[Zlm?w%~0¬ULʱW.MrrKRaYCY!\!pe Չ0Ʊ` uq;Cڦ->ab>?ԜJAWjH$&L~?7Od=Dh#?n^tA J _ֳ}/ } Ӑ"P2A7d#j#8Y^~g餒=0R& 5|_ 9Kwtꖓ;'YGl2p7FΠ=XZ>M{+rz˧[=KR <~\i53|g}@a$љӀ` ;_e>heWKP/q?Rdٍe?09QG i7 &nNķ_2zN~9`| Ee&Di AõO!€Ÿ[^rB'*R$Sd"t~{◻Wi\ӖrOCq? ̣t\/2>,6nNaՆZ,_yҒu͹F,N+N ywo:w5eK C<{WR@. ?Zh,Aq0 &AjarLs2"ȚC#?G%Iڪ=y=a`<~ }wCG@)G4c.E@9GOT)IbٯD:Bܟ~^3䙯6xC-xվtsyME*HXXxpb+v[huƸ<[˃+mu/2"Nw:f>;{4vO˃~J*oʺC9SAV~%ƇG;v@vGmC! n߶QnǣwET"UE cDfBe#Z$8?~tT>ᖢ~vаOW?pg~1h;J8thG?:A)ؤ֮`q)G?ttK+*5 K<;jsOJ2661A. DPAG7n{a٣ذNT.\ê4 #OUe{܍䟜?';Rz2|=_=~`"-411,H u3h,لdt4k=.3sp+T^ѡ 7D Ԫ,.d߅e?Ewa_ZId^^ .>KGWm-=dEyLؒy^X#"B#TB\{wDAK@#$tKC5Bap8n_j+C8OxFTd 6fUָp< &èT^:aD70$BÉ&  Jg{٪ﳩT6F F%Ady97C9,+yfgYFn=L r ~Bg,La6kwUެڊSn+ff@ *jEV5PU(5sԿxn>ZUq` @`0;)$&DZ9[f'9IJHm-D$߻Sh6H~(l3 J]^[>25j.} wP]k|>Dzl>3eܝvy"(U XmqmVb6rTigndsbp7NѮR,/BYJ)7XXTBrNInUaUmwq/ e7U%l|Ij-4L;K*ÆYaZig#U+w[o3+xa_/&%[U}bI/%sbq[l~MϞz&T3xxC,:5}?lEUwKd!x¥*vj&jUx#꩞yHAP^dll>룗GFF$I yVRP@|Z,@e-zj;L4##"> T ss^jվJ/"2npxG]BONDPb}[>|ŤW{a{ UFaIYVG.' u<];[O4R$M}~J$AKXWTjPх7WhǾK++W*w^c#oea-20fQĦ`"'c 8\6lpåpc%Nv8ᴻfeht}c|M6accǏ8/{5QOta";&7 ħ`&Ix^,Azn&&"7;Fn^ndY~>껛iY#sMz4vw_Y% 0 W!Z4+Gц7FhWz +rR0AYRY _ŁLC(bU{J! 0 !(`T=K…Dd-\dV$sM,>Þ w_vl_h񼣮J`P}R ^,pE=][X)[N}.c2rIs {2 b C!HHR)E"HQÇHR)@B6h3ՓN~8ZIb\x0<4lϞ|[cL~Cql8-Ϳ^c~RuIG? ;CQO4*aMM! 2j~Nc"Q@H8XuϋclT?0$ A2M+{~^+̝quY>C6?UggTwGY6HH%2T9D֌vl.&oiagLZ;_FY4eyM/|gwV;l.ۄ߿)K[ ?clڝZq0AY \ ;^x|>3ｏAٞEeQUU \ďUc3o |t{$$J<=~/*cGvR=w.Fʘc+4J:ZjWuldu|WfdVJ[L;NuaÕ+m9rӅa|`ë nFVF|IaG~@MiB{QF$֊ˬ0p.\6ۆXe#ˇZeˉmm+zR;I۟cbŋOcwG}-,P|hdkl;_ʒ0a\vS#L0 %$i~VYT+ 2LXGŽ%]8pCpP9c]j)21ܬVVWy#zK;1KeaQ]x4İrKVe+oګu@?6z<9Ї7W~!#L?8}Giutt~⻶4L9aÇ :< <4aqx:8;#%Udx:1.ΎUҞv];4aZGL<mW.].r6;R0 0Si?yTikm]GMxmOON(:iU}mrfiup.YuewaWU֍6ó20 4teþYee|ڋpqdrV24a4c UIۯs6twW[7'QC5QF FiJqQGىߗ?NV+펊O<7x*tʃTz;q:å V VV, Ȓi[9>vTtC! aNJB Zp\Jũ*#DY.](-kEZ ]u QBDx%I}% ZpBU ]V[UXjS!t. J.(lJ%K5`&c[E`h*tmKun;&Yb  <.yi7FFFdM\[3Mi5r(UMs\<&pAT`xҌy2cKSO7 e0 T/;u:i9]}"DH A {p]w$ddK+l ,I->u{ U킜$ݿч*>⪣KcPv>wEç;[+`shx]__^{XTfz .Ǻi0/4{ap4`Ŷ)j qK=Įr9F$W5 yS313kiN~q%WTJ豒3)*[ݪ{[Ks31^%vbnJQ)0ngQ&i<ۯQªvCYFy_[XM590ȕOG%tVR\|V#(د_1;!tGaWB*RX/X{SW[)0b'D@lj?k]E=Y0XaaeXaaLbKg-%-r Y]U^8/^l;}΁%r7tQ'844BmN4kGuU ꆽB⧥K6s7ڎ[d9rqj/(El "A3 !RG[}2bi=nI-_;;H^ew+g4E26EpJAKb)suvoz?"]r^G\X'.(0.iO!uj E1!$wE_ ?21F #kÉvpL?`zSʼUof+&61iF46f61iF4Cppz6d~?x;]60'Wjѽ;[ ܓ^ݏcUC>d4cI1& ad%aeT!,WHGrʏE2m|_V40hh```ШN[Q&A4q󢱂OWq[sD}/ 2s{l`HlA,H27]ƇI 0t OT 0 LI% !|U`P.=xv:V=]<$T@f #WV+++YYXYYXŢX3%d*$L0,ItaFeVa%cnA*}ž|ldQQؤ{M̉zqwI>9d<ѐψM*6vUTpGT/O`ѱݪ킶hmv#Ghxy]䔾zys#L%(iQ܌90ﱙEeezsW݇EU|mW^%w^+t^NhIJJ_W>iWFFFt e,Ib+vs #Cti6]ѩ-F`\>#*#Q3S*VKpC'_~xņY(T_N]i[F/G?WOy7>e_:3tpJdP< UPHJDxNZUKNWQ:OJq\{;eA^l|LQUKaNFE]g!嘝v: /-ب ]Cݩv_rn%x碏@܉ySypP$uNս{cgk1ŢX=qm{>5E1(:zڱesդumO5 lo_]Y+wWnx<-&0r#hZː00E5vU:9Ɣn:X e?ʭ#a *Ex-(ܭr2η!d&1 pq6Is6#i.e1\-` / :uXZ8֕GnFlCepƺW"pGSjVc%`*JP,V FTe!os:q߬IP^Kq4whaZ$&8I!"^rs_n]kL~} {ׂ1LczªW2U]q/*r|`_)fUt6'QlʚzGMC*yWTIιS}߲0'? R@;UU֩^ z:h:/)A<=!<<:]$4ѱ[VF b*#%'1y Or7L1m# 4/]!+q9^\ő SVUS"OtrM&/F7/{PTAzԬ'a6}AOA5}Z;G|'PVC&&nl7ɒNuH8G)3P0;C\Do{}x@*øc yz$ނ2iVZ# Gm;bm7a<3Dv b>Z`@_UrYhţq'K._v9ƒpuq5x"Z9DLHM7 ȴC_˝xB%~?0QP>_ wȯsy3y>ӊ_B{^?SF1Qb_TsJE?Cpn{sG"mvE1VWcLVW~PiZ6ccM"-4# 666FL2dmr}T]*w_d>3_[veTԤ4=ݞm8bHD. i=/AR.7mP ^p`8OŎ?{Ǔъzd-DeUPi>~_M{u?QEE!r8#"W O*κTsi%%mA'ҰjR \ņ#?"x|OETrT8݊>jR_0pNl^FFQ #7!ֹnw{jddU_sQߝa52!%)ңy_ 5FѸ6?*Q2J)$O<lW ҧ)Dy,7Tn]Bv0}XaUyF{pu&p}J.٧@[0bB ˯wёJEb0b\ɃkTxQ6F,TUjT_8#I99ok{ΧhTƍ]P$!q #QΖ=aȮHF #VRdXѕCR6U0bv)4RJ%֞,8>or!CZaf3&U1 02"f0XeVU`,b"_pžUd RBnz1'[os7nXkPw*x=B ,CpT00ΏQޘUMpU OK$aHd0 |?=):oj73An*1(t_b#j2GgF{/i3+ G I. F^#ZzAgEVu!0@wXJ k8{7P&`p/Yo+&&d9RCB@ VR c=:]S}_j;jvd@( M!yl_!ϸmQ!F=wž0;|\.@ Q+tF#EYx3ff K Q{ʗO`G= ک%m~lVষƎA +ٌGDz%\g]F++[TҺ'x(tnF a*5Uj,G I1E2WwWLL*nJI'Rx:Qnlbwgz &J:`xYy^$鈜 a ]]򺤇G+:PL+"XbM!LTlFR1 F(h4j0V\Rʌ"I(`0 л$,:lR+fY`LIT=8쏩z#ODy N]'աь@ 6l_" ~@ {]Kj.rt/G+|?8UsKʪF%_Qc5Y0 /1Q0۬znĬ?ϺXl`OvCNAb ]U]R!@)8'}}]cBj]N]Oy]TB:Qƪr# g^$j6m& qTu_dbjc(l2Z(}UnBOnT可ӡTRcֵ&'?/ b %~Ur0:I;hiQ;蔝z&T~wDtJ6iL6b1K HOiWɫЂU1 \\?>SӪ9h=}zҴ9N5p"uOa(Ty?Rq կ#'~Mx'ǕxW#'b$rR|Tn2 \g xiN ۜ4m9'T0D"Aj=mBLa1!qƚMp?4l7P3j<(:͘s1QosGQ~s3r0n񃦻~z8 K#GZ9:@l4+--ƣb:er@y]KAܜ,_Ɉ L2|R=wxU @iå /xRF#Q`V0%{7Ct8)e?N_Fi;uVAJ|{)%թT'mb>K-at*8 ~rң|*kuRpO*=A BnN7'%OY7!? Ϋ~=ii1]){ȏ+p>V BR0_)r+y Pdo?|on*|ڔ+JZ͟Qb)`>*ʥbPԧGeWQwr ?=.ʼQчfUF #ԯR(2@<L%-Y3oTׯK 7ɵg~[ ;h.JJ^xQf$"5=dXȆ+ %,KǾmc`!7vOw}'ҏܰd'>}/#¿abSF& xpOz,BAyOJ{_w@xpk3̤ io4nK :۵Mer.AIoiOvJ QIH!ɭ~so켟H_\ i6=-և:< Yv.zYQ+%]KK+%ؽysU>L\{pualn\fk5ߎsfa ^SzxrO S_D)Zđ?dhRs|Lx~"KFݝs 7?%y{2Uu`Z~ oRE6k|$":PR}Xע:ԎA }.W4qXDY@D"QƨЃ =[}ـgɓe =)#n1 ~? V(h6(aչ>Ulga^76E'pQ\ҞEn\3nrGP{.3{7][9['vT:֟Z@uivT?B;*uOyϜc_dDVS9m-Q]`JDgj'h]f݋7̛/+e^.jXyYn}rRO$txޙ{4ӿ%XyKTWyQMYrw=Q C ?`[i|G~=0O 11-V~$B#~R6!fr͛IŴuV"m}Uz.qL?{y>6Pr__ʗ]Z0ڷE\`FGIJEmUv&jk{_ˎDkG=X>^o`%\%"v0,.I ;.YW?}77iV !|.-w?oUwݠAڭ6)߉+_U -{ъ Vؾ-4ӊq>b7| ?OqV9kh^W`Ǽ?/]!׶} TJ7YF4 u4SyK;Y6|*b'ꏃdc yz 99 Z-; ̜:50Y:x~PEK;$[ڬT*XǸD(/d+sBҟvsǓcY :yb^,jGMkzB,rȍƖlocFY+,BY5c1 XN=b_ LEo%V=LZF U|z! A*bL@Ms'* b:p/Ty7I0 >imZARLckfπyޞtsԇJTܭ]׬T⥹s %~о˔{㜽Md[$r_dVySw2 Wi}=~+K;8F JxvU%]@8Bw M&T2wA)7.fgTS!=Ey+6v^O?J[±2וlubFڜʽx51+5 ְ-jg7ϳe#[h=E*(Ufyn"qA} *Ӫ55rnEP,W6,Hda|tZp%Bu')J-ϭ_ßq ̑[gXbT}AagǾ7`]j [5H?TPr={Ǣ>p#ڥ~|F}wAu8}ţ1X";6Bq/ajDJàqnBFߧvR_`R'5۱B>@`F*5$k*\ 4MH%xxT3f9~p\$$u}Jc륛Q})2~^6_%=jފ2p]>%f{hfuxTg}iT3}t4EbY[Ô88T^ v䩲9IO`EPY}c>؇HzLJ9x5}npV:d7+ZDe'#bqf✳×i2s-qsY M= 籙S߄ - V):Vn_p&`|vU&g?{7-7z4 Fw2 QPRw.um)]^eW/m(vK8D>Mۢ;!j>C]e}G:۸V؄DlW[U[hC@\rɿ8tT1X4 K}*'-zux\׿z7A., I4ܽmw#ڹ*9e{1LǢ̤X(vT̺vmy츿^μ-I A߼1_T=9lqt.;UlW0ŒZ.I#_NmH綸H-h]'`yd^A3^sm?)N5T9^z>r_5prSl]*^8 o`p4ū)@1)5juC)Uo|&)48e;' Kx|LQj`{Ͼ-f3|O`)ZPo?eޝH^C3>B _G:1]岾)^_vEＢUtOO IkǑ玏Waj?k$~Y8V?;JF)^e/ic"<%#zEɺ ouy Iݮf;'^`iI51!5*T~9h҅}}1sVN^I؝L28dZ+MyE2Pg_څZʮe_pt;E># |Fܙ \`]<vQ-\{Lgar@%(B"L/rb nmΗ73otSJ4;N-q*4ueR58KQOJ <#Kӵb.0\;?[- 9n5;[0;ՓN9SyWPEy []]٢NS蹧_+-%Es"p(3s Sa3Li@P(v~;Դt:2m\npyNTookbbK_aEV`6a皳:ڬvnJq7VvS w~mqH{;A:HfVr]]̏8E_q bŴFA( C ~ϿNV?EU{?D$'HyefL{nѶ"x#s|Ng66(\( axFYz>EL7#'*eZznj=Hm{ 蕸V7?B3U0muAWuY~Zcb2K2:mŷ;ge[CU'Թ_mN6._H_jY;񁏛{KPi:}!pއBK;uƽ#WC7l5IT}rzŒdl2w!6$Ւ35VG9%=nG?{ |2OIml_塗6Q<Xw#uO=_m _h@)9r }=#y7&>7,g~?SyG6./6|~hYKu!N>OhƉV7<WZ+)77UY}iV~ҫ&_F.WYtӞ`$<֧ͱ'[)um=Aw$,SU;ЕA.'a}ZI NACH,vNa\R}}fIU=E$a)-FM~37S|<飐y&#ʁ|YZ}b~quOvzp:OTUsyy N ˎ#䢿ZpBԒ6IbwʇoUQZF{3韪T ]?T=[Ծ۬[ {MP .|5N7_Ws@ldI\}0V^⡖HK~;x &Yccv-б[Z+:E}Vu>}̅y@|L~뇽I X]^QbN)-KmqLu%ڃE%G-IϷFV %Cv~Z7j65k $x:-vrúxx`$#d` //l۲U(u! ƫ(d"C2us䈡;r,8e1ۨ굅- sx@ԗhk9ǐ;Rl֟\ƚ:^e+Mr=SmcJ 3br{Lifdӷ;i%ذR}rsRE_ZśR riFNI^Zbo 7 XSMwp{V4T^޻+N^:h'a)5*,Ƅ'_-꩞X]m_G 6z=+ŭ#dYܻp^ dŭp Gd_1Z5Pp!!vw<~s4ں; \wg@ӗLÈܷpfїMFU `Uf4LBE8#X$2e}z*Gw *Y|o/HÖ4h{JtYԣ_=rsJpcqb9rE(W L,IwqEF:Âa!z;Ҙ&G $kF2聵d睙Nлp}+ a,5sN(?0rg-4Ɲ>WKMLp%y;=Sor->0qyFP]ݎ#֗pq y*˜!e1H*әae,k`nz"ǀ 5THG#۽t6gs/Huڌ,̑|힏dM1+[%N<19Ͼ,bVt ܫ:uuΧ?3qd yבTl&Lk܃gg_h~U8Lq.3^zXAcze|| {nRp*9~ 4+W _ rs {E=MuDRnBlލR]X̢{щzטU`()p0}gRܶX ur'\u&hO%N2Rxרj%I&b. 8@ٮ(S=A+i[\Z\|+4wqbv iv4x?٪ ~U]ݒ0=>T)aӔ5N7z.@:zNLH+%] 8glF`񸭤7inмtkԧm3aor!{8~7`"; uמA%=ְ5*֧}NM fAЯ]bpKI^3-8ȿGX0;P)qoӄj^V 39F= ҈dՔ87u6ֈI>^.T2hYlk><| ٫r P J\!$1H,iO3Zle\6_{/ssk/80k'a.~[c`=r7p?}Mr>ε'F6:P c꣟c|i$GH$cT}XL*U? Jf/+r9V}_|3P/Y,U_tHInSpnnX?/ݐe吴6AWsASK!QcmWRx+4Pϖk]߯Oy* T\$]ŎDRUૉei׶(f5n̳a=r<w i䰐kGN\x~>չn_Iso'Vz{?x6jFޛ>7ӾV1&addh'NM 4TtQ,ȦHBsр^{pz,>J;M(]Z 5s|?EgZET..g53}[#igw  vDb?!U~E馧4 Fzp-+ :+H!nŝ}}qP&}h?]ƹ 5,4Lz~PdM)OO|Ϸ&ݍ lzoQBM vVV*p>m~=EÍ~%/?鵝6\x7>'B(~^Spx=ds8>pu1ۃ)hj/T.cBhyK)z\Y{{;Xsf*iq6"E2cn>l9*#}nn^១jxg;X^L>{[4̷cמ&t}m H3I4 ĺ8\oCLv ͛}}TR̽Vc(+דTB+Y";l*}8"H,b͋)ΌGGzpM=MʫPA @+|lc;3?􍗠LZS(*@=/\:gMp<GʓRo MK^81}ݣmį52>y#ʁ8x Oc}~,R~Un ;Nbw|D~ն ^S땒tk1 #cxs%`%As8QJ''NqcԳPIH\%Z҈ԭJ΃m'k2tyUV$ JQcϩ߯] 3:Q ?a̴ɺ4v`!S5oݵo%D6Bۢx.v3?g>(ʲ>b9u7EtC!ͳ hs2x[SWs4m[x>>+?=r!In*QYO{9{rd/^^|<yja-"I߅S1`Jcl 6{US``rL[VrwTGTIjDL7D_-/$pqyL-H؎wpYdlAv7z_sxȞ)R>RC"Kȗ4LEh.~l""PnL8GC#/ W0A"-*JSע_}&R/–oLB-/IGeiJ`rGh$7l izν477GE5:D`袳IIM|.28; {}liE6;#i6ȣ$O7o<"1}K"IGbv.dƪ^)ECd fy2gcaR<8)D3<uܘ 4NJ }TJi`c&/KˇX}/s\oqգnl' +ʝ3&3I8;.(넃%G=  ,o/~/#$Q[~)4=aq 3rqQpw&[XlgJXih-ȮܳDjckջ{YWoP'6IBЩ`.Hy0 qUh &QƟ64YD)$O83<yN7A.ԗI\`Jqe EuMhT+U_A# C1z4d!k y/Oﬗ|Ζ wYbt(Ҵ8x,OJYHƱgN$m ?Zǻ;Wdl`sZ d5{wxgv(;y5LvYifgt\Q2xxh (kE[ޜĢ ^( 8I8@ v6CJl=KMF;#U_Xֿ 42(u/{,Xrŗ 'Hk@(ܝ>Hkyb~?撥 ;&*9r^&1Rvgy瑞͡Lq2Dqtjx(eur{1԰l'RdYu%"OV_a% a h*z48~s4|Q/A8M/l>-ꆦ&zG5^Q.k^V{-48~6BL틨j1[ѓƦ!Oqi}'N2EюHU D'f<膾b(خVT=2?B#Y'('ާEu$y)Csϔ@@&A3*NxيGrRly@ OwLx0BH.A~WͽƵ#kݢNաJ SA%(\DŽ0pd# 9GEɷ)F_z{$|L4Rt.1~ ?IaU؉j ѿ>=wn~akdO#1eo-;d`TrZ-,x&LJH:H1I fWyO'ٍAZL >8kdnEge%!q^*4QhYZ3hWhpQb.f(,ME6$a7' Cm6 f٫LJ6|(=%2 pҔ^1,}./z9E?1 r[KvjIV|X .r^mK}u*N=E:^)hD,ʌYZX8hl?0Qz  9dGp42GdKAX̨%<)KJLO|(W9ۼO HB:ᄤ"o2vXT-~SFFeUœś;L@KI 9Sj\mv}>NjڸSҷl׫筘7@o|2$7!Q)3Q\}u Vk=BK+kyI;)&#i܌4D2#)J 1[ONTp/ TJ1PS X?%& 6(|+2K:e7+%HbPFbmJ(iY.ڛBb#et|6.%HʻC!*KI@0)vHPDp}^(@uKT`{o'E: :{c_N3dYR?@X>|F,W=89li1CbonRV|X(FfŐWw?0z?삽aܘ$ddoMu{Sg?OA;4ؽ.% yErWdcP4 նy{ܤ- Ndx*\2Kv^j0tZhrke^Inbl/|ߠ<1]Fn09̬zDprk쟺;g$I-^\PeT?>t:R6]cU_4ʳ4sJhCQ-EGv C=Boty/J[ϒpKNIk r&$|w sa|?"E\\u>|:hsőR"Aq3b-u29p#k8asOj77(X,(Km՚忙:/!.ph'1>=lv! i.V}|ct.Հ x;K0sD2DA8K I"D˼^B#|]4{L. ]0 " KF|U)@]Rzrdyu({hءf]Kc>],apё0dI0I.8_fM:RFN>$qʇCCR/ /JHE%{23co][ߧ%޴S&wM7RŎԖwWr?JkĮCbEdL3w>92VؗR\7rv%\_JW9ԙpSI$q. 9hIR1ZHP%Җ7E =?#"8=^Cok?vj8s1N@wYe lrޭvw~tB̴- uDpueL]JX%I`0|7T|,m]"|jDw=r&z1r Pn7=*u%/8>"Ibdm ;rʚ'xOSaZ2UQVt#P},_kjr=w 'PJ. Ed5AP̬ dcYq m5qIwC_M)Eg?dh8 ) K:ϵV b#n%jqwLX24=H7* `;ɒOY2DC}En ) $A >XlbkIJkZ{Ϋ̇5sn8cv^ g1(P*LYɗQ *K֣qQݏ#%Pi&%fm;d.V%RFo_z#3y}耍wvn ?iCnͮ2]R[,x +kS_53%Jc2@,7XEnr+Vz}ڗRdO;-;ަsfH}8X v6}̓o85l`4Y;W\uk˟:w&t8X(I@2@UĀ*+$ĄEP,bUp_I2 ]s_c12@.PNz'uKez;HjE3ÊB#At}p KYw{, xQ"b}7Owx\yuʑ @߽()V(RErK1xO>[a93j88Z,6>=|矆\Atm +.N"(䢷:+yE8M{nNWWm|r Y,y˭7öD :xs> en>kx}M7F2gU`;kPWzn 6O#"Ė#`bVoɉ'u_rxx7Ϗw3kR5iaa&A9Wu}K'11(a8CJuQL# jp#i_;촫晜 n^_y ^t؟4Mݲ%/khat TWw]zcl>I147]2rSE4[O)]mOʿxl[UɾW=~ R`<4MS ~ Fo;A%7rq-殔^؁(ĩ-ZLjpHu\>uDz71TCYv7q@Xm)L\ B`QQ2VEWBm0D)26 NuI*UkC~;+Ǿs_-NXEO-?;'iE<%w }/;y>Q};cghDBBAmrLfP(޷nX!@ >JUd[iLEHTecӖ"sSv$P>`ɜ 'f?4~^I$$ C`uI [ÄjIOۖs12X( 蛄>Qm7:p ڔȴfW$͗.dYөtH[4gř[U3m5EB4@{#Z!ue8._)>ůEly,5w:1"DvxӸ3gòIF}2}ō4\ZKbs"(B@6:x1b:o]g O BHC!6w:p9T ܼ>Z6{$khO7{Y02Zg8%hۘ$Oo!qiƞ N"$TY>NQ DoӤɜ6XPU;ms-~wv \\h\SPI\`IrˁfsT >F͸ Փ-H,H'@dZk[>& q/ˆ}[~7c68X[QUr٤*3O47Rw[@WCxۘUmf~XA__<bI7Vc,A7ZŬ6:>ڀu޽/]bP`YSOQ+[ V-\se:U@㧲J!+q-$4vEINJ]B3ӒLgGP DCIZF_[>nm |iy(q )d &^Tvh >7'ML4w?7rUΕ  & `gf}u1uQO(f䟠$0f:5Kꍂe~V]`U/W#I4_i0WĔr9sc825O@B6 $3:Vkeqjaء7k &zPu Ui/@jSNZjKx!>z}u5ۖP곧GمYP]۾វȣ:AIpd1;<$Hh%M'1L(XIX^r3u>m2h'/ +GY\IH`f.[\L6H9= RETZ'QB-9:f>@nu͎,9s+ds|Vg?S [3/kDH~P^O jO(74M /KXr3̇RL[Uۻ>u12Ye_-Z;lo@-Q<.u pߙGMHlOېP d | Fj#{3I[LkI8rKuN,&q%*I@( *`DbHJx7t k?4b@uȃKK H\{2郏n1(Bh+F/STa{_1$h7gĎ vN7d59y N(M!~ V)wOtCHc&78)u tI- թa jkEXn0TV!#,_ư;)(,RkPtBrܧo~ҖJYVo*BSD-HԮ*ag8ψu n9SH%O, 2eߒ !y9SF9В6G^ AvE@"X=(T G c;u8CѴaK%;DB_ #bPI-GѼ?1?wECXS.=-) H+1#s8*FJ=;ԅP*TS1 x]|aymr"lC'J絿Sy_R|[Wg2`Jn? P̀tfJJy |#~>N39=V,"|(,?D I繸͈NX_!> a p ,12<v˰vlSv ⅣߋrbÐ0˧P~)=w34ў>ĩ) ǂ, %w3i'DLP@s"p K N񪝞Q&x&jH\DyEnZn#Ct91(`-AmB1"^>B.:<#YrҴ9:;d\gu6Eߜ:% |5ri 2drN ~:"˗.|' yUPmurTz8]BNۓXN\t e=#^w?n5\듂c9ThDoF*Ӗv = 0)) stopifnot(all(y >= 0)) sqrt(x^2 + y^2) } log1m <- function(x) { log(1 - x) } step <- function(x) { if (is.logical(x)) { warning2( "Consider using int_step() instead of step(), ", "because step(FALSE) = step(TRUE) = 1 in Stan." ) } ifelse(x >= 0, 1, 0) } int_step <- function(x) { ifelse(x > 0, 1, 0) } #' Logarithm with a minus one offset. #' #' Computes \code{log(x - 1)}. #' #' @param x A numeric or complex vector. #' @param base A positive or complex number: the base with respect to which #' logarithms are computed. Defaults to \emph{e} = \code{exp(1)}. #' #' @export logm1 <- function(x, base = exp(1)) { log(x - 1, base = base) } #' Exponential function plus one. #' #' Computes \code{exp(x) + 1}. #' #' @param x A numeric or complex vector. #' #' @export expp1 <- function(x) { exp(x) + 1 } #' Scaled logit-link #' #' Computes \code{logit((x - lb) / (ub - lb))} #' #' @param x A numeric or complex vector. #' @param lb Lower bound defaulting to \code{0}. #' @param ub Upper bound defaulting to \code{1}. #' #' @return A numeric or complex vector. #' #' @export logit_scaled <- function(x, lb = 0, ub = 1) { logit((x - lb) / (ub - lb)) } #' Scaled inverse logit-link #' #' Computes \code{inv_logit(x) * (ub - lb) + lb} #' #' @param x A numeric or complex vector. #' @param lb Lower bound defaulting to \code{0}. #' @param ub Upper bound defaulting to \code{1}. #' #' @return A numeric or complex vector between \code{lb} and \code{ub}. #' #' @export inv_logit_scaled <- function(x, lb = 0, ub = 1) { inv_logit(x) * (ub - lb) + lb } multiply_log <- function(x, y) { ifelse(x == y & x == 0, 0, x * log(y)) } log1p_exp <- function(x) { # approaches identity(x) for x -> Inf out <- log1p(exp(x)) ifelse(out < Inf, out, x) } log1m_exp <- function(x) { ifelse(x < 0, log1p(-exp(x)), NaN) } log_diff_exp <- function(x, y) { stopifnot(length(x) == length(y)) ifelse(x > y, log(exp(x) - exp(y)), NaN) } log_sum_exp <- function(x, y) { max <- pmax(x, y) max + log(exp(x - max) + exp(y - max)) } log_mean_exp <- function(x) { max_x <- max(x) max_x + log(sum(exp(x - max_x))) - log(length(x)) } log_expm1 <- function(x) { # approaches identity(x) for x -> Inf out <- log(expm1(x)) ifelse(out < Inf, out, x) } log_inv_logit <- function(x) { log(inv_logit(x)) } log1m_inv_logit <- function(x) { log(1 - inv_logit(x)) } scale_unit <- function(x, lb = min(x), ub = max(x)) { (x - lb) / (ub - lb) } fabs <- function(x) { abs(x) } log_softmax <- function(x) { ndim <- length(dim(x)) if (ndim <= 1) { x <- matrix(x, nrow = 1) ndim <- length(dim(x)) } dim_noncat <- dim(x)[-ndim] marg_noncat <- seq_along(dim(x))[-ndim] catsum <- log(array(apply(exp(x), marg_noncat, sum), dim = dim_noncat)) sweep(x, marg_noncat, catsum, "-") } softmax <- function(x) { # log_softmax is more numerically stable #1401 exp(log_softmax(x)) } inv_odds <- function(x) { x / (1 + x) } # inspired by logit but with softplus instead of log softit <- function(x) { log_expm1(x / (1 - x)) } # inspired by inv_logit but with softplus instead of exp inv_softit <- function(x) { y <- log1p_exp(x) y / (1 + y) } # inspired by inv_logit but with softplus instead of exp log_inv_softit <- function(x) { y <- log1p_exp(x) log(y) - log1p(y) } # inspired by inv_logit but with softplus instead of exp log1m_inv_softit <- function(x) { y <- log1p_exp(x) -log1p(y) } # names of built-in stan functons reimplemented in R within brms names_stan_functions <- function() { c("logit", "inv_logit", "cloglog", "inv_cloglog", "Phi", "incgamma", "square", "cbrt", "exp2", "pow", "inv", "inv_sqrt", "inv_square", "hypot", "log1m", "step", "logm1", "expp1", "logit_scaled", "inv_logit_scaled", "multiply_log", "log1p_exp", "log1m_exp", "log_diff_exp", "log_sum_exp", "log_mean_exp", "log_expm1", "log_inv_logit", "log1m_inv_logit", "scale_unit", "fabs", "log_softmax", "softmax", "inv_odds", "softit", "inv_softit", "log_inv_softit", "log1m_inv_softit") } # create an environement with all the reimplemented stan functions in it # see issue #1635 for discussion of this approach env_stan_functions <- function(...) { env <- new.env(...) brms_env <- asNamespace("brms") for (f in names_stan_functions()) { env[[f]] <- get(f, brms_env) } env } brms/R/priorsense.R0000644000176200001440000000665515053072461013751 0ustar liggesusers#' Prior sensitivity: Create priorsense data #' #' The \code{create_priorsense_data.brmsfit} method can be used to #' create the data structure needed by the \pkg{priorsense} package #' for performing power-scaling sensitivity analysis. This method is #' called automatically when performing powerscaling via #' \code{\link[priorsense:powerscale]{powerscale}} or other related #' functions, so you will rarely need to call it manually yourself. #' #' @param x A \code{brmsfit} object. #' @param ... Additional arguments passed to \code{\link{log_lik}}, #' for example \code{newdata}. #' #' @return A \code{priorsense_data} object to be used in conjunction #' with the \pkg{priorsense} package. #' #' @examples #' \dontrun{ #' # fit a model with non-uniform priors #' fit <- brm(rating ~ treat + period + carry, #' data = inhaler, family = sratio(), #' prior = set_prior("normal(0, 0.5)")) #' summary(fit) #' #' # The following code requires the 'priorsense' package to be installed: #' library(priorsense) #' #' # perform power-scaling of the prior #' powerscale(fit, alpha = 1.5, component = "prior") #' #' # perform power-scaling sensitivity checks #' powerscale_sensitivity(fit) #' #' # create power-scaling sensitivity plots (for one variable) #' powerscale_plot_dens(fit, variable = "b_treat") #' } #' #' @exportS3Method priorsense::create_priorsense_data brmsfit create_priorsense_data.brmsfit <- function(x, ...) { priorsense::create_priorsense_data( x = get_draws_ps(x), fit = x, log_prior = log_prior_draws.brmsfit(x, ...), log_lik = log_lik_draws.brmsfit(x, ...), log_prior_fn = log_prior_draws.brmsfit, log_lik_fn = log_lik_draws.brmsfit, log_ratio_fn = powerscale_log_ratio, ... ) } #' @exportS3Method priorsense::log_lik_draws log_lik_draws.brmsfit <- function(x, ...) { log_lik <- log_lik(x, ...) # check if log-lik was subset, if so, merge the chains if (nrow(log_lik) < ndraws(x)) { niters <- nrow(log_lik) nchains <- 1 } else { niters <- niterations(x) nchains <- nchains(x) } nobs <- ncol(log_lik) dim(log_lik) <- c(niters, nchains, nobs) log_lik <- as_draws_array(log_lik) posterior::variables(log_lik) <- paste0("log_lik[", seq_len(nobs), "]") log_lik } #' @exportS3Method priorsense::log_prior_draws log_prior_draws.brmsfit <- function(x, log_prior_name = "lprior", ...) { stopifnot(length(log_prior_name) == 1) if (!log_prior_name %in% variables(x)) { warning2("Variable '", log_prior_name, "' was not found. ", "Perhaps you used normalize = FALSE?") } posterior::subset_draws( as_draws_array(x), variable = paste0("^", log_prior_name), regex = TRUE ) } get_draws_ps <- function(x, variable = NULL, regex = FALSE, log_prior_name = "lprior") { excluded_variables <- c(log_prior_name, "lp__") draws <- as_draws_df(x, regex = regex) if (is.null(variable)) { # remove unnecessary variables variable <- variables(x) variable <- variable[!(variable %in% excluded_variables)] draws <- posterior::subset_draws(draws, variable = variable) } draws } powerscale_log_ratio <- function(draws, fit, alpha, component_fn) { component_draws <- component_fn(fit) component_draws <- rowsums_draws(component_draws) component_draws * (alpha - 1) } rowsums_draws <- function(x) { posterior::draws_array( sum = rowSums( as_draws_array(x), dims = 2 ), .nchains = nchains(x) ) } brms/R/formula-cs.R0000644000176200001440000000167314527413457013634 0ustar liggesusers#' Category Specific Predictors in \pkg{brms} Models #' #' @aliases cse #' #' @param expr Expression containing predictors, #' for which category specific effects should be estimated. #' For evaluation, \R formula syntax is applied. #' #' @details For detailed documentation see \code{help(brmsformula)} #' as well as \code{vignette("brms_overview")}. #' #' This function is almost solely useful when #' called in formulas passed to the \pkg{brms} package. #' #' @seealso \code{\link{brmsformula}} #' #' @examples #' \dontrun{ #' fit <- brm(rating ~ period + carry + cs(treat), #' data = inhaler, family = sratio("cloglog"), #' prior = set_prior("normal(0,5)"), chains = 2) #' summary(fit) #' plot(fit, ask = FALSE) #' } #' #' @export cs <- function(expr) { deparse_no_string(substitute(expr)) } # alias of function 'cs' used in the JSS paper of brms #' @export cse <- function(expr) { deparse_no_string(substitute(expr)) } brms/R/conditional_smooths.R0000644000176200001440000002323715053072461015632 0ustar liggesusers#' Display Smooth Terms #' #' Display smooth \code{s} and \code{t2} terms of models #' fitted with \pkg{brms}. #' #' @aliases marginal_smooths marginal_smooths.brmsfit #' #' @inheritParams conditional_effects.brmsfit #' @param smooths Optional character vector of smooth terms #' to display. If \code{NULL} (the default) all smooth terms #' are shown. #' @param surface Logical. Indicates if interactions or #' two-dimensional smooths should be visualized as a surface. #' Defaults to \code{TRUE}. The surface type can be controlled #' via argument \code{stype} of the related plotting method. #' @param ndraws Positive integer indicating how many #' posterior draws should be used. #' If \code{NULL} (the default) all draws are used. #' Ignored if \code{draw_ids} is not \code{NULL}. #' @param draw_ids An integer vector specifying #' the posterior draws to be used. #' If \code{NULL} (the default), all draws are used. #' @param nsamples Deprecated alias of \code{ndraws}. #' @param subset Deprecated alias of \code{draw_ids}. #' @param ... Currently ignored. #' #' @return For the \code{brmsfit} method, #' an object of class \code{brms_conditional_effects}. See #' \code{\link{conditional_effects}} for #' more details and documentation of the related plotting function. #' #' @details Two-dimensional smooth terms will be visualized using #' either contour or raster plots. #' #' @examples #' \dontrun{ #' set.seed(0) #' dat <- mgcv::gamSim(1, n = 200, scale = 2) #' fit <- brm(y ~ s(x0) + s(x1) + s(x2) + s(x3), data = dat) #' # show all smooth terms #' plot(conditional_smooths(fit), rug = TRUE, ask = FALSE) #' # show only the smooth term s(x2) #' plot(conditional_smooths(fit, smooths = "s(x2)"), ask = FALSE) #' #' # fit and plot a two-dimensional smooth term #' fit2 <- brm(y ~ t2(x0, x2), data = dat) #' ms <- conditional_smooths(fit2) #' plot(ms, stype = "contour") #' plot(ms, stype = "raster") #' } #' #' @export conditional_smooths.brmsfit <- function(x, smooths = NULL, int_conditions = NULL, prob = 0.95, spaghetti = FALSE, surface = TRUE, resolution = 100, too_far = 0, ndraws = NULL, draw_ids = NULL, nsamples = NULL, subset = NULL, probs = NULL, ...) { probs <- validate_ci_bounds(prob, probs = probs) spaghetti <- as_one_logical(spaghetti) surface <- as_one_logical(surface) draw_ids <- use_alias(draw_ids, subset) ndraws <- use_alias(ndraws, nsamples) contains_draws(x) x <- restructure(x) x <- exclude_terms(x, incl_autocor = FALSE) smooths <- rm_wsp(as.character(smooths)) conditions <- prepare_conditions(x) draw_ids <- validate_draw_ids(x, draw_ids, ndraws) bterms <- brmsterms(exclude_terms(x$formula, smooths_only = TRUE)) out <- conditional_smooths( bterms, fit = x, smooths = smooths, conditions = conditions, int_conditions = int_conditions, too_far = too_far, resolution = resolution, probs = probs, spaghetti = spaghetti, surface = surface, draw_ids = draw_ids ) if (!length(out)) { stop2("No valid smooth terms found in the model.") } structure(out, class = "brms_conditional_effects", smooths_only = TRUE) } #' @rdname conditional_smooths.brmsfit #' @export conditional_smooths <- function(x, ...) { UseMethod("conditional_smooths") } #' @export conditional_smooths.default <- function(x, ...) { NULL } #' @export conditional_smooths.mvbrmsterms <- function(x, ...) { out <- list() for (r in names(x$terms)) { c(out) <- conditional_smooths(x$terms[[r]], ...) } out } #' @export conditional_smooths.brmsterms <- function(x, ...) { out <- list() for (dp in names(x$dpars)) { c(out) <- conditional_smooths(x$dpars[[dp]], ...) } for (nlp in names(x$nlpars)) { c(out) <- conditional_smooths(x$nlpars[[nlp]], ...) } out } # conditional smooths for a single predicted parameter # @param fit brmsfit object # @param smooths optional names of smooth terms to plot # @param conditions output of prepare_conditions # @param int_conditions values of by-vars at which to evalute smooths # @param ...: currently ignored # @return a named list with one element per smooth term #' @export conditional_smooths.btl <- function(x, fit, smooths, conditions, int_conditions, probs, resolution, too_far, spaghetti, surface, ...) { stopifnot(is.brmsfit(fit)) out <- list() mf <- model.frame(fit) smframe <- frame_sm(x, mf) # fixes issue #1265 smframe$term <- rm_wsp(smframe$term) smterms <- unique(smframe$term) if (!length(smooths)) { I <- seq_along(smterms) } else { I <- which(smterms %in% smooths) } for (i in I) { # loop over smooth terms and compute their predictions smooth <- smterms[i] sub_smframe <- subset2(smframe, term = smooth) # extract raw variable names before transformations covars <- all_vars(sub_smframe$covars[[1]]) byvars <- all_vars(sub_smframe$byvars[[1]]) if (length(covars) > 2L) { # show additional covariates via facetting byvars <- c(covars[-(1:2)], byvars) covars <- covars[1:2] } else if (length(covars) == 1L && length(byvars)) { # move first byvar to covars to reduce facetting covars <- c(covars, byvars[1]) byvars <- byvars[-1] } vars <- c(covars, byvars) values <- named_list(vars) is_numeric <- setNames(rep(FALSE, length(covars)), covars) for (cv in covars) { is_numeric[cv] <- is.numeric(mf[[cv]]) is_second_covar <- isTRUE(cv == covars[2]) if (cv %in% names(int_conditions)) { int_cond <- int_conditions[[cv]] if (is.function(int_cond)) { int_cond <- int_cond(mf[[cv]]) } values[[cv]] <- int_cond } else if (is_numeric[cv]) { if (!surface && is_second_covar) { mean2 <- mean(mf[[cv]], na.rm = TRUE) sd2 <- sd(mf[[cv]], na.rm = TRUE) values[[cv]] <- (-1:1) * sd2 + mean2 } else { values[[cv]] <- seq( min(mf[[cv]]), max(mf[[cv]]), length.out = resolution ) } } else { values[[cv]] <- levels(factor(mf[[cv]])) } } for (cv in byvars) { if (cv %in% names(int_conditions)) { int_cond <- int_conditions[[cv]] if (is.function(int_cond)) { int_cond <- int_cond(mf[[cv]]) } values[[cv]] <- int_cond } else if (is.numeric(mf[[cv]])) { mean2 <- mean(mf[[cv]], na.rm = TRUE) sd2 <- sd(mf[[cv]], na.rm = TRUE) values[[cv]] <- (-1:1) * sd2 + mean2 } else { values[[cv]] <- levels(factor(mf[[cv]])) } } newdata <- expand.grid(values) # indicates whether a surface will actually be plotted show_surface <- surface && length(covars) == 2L && all(is_numeric) if (show_surface && too_far > 0) { # exclude prediction grid points too far from data ex_too_far <- mgcv::exclude.too.far( g1 = newdata[[covars[1]]], g2 = newdata[[covars[2]]], d1 = mf[, covars[1]], d2 = mf[, covars[2]], dist = too_far ) newdata <- newdata[!ex_too_far, ] } other_vars <- setdiff(names(conditions), vars) newdata <- fill_newdata(newdata, other_vars, conditions) eta <- posterior_smooths(x, fit, smooth, newdata, ...) effects <- na.omit(covars[1:2]) cond_data <- add_effects__(newdata[, vars, drop = FALSE], effects) second_numeric <- isTRUE(is_numeric[2]) if (second_numeric && !surface) { # only convert 'effect2__' to factor so that the original # second effect variable remains unchanged in the data mde2 <- round(cond_data[[effects[2]]], 2) levels2 <- sort(unique(mde2), TRUE) cond_data$effect2__ <- factor(mde2, levels = levels2) labels2 <- names(int_conditions[[effects[2]]]) if (length(labels2) == length(levels2)) { levels(cond_data$effect2__) <- labels2 } } if (length(byvars)) { # byvars will be plotted as facets cond_data$cond__ <- rows2labels(cond_data[, byvars, drop = FALSE]) } else { cond_data$cond__ <- factor(1) } spa_data <- NULL if (spaghetti && !show_surface && is_numeric[1]) { sample <- rep(seq_rows(eta), each = ncol(eta)) if (length(covars) == 2L) { # draws should be unique across plotting groups sample <- paste0(sample, "_", cond_data[[effects[2]]]) } spa_data <- data.frame(as.numeric(t(eta)), factor(sample)) colnames(spa_data) <- c("estimate__", "sample__") spa_data <- cbind(cond_data, spa_data) } eta <- posterior_summary(eta, robust = TRUE, probs = probs) colnames(eta) <- c("estimate__", "se__", "lower__", "upper__") eta <- cbind(cond_data, eta) response <- combine_prefix(x, keep_mu = TRUE) response <- paste0(response, ": ", smooth) points <- mf[, vars, drop = FALSE] points <- add_effects__(points, covars) attr(eta, "response") <- response attr(eta, "effects") <- effects attr(eta, "surface") <- show_surface attr(eta, "spaghetti") <- spa_data attr(eta, "points") <- points out[[response]] <- eta } out } # the name 'marginal_smooths' is deprecated as of brms 2.10.3 # do not remove it eventually as it has been used in the brms papers #' @export marginal_smooths <- function(x, ...) { UseMethod("marginal_smooths") } #' @export marginal_smooths.brmsfit <- function(x, ...) { warning2("Method 'marginal_smooths' is deprecated. ", "Please use 'conditional_smooths' instead.") conditional_smooths.brmsfit(x, ...) } brms/R/diagnostics.R0000644000176200001440000000676214527413457014077 0ustar liggesusers#' Extract Diagnostic Quantities of \pkg{brms} Models #' #' Extract quantities that can be used to diagnose sampling behavior #' of the algorithms applied by \pkg{Stan} at the back-end of \pkg{brms}. #' #' @name diagnostic-quantities #' @aliases log_posterior nuts_params rhat neff_ratio #' #' @param object,x A \code{brmsfit} object. #' @param pars An optional character vector of parameter names. #' For \code{nuts_params} these will be NUTS sampler parameter #' names rather than model parameters. If pars is omitted #' all parameters are included. #' @param ... Arguments passed to individual methods. #' #' @return The exact form of the output depends on the method. #' #' @details For more details see #' \code{\link[bayesplot:bayesplot-extractors]{bayesplot-extractors}}. #' #' @examples #' \dontrun{ #' fit <- brm(time ~ age * sex, data = kidney) #' #' lp <- log_posterior(fit) #' head(lp) #' #' np <- nuts_params(fit) #' str(np) #' # extract the number of divergence transitions #' sum(subset(np, Parameter == "divergent__")$Value) #' #' head(rhat(fit)) #' head(neff_ratio(fit)) #' } NULL #' @rdname diagnostic-quantities #' @importFrom bayesplot log_posterior #' @export log_posterior #' @export log_posterior.brmsfit <- function(object, ...) { contains_draws(object) bayesplot::log_posterior(object$fit, ...) } #' @rdname diagnostic-quantities #' @importFrom bayesplot nuts_params #' @export nuts_params #' @export nuts_params.brmsfit <- function(object, pars = NULL, ...) { contains_draws(object) bayesplot::nuts_params(object$fit, pars = pars, ...) } #' @rdname diagnostic-quantities #' @importFrom posterior rhat #' @export rhat #' @export rhat.brmsfit <- function(x, pars = NULL, ...) { contains_draws(x) # bayesplot uses outdated rhat code from rstan # bayesplot::rhat(object$fit, pars = pars, ...) draws <- as_draws_array(x, variable = pars, ...) tmp <- posterior::summarise_draws(draws, rhat = posterior::rhat) rhat <- tmp$rhat names(rhat) <- tmp$variable rhat } #' @rdname diagnostic-quantities #' @importFrom bayesplot neff_ratio #' @export neff_ratio #' @export neff_ratio.brmsfit <- function(object, pars = NULL, ...) { contains_draws(object) # bayesplot uses outdated ess code from rstan # bayesplot::neff_ratio(object$fit, pars = pars, ...) draws <- as_draws_array(object, variable = pars, ...) tmp <- posterior::summarise_draws( draws, ess_bulk = posterior::ess_bulk, ess_tail = posterior::ess_tail ) # min of ess_bulk and ess_tail mimics definition of posterior::rhat.default ess <- matrixStats::rowMins(cbind(tmp$ess_bulk, tmp$ess_tail)) names(ess) <- tmp$variable ess / ndraws(draws) } #' Extract Control Parameters of the NUTS Sampler #' #' Extract control parameters of the NUTS sampler such as #' \code{adapt_delta} or \code{max_treedepth}. #' #' @param x An \R object #' @param pars Optional names of the control parameters to be returned. #' If \code{NULL} (the default) all control parameters are returned. #' See \code{\link[rstan:stan]{stan}} for more details. #' @param ... Currently ignored. #' #' @return A named \code{list} with control parameter values. #' #' @export control_params <- function(x, ...) { UseMethod("control_params") } #' @rdname control_params #' @export control_params.brmsfit <- function(x, pars = NULL, ...) { contains_draws(x) if (is_equal(x$backend, "cmdstanr")) { out <- attr(x$fit, "metadata")$metadata } else { out <- attr(x$fit@sim$samples[[1]], "args")$control } if (!is.null(pars)) { out <- out[pars] } out } brms/R/model_weights.R0000644000176200001440000002730615053072461014406 0ustar liggesusers#' Model Weighting Methods #' #' Compute model weights in various ways, for instance, via #' stacking of posterior predictive distributions, Akaike weights, #' or marginal likelihoods. #' #' @inheritParams loo.brmsfit #' @param weights Name of the criterion to compute weights from. Should be one #' of \code{"loo"}, \code{"waic"}, \code{"kfold"}, \code{"stacking"} (current #' default), \code{"bma"}, or \code{"pseudobma"}. For the former three #' options, Akaike weights will be computed based on the information criterion #' values returned by the respective methods. For \code{"stacking"} and #' \code{"pseudobma"}, method \code{\link{loo_model_weights}} will be used to #' obtain weights. For \code{"bma"}, method \code{\link{post_prob}} will be #' used to compute Bayesian model averaging weights based on log marginal #' likelihood values (make sure to specify reasonable priors in this case). #' For some methods, \code{weights} may also be a numeric vector of #' pre-specified weights. #' #' @return A numeric vector of weights for the models. #' #' @examples #' \dontrun{ #' # model with 'treat' as predictor #' fit1 <- brm(rating ~ treat + period + carry, data = inhaler) #' summary(fit1) #' #' # model without 'treat' as predictor #' fit2 <- brm(rating ~ period + carry, data = inhaler) #' summary(fit2) #' #' # obtain Akaike weights based on the WAIC #' model_weights(fit1, fit2, weights = "waic") #' } #' #' @export model_weights.brmsfit <- function(x, ..., weights = "stacking", model_names = NULL) { weights <- validate_weights_method(weights) args <- split_dots(x, ..., model_names = model_names) models <- args$models args$models <- NULL model_names <- names(models) if (weights %in% c("loo", "waic", "kfold")) { # Akaike weights based on information criteria ics <- rep(NA, length(models)) for (i in seq_along(ics)) { args$x <- models[[i]] args$model_names <- names(models)[i] ics[i] <- SW(do_call(weights, args))$estimates[3, 1] } ic_diffs <- ics - min(ics) out <- exp(-ic_diffs / 2) } else if (weights %in% c("stacking", "pseudobma")) { args <- c(unname(models), args) args$method <- weights out <- do_call("loo_model_weights", args) } else if (weights %in% "bma") { args <- c(unname(models), args) out <- do_call("post_prob", args) } out <- as.numeric(out) out <- out / sum(out) names(out) <- model_names out } #' @rdname model_weights.brmsfit #' @export model_weights <- function(x, ...) { UseMethod("model_weights") } # validate name of the applied weighting method validate_weights_method <- function(method) { method <- as_one_character(method) method <- tolower(method) if (method == "loo2") { warning2("Weight method 'loo2' is deprecated. Use 'stacking' instead.") method <- "stacking" } if (method == "marglik") { warning2("Weight method 'marglik' is deprecated. Use 'bma' instead.") method <- "bma" } options <- c("loo", "waic", "kfold", "stacking", "pseudobma", "bma") match.arg(method, options) } #' Posterior predictive draws averaged across models #' #' Compute posterior predictive draws averaged across models. #' Weighting can be done in various ways, for instance using #' Akaike weights based on information criteria or #' marginal likelihoods. #' #' @inheritParams model_weights.brmsfit #' @param method Method used to obtain predictions to average over. Should be #' one of \code{"posterior_predict"} (default), \code{"posterior_epred"}, #' \code{"posterior_linpred"} or \code{"predictive_error"}. #' @param control Optional \code{list} of further arguments #' passed to the function specified in \code{weights}. #' @param ndraws Total number of posterior draws to use. #' @param nsamples Deprecated alias of \code{ndraws}. #' @param seed A single numeric value passed to \code{\link{set.seed}} #' to make results reproducible. #' @param summary Should summary statistics #' (i.e. means, sds, and 95\% intervals) be returned #' instead of the raw values? Default is \code{TRUE}. #' @param robust If \code{FALSE} (the default) the mean is used as #' the measure of central tendency and the standard deviation as #' the measure of variability. If \code{TRUE}, the median and the #' median absolute deviation (MAD) are applied instead. #' Only used if \code{summary} is \code{TRUE}. #' @param probs The percentiles to be computed by the \code{quantile} #' function. Only used if \code{summary} is \code{TRUE}. #' #' @return Same as the output of the method specified #' in argument \code{method}. #' #' @details Weights are computed with the \code{\link{model_weights}} method. #' #' @seealso \code{\link{model_weights}}, \code{\link{posterior_average}} #' #' @examples #' \dontrun{ #' # model with 'treat' as predictor #' fit1 <- brm(rating ~ treat + period + carry, data = inhaler) #' summary(fit1) #' #' # model without 'treat' as predictor #' fit2 <- brm(rating ~ period + carry, data = inhaler) #' summary(fit2) #' #' # compute model-averaged predicted values #' (df <- unique(inhaler[, c("treat", "period", "carry")])) #' pp_average(fit1, fit2, newdata = df) #' #' # compute model-averaged fitted values #' pp_average(fit1, fit2, method = "fitted", newdata = df) #' } #' #' @export pp_average.brmsfit <- function( x, ..., weights = "stacking", method = "posterior_predict", ndraws = NULL, nsamples = NULL, summary = TRUE, probs = c(0.025, 0.975), robust = FALSE, model_names = NULL, control = list(), seed = NULL ) { if (!is.null(seed)) { set.seed(seed) } method <- validate_pp_method(method) ndraws <- use_alias(ndraws, nsamples) if (any(c("draw_ids", "subset") %in% names(list(...)))) { stop2("Cannot use argument 'draw_ids' in pp_average.") } args <- split_dots(x, ..., model_names = model_names) args$summary <- FALSE models <- args$models args$models <- NULL if (!match_response(models)) { stop2("Can only average models predicting the same response.") } if (is.null(ndraws)) { ndraws <- ndraws(models[[1]]) } ndraws <- as_one_integer(ndraws) weights <- validate_weights(weights, models, control) ndraws <- round_largest_remainder(weights * ndraws) names(weights) <- names(ndraws) <- names(models) out <- named_list(names(models)) for (i in seq_along(out)) { if (ndraws[i] > 0) { args$object <- models[[i]] args$ndraws <- ndraws[i] out[[i]] <- do_call(method, args) } } out <- do_call(rbind, out) if (summary) { out <- posterior_summary(out, probs = probs, robust = robust) } attr(out, "weights") <- weights attr(out, "ndraws") <- ndraws out } #' @rdname pp_average.brmsfit #' @export pp_average <- function(x, ...) { UseMethod("pp_average") } # validate weights passed to model averaging functions # see pp_average.brmsfit for more documentation validate_weights <- function(weights, models, control = list()) { if (!is.numeric(weights)) { weight_args <- c(unname(models), control) weight_args$weights <- weights weights <- do_call(model_weights, weight_args) } else { if (length(weights) != length(models)) { stop2("If numeric, 'weights' must have the same length ", "as the number of models.") } if (any(weights < 0)) { stop2("If numeric, 'weights' must be positive.") } } weights / sum(weights) } #' Posterior draws of parameters averaged across models #' #' Extract posterior draws of parameters averaged across models. #' Weighting can be done in various ways, for instance using #' Akaike weights based on information criteria or #' marginal likelihoods. #' #' @inheritParams pp_average.brmsfit #' @param variable Names of variables (parameters) for which to average across #' models. Only those variables can be averaged that appear in every model. #' Defaults to all overlapping variables. #' @param pars Deprecated alias of \code{variable}. #' @param missing An optional numeric value or a named list of numeric values #' to use if a model does not contain a variable for which posterior draws #' should be averaged. Defaults to \code{NULL}, in which case only those #' variables can be averaged that are present in all of the models. #' #' @return A \code{data.frame} of posterior draws. #' #' @details Weights are computed with the \code{\link{model_weights}} method. #' #' @seealso \code{\link{model_weights}}, \code{\link{pp_average}} #' #' @examples #' \dontrun{ #' # model with 'treat' as predictor #' fit1 <- brm(rating ~ treat + period + carry, data = inhaler) #' summary(fit1) #' #' # model without 'treat' as predictor #' fit2 <- brm(rating ~ period + carry, data = inhaler) #' summary(fit2) #' #' # compute model-averaged posteriors of overlapping parameters #' posterior_average(fit1, fit2, weights = "waic") #' } #' #' @export posterior_average.brmsfit <- function( x, ..., variable = NULL, pars = NULL, weights = "stacking", ndraws = NULL, nsamples = NULL, missing = NULL, model_names = NULL, control = list(), seed = NULL ) { if (!is.null(seed)) { set.seed(seed) } variable <- use_alias(variable, pars) ndraws <- use_alias(ndraws, nsamples) models <- split_dots(x, ..., model_names = model_names, other = FALSE) vars_list <- lapply(models, variables) all_vars <- unique(unlist(vars_list)) if (is.null(missing)) { common_vars <- lapply(vars_list, function(x) all_vars %in% x) common_vars <- all_vars[Reduce("&", common_vars)] if (is.null(variable)) { variable <- setdiff(common_vars, "lp__") } variable <- as.character(variable) inv_vars <- setdiff(variable, common_vars) if (length(inv_vars)) { inv_vars <- collapse_comma(inv_vars) stop2( "Parameters ", inv_vars, " cannot be found in all ", "of the models. Consider using argument 'missing'." ) } } else { if (is.null(variable)) { variable <- setdiff(all_vars, "lp__") } variable <- as.character(variable) inv_vars <- setdiff(variable, all_vars) if (length(inv_vars)) { inv_vars <- collapse_comma(inv_vars) stop2("Parameters ", inv_vars, " cannot be found in any of the models.") } if (is.list(missing)) { all_miss_vars <- unique(ulapply( models, function(m) setdiff(variable, variables(m)) )) inv_vars <- setdiff(all_miss_vars, names(missing)) if (length(inv_vars)) { stop2("Argument 'missing' has no value for parameters ", collapse_comma(inv_vars), ".") } missing <- lapply(missing, as_one_numeric, allow_na = TRUE) } else { missing <- as_one_numeric(missing, allow_na = TRUE) missing <- named_list(variable, missing) } } if (is.null(ndraws)) { ndraws <- ndraws(models[[1]]) } ndraws <- as_one_integer(ndraws) weights <- validate_weights(weights, models, control) ndraws <- round_largest_remainder(weights * ndraws) names(weights) <- names(ndraws) <- names(models) out <- named_list(names(models)) for (i in seq_along(out)) { if (ndraws[i] > 0) { draw <- sample(seq_len(ndraws(models[[i]])), ndraws[i]) draw <- sort(draw) found_vars <- intersect(variable, variables(models[[i]])) if (length(found_vars)) { out[[i]] <- as.data.frame( models[[i]], variable = found_vars, draw = draw ) } else { out[[i]] <- as.data.frame(matrix( numeric(0), nrow = ndraws[i], ncol = 0 )) } if (!is.null(missing)) { miss_vars <- setdiff(variable, names(out[[i]])) if (length(miss_vars)) { out[[i]][miss_vars] <- missing[miss_vars] } } } } out <- do_call(rbind, out) rownames(out) <- NULL attr(out, "weights") <- weights attr(out, "ndraws") <- ndraws out } #' @rdname posterior_average.brmsfit #' @export posterior_average <- function(x, ...) { UseMethod("posterior_average") } brms/R/stan-helpers.R0000644000176200001440000001100715053072461014150 0ustar liggesusers# unless otherwise specified, functions return a named list # of Stan code snippets to be pasted together later on # link function in Stan language # @param link name of the link function # @param transform actually apply the link function? stan_link <- function(link, transform = TRUE) { transform <- as_one_logical(transform %||% FALSE) if (!transform) { # we have a Stan lpdf that applies the link automatically # or we have a non-linear parameter that has no link function return("") } out <- switch( link, identity = "", log = "log", logm1 = "logm1", inverse = "inv", sqrt = "sqrt", "1/mu^2" = "inv_square", logit = "logit", probit = "inv_Phi", probit_approx = "inv_Phi", cloglog = "cloglog", cauchit = "cauchit", tan_half = "tan_half", log1p = "log1p", softplus = "log_expm1", squareplus = "inv_squareplus", softit = "softit" ) out } # inverse link in Stan language # @param link name of the link function # @param transform actually apply the inv_link function? stan_inv_link <- function(link, transform = TRUE) { transform <- as_one_logical(transform %||% FALSE) if (!transform) { # we have a Stan lpdf that applies the inv_link automatically # or we have a non-linear parameter that has no link function return("") } out <- switch( link, identity = "", log = "exp", logm1 = "expp1", inverse = "inv", sqrt = "square", "1/mu^2" = "inv_sqrt", logit = "inv_logit", probit = "Phi", probit_approx = "Phi_approx", cloglog = "inv_cloglog", cauchit = "inv_cauchit", tan_half = "inv_tan_half", log1p = "expm1", softplus = "log1p_exp", squareplus = "squareplus", softit = "inv_softit" ) out } # define a vector in Stan language stan_vector <- function(...) { paste0("transpose([", paste0(c(...), collapse = ", "), "])") } # prepare Stan code for correlations in the generated quantities block # @param cor name of the correlation vector # @param ncol number of columns of the correlation matrix stan_cor_gen_comp <- function(cor, ncol) { Cor <- paste0(toupper(substring(cor, 1, 1)), substring(cor, 2)) glue( " // extract upper diagonal of correlation matrix\n", " for (k in 1:{ncol}) {{\n", " for (j in 1:(k - 1)) {{\n", " {cor}[choose(k - 1, 2) + j] = {Cor}[j, k];\n", " }}\n", " }}\n" ) } # indicates if a family-link combination has a built in # function in Stan (such as binomial_logit) # @param bterms brmsterms object of the univariate model # @param family a list with elements 'family' and 'link' # ideally a (brms)family object stan_has_built_in_fun <- function(bterms, family = NULL) { stopifnot(is.brmsterms(bterms)) family <- family %||% bterms$family stopifnot(all(c("family", "link") %in% names(family))) link <- family[["link"]] dpar <- family[["dpar"]] # only few families have special lcdf and lccdf functions cdf <- has_ad_terms(bterms, c("cens", "trunc")) has_built_in_fun(family, link, cdf = cdf) || has_built_in_fun(bterms, link, dpar = dpar, cdf = cdf) } # get all variable names accepted in Stan stan_all_vars <- function(x) { x <- gsub("\\.", "+", x) all_vars(x) } # transform names to be used as variable names in Stan make_stan_names <- function(x) { gsub("\\.|_", "", make.names(x, unique = TRUE)) } # functions to handle indexing when threading stan_slice <- function(threads) { str_if(use_threading(threads), "[start:end]") } stan_nn <- function(threads) { str_if(use_threading(threads), "[nn]", "[n]") } stan_nn_def <- function(threads) { str_if(use_threading(threads), " int nn = n + start - 1;\n") } stan_nn_regex <- function() { "\\[((n)|(nn))\\]" } # clean up arguments for partial_log_lik # @param ... strings containing arguments of the form ', type identifier' # @return named list of two elements: # typed: types + identifiers for use in the function header # plain: identifiers only for use in the function call stan_clean_pll_args <- function(...) { args <- paste0(...) # split up header to remove duplicates typed <- unlist(strsplit(args, ", +"))[-1] typed <- unique(typed) plain <- rm_wsp(get_matches(" [^ ]+$", typed)) typed <- collapse(", ", typed) plain <- collapse(", ", plain) nlist(typed, plain) } # prepare a string to be used as comment in Stan stan_comment <- function(comment, wsp = 2) { comment <- as.character(comment) wsp <- wsp(nsp = wsp) if (!length(comment)) { return(character(0)) } ifelse(nzchar(comment), paste0(wsp, "// ", comment), "") } brms/R/brmsframe.R0000644000176200001440000003035615053305627013534 0ustar liggesusers# The brmsframe methods are combining formula with data information in # such a way that it can be used across the full range of primary brms # functions, including brm, stancode, standata, prepare_predictions etc. # Before brmsframe was introduced, a lot of of the frame_ functions had to # be run many times at different places of the pre- and post-processing functions, # which was uncessarily wasteful. To avoid this, brmsframe also computes # some parts of the Stan data already (see brmsframe.btl), which is automatically # reused in standata to avoid redundant function evaluations. brmsframe <- function(x, ...) { UseMethod("brmsframe") } # @param basis information from original Stan data used to correctly # predict from newdata. See 'frame_basis' for details. #' @export brmsframe.mvbrmsterms <- function(x, data, basis = NULL, ...) { x$frame <- initialize_frame(x, data = data, basis = basis, ...) for (r in names(x$terms)) { x$terms[[r]] <- brmsframe( x$terms[[r]], data = data, frame = x$frame, basis = basis$resps[[r]], ... ) } class(x) <- c("mvbrmsframe", class(x)) x } #' @export brmsframe.brmsterms <- function(x, data, frame = NULL, basis = NULL, ...) { if (is.null(frame)) { # this is a univariate model so brmsterms is at the top level x$frame <- initialize_frame(x, data = data, basis = basis, ...) } else { # this must be a multivariate model stopifnot(is.list(frame)) x$frame <- frame x$frame$re <- subset2(x$frame$re, resp = x$resp) } if (!is.null(basis)) { x$frame$basis <- basis[c("resp_levels")] } data <- subset_data(data, x) x$frame$resp <- frame_resp(x, data = data) x$frame$ac <- frame_ac(x, data = data) for (dp in names(x$dpars)) { x$dpars[[dp]] <- brmsframe( x$dpars[[dp]], data, frame = x$frame, basis = basis$dpars[[dp]], ... ) } for (nlp in names(x$nlpars)) { x$nlpars[[nlp]] <- brmsframe( x$nlpars[[nlp]], data, frame = x$frame, basis = basis$nlpars[[nlp]], ... ) } class(x) <- c("brmsframe", class(x)) x } # This methods handles the intricate relationship of frame_ and data_ functions. # In some cases, frame_ functions are computed from their data_ function's # output, but in some other cases, it is the other way around. This is slightly # inconsistent but avoids code duplication as much as possible, reflecting # the different ways formula terms are evaluated in brms #' @export brmsframe.btl <- function(x, data, frame = list(), basis = NULL, ...) { stopifnot(is.list(frame)) # the outputs of these data_ functions are required in the corresponding # frame_ functions (but not vice versa) and are thus evaluated first x$frame <- frame x$basis <- basis x$sdata <- list( fe = data_fe(x, data), cs = data_cs(x, data), sm = data_sm(x, data) ) # this enables overwriting of frames if necessary x$frame$fe <- frame_fe(x) x$frame$cs <- frame_cs(x) x$frame$sm <- frame_sm(x) x$frame$sp <- frame_sp(x, data = data) x$frame$gp <- frame_gp(x, data = data) x$frame$ac <- frame_ac(x, data = data) # only store the ranefs of this specific linear formula x$frame$re <- subset2(frame$re, ls = check_prefix(x)) class(x) <- c("bframel", class(x)) # these data_ functions may require the outputs of the corresponding # frame_ functions (but not vice versa) and are thus evaluated last x$sdata$gp <- data_gp(x, data, internal = TRUE) x$sdata$offset <- data_offset(x, data) x } #' @export brmsframe.btnl <- function(x, data, frame = list(), basis = NULL, ...) { stopifnot(is.list(frame)) x$frame <- frame x$basis <- basis x$sdata <- list( cnl = data_cnl(x, data) ) x$frame$cnl <- frame_cnl(x) x$frame$ac <- frame_ac(x, data = data) class(x) <- c("bframenl", class(x)) x } #' @export brmsframe.default <- function(x, ...) { brmsframe(brmsterms(x), ...) } # initialize the $frame list with general information initialize_frame <- function(x, data, basis = NULL, ...) { old_levels <- basis$group_levels out <- list( re = frame_re(x, data = data, old_levels = old_levels), me = frame_me(x, data = data, old_levels = old_levels), index = frame_index(x, data = data) ) if (!is.null(old_levels)) { # this can only happen in post-processing potentially with newdata # knowing both new and old indices in important in prepare_predictions set_levels(out) <- old_levels set_levels(out, "used") <- get_levels(out, prefix = "used") } else { set_levels(out) <- get_levels(out) } out } frame_resp <- function(x, data, ....) { stopifnot(is.brmsterms(x)) y <- model.response(model.frame(x$respform, data, na.action = na.pass)) out <- list( values = y, bounds = trunc_bounds(x, data), Ybounds = trunc_bounds(x, data, incl_family = TRUE, stan = TRUE), Jmi = as.array(which(is.na(y))), subset = attr(data, "subset") ) out } frame_fe <- function(x, data = NULL, ...) { stopifnot(is.btl(x)) sdata <- x$sdata$fe if (is.null(sdata)) { sdata <- data_fe(x, data) } out <- list( vars = colnames(x$sdata$fe$X), center = stan_center_X(x), sparse = is_sparse(x$fe), decomp = get_decomp(x$fe) ) out$vars_stan <- out$vars if (out$center) { out$vars_stan <- setdiff(out$vars_stan, "Intercept") } out } frame_cs <- function(x, data = NULL, ...) { stopifnot(is.btl(x)) sdata <- x$sdata$cs if (is.null(sdata)) { sdata <- data_cs(x, data) } out <- list(vars = colnames(x$sdata$cs$Xcs)) out } frame_cnl <- function(x, data, ...) { stopifnot(is.btnl(x)) covars <- all.vars(x$covars) if (!length(covars)) { return(empty_data_frame()) } sdata <- x$sdata$cnl if (is.null(sdata)) { sdata <- data_cnl(x, data) } out <- data.frame( covar = covars, integer = FALSE, matrix = FALSE, dim2 = 0 ) p <- usc(combine_prefix(x)) for (i in seq_along(covars)) { cname <- glue("C{p}_{i}") cvalues <- x$sdata$cnl[[cname]] out$integer[i] <- is.integer(cvalues) out$matrix[i] <- is.matrix(cvalues) if (out$matrix[i]) { out$dim2[i] <- dim(cvalues)[2] } } out } is.brmsframe <- function(x) { inherits(x, "brmsframe") } is.mvbrmsframe <- function(x) { inherits(x, "mvbrmsframe") } # useful for functions that require either of the two objects is.anybrmsframe <- function(x) { is.brmsframe(x) || is.mvbrmsframe(x) } is.bframel <- function(x) { inherits(x, "bframel") } is.bframenl <- function(x) { inherits(x, "bframenl") } # assignment function to store levels as an attribute 'set_levels<-' <- function(x, prefix = "", value) { prefix_ <- usc(prefix, "suffix") attr_name <- paste0(prefix_, "levels") attr(x, attr_name) <- value x } # extract list of levels with one element per grouping factor # assumes that levels have been stored as a 'levels' attribute get_levels <- function(x, ...) { UseMethod("get_levels") } #' @export get_levels.default <- function(x, prefix = "", ...) { prefix_ <- usc(prefix, "suffix") attr_name <- paste0(prefix_, "levels") attr(x, attr_name, exact = TRUE) } #' @export get_levels.list <- function(x, ...) { out <- get_levels.default(x, ...) if (!is.null(out)) { return(out) } out <- vector("list", length(x)) for (i in seq_along(out)) { levels <- get_levels(x[[i]], ...) if (!length(levels)) { next } if (is.list(levels)) { stopifnot(!is.null(names(levels))) out[[i]] <- as.list(levels) } else if (is.vector(levels)) { name_i <- names(x)[i] stopifnot(isTRUE(nzchar(name_i))) out[[i]] <- setNames(list(levels), name_i) } } out <- unlist(out, recursive = FALSE) out[!duplicated(names(out))] } #' @export get_levels.brmsterms <- function(x, data = NULL, ...) { # if available, precomputed levels are stored in x$frame out <- get_levels(x$frame, ...) if (!is.null(out)) { return(out) } if (!is.null(data)) { ls <- list(frame_re_levels_only(x, data), frame_me(x, data)) out <- get_levels(ls) } out } #' @export get_levels.mvbrmsterms <- function(x, data = NULL, ...) { get_levels.brmsterms(x, data = data, ...) } # prepare basis data required for correct predictions from new data # TODO: eventually export this function if we want to ensure full compatibility # with the 'empty' feature. see ?rename_pars for an example frame_basis <- function(x, data, ...) { UseMethod("frame_basis") } #' @export frame_basis.default <- function(x, data, ...) { list() } #' @export frame_basis.mvbrmsterms <- function(x, data, ...) { out <- list() # old levels are required to select the right indices for new levels levels <- get_levels(x, data = data) for (r in names(x$terms)) { out$resps[[r]] <- frame_basis(x$terms[[r]], data, levels = levels, ...) } # store levels as list element rather than as attribute (via set_levels) # to differentiate more easily whether or not old levels were provided out$group_levels <- levels out } #' @export frame_basis.brmsterms <- function(x, data, levels = NULL, ...) { out <- list() data <- subset_data(data, x) for (dp in names(x$dpars)) { out$dpars[[dp]] <- frame_basis(x$dpars[[dp]], data, ...) } for (nlp in names(x$nlpars)) { out$nlpars[[nlp]] <- frame_basis(x$nlpars[[nlp]], data, ...) } # old levels are required to select the right indices for new levels if (is.null(levels)) { levels <- get_levels(x, data = data) } # store levels as list element rather than as attribute (via set_levels) # to differentiate more easily whether or not old levels were provided out$group_levels <- levels if (is_binary(x$family) || is_categorical(x$family)) { y <- model.response(model.frame(x$respform, data, na.action = na.pass)) out$resp_levels <- levels(as.factor(y)) } out } #' @export frame_basis.btnl <- function(x, data, ...) { list() } #' @export frame_basis.btl <- function(x, data, ...) { out <- list() out$sm <- frame_basis_sm(x, data, ...) out$gp <- frame_basis_gp(x, data, ...) out$sp <- frame_basis_sp(x, data, ...) out$ac <- frame_basis_ac(x, data, ...) out$bhaz <- frame_basis_bhaz(x, data, ...) out } # prepare basis data related to smooth terms frame_basis_sm <- function(x, data, ...) { stopifnot(is.btl(x)) smterms <- all_terms(x[["sm"]]) out <- named_list(smterms) if (length(smterms)) { knots <- get_knots(data) data <- rm_attr(data, "terms") # the spline penalty has changed in 2.8.7 (#646) diagonal.penalty <- !require_old_default("2.8.7") gam_args <- list( data = data, knots = knots, absorb.cons = TRUE, modCon = 3, diagonal.penalty = diagonal.penalty ) for (i in seq_along(smterms)) { sc_args <- c(list(eval2(smterms[i])), gam_args) sm <- do_call(smoothCon, sc_args) re <- vector("list", length(sm)) for (j in seq_along(sm)) { re[[j]] <- mgcv::smooth2random(sm[[j]], names(data), type = 2) } out[[i]]$sm <- sm out[[i]]$re <- re } } out } # prepare basis data related to gaussian processes frame_basis_gp <- function(x, data, ...) { stopifnot(is.btl(x)) out <- data_gp(x, data, internal = TRUE) out <- out[grepl("^((Xgp)|(dmax)|(cmeans)|(L))", names(out))] out } # prepare basis data related to special terms frame_basis_sp <- function(x, data, ...) { stopifnot(is.btl(x)) out <- list() if (length(attr(x$sp, "uni_mo"))) { # do it like data_sp() spframe <- frame_sp(x, data) Xmo <- lapply(unlist(spframe$calls_mo), get_mo_values, data = data) out$Jmo <- as.array(ulapply(Xmo, attr, "max")) } out } # prepare basis data related to autocorrelation structures frame_basis_ac <- function(x, data, ...) { out <- list() if (has_ac_class(x, "car")) { gr <- get_ac_vars(x, "gr", class = "car") if (isTRUE(nzchar(gr))) { out$locations <- extract_levels(get(gr, data)) } else { out$locations <- NA } } if (has_ac_class(x, "unstr")) { time <- get_ac_vars(x, "time", dim = "time") out$times <- extract_levels(get(time, data)) } out } # prepare basis data for baseline hazards of the cox model frame_basis_bhaz <- function(x, data, ...) { out <- list() if (is_cox(x$family)) { # compute basis matrix of the baseline hazard for the Cox model y <- model.response(model.frame(x$respform, data, na.action = na.pass)) args <- family_info(x, "bhaz")$args out$basis_matrix <- bhaz_basis_matrix(y, args = args) } out } brms/R/autocor.R0000644000176200001440000004530015053072461013222 0ustar liggesusers# All functions in this file belong to the deprecated 'cor_brms' class # for specifying autocorrelation structures. They will be removed in brms 3. #' (Deprecated) Correlation structure classes for the \pkg{brms} package #' #' Classes of correlation structures available in the \pkg{brms} package. #' \code{cor_brms} is not a correlation structure itself, #' but the class common to all correlation structures implemented in \pkg{brms}. #' #' @name cor_brms #' @aliases cor_brms-class #' #' @section Available correlation structures: #' \describe{ #' \item{cor_arma}{autoregressive-moving average (ARMA) structure, #' with arbitrary orders for the autoregressive and moving #' average components} #' \item{cor_ar}{autoregressive (AR) structure of arbitrary order} #' \item{cor_ma}{moving average (MA) structure of arbitrary order} #' \item{cor_car}{Spatial conditional autoregressive (CAR) structure} #' \item{cor_sar}{Spatial simultaneous autoregressive (SAR) structure} #' \item{cor_fixed}{fixed user-defined covariance structure} #' } #' #' @seealso #' \code{\link{cor_arma}, \link{cor_ar}, \link{cor_ma}, #' \link{cor_car}, \link{cor_sar}, \link{cor_fixed}} #' NULL #' (Deprecated) ARMA(p,q) correlation structure #' #' This function is deprecated. Please see \code{\link{arma}} for the new syntax. #' This functions is a constructor for the \code{cor_arma} class, representing #' an autoregression-moving average correlation structure of order (p, q). #' #' @aliases cor_arma-class #' #' @param formula A one sided formula of the form \code{~ t}, or \code{~ t | g}, #' specifying a time covariate \code{t} and, optionally, a grouping factor #' \code{g}. A covariate for this correlation structure must be integer #' valued. When a grouping factor is present in \code{formula}, the #' correlation structure is assumed to apply only to observations within the #' same grouping level; observations with different grouping levels are #' assumed to be uncorrelated. Defaults to \code{~ 1}, which corresponds to #' using the order of the observations in the data as a covariate, and no #' groups. #' @param p A non-negative integer specifying the autoregressive (AR) #' order of the ARMA structure. Default is 0. #' @param q A non-negative integer specifying the moving average (MA) #' order of the ARMA structure. Default is 0. #' @param r No longer supported. #' @param cov A flag indicating whether ARMA effects should be estimated by #' means of residual covariance matrices. This is currently only possible for #' stationary ARMA effects of order 1. If the model family does not have #' natural residuals, latent residuals are added automatically. If #' \code{FALSE} (the default) a regression formulation is used that is #' considerably faster and allows for ARMA effects of order higher than 1 but #' is only available for \code{gaussian} models and some of its #' generalizations. #' #' @return An object of class \code{cor_arma}, representing an #' autoregression-moving-average correlation structure. #' #' @seealso \code{\link{cor_ar}}, \code{\link{cor_ma}} #' #' @examples #' cor_arma(~ visit | patient, p = 2, q = 2) #' #' @export cor_arma <- function(formula = ~1, p = 0, q = 0, r = 0, cov = FALSE) { formula <- as.formula(formula) p <- as_one_numeric(p) q <- as_one_numeric(q) cov <- as_one_logical(cov) if ("r" %in% names(match.call())) { warning2("The ARR structure is no longer supported and ignored.") } if (!(p >= 0 && p == round(p))) { stop2("Autoregressive order must be a non-negative integer.") } if (!(q >= 0 && q == round(q))) { stop2("Moving-average order must be a non-negative integer.") } if (!sum(p, q)) { stop2("At least one of 'p' and 'q' should be greater zero.") } if (cov && (p > 1 || q > 1)) { stop2("Covariance formulation of ARMA structures is ", "only possible for effects of maximal order one.") } x <- nlist(formula, p, q, cov) class(x) <- c("cor_arma", "cor_brms") x } #' (Deprecated) AR(p) correlation structure #' #' This function is deprecated. Please see \code{\link{ar}} for the new syntax. #' This function is a constructor for the \code{cor_arma} class, #' allowing for autoregression terms only. #' #' @inheritParams cor_arma #' @param p A non-negative integer specifying the autoregressive (AR) #' order of the ARMA structure. Default is 1. #' #' @return An object of class \code{cor_arma} containing solely autoregression terms. #' #' @details AR refers to autoregressive effects of residuals, which #' is what is typically understood as autoregressive effects. #' However, one may also model autoregressive effects of the response #' variable, which is called ARR in \pkg{brms}. #' #' @seealso \code{\link{cor_arma}} #' #' @examples #' cor_ar(~visit|patient, p = 2) #' #' @export cor_ar <- function(formula = ~1, p = 1, cov = FALSE) { cor_arma(formula = formula, p = p, q = 0, cov = cov) } #' (Deprecated) MA(q) correlation structure #' #' This function is deprecated. Please see \code{\link{ma}} for the new syntax. #' This function is a constructor for the \code{cor_arma} class, #' allowing for moving average terms only. #' #' @inheritParams cor_arma #' @param q A non-negative integer specifying the moving average (MA) #' order of the ARMA structure. Default is 1. #' #' @return An object of class \code{cor_arma} containing solely moving #' average terms. #' #' @seealso \code{\link{cor_arma}} #' #' @examples #' cor_ma(~visit|patient, q = 2) #' #' @export cor_ma <- function(formula = ~1, q = 1, cov = FALSE) { cor_arma(formula = formula, p = 0, q = q, cov = cov) } #' (Defunct) ARR correlation structure #' #' The ARR correlation structure is no longer supported. #' #' @inheritParams cor_arma #' #' @keywords internal #' @export cor_arr <- function(formula = ~1, r = 1) { cor_arma(formula = formula, p = 0, q = 0, r = r) } #' (Deprecated) Compound Symmetry (COSY) Correlation Structure #' #' This function is deprecated. Please see \code{\link{cosy}} for the new syntax. #' This functions is a constructor for the \code{cor_cosy} class, representing #' a compound symmetry structure corresponding to uniform correlation. #' #' @aliases cor_cosy-class #' #' @inheritParams cor_arma #' #' @return An object of class \code{cor_cosy}, representing a compound symmetry #' correlation structure. #' #' @examples #' cor_cosy(~ visit | patient) #' #' @export cor_cosy <- function(formula = ~1) { formula <- as.formula(formula) x <- nlist(formula) class(x) <- c("cor_cosy", "cor_brms") x } #' (Deprecated) Spatial simultaneous autoregressive (SAR) structures #' #' Thse functions are deprecated. Please see \code{\link{sar}} for the new #' syntax. These functions are constructors for the \code{cor_sar} class #' implementing spatial simultaneous autoregressive structures. #' The \code{lagsar} structure implements SAR of the response values: #' \deqn{y = \rho W y + \eta + e} #' The \code{errorsar} structure implements SAR of the residuals: #' \deqn{y = \eta + u, u = \rho W u + e} #' In the above equations, \eqn{\eta} is the predictor term and #' \eqn{e} are independent normally or t-distributed residuals. #' #' @param W An object specifying the spatial weighting matrix. #' Can be either the spatial weight matrix itself or an #' object of class \code{listw} or \code{nb}, from which #' the spatial weighting matrix can be computed. #' @param type Type of the SAR structure. Either \code{"lag"} #' (for SAR of the response values) or \code{"error"} #' (for SAR of the residuals). #' #' @details Currently, only families \code{gaussian} and \code{student} #' support SAR structures. #' #' @return An object of class \code{cor_sar} to be used in calls to #' \code{\link{brm}}. #' #' @examples #' \dontrun{ #' data(oldcol, package = "spdep") #' fit1 <- brm(CRIME ~ INC + HOVAL, data = COL.OLD, #' autocor = cor_lagsar(COL.nb), #' chains = 2, cores = 2) #' summary(fit1) #' plot(fit1) #' #' fit2 <- brm(CRIME ~ INC + HOVAL, data = COL.OLD, #' autocor = cor_errorsar(COL.nb), #' chains = 2, cores = 2) #' summary(fit2) #' plot(fit2) #' } #' #' @export cor_sar <- function(W, type = c("lag", "error")) { type <- match.arg(type) W_name <- deparse0(substitute(W)) W <- validate_sar_matrix(W) structure( nlist(W, W_name, type), class = c("cor_sar", "cor_brms") ) } #' @rdname cor_sar #' @export cor_lagsar <- function(W) { out <- cor_sar(W, type = "lag") out$W_name <- deparse0(substitute(W)) out } #' @rdname cor_sar #' @export cor_errorsar <- function(W) { out <- cor_sar(W, type = "error") out$W_name <- deparse0(substitute(W)) out } #' (Deprecated) Spatial conditional autoregressive (CAR) structures #' #' These function are deprecated. Please see \code{\link{car}} for the new #' syntax. These functions are constructors for the \code{cor_car} class #' implementing spatial conditional autoregressive structures. #' #' @param W Adjacency matrix of locations. #' All non-zero entries are treated as if the two locations #' are adjacent. If \code{formula} contains a grouping factor, #' the row names of \code{W} have to match the levels #' of the grouping factor. #' @param formula An optional one-sided formula of the form #' \code{~ 1 | g}, where \code{g} is a grouping factor mapping #' observations to spatial locations. If not specified, #' each observation is treated as a separate location. #' It is recommended to always specify a grouping factor #' to allow for handling of new data in post-processing methods. #' @param type Type of the CAR structure. Currently implemented #' are \code{"escar"} (exact sparse CAR), \code{"esicar"} #' (exact sparse intrinsic CAR), \code{"icar"} (intrinsic CAR), #' and \code{"bym2"}. More information is provided in the 'Details' section. #' #' @details The \code{escar} and \code{esicar} types are #' implemented based on the case study of Max Joseph #' (\url{https://github.com/mbjoseph/CARstan}). The \code{icar} and #' \code{bym2} type is implemented based on the case study of Mitzi Morris #' (\url{https://mc-stan.org/users/documentation/case-studies/icar_stan.html}). #' #' @examples #' \dontrun{ #' # generate some spatial data #' east <- north <- 1:10 #' Grid <- expand.grid(east, north) #' K <- nrow(Grid) #' #' # set up distance and neighbourhood matrices #' distance <- as.matrix(dist(Grid)) #' W <- array(0, c(K, K)) #' W[distance == 1] <- 1 #' #' # generate the covariates and response data #' x1 <- rnorm(K) #' x2 <- rnorm(K) #' theta <- rnorm(K, sd = 0.05) #' phi <- rmulti_normal( #' 1, mu = rep(0, K), Sigma = 0.4 * exp(-0.1 * distance) #' ) #' eta <- x1 + x2 + phi #' prob <- exp(eta) / (1 + exp(eta)) #' size <- rep(50, K) #' y <- rbinom(n = K, size = size, prob = prob) #' dat <- data.frame(y, size, x1, x2) #' #' # fit a CAR model #' fit <- brm(y | trials(size) ~ x1 + x2, data = dat, #' family = binomial(), autocor = cor_car(W)) #' summary(fit) #' } #' #' @export cor_car <- function(W, formula = ~1, type = "escar") { options <- c("escar", "esicar", "icar", "bym2") type <- match.arg(type, options) W_name <- deparse0(substitute(W)) W <- validate_car_matrix(W) formula <- as.formula(formula) if (!is.null(lhs(formula))) { stop2("'formula' should be a one-sided formula.") } if (length(attr(terms(formula), "term.labels")) > 1L) { stop2("'formula' should not contain more than one term.") } structure( nlist(W, W_name, formula, type), class = c("cor_car", "cor_brms") ) } #' @rdname cor_car #' @export cor_icar <- function(W, formula = ~1) { out <- cor_car(W, formula, type = "icar") out$W_name <- deparse0(substitute(W)) out } #' (Deprecated) Fixed user-defined covariance matrices #' #' This function is deprecated. Please see \code{\link{fcor}} for the new #' syntax. Define a fixed covariance matrix of the response variable for #' instance to model multivariate effect sizes in meta-analysis. #' #' @aliases cov_fixed #' #' @param V Known covariance matrix of the response variable. #' If a vector is passed, it will be used as diagonal entries #' (variances) and covariances will be set to zero. #' #' @return An object of class \code{cor_fixed}. #' #' @examples #' \dontrun{ #' dat <- data.frame(y = rnorm(3)) #' V <- cbind(c(0.5, 0.3, 0.2), c(0.3, 1, 0.1), c(0.2, 0.1, 0.2)) #' fit <- brm(y~1, data = dat, autocor = cor_fixed(V)) #' } #' #' @export cor_fixed <- function(V) { V_name <- deparse0(substitute(V)) if (is.vector(V)) { V <- diag(V) } else { V <- as.matrix(V) } if (!isSymmetric(unname(V))) { stop2("'V' must be symmetric") } structure(nlist(V, V_name), class = c("cor_fixed", "cor_brms")) } #' (Defunct) Basic Bayesian Structural Time Series #' #' The BSTS correlation structure is no longer supported. #' #' @inheritParams cor_arma #' #' @keywords internal #' @export cor_bsts <- function(formula = ~1) { stop2("The BSTS structure is no longer supported.") } #' Check if argument is a correlation structure #' #' Check if argument is one of the correlation structures #' used in \pkg{brms}. #' #' @param x An \R object. #' #' @export is.cor_brms <- function(x) { inherits(x, "cor_brms") } #' @rdname is.cor_brms #' @export is.cor_arma <- function(x) { inherits(x, "cor_arma") } #' @rdname is.cor_brms #' @export is.cor_cosy <- function(x) { inherits(x, "cor_cosy") } #' @rdname is.cor_brms #' @export is.cor_sar <- function(x) { inherits(x, "cor_sar") } #' @rdname is.cor_brms #' @export is.cor_car <- function(x) { inherits(x, "cor_car") } #' @rdname is.cor_brms #' @export is.cor_fixed <- function(x) { inherits(x, "cor_fixed") } #' @export print.cor_empty <- function(x, ...) { cat("empty()\n") } #' @export print.cor_arma <- function(x, ...) { cat(paste0("arma(", formula2str(x$formula), ", ", x$p, ", ", x$q, ")\n")) invisible(x) } #' @export print.cor_cosy <- function(x, ...) { cat(paste0("cosy(", formula2str(x$formula), ")\n")) invisible(x) } #' @export print.cor_sar <- function(x, ...) { cat(paste0("sar(", x$W_name, ", '", x$type, "')\n")) invisible(x) } #' @export print.cor_car <- function(x, ...) { form <- formula2str(x$formula) cat(paste0("car(", x$W_name, ", ", form, ", '", x$type, "')\n")) invisible(x) } #' @export print.cor_fixed <- function(x, ...) { cat("Fixed covariance matrix: \n") print(x$V) invisible(x) } #' @export print.cov_fixed <- function(x, ...) { class(x) <- "cor_fixed" print.cor_fixed(x) } stop_not_cor_brms <- function(x) { if (!(is.null(x) || is.cor_brms(x))) { stop2("Argument 'autocor' must be of class 'cor_brms'.") } TRUE } # empty 'cor_brms' object cor_empty <- function() { structure(list(), class = c("cor_empty", "cor_brms")) } is.cor_empty <- function(x) { inherits(x, "cor_empty") } #' (Deprecated) Extract Autocorrelation Objects #' #' @inheritParams posterior_predict.brmsfit #' @param ... Currently unused. #' #' @return A \code{cor_brms} object or a list of such objects for multivariate #' models. Not supported for models fitted with brms 2.11.1 or higher. #' #' @export autocor.brmsfit <- function(object, resp = NULL, ...) { warning2("Method 'autocor' is deprecated and will be removed in the future.") object <- restructure(object) resp <- validate_resp(resp, object) if (!is.null(resp)) { # multivariate model autocor <- object$autocor[resp] if (length(resp) == 1L) { autocor <- autocor[[1]] } } else { # univariate model autocor <- object$autocor } autocor } #' @rdname autocor.brmsfit #' @export autocor <- function(object, ...) { UseMethod("autocor") } # extract variables for autocorrelation structures # @param autocor object of class 'cor_brms' # @return a list with elements 'time', and 'group' terms_autocor <- function(autocor) { out <- list() formula <- autocor$formula if (is.null(formula)) { formula <- ~1 } if (!is.null(lhs(formula))) { stop2("Autocorrelation formulas must be one-sided.") } formula <- formula2str(formula) time <- as.formula(paste("~", gsub("~|\\|[[:print:]]*", "", formula))) time_vars <- all_vars(time) if (is.cor_car(autocor) && length(time_vars) > 0L) { stop2("The CAR structure should not contain a 'time' variable.") } if (length(time_vars) > 1L) { stop2("Autocorrelation structures may only contain 1 time variable.") } if (length(time_vars)) { out$time <- time_vars } else { out$time <- NA } group <- sub("^\\|*", "", sub("~[^\\|]*", "", formula)) stopif_illegal_group(group) group_vars <- all_vars(group) if (length(group_vars)) { out$group <- paste0(group_vars, collapse = ":") } else { out$group <- NA } out } # transform a 'cor_brms' object into a formula # this ensure compatibility with brms <= 2.11 as_formula_cor_brms <- function(x) { stop_not_cor_brms(x) if (is.cor_empty(x)) { return(NULL) } args <- data2 <- list() pac <- terms_autocor(x) if (is.cor_arma(x)) { fun <- "arma" args$time <- pac$time args$gr <- pac$group args$p <- x$p args$q <- x$q args$cov <- x$cov out <- paste0(names(args), " = ", args, collapse = ", ") out <- paste0("arma(", out, ")") } else if (is.cor_cosy(x)) { fun <- "cosy" args$time <- pac$time args$gr <- pac$group } else if (is.cor_sar(x)) { fun <- "sar" args$M <- make_M_names(x$W_name) args$type <- paste0("'", x$type, "'") data2[[args$M]] <- x$W } else if (is.cor_car(x)) { fun <- "car" args$M <- make_M_names(x$W_name) args$gr <- pac$group args$type <- paste0("'", x$type, "'") data2[[args$M]] <- x$W } else if (is.cor_fixed(x)) { fun <- "fcor" args$M <- make_M_names(x$V_name) data2[[args$M]] <- x$V } out <- paste0(names(args), " = ", args, collapse = ", ") out <- paste0(fun, "(", out, ")") out <- str2formula(out) attr(out, "data2") <- data2 class(out) <- c("cor_brms_formula", "formula") out } # ensures covariance matrix inputs are named reasonably make_M_names <- function(x) { out <- make.names(x) if (!length(out)) { # likely unique random name for the matrix argument out <- paste0("M", collapse(sample(0:9, 5, TRUE))) } out } # get data objects from 'autocor' for use in 'data2' # for backwards compatibility with brms <= 2.11 get_data2_autocor <- function(x, ...) { UseMethod("get_data2_autocor") } #' @export get_data2_autocor.brmsformula <- function(x, ...) { attr(attr(x$formula, "autocor"), "data2") } #' @export get_data2_autocor.brmsterms <- function(x, ...) { attr(attr(x$formula, "autocor"), "data2") } #' @export get_data2_autocor.mvbrmsformula <- function(x, ...) { ulapply(x$forms, get_data2_autocor, recursive = FALSE) } #' @export get_data2_autocor.mvbrmsterms <- function(x, ...) { ulapply(x$terms, get_data2_autocor, recursive = FALSE) } #' @export print.cor_brms_formula <- function(x, ...) { y <- x attr(y, "data2") <- NULL class(y) <- "formula" print(y) invisible(x) } brms/R/distributions.R0000644000176200001440000023547315053072461014464 0ustar liggesusers#' The Student-t Distribution #' #' Density, distribution function, quantile function and random generation #' for the Student-t distribution with location \code{mu}, scale \code{sigma}, #' and degrees of freedom \code{df}. #' #' @name StudentT #' #' @param x Vector of quantiles. #' @param q Vector of quantiles. #' @param p Vector of probabilities. #' @param n Number of draws to sample from the distribution. #' @param mu Vector of location values. #' @param sigma Vector of scale values. #' @param df Vector of degrees of freedom. #' @param log Logical; If \code{TRUE}, values are returned on the log scale. #' @param log.p Logical; If \code{TRUE}, values are returned on the log scale. #' @param lower.tail Logical; If \code{TRUE} (default), return P(X <= x). #' Else, return P(X > x) . #' #' @details See \code{vignette("brms_families")} for details #' on the parameterization. #' #' @seealso \code{\link[stats:TDist]{TDist}} #' #' @export dstudent_t <- function(x, df, mu = 0, sigma = 1, log = FALSE) { if (isTRUE(any(sigma < 0))) { stop2("sigma must be non-negative.") } if (log) { dt((x - mu) / sigma, df = df, log = TRUE) - log(sigma) } else { dt((x - mu) / sigma, df = df) / sigma } } #' @rdname StudentT #' @export pstudent_t <- function(q, df, mu = 0, sigma = 1, lower.tail = TRUE, log.p = FALSE) { if (isTRUE(any(sigma < 0))) { stop2("sigma must be non-negative.") } pt((q - mu) / sigma, df = df, lower.tail = lower.tail, log.p = log.p) } #' @rdname StudentT #' @export qstudent_t <- function(p, df, mu = 0, sigma = 1, lower.tail = TRUE, log.p = FALSE) { if (isTRUE(any(sigma < 0))) { stop2("sigma must be non-negative.") } mu + sigma * qt(p, df = df, lower.tail = lower.tail, log.p = log.p) } #' @rdname StudentT #' @export rstudent_t <- function(n, df, mu = 0, sigma = 1) { if (isTRUE(any(sigma < 0))) { stop2("sigma must be non-negative.") } mu + sigma * rt(n, df = df) } #' The Multivariate Normal Distribution #' #' Density function and random generation for the multivariate normal #' distribution with mean vector \code{mu} and covariance matrix \code{Sigma}. #' #' @name MultiNormal #' #' @inheritParams StudentT #' @param x Vector or matrix of quantiles. If \code{x} is a matrix, #' each row is taken to be a quantile. #' @param mu Mean vector with length equal to the number of dimensions. #' @param Sigma Covariance matrix. #' @param check Logical; Indicates whether several input checks #' should be performed. Defaults to \code{FALSE} to improve #' efficiency. #' #' @details See the Stan user's manual \url{https://mc-stan.org/docs/} #' for details on the parameterization #' #' @export dmulti_normal <- function(x, mu, Sigma, log = FALSE, check = FALSE) { if (is.vector(x) || length(dim(x)) == 1L) { x <- matrix(x, ncol = length(x)) } p <- ncol(x) if (check) { if (length(mu) != p) { stop2("Dimension of mu is incorrect.") } if (!all(dim(Sigma) == c(p, p))) { stop2("Dimension of Sigma is incorrect.") } if (!is_symmetric(Sigma)) { stop2("Sigma must be a symmetric matrix.") } } chol_Sigma <- chol(Sigma) rooti <- backsolve(chol_Sigma, t(x) - mu, transpose = TRUE) quads <- colSums(rooti^2) out <- -(p / 2) * log(2 * pi) - sum(log(diag(chol_Sigma))) - .5 * quads if (!log) { out <- exp(out) } out } #' @rdname MultiNormal #' @export rmulti_normal <- function(n, mu, Sigma, check = FALSE) { p <- length(mu) if (check) { if (!(is_wholenumber(n) && n > 0)) { stop2("n must be a positive integer.") } if (!all(dim(Sigma) == c(p, p))) { stop2("Dimension of Sigma is incorrect.") } if (!is_symmetric(Sigma)) { stop2("Sigma must be a symmetric matrix.") } } draws <- matrix(rnorm(n * p), nrow = n, ncol = p) sweep(draws %*% chol(Sigma), 2, mu, "+") } #' The Multivariate Student-t Distribution #' #' Density function and random generation for the multivariate Student-t #' distribution with location vector \code{mu}, covariance matrix \code{Sigma}, #' and degrees of freedom \code{df}. #' #' @name MultiStudentT #' #' @inheritParams StudentT #' @param x Vector or matrix of quantiles. If \code{x} is a matrix, #' each row is taken to be a quantile. #' @param mu Location vector with length equal to the number of dimensions. #' @param Sigma Covariance matrix. #' @param check Logical; Indicates whether several input checks #' should be performed. Defaults to \code{FALSE} to improve #' efficiency. #' #' @details See the Stan user's manual \url{https://mc-stan.org/docs/} #' for details on the parameterization #' #' @export dmulti_student_t <- function(x, df, mu, Sigma, log = FALSE, check = FALSE) { if (is.vector(x) || length(dim(x)) == 1L) { x <- matrix(x, ncol = length(x)) } p <- ncol(x) if (check) { if (isTRUE(any(df <= 0))) { stop2("df must be greater than 0.") } if (length(mu) != p) { stop2("Dimension of mu is incorrect.") } if (!all(dim(Sigma) == c(p, p))) { stop2("Dimension of Sigma is incorrect.") } if (!is_symmetric(Sigma)) { stop2("Sigma must be a symmetric matrix.") } } chol_Sigma <- chol(Sigma) rooti <- backsolve(chol_Sigma, t(x) - mu, transpose = TRUE) quads <- colSums(rooti^2) out <- lgamma((p + df)/2) - (lgamma(df / 2) + sum(log(diag(chol_Sigma))) + p / 2 * log(pi * df)) - 0.5 * (df + p) * log1p(quads / df) if (!log) { out <- exp(out) } out } #' @rdname MultiStudentT #' @export rmulti_student_t <- function(n, df, mu, Sigma, check = FALSE) { p <- length(mu) if (isTRUE(any(df <= 0))) { stop2("df must be greater than 0.") } draws <- rmulti_normal(n, mu = rep(0, p), Sigma = Sigma, check = check) draws <- draws / sqrt(rchisq(n, df = df) / df) sweep(draws, 2, mu, "+") } #' The (Multivariate) Logistic Normal Distribution #' #' Density function and random generation for the (multivariate) logistic normal #' distribution with latent mean vector \code{mu} and covariance matrix \code{Sigma}. #' #' @name LogisticNormal #' #' @inheritParams StudentT #' @param x Vector or matrix of quantiles. If \code{x} is a matrix, #' each row is taken to be a quantile. #' @param mu Mean vector with length equal to the number of dimensions. #' @param Sigma Covariance matrix. #' @param refcat A single integer indicating the reference category. #' Defaults to \code{1}. #' @param check Logical; Indicates whether several input checks #' should be performed. Defaults to \code{FALSE} to improve #' efficiency. #' #' @export dlogistic_normal <- function(x, mu, Sigma, refcat = 1, log = FALSE, check = FALSE) { if (is.vector(x) || length(dim(x)) == 1L) { x <- matrix(x, ncol = length(x)) } lx <- link_categorical(x, refcat) out <- dmulti_normal(lx, mu, Sigma, log = TRUE) - rowSums(log(x)) if (!log) { out <- exp(out) } out } #' @rdname LogisticNormal #' @export rlogistic_normal <- function(n, mu, Sigma, refcat = 1, check = FALSE) { out <- rmulti_normal(n, mu, Sigma, check = check) inv_link_categorical(out, refcat = refcat) } #' The Skew-Normal Distribution #' #' Density, distribution function, and random generation for the #' skew-normal distribution with mean \code{mu}, #' standard deviation \code{sigma}, and skewness \code{alpha}. #' #' @name SkewNormal #' #' @inheritParams StudentT #' @param x,q Vector of quantiles. #' @param mu Vector of mean values. #' @param sigma Vector of standard deviation values. #' @param alpha Vector of skewness values. #' @param xi Optional vector of location values. #' If \code{NULL} (the default), will be computed internally. #' @param omega Optional vector of scale values. #' If \code{NULL} (the default), will be computed internally. #' @param tol Tolerance of the approximation used in the #' computation of quantiles. #' #' @details See \code{vignette("brms_families")} for details #' on the parameterization. #' #' @export dskew_normal <- function(x, mu = 0, sigma = 1, alpha = 0, xi = NULL, omega = NULL, log = FALSE) { if (isTRUE(any(sigma < 0))) { stop2("sigma must be greater than 0.") } args <- cp2dp(mu, sigma, alpha, xi = xi, omega = omega, x = x) out <- with(args, { # do it like sn::dsn z <- (x - xi) / omega if (length(alpha) == 1L) { alpha <- rep(alpha, length(z)) } logN <- -log(sqrt(2 * pi)) - log(omega) - z^2 / 2 logS <- ifelse( abs(alpha) < Inf, pnorm(alpha * z, log.p = TRUE), log(as.numeric(sign(alpha) * z > 0)) ) out <- logN + logS - pnorm(0, log.p = TRUE) ifelse(abs(z) == Inf, -Inf, out) }) if (!log) { out <- exp(out) } out } #' @rdname SkewNormal #' @export pskew_normal <- function(q, mu = 0, sigma = 1, alpha = 0, xi = NULL, omega = NULL, lower.tail = TRUE, log.p = FALSE) { require_package("mnormt") if (isTRUE(any(sigma < 0))) { stop2("sigma must be non-negative.") } args <- cp2dp(mu, sigma, alpha, xi = xi, omega = omega, q = q) out <- with(args, { # do it like sn::psn z <- (q - xi) / omega nz <- length(z) is_alpha_inf <- abs(alpha) == Inf delta[is_alpha_inf] <- sign(alpha[is_alpha_inf]) out <- numeric(nz) for (k in seq_len(nz)) { if (is.infinite(z[k])) { if (z[k] > 0) { out[k] <- 1 } else { out[k] <- 0 } } else if (is_alpha_inf[k]) { if (alpha[k] > 0) { out[k] <- 2 * (pnorm(pmax(z[k], 0)) - 0.5) } else { out[k] <- 1 - 2 * (0.5 - pnorm(pmin(z[k], 0))) } } else { S <- matrix(c(1, -delta[k], -delta[k], 1), 2, 2) out[k] <- 2 * mnormt::biv.nt.prob( 0, lower = rep(-Inf, 2), upper = c(z[k], 0), mean = c(0, 0), S = S ) } } pmin(1, pmax(0, out)) }) if (!lower.tail) { out <- 1 - out } if (log.p) { out <- log(out) } out } #' @rdname SkewNormal #' @export qskew_normal <- function(p, mu = 0, sigma = 1, alpha = 0, xi = NULL, omega = NULL, lower.tail = TRUE, log.p = FALSE, tol = 1e-8) { if (isTRUE(any(sigma < 0))) { stop2("sigma must be non-negative.") } p <- validate_p_dist(p, lower.tail = lower.tail, log.p = log.p) args <- cp2dp(mu, sigma, alpha, xi = xi, omega = omega, p = p) out <- with(args, { # do it like sn::qsn na <- is.na(p) | (p < 0) | (p > 1) zero <- (p == 0) one <- (p == 1) p <- replace(p, (na | zero | one), 0.5) cum <- skew_normal_cumulants(0, 1, alpha, n = 4) g1 <- cum[, 3] / cum[, 2]^(3 / 2) g2 <- cum[, 4] / cum[, 2]^2 x <- qnorm(p) x <- x + (x^2 - 1) * g1 / 6 + x * (x^2 - 3) * g2 / 24 - x * (2 * x^2 - 5) * g1^2 / 36 x <- cum[, 1] + sqrt(cum[, 2]) * x px <- pskew_normal(x, xi = 0, omega = 1, alpha = alpha) max_err <- 1 while (max_err > tol) { x1 <- x - (px - p) / dskew_normal(x, xi = 0, omega = 1, alpha = alpha) x <- x1 px <- pskew_normal(x, xi = 0, omega = 1, alpha = alpha) max_err <- max(abs(px - p)) if (is.na(max_err)) { warning2("Approximation in 'qskew_normal' might have failed.") } } x <- replace(x, na, NA) x <- replace(x, zero, -Inf) x <- replace(x, one, Inf) as.numeric(xi + omega * x) }) out } #' @rdname SkewNormal #' @export rskew_normal <- function(n, mu = 0, sigma = 1, alpha = 0, xi = NULL, omega = NULL) { if (isTRUE(any(sigma < 0))) { stop2("sigma must be non-negative.") } args <- cp2dp(mu, sigma, alpha, xi = xi, omega = omega) with(args, { # do it like sn::rsn z1 <- rnorm(n) z2 <- rnorm(n) id <- z2 > args$alpha * z1 z1[id] <- -z1[id] xi + omega * z1 }) } # convert skew-normal mixed-CP to DP parameterization # @return a data.frame containing all relevant parameters cp2dp <- function(mu = 0, sigma = 1, alpha = 0, xi = NULL, omega = NULL, ...) { delta <- alpha / sqrt(1 + alpha^2) if (is.null(omega)) { omega <- sigma / sqrt(1 - 2 / pi * delta^2) } if (is.null(xi)) { xi <- mu - omega * delta * sqrt(2 / pi) } expand(dots = nlist(mu, sigma, alpha, xi, omega, delta, ...)) } # helper function for qskew_normal # code basis taken from sn::sn.cumulants # uses xi and omega rather than mu and sigma skew_normal_cumulants <- function(xi = 0, omega = 1, alpha = 0, n = 4) { cumulants_half_norm <- function(n) { n <- max(n, 2) n <- as.integer(2 * ceiling(n/2)) half.n <- as.integer(n/2) m <- 0:(half.n - 1) a <- sqrt(2/pi)/(gamma(m + 1) * 2^m * (2 * m + 1)) signs <- rep(c(1, -1), half.n)[seq_len(half.n)] a <- as.vector(rbind(signs * a, rep(0, half.n))) coeff <- rep(a[1], n) for (k in 2:n) { ind <- seq_len(k - 1) coeff[k] <- a[k] - sum(ind * coeff[ind] * a[rev(ind)]/k) } kappa <- coeff * gamma(seq_len(n) + 1) kappa[2] <- 1 + kappa[2] return(kappa) } args <- expand(dots = nlist(xi, omega, alpha)) with(args, { # do it like sn::sn.cumulants delta <- alpha / sqrt(1 + alpha^2) kv <- cumulants_half_norm(n) if (length(kv) > n) { kv <- kv[-(n + 1)] } kv[2] <- kv[2] - 1 kappa <- outer(delta, 1:n, "^") * matrix(rep(kv, length(xi)), ncol = n, byrow = TRUE) kappa[, 2] <- kappa[, 2] + 1 kappa <- kappa * outer(omega, 1:n, "^") kappa[, 1] <- kappa[, 1] + xi kappa }) } # CDF of the inverse gamma function pinvgamma <- function(q, shape, rate, lower.tail = TRUE, log.p = FALSE) { pgamma(1/q, shape, rate = rate, lower.tail = !lower.tail, log.p = log.p) } #' The von Mises Distribution #' #' Density, distribution function, and random generation for the #' von Mises distribution with location \code{mu}, and precision \code{kappa}. #' #' @name VonMises #' #' @inheritParams StudentT #' @param x,q Vector of quantiles between \code{-pi} and \code{pi}. #' @param kappa Vector of precision values. #' @param acc Accuracy of numerical approximations. #' #' @details See \code{vignette("brms_families")} for details #' on the parameterization. #' #' @export dvon_mises <- function(x, mu, kappa, log = FALSE) { if (isTRUE(any(kappa < 0))) { stop2("kappa must be non-negative") } # expects x in [-pi, pi] rather than [0, 2*pi] as CircStats::dvm be <- besselI(kappa, nu = 0, expon.scaled = TRUE) out <- -log(2 * pi * be) + kappa * (cos(x - mu) - 1) if (!log) { out <- exp(out) } out } #' @rdname VonMises #' @export pvon_mises <- function(q, mu, kappa, lower.tail = TRUE, log.p = FALSE, acc = 1e-20) { if (isTRUE(any(kappa < 0))) { stop2("kappa must be non-negative") } pi <- base::pi pi2 <- 2 * pi q <- (q + pi) %% pi2 mu <- (mu + pi) %% pi2 args <- expand(q = q, mu = mu, kappa = kappa) q <- args$q mu <- args$mu kappa <- args$kappa rm(args) # code basis taken from CircStats::pvm but improved # considerably with respect to speed and stability rec_sum <- function(q, kappa, acc, sum = 0, i = 1) { # compute the sum of of besselI functions recursively term <- (besselI(kappa, nu = i) * sin(i * q)) / i sum <- sum + term rd <- abs(term) >= acc if (sum(rd)) { sum[rd] <- rec_sum( q[rd], kappa[rd], acc, sum = sum[rd], i = i + 1 ) } sum } .pvon_mises <- function(q, kappa, acc) { sum <- rec_sum(q, kappa, acc) q / pi2 + sum / (pi * besselI(kappa, nu = 0)) } out <- rep(NA, length(mu)) zero_mu <- mu == 0 if (sum(zero_mu)) { out[zero_mu] <- .pvon_mises(q[zero_mu], kappa[zero_mu], acc) } lq_mu <- q <= mu if (sum(lq_mu)) { upper <- (q[lq_mu] - mu[lq_mu]) %% pi2 upper[upper == 0] <- pi2 lower <- (-mu[lq_mu]) %% pi2 out[lq_mu] <- .pvon_mises(upper, kappa[lq_mu], acc) - .pvon_mises(lower, kappa[lq_mu], acc) } uq_mu <- q > mu if (sum(uq_mu)) { upper <- q[uq_mu] - mu[uq_mu] lower <- mu[uq_mu] %% pi2 out[uq_mu] <- .pvon_mises(upper, kappa[uq_mu], acc) + .pvon_mises(lower, kappa[uq_mu], acc) } if (!lower.tail) { out <- 1 - out } if (log.p) { out <- log(out) } out } #' @rdname VonMises #' @export rvon_mises <- function(n, mu, kappa) { if (isTRUE(any(kappa < 0))) { stop2("kappa must be non-negative") } args <- expand(mu = mu, kappa = kappa, length = n) mu <- args$mu kappa <- args$kappa rm(args) pi <- base::pi mu <- mu + pi # code basis taken from CircStats::rvm but improved # considerably with respect to speed and stability rvon_mises_outer <- function(r, mu, kappa) { n <- length(r) U1 <- runif(n, 0, 1) z <- cos(pi * U1) f <- (1 + r * z) / (r + z) c <- kappa * (r - f) U2 <- runif(n, 0, 1) outer <- is.na(f) | is.infinite(f) | !(c * (2 - c) - U2 > 0 | log(c / U2) + 1 - c >= 0) inner <- !outer out <- rep(NA, n) if (sum(inner)) { out[inner] <- rvon_mises_inner(f[inner], mu[inner]) } if (sum(outer)) { # evaluate recursively until a valid sample is found out[outer] <- rvon_mises_outer(r[outer], mu[outer], kappa[outer]) } out } rvon_mises_inner <- function(f, mu) { n <- length(f) U3 <- runif(n, 0, 1) (sign(U3 - 0.5) * acos(f) + mu) %% (2 * pi) } a <- 1 + (1 + 4 * (kappa^2))^0.5 b <- (a - (2 * a)^0.5) / (2 * kappa) r <- (1 + b^2) / (2 * b) # indicates underflow due to kappa being close to zero is_uf <- is.na(r) | is.infinite(r) not_uf <- !is_uf out <- rep(NA, n) if (sum(is_uf)) { out[is_uf] <- runif(sum(is_uf), 0, 2 * pi) } if (sum(not_uf)) { out[not_uf] <- rvon_mises_outer(r[not_uf], mu[not_uf], kappa[not_uf]) } out - pi } #' The Exponentially Modified Gaussian Distribution #' #' Density, distribution function, and random generation #' for the exponentially modified Gaussian distribution with #' mean \code{mu} and standard deviation \code{sigma} of the gaussian #' component, as well as scale \code{beta} of the exponential #' component. #' #' @name ExGaussian #' #' @inheritParams StudentT #' @param x,q Vector of quantiles. #' @param mu Vector of means of the combined distribution. #' @param sigma Vector of standard deviations of the gaussian component. #' @param beta Vector of scales of the exponential component. #' #' @details See \code{vignette("brms_families")} for details #' on the parameterization. #' #' @export dexgaussian <- function(x, mu, sigma, beta, log = FALSE) { if (isTRUE(any(sigma < 0))) { stop2("sigma must be non-negative.") } if (isTRUE(any(beta < 0))) { stop2("beta must be non-negative.") } args <- nlist(x, mu, sigma, beta) args <- do_call(expand, args) args$mu <- with(args, mu - beta) args$z <- with(args, x - mu - sigma^2 / beta) out <- with(args, -log(beta) - (z + sigma^2 / (2 * beta)) / beta + pnorm(z / sigma, log.p = TRUE) ) if (!log) { out <- exp(out) } out } #' @rdname ExGaussian #' @export pexgaussian <- function(q, mu, sigma, beta, lower.tail = TRUE, log.p = FALSE) { if (isTRUE(any(sigma < 0))) { stop2("sigma must be non-negative.") } if (isTRUE(any(beta < 0))) { stop2("beta must be non-negative.") } args <- nlist(q, mu, sigma, beta) args <- do_call(expand, args) args$mu <- with(args, mu - beta) args$z <- with(args, q - mu - sigma^2 / beta) out <- with(args, pnorm((q - mu) / sigma) - pnorm(z / sigma) * exp(((mu + sigma^2 / beta)^2 - mu^2 - 2 * q * sigma^2 / beta) / (2 * sigma^2)) ) if (!lower.tail) { out <- 1 - out } if (log.p) { out <- log(out) } out } #' @rdname ExGaussian #' @export rexgaussian <- function(n, mu, sigma, beta) { if (isTRUE(any(sigma < 0))) { stop2("sigma must be non-negative.") } if (isTRUE(any(beta < 0))) { stop2("beta must be non-negative.") } mu <- mu - beta rnorm(n, mean = mu, sd = sigma) + rexp(n, rate = 1 / beta) } #' The Frechet Distribution #' #' Density, distribution function, quantile function and random generation #' for the Frechet distribution with location \code{loc}, scale \code{scale}, #' and shape \code{shape}. #' #' @name Frechet #' #' @inheritParams StudentT #' @param x,q Vector of quantiles. #' @param loc Vector of locations. #' @param scale Vector of scales. #' @param shape Vector of shapes. #' #' @details See \code{vignette("brms_families")} for details #' on the parameterization. #' #' @export dfrechet <- function(x, loc = 0, scale = 1, shape = 1, log = FALSE) { if (isTRUE(any(scale <= 0))) { stop2("Argument 'scale' must be positive.") } if (isTRUE(any(shape <= 0))) { stop2("Argument 'shape' must be positive.") } x <- (x - loc) / scale args <- nlist(x, loc, scale, shape) args <- do_call(expand, args) out <- with(args, log(shape / scale) - (1 + shape) * log(x) - x^(-shape) ) if (!log) { out <- exp(out) } out } #' @rdname Frechet #' @export pfrechet <- function(q, loc = 0, scale = 1, shape = 1, lower.tail = TRUE, log.p = FALSE) { if (isTRUE(any(scale <= 0))) { stop2("Argument 'scale' must be positive.") } if (isTRUE(any(shape <= 0))) { stop2("Argument 'shape' must be positive.") } q <- pmax((q - loc) / scale, 0) out <- exp(-q^(-shape)) if (!lower.tail) { out <- 1 - out } if (log.p) { out <- log(out) } out } #' @rdname Frechet #' @export qfrechet <- function(p, loc = 0, scale = 1, shape = 1, lower.tail = TRUE, log.p = FALSE) { if (isTRUE(any(scale <= 0))) { stop2("Argument 'scale' must be positive.") } if (isTRUE(any(shape <= 0))) { stop2("Argument 'shape' must be positive.") } p <- validate_p_dist(p, lower.tail = lower.tail, log.p = log.p) loc + scale * (-log(p))^(-1/shape) } #' @rdname Frechet #' @export rfrechet <- function(n, loc = 0, scale = 1, shape = 1) { if (isTRUE(any(scale <= 0))) { stop2("Argument 'scale' must be positive.") } if (isTRUE(any(shape <= 0))) { stop2("Argument 'shape' must be positive.") } loc + scale * rexp(n)^(-1 / shape) } #' The Shifted Log Normal Distribution #' #' Density, distribution function, quantile function and random generation #' for the shifted log normal distribution with mean \code{meanlog}, #' standard deviation \code{sdlog}, and shift parameter \code{shift}. #' #' @name Shifted_Lognormal #' #' @inheritParams StudentT #' @param x,q Vector of quantiles. #' @param meanlog Vector of means. #' @param sdlog Vector of standard deviations. #' @param shift Vector of shifts. #' #' @details See \code{vignette("brms_families")} for details #' on the parameterization. #' #' @export dshifted_lnorm <- function(x, meanlog = 0, sdlog = 1, shift = 0, log = FALSE) { args <- nlist(dist = "lnorm", x, shift, meanlog, sdlog, log) do_call(dshifted, args) } #' @rdname Shifted_Lognormal #' @export pshifted_lnorm <- function(q, meanlog = 0, sdlog = 1, shift = 0, lower.tail = TRUE, log.p = FALSE) { args <- nlist(dist = "lnorm", q, shift, meanlog, sdlog, lower.tail, log.p) do_call(pshifted, args) } #' @rdname Shifted_Lognormal #' @export qshifted_lnorm <- function(p, meanlog = 0, sdlog = 1, shift = 0, lower.tail = TRUE, log.p = FALSE) { args <- nlist(dist = "lnorm", p, shift, meanlog, sdlog, lower.tail, log.p) do_call(qshifted, args) } #' @rdname Shifted_Lognormal #' @export rshifted_lnorm <- function(n, meanlog = 0, sdlog = 1, shift = 0) { args <- nlist(dist = "lnorm", n, shift, meanlog, sdlog) do_call(rshifted, args) } #' The Inverse Gaussian Distribution #' #' Density, distribution function, and random generation #' for the inverse Gaussian distribution with location \code{mu}, #' and shape \code{shape}. #' #' @name InvGaussian #' #' @inheritParams StudentT #' @param x,q Vector of quantiles. #' @param mu Vector of locations. #' @param shape Vector of shapes. #' #' @details See \code{vignette("brms_families")} for details #' on the parameterization. #' #' @export dinv_gaussian <- function(x, mu = 1, shape = 1, log = FALSE) { if (isTRUE(any(mu <= 0))) { stop2("Argument 'mu' must be positive.") } if (isTRUE(any(shape <= 0))) { stop2("Argument 'shape' must be positive.") } args <- nlist(x, mu, shape) args <- do_call(expand, args) out <- with(args, 0.5 * log(shape / (2 * pi)) - 1.5 * log(x) - 0.5 * shape * (x - mu)^2 / (x * mu^2) ) if (!log) { out <- exp(out) } out } #' @rdname InvGaussian #' @export pinv_gaussian <- function(q, mu = 1, shape = 1, lower.tail = TRUE, log.p = FALSE) { if (isTRUE(any(mu <= 0))) { stop2("Argument 'mu' must be positive.") } if (isTRUE(any(shape <= 0))) { stop2("Argument 'shape' must be positive.") } args <- nlist(q, mu, shape) args <- do_call(expand, args) out <- with(args, pnorm(sqrt(shape / q) * (q / mu - 1)) + exp(2 * shape / mu) * pnorm(-sqrt(shape / q) * (q / mu + 1)) ) if (!lower.tail) { out <- 1 - out } if (log.p) { out <- log(out) } out } #' @rdname InvGaussian #' @export rinv_gaussian <- function(n, mu = 1, shape = 1) { # create random numbers for the inverse gaussian distribution # Args: # Args: see dinv_gaussian if (isTRUE(any(mu <= 0))) { stop2("Argument 'mu' must be positive.") } if (isTRUE(any(shape <= 0))) { stop2("Argument 'shape' must be positive.") } args <- nlist(mu, shape, length = n) args <- do_call(expand, args) # algorithm from wikipedia args$y <- rnorm(n)^2 args$x <- with(args, mu + (mu^2 * y) / (2 * shape) - mu / (2 * shape) * sqrt(4 * mu * shape * y + mu^2 * y^2) ) args$z <- runif(n) with(args, ifelse(z <= mu / (mu + x), x, mu^2 / x)) } #' The Beta-binomial Distribution #' #' Cumulative density & mass functions, and random number generation for the #' Beta-binomial distribution using the following re-parameterisation of the #' \href{https://mc-stan.org/docs/2_29/functions-reference/beta-binomial-distribution.html}{Stan #' Beta-binomial definition}: #' \itemize{ #' \item{\code{mu = alpha * beta}} mean probability of trial success. #' \item{\code{phi = (1 - mu) * beta}} precision or over-dispersion, component. #' } #' #' @name BetaBinomial #' #' @inheritParams StudentT #' @param x,q Vector of quantiles. #' @param size Vector of number of trials (zero or more). #' @param mu Vector of means. #' @param phi Vector of precisions. #' #' @export dbeta_binomial <- function(x, size, mu, phi, log = FALSE) { require_package("extraDistr") alpha <- mu * phi beta <- (1 - mu) * phi extraDistr::dbbinom(x, size, alpha = alpha, beta = beta, log = log) } #' @rdname BetaBinomial #' @export pbeta_binomial <- function(q, size, mu, phi, lower.tail = TRUE, log.p = FALSE) { require_package("extraDistr") alpha <- mu * phi beta <- (1 - mu) * phi extraDistr::pbbinom(q, size, alpha = alpha, beta = beta, lower.tail = lower.tail, log.p = log.p) } #' @rdname BetaBinomial #' @export rbeta_binomial <- function(n, size, mu, phi) { # beta location-scale probabilities probs <- rbeta(n, mu * phi, (1 - mu) * phi) # binomial draws rbinom(n, size = size, prob = probs) } #' The Generalized Extreme Value Distribution #' #' Density, distribution function, and random generation #' for the generalized extreme value distribution with #' location \code{mu}, scale \code{sigma} and shape \code{xi}. #' #' @name GenExtremeValue #' #' @inheritParams StudentT #' @param x,q Vector of quantiles. #' @param mu Vector of locations. #' @param sigma Vector of scales. #' @param xi Vector of shapes. #' #' @details See \code{vignette("brms_families")} for details #' on the parameterization. #' #' @export dgen_extreme_value <- function(x, mu = 0, sigma = 1, xi = 0, log = FALSE) { if (isTRUE(any(sigma <= 0))) { stop2("sigma bust be positive.") } x <- (x - mu) / sigma args <- nlist(x, mu, sigma, xi) args <- do_call(expand, args) args$t <- with(args, 1 + xi * x) out <- with(args, ifelse( xi == 0, -log(sigma) - x - exp(-x), -log(sigma) - (1 + 1 / xi) * log(t) - t^(-1 / xi) )) if (!log) { out <- exp(out) } out } #' @rdname GenExtremeValue #' @export pgen_extreme_value <- function(q, mu = 0, sigma = 1, xi = 0, lower.tail = TRUE, log.p = FALSE) { if (isTRUE(any(sigma <= 0))) { stop2("sigma bust be positive.") } q <- (q - mu) / sigma args <- nlist(q, mu, sigma, xi) args <- do_call(expand, args) out <- with(args, ifelse( xi == 0, exp(-exp(-q)), exp(-(1 + xi * q)^(-1 / xi)) )) if (!lower.tail) { out <- 1 - out } if (log.p) { out <- log(out) } out } #' @rdname GenExtremeValue #' @export qgen_extreme_value <- function(p, mu = 0, sigma = 1, xi = 0, lower.tail = TRUE, log.p = FALSE) { if (isTRUE(any(sigma <= 0))) { stop2("sigma bust be positive.") } p <- validate_p_dist(p, lower.tail = lower.tail, log.p = log.p) args <- nlist(p, mu, sigma, xi) args <- do_call(expand, args) out <- with(args, ifelse( xi == 0, mu - sigma * log(-log(p)), mu - sigma * (1 - (-log(p)) ^ (-xi)) / xi )) out } #' @rdname GenExtremeValue #' @export rgen_extreme_value <- function(n, mu = 0, sigma = 1, xi = 0) { if (isTRUE(any(sigma <= 0))) { stop2("sigma bust be positive.") } args <- nlist(mu, sigma, xi, length = n) args <- do_call(expand, args) with(args, ifelse( xi == 0, mu - sigma * log(rexp(n)), mu + sigma * (rexp(n)^(-xi) - 1) / xi )) } #' The Asymmetric Laplace Distribution #' #' Density, distribution function, quantile function and random generation #' for the asymmetric Laplace distribution with location \code{mu}, #' scale \code{sigma} and asymmetry parameter \code{quantile}. #' #' @name AsymLaplace #' #' @inheritParams StudentT #' @param x,q Vector of quantiles. #' @param mu Vector of locations. #' @param sigma Vector of scales. #' @param quantile Asymmetry parameter corresponding to quantiles #' in quantile regression (hence the name). #' #' @details See \code{vignette("brms_families")} for details #' on the parameterization. #' #' @export dasym_laplace <- function(x, mu = 0, sigma = 1, quantile = 0.5, log = FALSE) { out <- ifelse(x < mu, yes = (quantile * (1 - quantile) / sigma) * exp((1 - quantile) * (x - mu) / sigma), no = (quantile * (1 - quantile) / sigma) * exp(-quantile * (x - mu) / sigma) ) if (log) { out <- log(out) } out } #' @rdname AsymLaplace #' @export pasym_laplace <- function(q, mu = 0, sigma = 1, quantile = 0.5, lower.tail = TRUE, log.p = FALSE) { out <- ifelse(q < mu, yes = quantile * exp((1 - quantile) * (q - mu) / sigma), no = 1 - (1 - quantile) * exp(-quantile * (q - mu) / sigma) ) if (!lower.tail) { out <- 1 - out } if (log.p) { out <- log(out) } out } #' @rdname AsymLaplace #' @export qasym_laplace <- function(p, mu = 0, sigma = 1, quantile = 0.5, lower.tail = TRUE, log.p = FALSE) { p <- validate_p_dist(p, lower.tail = lower.tail, log.p = log.p) if (length(quantile) == 1L) { quantile <- rep(quantile, length(mu)) } ifelse(p < quantile, yes = mu + ((sigma * log(p / quantile)) / (1 - quantile)), no = mu - ((sigma * log((1 - p) / (1 - quantile))) / quantile) ) } #' @rdname AsymLaplace #' @export rasym_laplace <- function(n, mu = 0, sigma = 1, quantile = 0.5) { u <- runif(n) qasym_laplace(u, mu = mu, sigma = sigma, quantile = quantile) } # The Discrete Weibull Distribution # # Density, distribution function, quantile function and random generation # for the discrete Weibull distribution with location \code{mu} and # shape \code{shape}. # # @name DiscreteWeibull # # @inheritParams StudentT # @param mu Location parameter in the unit interval. # @param shape Positive shape parameter. # # @details See \code{vignette("brms_families")} for details # on the parameterization. # # @export ddiscrete_weibull <- function(x, mu, shape, log = FALSE) { if (isTRUE(any(mu < 0 | mu > 1))) { stop2("mu bust be between 0 and 1.") } if (isTRUE(any(shape <= 0))) { stop2("shape bust be positive.") } x <- round(x) out <- mu^x^shape - mu^(x + 1)^shape out[x < 0] <- 0 if (log) { out <- log(out) } out } # @rdname DiscreteWeibull # @export pdiscrete_weibull <- function(x, mu, shape, lower.tail = TRUE, log.p = FALSE) { if (isTRUE(any(mu < 0 | mu > 1))) { stop2("mu bust be between 0 and 1.") } if (isTRUE(any(shape <= 0))) { stop2("shape bust be positive.") } x <- round(x) if (lower.tail) { out <- 1 - mu^(x + 1)^shape out[x < 0] <- 0 } else { out <- mu^(x + 1)^shape out[x < 0] <- 1 } if (log.p) { out <- log(out) } out } # @rdname DiscreteWeibull # @export qdiscrete_weibull <- function(p, mu, shape, lower.tail = TRUE, log.p = FALSE) { if (isTRUE(any(mu < 0 | mu > 1))) { stop2("mu bust be between 0 and 1.") } if (isTRUE(any(shape <= 0))) { stop2("shape bust be positive.") } p <- validate_p_dist(p, lower.tail = lower.tail, log.p = log.p) ceiling((log(1 - p) / log(mu))^(1 / shape) - 1) } # @rdname DiscreteWeibull # @export rdiscrete_weibull <- function(n, mu, shape) { u <- runif(n, 0, 1) qdiscrete_weibull(u, mu, shape) } # mean of the discrete weibull distribution # @param mu location parameter # @param shape shape parameter # @param M maximal evaluated element of the series # @param thres threshold for new elements at which to stop evaluation mean_discrete_weibull <- function(mu, shape, M = 1000, thres = 0.001) { opt_M <- ceiling(max((log(thres) / log(mu))^(1 / shape))) if (opt_M <= M) { M <- opt_M } else { # avoid the loop below running too slow warning2( "Approximating the mean of the 'discrete_weibull' ", "distribution failed and results be inaccurate." ) } out <- 0 for (y in seq_len(M)) { out <- out + mu^y^shape } # approximation of the residual series (see Englehart & Li, 2011) # returns unreasonably large values presumably due to numerical issues out } # PDF of the COM-Poisson distribution # com_poisson in brms uses the mode parameterization dcom_poisson <- function(x, mu, shape, log = FALSE) { x <- round(x) log_mu <- log(mu) log_Z <- log_Z_com_poisson(log_mu, shape) out <- shape * (x * log_mu - lgamma(x + 1)) - log_Z if (!log) { out <- exp(out) } out } # random numbers from the COM-Poisson distribution rcom_poisson <- function(n, mu, shape, M = 10000) { n <- check_n_rdist(n, mu, shape) M <- as.integer(as_one_numeric(M)) log_mu <- log(mu) # approximating log_Z may yield too large random draws log_Z <- log_Z_com_poisson(log_mu, shape, approx = FALSE) u <- runif(n, 0, 1) cdf <- exp(-log_Z) lfac <- 0 y <- 0 out <- rep(0, n) not_found <- cdf < u while (any(not_found) && y <= M) { y <- y + 1 out[not_found] <- y lfac <- lfac + log(y) cdf <- cdf + exp(shape * (y * log_mu - lfac) - log_Z) not_found <- cdf < u } if (any(not_found)) { out[not_found] <- NA nfailed <- sum(not_found) warning2( "Drawing random numbers from the 'com_poisson' ", "distribution failed in ", nfailed, " cases." ) } out } # CDF of the COM-Poisson distribution pcom_poisson <- function(x, mu, shape, lower.tail = TRUE, log.p = FALSE) { x <- round(x) args <- expand(x = x, mu = mu, shape = shape) x <- args$x mu <- args$mu shape <- args$shape log_mu <- log(mu) log_Z <- log_Z_com_poisson(log_mu, shape) out <- rep(0, length(x)) dim(out) <- attributes(args)$max_dim out[x > 0] <- log1p_exp(shape * log_mu) k <- 2 lfac <- 0 while (any(x >= k)) { lfac <- lfac + log(k) term <- shape * (k * log_mu - lfac) out[x >= k] <- log_sum_exp(out[x >= k], term) k <- k + 1 } out <- out - log_Z out[out > 0] <- 0 if (!lower.tail) { out <- log1m_exp(out) } if (!log.p) { out <- exp(out) } out } # log normalizing constant of the COM Poisson distribution # @param log_mu log location parameter # @param shape shape parameter # @param M maximal evaluated element of the series # @param thres threshold for new elements at which to stop evaluation # @param approx use a closed form approximation of the mean if appropriate? log_Z_com_poisson <- function(log_mu, shape, M = 10000, thres = 1e-16, approx = TRUE) { if (isTRUE(any(shape <= 0))) { stop2("'shape' must be positive.") } if (isTRUE(any(shape == Inf))) { stop2("'shape' must be finite.") } approx <- as_one_logical(approx) args <- expand(log_mu = log_mu, shape = shape) log_mu <- args$log_mu shape <- args$shape out <- rep(NA, length(log_mu)) dim(out) <- attributes(args)$max_dim use_poisson <- shape == 1 if (any(use_poisson)) { # shape == 1 implies the poisson distribution out[use_poisson] <- exp(log_mu[use_poisson]) } if (approx) { # use a closed form approximation if appropriate use_approx <- log_mu * shape >= log(1.5) & log_mu >= log(1.5) if (any(use_approx)) { out[use_approx] <- log_Z_com_poisson_approx( log_mu[use_approx], shape[use_approx] ) } } use_exact <- is.na(out) if (any(use_exact)) { # direct computation of the truncated series M <- as.integer(as_one_numeric(M)) thres <- as_one_numeric(thres) log_thres <- log(thres) log_mu <- log_mu[use_exact] shape <- shape[use_exact] # first 2 terms of the series out_exact <- log1p_exp(shape * log_mu) lfac <- 0 k <- 2 converged <- FALSE while (!converged && k <= M) { lfac <- lfac + log(k) term <- shape * (k * log_mu - lfac) out_exact <- log_sum_exp(out_exact, term) converged <- all(term <= log_thres) k <- k + 1 } out[use_exact] <- out_exact if (!converged) { warning2( "Approximating the normalizing constant of the 'com_poisson' ", "distribution failed and results may be inaccurate." ) } } out } # approximate the log normalizing constant of the COM Poisson distribution # based on doi:10.1007/s10463-017-0629-6 log_Z_com_poisson_approx <- function(log_mu, shape) { shape_mu <- shape * exp(log_mu) shape2 <- shape^2 # first 4 terms of the residual series log_sum_resid <- log( 1 + shape_mu^(-1) * (shape2 - 1) / 24 + shape_mu^(-2) * (shape2 - 1) / 1152 * (shape2 + 23) + shape_mu^(-3) * (shape2 - 1) / 414720 * (5 * shape2^2 - 298 * shape2 + 11237) ) shape_mu + log_sum_resid - ((log(2 * pi) + log_mu) * (shape - 1) / 2 + log(shape) / 2) } # compute the log mean of the COM Poisson distribution # @param mu location parameter # @param shape shape parameter # @param M maximal evaluated element of the series # @param thres threshold for new elements at which to stop evaluation # @param approx use a closed form approximation of the mean if appropriate? mean_com_poisson <- function(mu, shape, M = 10000, thres = 1e-16, approx = TRUE) { if (isTRUE(any(shape <= 0))) { stop2("'shape' must be positive.") } if (isTRUE(any(shape == Inf))) { stop2("'shape' must be finite.") } approx <- as_one_logical(approx) args <- expand(mu = mu, shape = shape) mu <- args$mu shape <- args$shape out <- rep(NA, length(mu)) dim(out) <- attributes(args)$max_dim use_poisson <- shape == 1 if (any(use_poisson)) { # shape == 1 implies the poisson distribution out[use_poisson] <- mu[use_poisson] } if (approx) { # use a closed form approximation if appropriate use_approx <- mu^shape >= 1.5 & mu >= 1.5 if (any(use_approx)) { out[use_approx] <- mean_com_poisson_approx( mu[use_approx], shape[use_approx] ) } } use_exact <- is.na(out) if (any(use_exact)) { # direct computation of the truncated series M <- as.integer(as_one_numeric(M)) thres <- as_one_numeric(thres) log_thres <- log(thres) mu <- mu[use_exact] shape <- shape[use_exact] log_mu <- log(mu) # first 2 terms of the series log_num <- shape * log_mu # numerator log_Z <- log1p_exp(shape * log_mu) # denominator lfac <- 0 k <- 2 converged <- FALSE while (!converged && k <= M) { log_k <- log(k) lfac <- lfac + log_k term <- shape * (k * log_mu - lfac) log_num <- log_sum_exp(log_num, log_k + term) log_Z <- log_sum_exp(log_Z, term) converged <- all(term <= log_thres) k <- k + 1 } if (!converged) { warning2( "Approximating the mean of the 'com_poisson' ", "distribution failed and results may be inaccurate." ) } out[use_exact] <- exp(log_num - log_Z) } out } # approximate the mean of COM-Poisson distribution # based on doi:10.1007/s10463-017-0629-6 mean_com_poisson_approx <- function(mu, shape) { term <- 1 - (shape - 1) / (2 * shape) * mu^(-1) - (shape^2 - 1) / (24 * shape^2) * mu^(-2) - (shape^2 - 1) / (24 * shape^3) * mu^(-3) mu * term } #' The Dirichlet Distribution #' #' Density function and random number generation for the dirichlet #' distribution with shape parameter vector \code{alpha}. #' #' @name Dirichlet #' #' @inheritParams StudentT #' @param x Matrix of quantiles. Each row corresponds to one probability vector. #' @param alpha Matrix of positive shape parameters. Each row corresponds to one #' probability vector. #' #' @details See \code{vignette("brms_families")} for details on the #' parameterization. #' #' @export ddirichlet <- function(x, alpha, log = FALSE) { log <- as_one_logical(log) if (!is.matrix(x)) { x <- matrix(x, nrow = 1) } if (!is.matrix(alpha)) { alpha <- matrix(alpha, nrow(x), length(alpha), byrow = TRUE) } if (nrow(x) == 1L && nrow(alpha) > 1L) { x <- repl(x, nrow(alpha)) x <- do_call(rbind, x) } else if (nrow(x) > 1L && nrow(alpha) == 1L) { alpha <- repl(alpha, nrow(x)) alpha <- do_call(rbind, alpha) } if (isTRUE(any(x < 0))) { stop2("x must be non-negative.") } if (!is_equal(rowSums(x), rep(1, nrow(x)))) { stop2("x must sum to 1 per row.") } if (isTRUE(any(alpha <= 0))) { stop2("alpha must be positive.") } out <- lgamma(rowSums(alpha)) - rowSums(lgamma(alpha)) + rowSums((alpha - 1) * log(x)) if (!log) { out <- exp(out) } return(out) } #' @rdname Dirichlet #' @export rdirichlet <- function(n, alpha) { n <- as_one_numeric(n) if (!is.matrix(alpha)) { alpha <- matrix(alpha, nrow = 1) } if (prod(dim(alpha)) == 0) { stop2("alpha should be non-empty.") } if (isTRUE(any(alpha <= 0))) { stop2("alpha must be positive.") } if (n == 1) { n <- nrow(alpha) } if (n > nrow(alpha)) { alpha <- matrix(alpha, nrow = n, ncol = ncol(alpha), byrow = TRUE) } x <- matrix(rgamma(ncol(alpha) * n, alpha), ncol = ncol(alpha)) x / rowSums(x) } #' The Wiener Diffusion Model Distribution #' #' Density function and random generation for the Wiener #' diffusion model distribution with boundary separation \code{alpha}, #' non-decision time \code{tau}, bias \code{beta} and #' drift rate \code{delta}. #' #' @name Wiener #' #' @inheritParams StudentT #' @param alpha Boundary separation parameter. #' @param tau Non-decision time parameter. #' @param beta Bias parameter. #' @param delta Drift rate parameter. #' @param resp Response: \code{"upper"} or \code{"lower"}. #' If no character vector, it is coerced to logical #' where \code{TRUE} indicates \code{"upper"} and #' \code{FALSE} indicates \code{"lower"}. #' @param types Which types of responses to return? By default, #' return both the response times \code{"q"} and the dichotomous #' responses \code{"resp"}. If either \code{"q"} or \code{"resp"}, #' return only one of the two types. #' @param backend Name of the package to use as backend for the computations. #' Either \code{"Rwiener"} (the default) or \code{"rtdists"}. #' Can be set globally for the current \R session via the #' \code{"wiener_backend"} option (see \code{\link{options}}). #' #' @details #' These are wrappers around functions of the \pkg{RWiener} or \pkg{rtdists} #' package (depending on the chosen \code{backend}). See #' \code{vignette("brms_families")} for details on the parameterization. #' #' @seealso \code{\link[RWiener:wienerdist]{wienerdist}}, #' \code{\link[rtdists:Diffusion]{Diffusion}} #' #' @export dwiener <- function(x, alpha, tau, beta, delta, resp = 1, log = FALSE, backend = getOption("wiener_backend", "Rwiener")) { alpha <- as.numeric(alpha) tau <- as.numeric(tau) beta <- as.numeric(beta) delta <- as.numeric(delta) if (!is.character(resp)) { resp <- ifelse(resp, "upper", "lower") } log <- as_one_logical(log) backend <- match.arg(backend, c("Rwiener", "rtdists")) .dwiener <- paste0(".dwiener_", backend) args <- nlist(x, alpha, tau, beta, delta, resp) args <- as.list(do_call(expand, args)) args$log <- log do_call(.dwiener, args) } # dwiener using Rwiener as backend .dwiener_Rwiener <- function(x, alpha, tau, beta, delta, resp, log) { require_package("RWiener") .dwiener <- Vectorize( RWiener::dwiener, c("q", "alpha", "tau", "beta", "delta", "resp") ) args <- nlist(q = x, alpha, tau, beta, delta, resp, give_log = log) do_call(.dwiener, args) } # dwiener using rtdists as backend .dwiener_rtdists <- function(x, alpha, tau, beta, delta, resp, log) { require_package("rtdists") args <- list( rt = x, response = resp, a = alpha, t0 = tau, z = beta * alpha, v = delta ) out <- do_call(rtdists::ddiffusion, args) if (log) { out <- log(out) } out } #' @rdname Wiener #' @export rwiener <- function(n, alpha, tau, beta, delta, types = c("q", "resp"), backend = getOption("wiener_backend", "Rwiener")) { n <- as_one_numeric(n) alpha <- as.numeric(alpha) tau <- as.numeric(tau) beta <- as.numeric(beta) delta <- as.numeric(delta) types <- match.arg(types, several.ok = TRUE) backend <- match.arg(backend, c("Rwiener", "rtdists")) .rwiener <- paste0(".rwiener_", backend) args <- nlist(n, alpha, tau, beta, delta, types) do_call(.rwiener, args) } # rwiener using Rwiener as backend .rwiener_Rwiener <- function(n, alpha, tau, beta, delta, types) { require_package("RWiener") max_len <- max(lengths(list(alpha, tau, beta, delta))) if (max_len > 1L) { if (!n %in% c(1, max_len)) { stop2("Can only sample exactly once for each condition.") } n <- 1 } # helper function to return a numeric vector instead # of a data.frame with two columns as for RWiener::rwiener .rwiener_num <- function(n, alpha, tau, beta, delta, types) { out <- RWiener::rwiener(n, alpha, tau, beta, delta) out$resp <- ifelse(out$resp == "upper", 1, 0) if (length(types) == 1L) { out <- out[[types]] } out } # vectorized version of .rwiener_num .rwiener <- function(...) { fun <- Vectorize( .rwiener_num, c("alpha", "tau", "beta", "delta"), SIMPLIFY = FALSE ) do_call(rbind, fun(...)) } args <- nlist(n, alpha, tau, beta, delta, types) do_call(.rwiener, args) } # rwiener using rtdists as backend .rwiener_rtdists <- function(n, alpha, tau, beta, delta, types) { require_package("rtdists") max_len <- max(lengths(list(alpha, tau, beta, delta))) if (max_len > 1L) { if (!n %in% c(1, max_len)) { stop2("Can only sample exactly once for each condition.") } n <- max_len } out <- rtdists::rdiffusion( n, a = alpha, t0 = tau, z = beta * alpha, v = delta ) # TODO: use column names of rtdists in the output? names(out)[names(out) == "rt"] <- "q" names(out)[names(out) == "response"] <- "resp" out$resp <- ifelse(out$resp == "upper", 1, 0) if (length(types) == 1L) { out <- out[[types]] } out } # density of the cox proportional hazards model # @param x currently ignored as the information is passed # via 'bhaz' and 'cbhaz'. Before exporting the cox distribution # functions, this needs to be refactored so that x is actually used # @param mu positive location parameter # @param bhaz baseline hazard # @param cbhaz cumulative baseline hazard dcox <- function(x, mu, bhaz, cbhaz, log = FALSE) { out <- hcox(x, mu, bhaz, cbhaz, log = TRUE) + pcox(x, mu, bhaz, cbhaz, lower.tail = FALSE, log.p = TRUE) if (!log) { out <- exp(out) } out } # hazard function of the cox model hcox <- function(x, mu, bhaz, cbhaz, log = FALSE) { out <- log(bhaz) + log(mu) if (!log) { out <- exp(out) } out } # distribution function of the cox model pcox <- function(q, mu, bhaz, cbhaz, lower.tail = TRUE, log.p = FALSE) { log_surv <- -cbhaz * mu if (lower.tail) { if (log.p) { out <- log1m_exp(log_surv) } else { out <- 1 - exp(log_surv) } } else { if (log.p) { out <- log_surv } else { out <- exp(log_surv) } } out } # ensures that posterior_predict and friends can safely find these functions dxbeta <- function(...) { require_package("betareg") betareg::dxbeta(...) } pxbeta <- function(...) { require_package("betareg") betareg::pxbeta(...) } qxbeta <- function(...) { require_package("betareg") betareg::qxbeta(...) } rxbeta <- function(...) { require_package("betareg") betareg::rxbeta(...) } #' Zero-Inflated Distributions #' #' Density and distribution functions for zero-inflated distributions. #' #' @name ZeroInflated #' #' @inheritParams StudentT #' @param zi zero-inflation probability #' @param mu,lambda location parameter #' @param shape,shape1,shape2 shape parameter #' @param phi precision parameter #' @param size number of trials #' @param prob probability of success on each trial #' #' @details #' The density of a zero-inflated distribution can be specified as follows. #' If \eqn{x = 0} set \eqn{f(x) = \theta + (1 - \theta) * g(0)}. #' Else set \eqn{f(x) = (1 - \theta) * g(x)}, #' where \eqn{g(x)} is the density of the non-zero-inflated part. NULL #' @rdname ZeroInflated #' @export dzero_inflated_poisson <- function(x, lambda, zi, log = FALSE) { pars <- nlist(lambda) .dzero_inflated(x, "pois", zi, pars, log) } #' @rdname ZeroInflated #' @export pzero_inflated_poisson <- function(q, lambda, zi, lower.tail = TRUE, log.p = FALSE) { pars <- nlist(lambda) .pzero_inflated(q, "pois", zi, pars, lower.tail, log.p) } #' @rdname ZeroInflated #' @export dzero_inflated_negbinomial <- function(x, mu, shape, zi, log = FALSE) { pars <- nlist(mu, size = shape) .dzero_inflated(x, "nbinom", zi, pars, log) } #' @rdname ZeroInflated #' @export pzero_inflated_negbinomial <- function(q, mu, shape, zi, lower.tail = TRUE, log.p = FALSE) { pars <- nlist(mu, size = shape) .pzero_inflated(q, "nbinom", zi, pars, lower.tail, log.p) } #' @rdname ZeroInflated #' @export dzero_inflated_binomial <- function(x, size, prob, zi, log = FALSE) { pars <- nlist(size, prob) .dzero_inflated(x, "binom", zi, pars, log) } #' @rdname ZeroInflated #' @export pzero_inflated_binomial <- function(q, size, prob, zi, lower.tail = TRUE, log.p = FALSE) { pars <- nlist(size, prob) .pzero_inflated(q, "binom", zi, pars, lower.tail, log.p) } #' @rdname ZeroInflated #' @export dzero_inflated_beta_binomial <- function(x, size, mu, phi, zi, log = FALSE) { pars <- nlist(size, mu, phi) .dzero_inflated(x, "beta_binomial", zi, pars, log) } #' @rdname ZeroInflated #' @export pzero_inflated_beta_binomial <- function(q, size, mu, phi, zi, lower.tail = TRUE, log.p = FALSE) { pars <- nlist(size, mu, phi) .pzero_inflated(q, "beta_binomial", zi, pars, lower.tail, log.p) } #' @rdname ZeroInflated #' @export dzero_inflated_beta <- function(x, shape1, shape2, zi, log = FALSE) { pars <- nlist(shape1, shape2) # zi_beta is technically a hurdle model .dhurdle(x, "beta", zi, pars, log, type = "real") } #' @rdname ZeroInflated #' @export pzero_inflated_beta <- function(q, shape1, shape2, zi, lower.tail = TRUE, log.p = FALSE) { pars <- nlist(shape1, shape2) # zi_beta is technically a hurdle model .phurdle(q, "beta", zi, pars, lower.tail, log.p, type = "real") } # @rdname ZeroInflated # @export dzero_inflated_asym_laplace <- function(x, mu, sigma, quantile, zi, log = FALSE) { pars <- nlist(mu, sigma, quantile) # zi_asym_laplace is technically a hurdle model .dhurdle(x, "asym_laplace", zi, pars, log, type = "real") } # @rdname ZeroInflated # @export pzero_inflated_asym_laplace <- function(q, mu, sigma, quantile, zi, lower.tail = TRUE, log.p = FALSE) { pars <- nlist(mu, sigma, quantile) # zi_asym_laplace is technically a hurdle model .phurdle(q, "asym_laplace", zi, pars, lower.tail, log.p, type = "real", lb = -Inf, ub = Inf) } # density of a zero-inflated distribution # @param dist name of the distribution # @param zi bernoulli zero-inflated parameter # @param pars list of parameters passed to pdf .dzero_inflated <- function(x, dist, zi, pars, log) { stopifnot(is.list(pars)) dist <- as_one_character(dist) log <- as_one_logical(log) args <- expand(dots = c(nlist(x, zi), pars)) x <- args$x zi <- args$zi pars <- args[names(pars)] pdf <- paste0("d", dist) out <- ifelse(x == 0, log(zi + (1 - zi) * do_call(pdf, c(0, pars))), log(1 - zi) + do_call(pdf, c(list(x), pars, log = TRUE)) ) if (!log) { out <- exp(out) } out } # CDF of a zero-inflated distribution # @param dist name of the distribution # @param zi bernoulli zero-inflated parameter # @param pars list of parameters passed to pdf # @param lb lower bound of the conditional distribution # @param ub upper bound of the conditional distribution .pzero_inflated <- function(q, dist, zi, pars, lower.tail, log.p, lb = 0, ub = Inf) { stopifnot(is.list(pars)) dist <- as_one_character(dist) lower.tail <- as_one_logical(lower.tail) log.p <- as_one_logical(log.p) lb <- as_one_numeric(lb) ub <- as_one_numeric(ub) args <- expand(dots = c(nlist(q, zi), pars)) q <- args$q zi <- args$zi pars <- args[names(pars)] cdf <- paste0("p", dist) # compute log CCDF values out <- log(1 - zi) + do_call(cdf, c(list(q), pars, lower.tail = FALSE, log.p = TRUE)) # take the limits of the distribution into account out <- ifelse(q < lb, 0, out) out <- ifelse(q > ub, -Inf, out) if (lower.tail) { out <- 1 - exp(out) if (log.p) { out <- log(out) } } else { if (!log.p) { out <- exp(out) } } out } #' Hurdle Distributions #' #' Density and distribution functions for hurdle distributions. #' #' @name Hurdle #' #' @inheritParams StudentT #' @param hu hurdle probability #' @param mu,lambda location parameter #' @param shape shape parameter #' @param sigma,scale scale parameter #' #' @details #' The density of a hurdle distribution can be specified as follows. #' If \eqn{x = 0} set \eqn{f(x) = \theta}. Else set #' \eqn{f(x) = (1 - \theta) * g(x) / (1 - G(0))} #' where \eqn{g(x)} and \eqn{G(x)} are the density and distribution #' function of the non-hurdle part, respectively. NULL #' @rdname Hurdle #' @export dhurdle_poisson <- function(x, lambda, hu, log = FALSE) { pars <- nlist(lambda) .dhurdle(x, "pois", hu, pars, log, type = "int") } #' @rdname Hurdle #' @export phurdle_poisson <- function(q, lambda, hu, lower.tail = TRUE, log.p = FALSE) { pars <- nlist(lambda) .phurdle(q, "pois", hu, pars, lower.tail, log.p, type = "int") } #' @rdname Hurdle #' @export dhurdle_negbinomial <- function(x, mu, shape, hu, log = FALSE) { pars <- nlist(mu, size = shape) .dhurdle(x, "nbinom", hu, pars, log, type = "int") } #' @rdname Hurdle #' @export phurdle_negbinomial <- function(q, mu, shape, hu, lower.tail = TRUE, log.p = FALSE) { pars <- nlist(mu, size = shape) .phurdle(q, "nbinom", hu, pars, lower.tail, log.p, type = "int") } #' @rdname Hurdle #' @export dhurdle_gamma <- function(x, shape, scale, hu, log = FALSE) { pars <- nlist(shape, scale) .dhurdle(x, "gamma", hu, pars, log, type = "real") } #' @rdname Hurdle #' @export phurdle_gamma <- function(q, shape, scale, hu, lower.tail = TRUE, log.p = FALSE) { pars <- nlist(shape, scale) .phurdle(q, "gamma", hu, pars, lower.tail, log.p, type = "real") } #' @rdname Hurdle #' @export dhurdle_lognormal <- function(x, mu, sigma, hu, log = FALSE) { pars <- list(meanlog = mu, sdlog = sigma) .dhurdle(x, "lnorm", hu, pars, log, type = "real") } #' @rdname Hurdle #' @export phurdle_lognormal <- function(q, mu, sigma, hu, lower.tail = TRUE, log.p = FALSE) { pars <- list(meanlog = mu, sdlog = sigma) .phurdle(q, "lnorm", hu, pars, lower.tail, log.p, type = "real") } # density of a hurdle distribution # @param dist name of the distribution # @param hu bernoulli hurdle parameter # @param pars list of parameters passed to pdf # @param type support of distribution (int or real) .dhurdle <- function(x, dist, hu, pars, log, type) { stopifnot(is.list(pars)) dist <- as_one_character(dist) log <- as_one_logical(log) type <- match.arg(type, c("int", "real")) args <- expand(dots = c(nlist(x, hu), pars)) x <- args$x hu <- args$hu pars <- args[names(pars)] pdf <- paste0("d", dist) if (type == "int") { lccdf0 <- log(1 - do_call(pdf, c(0, pars))) } else { lccdf0 <- 0 } out <- ifelse(x == 0, log(hu), log(1 - hu) + do_call(pdf, c(list(x), pars, log = TRUE)) - lccdf0 ) if (!log) { out <- exp(out) } out } # CDF of a hurdle distribution # @param dist name of the distribution # @param hu bernoulli hurdle parameter # @param pars list of parameters passed to pdf # @param type support of distribution (int or real) # @param lb lower bound of the conditional distribution # @param ub upper bound of the conditional distribution .phurdle <- function(q, dist, hu, pars, lower.tail, log.p, type, lb = 0, ub = Inf) { stopifnot(is.list(pars)) dist <- as_one_character(dist) lower.tail <- as_one_logical(lower.tail) log.p <- as_one_logical(log.p) type <- match.arg(type, c("int", "real")) lb <- as_one_numeric(lb) ub <- as_one_numeric(ub) args <- expand(dots = c(nlist(q, hu), pars)) q <- args$q hu <- args$hu pars <- args[names(pars)] cdf <- paste0("p", dist) # compute log CCDF values out <- log(1 - hu) + do_call(cdf, c(list(q), pars, lower.tail = FALSE, log.p = TRUE)) if (type == "int") { pdf <- paste0("d", dist) out <- out - log(1 - do_call(pdf, c(0, pars))) } out <- ifelse(q < 0, log_sum_exp(out, log(hu)), out) # take the limits of the distribution into account out <- ifelse(q < lb, 0, out) out <- ifelse(q > ub, -Inf, out) if (lower.tail) { out <- 1 - exp(out) if (log.p) { out <- log(out) } } else { if (!log.p) { out <- exp(out) } } out } # density of the categorical distribution with the softmax transform # @param x positive integers not greater than ncat # @param eta the linear predictor (of length or ncol ncat) # @param log return values on the log scale? dcategorical <- function(x, eta, log = FALSE) { if (is.null(dim(eta))) { eta <- matrix(eta, nrow = 1) } if (length(dim(eta)) != 2L) { stop2("eta must be a numeric vector or matrix.") } out <- inv_link_categorical(eta, log = log, refcat = NULL) out[, x, drop = FALSE] } # generic inverse link function for the categorical family # # @param x Matrix (S x `ncat` or S x `ncat - 1` (depending on `refcat_obj`), # with S denoting the number of posterior draws and `ncat` denoting the number # of response categories) with values of `eta` for one observation (see # dcategorical()) or an array (S x N x `ncat` or S x N x `ncat - 1` (depending # on `refcat_obj`)) containing the same values as the matrix just described, # but for N observations. # @param refcat Integer indicating the reference category to be inserted in 'x'. # If NULL, `x` is not modified at all. # @param log Logical (length 1) indicating whether to log the return value. # # @return If `x` is a matrix, then a matrix (S x `ncat`, with S denoting the # number of posterior draws and `ncat` denoting the number of response # categories) containing the values of the inverse-link function applied to # `x`. If `x` is an array, then an array (S x N x `ncat`) containing the same # values as the matrix just described, but for N observations. inv_link_categorical <- function(x, refcat = 1, log = FALSE) { if (!is.null(refcat)) { x <- insert_refcat(x, refcat = refcat) } out <- log_softmax(x) if (!log) { out <- exp(out) } out } # generic link function for the categorical family # # @param x Matrix (S x `ncat`, with S denoting the number of posterior draws and # `ncat` denoting the number of response categories) of probabilities for the # response categories or an array (S x N x `ncat`) containing the same values # as the matrix just described, but for N observations. # @param refcat Numeric (length 1) giving the index of the reference category. # @param return_refcat Logical (length 1) indicating whether to include the # reference category in the return value. # # @return If `x` is a matrix, then a matrix (S x `ncat` or S x `ncat - 1` # (depending on `return_refcat`), with S denoting the number of posterior # draws and `ncat` denoting the number of response categories) containing the # values of the link function applied to `x`. If `x` is an array, then an # array (S x N x `ncat` or S x N x `ncat - 1` (depending on `return_refcat`)) # containing the same values as the matrix just described, but for N # observations. link_categorical <- function(x, refcat = 1, return_refcat = FALSE) { ndim <- length(dim(x)) marg_noncat <- seq_along(dim(x))[-ndim] if (return_refcat) { x_tosweep <- x } else { x_tosweep <- slice(x, ndim, -refcat, drop = FALSE) } log(sweep( x_tosweep, MARGIN = marg_noncat, STATS = slice(x, ndim, refcat), FUN = "/" )) } # CDF of the categorical distribution with the softmax transform # @param q positive integers not greater than ncat # @param eta the linear predictor (of length or ncol ncat) # @param log.p return values on the log scale? pcategorical <- function(q, eta, log.p = FALSE) { p <- dcategorical(seq_len(max(q)), eta = eta) out <- cblapply(q, function(j) rowSums(p[, 1:j, drop = FALSE])) if (log.p) { out <- log(out) } out } # density of the multinomial distribution with the softmax transform # @param x positive integers not greater than ncat # @param eta the linear predictor (of length or ncol ncat) # @param log return values on the log scale? dmultinomial <- function(x, eta, log = FALSE) { if (is.null(dim(eta))) { eta <- matrix(eta, nrow = 1) } if (length(dim(eta)) != 2L) { stop2("eta must be a numeric vector or matrix.") } log_prob <- log_softmax(eta) size <- sum(x) x <- data2draws(x, dim = dim(eta)) out <- lgamma(size + 1) + rowSums(x * log_prob - lgamma(x + 1)) if (!log) { out <- exp(out) } out } # density of the dirichlet-multinomial distribution with the softmax transform # @param x positive integers not greater than ncat # @param eta the linear predictor (of length or ncol ncat) # @param phi the dispersion parameter (i.e., sum of dirichlet alphas) # @param log return values on the log scale? ddirichletmultinomial <- function(x, eta, phi, log = FALSE) { require_package("extraDistr") if (is.null(dim(eta))) { eta <- matrix(eta, nrow = 1) } if (length(dim(eta)) != 2L) { stop2("eta must be a numeric vector or matrix.") } alpha <- softmax(eta) * phi size <- sum(x) extraDistr::ddirmnom(x, size = size, alpha = alpha, log = log) } # density of the cumulative distribution # # @param x Integer vector containing response category indices to return the # "densities" (probability masses) for. # @param eta Vector (length S, with S denoting the number of posterior draws) of # linear predictor draws. # @param thres Matrix (S x `ncat - 1`, with S denoting the number of posterior # draws and `ncat` denoting the number of response categories) of threshold # draws. # @param disc Vector (length S, with S denoting the number of posterior draws, # or length 1 for recycling) of discrimination parameter draws. # @param link Character vector (length 1) giving the name of the link function. # # @return A matrix (S x `length(x)`) containing the values of the inverse-link # function applied to `disc * (thres - eta)`. dcumulative <- function(x, eta, thres, disc = 1, link = "logit") { eta <- disc * (thres - eta) if (link == "identity") { out <- eta } else { out <- inv_link_cumulative(eta, link = link) } out[, x, drop = FALSE] } # generic inverse link function for the cumulative family # # @param x Matrix (S x `ncat - 1`, with S denoting the number of posterior draws # and `ncat` denoting the number of response categories) with values of # `disc * (thres - eta)` for one observation (see dcumulative()) or an array # (S x N x `ncat - 1`) containing the same values as the matrix just # described, but for N observations. # @param link Character vector (length 1) giving the name of the link function. # # @return If `x` is a matrix, then a matrix (S x `ncat`, with S denoting the # number of posterior draws and `ncat` denoting the number of response # categories) containing the values of the inverse-link function applied to # `x`. If `x` is an array, then an array (S x N x `ncat`) containing the same # values as the matrix just described, but for N observations. inv_link_cumulative <- function(x, link) { x <- inv_link(x, link) ndim <- length(dim(x)) dim_noncat <- dim(x)[-ndim] ones_arr <- array(1, dim = c(dim_noncat, 1)) zeros_arr <- array(0, dim = c(dim_noncat, 1)) abind::abind(x, ones_arr) - abind::abind(zeros_arr, x) } # generic link function for the cumulative family # # @param x Matrix (S x `ncat`, with S denoting the number of posterior draws and # `ncat` denoting the number of response categories) of probabilities for the # response categories or an array (S x N x `ncat`) containing the same values # as the matrix just described, but for N observations. # @param link Character string (length 1) giving the name of the link function. # # @return If `x` is a matrix, then a matrix (S x `ncat - 1`, with S denoting the # number of posterior draws and `ncat` denoting the number of response # categories) containing the values of the link function applied to `x`. If # `x` is an array, then an array (S x N x `ncat - 1`) containing the same # values as the matrix just described, but for N observations. link_cumulative <- function(x, link) { ndim <- length(dim(x)) ncat <- dim(x)[ndim] dim_noncat <- dim(x)[-ndim] nthres <- dim(x)[ndim] - 1 marg_noncat <- seq_along(dim(x))[-ndim] dim_t <- c(nthres, dim_noncat) x <- apply(slice(x, ndim, -ncat, drop = FALSE), marg_noncat, cumsum) x <- aperm(array(x, dim = dim_t), perm = c(marg_noncat + 1, 1)) link(x, link) } # density of the sratio distribution # # @param x Integer vector containing response category indices to return the # "densities" (probability masses) for. # @param eta Vector (length S, with S denoting the number of posterior draws) of # linear predictor draws. # @param thres Matrix (S x `ncat - 1`, with S denoting the number of posterior # draws and `ncat` denoting the number of response categories) of threshold # draws. # @param disc Vector (length S, with S denoting the number of posterior draws, # or length 1 for recycling) of discrimination parameter draws. # @param link Character vector (length 1) giving the name of the link function. # # @return A matrix (S x `length(x)`) containing the values of the inverse-link # function applied to `disc * (thres - eta)`. dsratio <- function(x, eta, thres, disc = 1, link = "logit") { eta <- disc * (thres - eta) if (link == "identity") { out <- eta } else { out <- inv_link_sratio(eta, link = link) } out[, x, drop = FALSE] } # generic inverse link function for the sratio family # # @param x Matrix (S x `ncat - 1`, with S denoting the number of posterior draws # and `ncat` denoting the number of response categories) with values of # `disc * (thres - eta)` for one observation (see dsratio()) or an array # (S x N x `ncat - 1`) containing the same values as the matrix just # described, but for N observations. # @param link Character vector (length 1) giving the name of the link function. # # @return If `x` is a matrix, then a matrix (S x `ncat`, with S denoting the # number of posterior draws and `ncat` denoting the number of response # categories) containing the values of the inverse-link function applied to # `x`. If `x` is an array, then an array (S x N x `ncat`) containing the same # values as the matrix just described, but for N observations. inv_link_sratio <- function(x, link) { x <- inv_link(x, link) ndim <- length(dim(x)) dim_noncat <- dim(x)[-ndim] nthres <- dim(x)[ndim] marg_noncat <- seq_along(dim(x))[-ndim] ones_arr <- array(1, dim = c(dim_noncat, 1)) dim_t <- c(nthres, dim_noncat) Sx_cumprod <- aperm( array(apply(1 - x, marg_noncat, cumprod), dim = dim_t), perm = c(marg_noncat + 1, 1) ) abind::abind(x, ones_arr) * abind::abind(ones_arr, Sx_cumprod) } # generic link function for the sratio family # # @param x Matrix (S x `ncat`, with S denoting the number of posterior draws and # `ncat` denoting the number of response categories) of probabilities for the # response categories or an array (S x N x `ncat`) containing the same values # as the matrix just described, but for N observations. # @param link Character string (length 1) giving the name of the link function. # # @return If `x` is a matrix, then a matrix (S x `ncat - 1`, with S denoting the # number of posterior draws and `ncat` denoting the number of response # categories) containing the values of the link function applied to `x`. If # `x` is an array, then an array (S x N x `ncat - 1`) containing the same # values as the matrix just described, but for N observations. link_sratio <- function(x, link) { ndim <- length(dim(x)) .F_k <- function(k) { if (k == 1) { prev_res <- list(F_k = NULL, S_km1_prod = 1) } else { prev_res <- .F_k(k - 1) } F_k <- slice(x, ndim, k, drop = FALSE) / prev_res$S_km1_prod .out <- list( F_k = abind::abind(prev_res$F_k, F_k), S_km1_prod = prev_res$S_km1_prod * (1 - F_k) ) return(.out) } x <- .F_k(dim(x)[ndim] - 1)$F_k link(x, link) } # density of the cratio distribution # # @param x Integer vector containing response category indices to return the # "densities" (probability masses) for. # @param eta Vector (length S, with S denoting the number of posterior draws) of # linear predictor draws. # @param thres Matrix (S x `ncat - 1`, with S denoting the number of posterior # draws and `ncat` denoting the number of response categories) of threshold # draws. # @param disc Vector (length S, with S denoting the number of posterior draws, # or length 1 for recycling) of discrimination parameter draws. # @param link Character vector (length 1) giving the name of the link function. # # @return A matrix (S x `length(x)`) containing the values of the inverse-link # function applied to `disc * (thres - eta)`. dcratio <- function(x, eta, thres, disc = 1, link = "logit") { eta <- disc * (eta - thres) if (link == "identity") { out <- eta } else { out <- inv_link_cratio(eta, link = link) } out[, x, drop = FALSE] } # generic inverse link function for the cratio family # # @param x Matrix (S x `ncat - 1`, with S denoting the number of posterior draws # and `ncat` denoting the number of response categories) with values of # `disc * (thres - eta)` for one observation (see dcratio()) or an array # (S x N x `ncat - 1`) containing the same values as the matrix just # described, but for N observations. # @param link Character vector (length 1) giving the name of the link function. # # @return If `x` is a matrix, then a matrix (S x `ncat`, with S denoting the # number of posterior draws and `ncat` denoting the number of response # categories) containing the values of the inverse-link function applied to # `x`. If `x` is an array, then an array (S x N x `ncat`) containing the same # values as the matrix just described, but for N observations. inv_link_cratio <- function(x, link) { x <- inv_link(x, link) ndim <- length(dim(x)) dim_noncat <- dim(x)[-ndim] nthres <- dim(x)[ndim] marg_noncat <- seq_along(dim(x))[-ndim] ones_arr <- array(1, dim = c(dim_noncat, 1)) dim_t <- c(nthres, dim_noncat) x_cumprod <- aperm( array(apply(x, marg_noncat, cumprod), dim = dim_t), perm = c(marg_noncat + 1, 1) ) abind::abind(1 - x, ones_arr) * abind::abind(ones_arr, x_cumprod) } # generic link function for the cratio family # # @param x Matrix (S x `ncat`, with S denoting the number of posterior draws and # `ncat` denoting the number of response categories) of probabilities for the # response categories or an array (S x N x `ncat`) containing the same values # as the matrix just described, but for N observations. # @param link Character string (length 1) giving the name of the link function. # # @return If `x` is a matrix, then a matrix (S x `ncat - 1`, with S denoting the # number of posterior draws and `ncat` denoting the number of response # categories) containing the values of the link function applied to `x`. If # `x` is an array, then an array (S x N x `ncat - 1`) containing the same # values as the matrix just described, but for N observations. link_cratio <- function(x, link) { ndim <- length(dim(x)) .F_k <- function(k) { if (k == 1) { prev_res <- list(F_k = NULL, F_km1_prod = 1) } else { prev_res <- .F_k(k - 1) } F_k <- 1 - slice(x, ndim, k, drop = FALSE) / prev_res$F_km1_prod .out <- list( F_k = abind::abind(prev_res$F_k, F_k), F_km1_prod = prev_res$F_km1_prod * F_k ) return(.out) } x <- .F_k(dim(x)[ndim] - 1)$F_k link(x, link) } # density of the acat distribution # # @param x Integer vector containing response category indices to return the # "densities" (probability masses) for. # @param eta Vector (length S, with S denoting the number of posterior draws) of # linear predictor draws. # @param thres Matrix (S x `ncat - 1`, with S denoting the number of posterior # draws and `ncat` denoting the number of response categories) of threshold # draws. # @param disc Vector (length S, with S denoting the number of posterior draws, # or length 1 for recycling) of discrimination parameter draws. # @param link Character vector (length 1) giving the name of the link function. # # @return A matrix (S x `length(x)`) containing the values of the inverse-link # function applied to `disc * (thres - eta)`. dacat <- function(x, eta, thres, disc = 1, link = "logit") { eta <- disc * (eta - thres) if (link == "identity") { out <- eta } else { out <- inv_link_acat(eta, link = link) } out[, x, drop = FALSE] } # generic inverse link function for the acat family # # @param x Matrix (S x `ncat - 1`, with S denoting the number of posterior draws # and `ncat` denoting the number of response categories) with values of # `disc * (thres - eta)` (see dacat()). # @param link Character vector (length 1) giving the name of the link function. # # @return A matrix (S x `ncat`, with S denoting the number of posterior draws # and `ncat` denoting the number of response categories) containing the values # of the inverse-link function applied to `x`. inv_link_acat <- function(x, link) { ndim <- length(dim(x)) dim_noncat <- dim(x)[-ndim] nthres <- dim(x)[ndim] marg_noncat <- seq_along(dim(x))[-ndim] ones_arr <- array(1, dim = c(dim_noncat, 1)) dim_t <- c(nthres, dim_noncat) if (link == "logit") { # faster evaluation in this case exp_x_cumprod <- aperm( array(apply(exp(x), marg_noncat, cumprod), dim = dim_t), perm = c(marg_noncat + 1, 1) ) out <- abind::abind(ones_arr, exp_x_cumprod) } else { x <- inv_link(x, link) x_cumprod <- aperm( array(apply(x, marg_noncat, cumprod), dim = dim_t), perm = c(marg_noncat + 1, 1) ) Sx_cumprod_rev <- apply( 1 - slice(x, ndim, rev(seq_len(nthres)), drop = FALSE), marg_noncat, cumprod ) Sx_cumprod_rev <- aperm( array(Sx_cumprod_rev, dim = dim_t), perm = c(marg_noncat + 1, 1) ) Sx_cumprod_rev <- slice( Sx_cumprod_rev, ndim, rev(seq_len(nthres)), drop = FALSE ) out <- abind::abind(ones_arr, x_cumprod) * abind::abind(Sx_cumprod_rev, ones_arr) } catsum <- array(apply(out, marg_noncat, sum), dim = dim_noncat) sweep(out, marg_noncat, catsum, "/") } # generic link function for the acat family # # @param x Matrix (S x `ncat`, with S denoting the number of posterior draws and # `ncat` denoting the number of response categories) of probabilities for the # response categories or an array (S x N x `ncat`) containing the same values # as the matrix just described, but for N observations. # @param link Character string (length 1) giving the name of the link function. # # @return If `x` is a matrix, then a matrix (S x `ncat - 1`, with S denoting the # number of posterior draws and `ncat` denoting the number of response # categories) containing the values of the link function applied to `x`. If # `x` is an array, then an array (S x N x `ncat - 1`) containing the same # values as the matrix just described, but for N observations. link_acat <- function(x, link) { ndim <- length(dim(x)) ncat <- dim(x)[ndim] x <- slice(x, ndim, -1, drop = FALSE) / slice(x, ndim, -ncat, drop = FALSE) if (link == "logit") { # faster evaluation in this case out <- log(x) } else { x <- inv_odds(x) out <- link(x, link) } out } # CDF for ordinal distributions # @param q positive integers not greater than ncat # @param eta draws of the linear predictor # @param thres draws of threshold parameters # @param disc draws of the discrimination parameter # @param family a character string naming the family # @param link a character string naming the link # @return a matrix of probabilities P(x <= q) pordinal <- function(q, eta, thres, disc = 1, family = NULL, link = "logit") { family <- as_one_character(family) link <- as_one_character(link) args <- nlist(x = seq_len(max(q)), eta, thres, disc, link) p <- do_call(paste0("d", family), args) .fun <- function(j) rowSums(as.matrix(p[, 1:j, drop = FALSE])) cblapply(q, .fun) } # helper functions to shift arbitrary distributions dshifted <- function(dist, x, shift = 0, ...) { do_call(paste0("d", dist), list(x - shift, ...)) } pshifted <- function(dist, q, shift = 0, ...) { do_call(paste0("p", dist), list(q - shift, ...)) } qshifted <- function(dist, p, shift = 0, ...) { do_call(paste0("q", dist), list(p, ...)) + shift } rshifted <- function(dist, n, shift = 0, ...) { do_call(paste0("r", dist), list(n, ...)) + shift } # validate argument p in q functions validate_p_dist <- function(p, lower.tail = TRUE, log.p = FALSE) { if (log.p) { p <- exp(p) } if (!lower.tail) { p <- 1 - p } if (isTRUE(any(p < 0)) || isTRUE(any(p > 1))) { p[p < 0 | p > 1] <- NaN warning2("NaNs produced") } p } # check if 'n' in r functions is valid # @param n number of desired random draws # @param .. parameter vectors # @return validated 'n' check_n_rdist <- function(n, ...) { n <- as.integer(as_one_numeric(n)) max_len <- max(lengths(list(...))) if (max_len > 1L) { if (!n %in% c(1, max_len)) { stop2("'n' must match the maximum length of the parameter vectors.") } n <- max_len } n } brms/R/exclude_pars.R0000644000176200001440000001743515053072461014234 0ustar liggesusers# list parameters NOT to be saved by Stan # @return a vector of parameter names to be excluded exclude_pars <- function(x, ...) { UseMethod("exclude_pars") } #' @export exclude_pars.default <- function(x, ...) { character(0) } #' @export exclude_pars.brmsfit <- function(x, bframe = NULL, ...) { out <- character(0) if (is.null(bframe)) { # needed for the moment until brmsframe is stored in brmsfit bframe <- brmsframe(x$formula, data = x$data) } stopifnot(is.anybrmsframe(bframe)) c(out) <- exclude_pars(bframe, save_pars = x$save_pars, ...) c(out) <- exclude_pars_re(bframe, save_pars = x$save_pars, ...) c(out) <- exclude_pars_me(bframe, save_pars = x$save_pars, ...) out <- unique(out) out <- setdiff(out, x$save_pars$manual) out } #' @export exclude_pars.mvbrmsframe <- function(x, save_pars, ...) { out <- c("Rescor", "Sigma") if (!save_pars$all) { c(out) <- c("Lrescor", "LSigma") } for (i in seq_along(x$terms)) { c(out) <- exclude_pars(x$terms[[i]], save_pars = save_pars, ...) } out } #' @export exclude_pars.brmsframe <- function(x, save_pars, ...) { resp <- usc(combine_prefix(x)) par_classes <- c("Lncor", "Cortime") out <- paste0(par_classes, resp) if (!save_pars$all) { par_classes <- c( "ordered_Intercept", "fixed_Intercept", "theta", "Llncor", "Lcortime" ) c(out) <- paste0(par_classes, resp) } for (dp in names(x$dpars)) { c(out) <- exclude_pars(x$dpars[[dp]], save_pars = save_pars, ...) } for (nlp in names(x$nlpars)) { c(out) <- exclude_pars(x$nlpars[[nlp]], save_pars = save_pars, ...) } if (is.formula(x$adforms$mi)) { if (!(isTRUE(save_pars$latent) || x$resp %in% save_pars$latent)) { c(out) <- paste0("Yl", resp) } } if (!(isTRUE(save_pars$group) || ".err" %in% save_pars$group)) { # latent residuals are like group-level effects c(out) <- paste0("err", resp) } out } #' @export exclude_pars.bframel <- function(x, save_pars, ...) { out <- character(0) p <- usc(combine_prefix(x)) c(out) <- paste0("chol_cor", p) if (!save_pars$all) { # removed the "Intercept" and "first_Intercept" parameters from this list # to reduce the number of models that need refitting for moment matching par_classes <- c( "bQ", "zb", "zbsp", "zbs", "zar", "zma", "hs_local", "R2D2_phi", "scales", "merged_Intercept", "zcar", "nszcar", "zerr" ) c(out) <- paste0(par_classes, p) smframe <- x$frame$sm for (i in seq_rows(smframe)) { nb <- seq_len(smframe$nbases[i]) c(out) <- paste0("zs", p, "_", i, "_", nb) } } out } # exclude variables related to random effects exclude_pars_re <- function(bframe, save_pars, ...) { reframe <- bframe$frame$re stopifnot(is.reframe(reframe)) out <- list() if (!has_rows(reframe)) { return(out) } rm_re_pars <- c(if (!save_pars$all) c("z", "L"), "Cor", "r") for (id in unique(reframe$id)) { c(out) <- paste0(rm_re_pars, "_", id) } if (isFALSE(save_pars$group)) { p <- usc(combine_prefix(reframe)) c(out) <- paste0("r_", reframe$id, p, "_", reframe$cn) } else if (is.character(save_pars$group)) { sub_reframe <- reframe[!reframe$group %in% save_pars$group, ] if (has_rows(sub_reframe)) { sub_p <- usc(combine_prefix(sub_reframe)) c(out) <- paste0("r_", sub_reframe$id, sub_p, "_", sub_reframe$cn) } } reframe_t <- subset_reframe_dist(reframe, "student") if (!save_pars$all && has_rows(reframe_t)) { c(out) <- paste0(c("udf_", "dfm_"), reframe_t$ggn) } out } # exclude variables related to noise-free variables exclude_pars_me <- function(bframe, save_pars, ...) { meframe <- bframe$frame$me stopifnot(is.meframe(meframe)) out <- list() if (!has_rows(meframe)) { return(out) } I <- seq_along(unique(meframe$grname)) K <- seq_rows(meframe) c(out) <- paste0(c("Corme_"), I) if (!save_pars$all) { c(out) <- c(paste0("zme_", K), paste0("Lme_", I)) } if (isFALSE(save_pars$latent)) { c(out) <- paste0("Xme_", K) } else if (is.character(save_pars$latent)) { sub_K <- K[!meframe$xname %in% save_pars$latent] if (length(sub_K)) { c(out) <- paste0("Xme_", sub_K) } } out } #' Control Saving of Parameter Draws #' #' Control which (draws of) parameters should be saved in a \pkg{brms} #' model. The output of this function is meant for usage in the #' \code{save_pars} argument of \code{\link{brm}}. #' #' @param group A flag to indicate if group-level coefficients for #' each level of the grouping factors should be saved (default is #' \code{TRUE}). Set to \code{FALSE} to save memory. Alternatively, #' \code{group} may also be a character vector naming the grouping factors #' for which to save draws of coefficients. #' @param latent A flag to indicate if draws of latent variables obtained by #' using \code{me} and \code{mi} terms should be saved (default is #' \code{FALSE}). Saving these draws allows to better use methods such as #' \code{posterior_predict} with the latent variables but leads to very large #' \R objects even for models of moderate size and complexity. Alternatively, #' \code{latent} may also be a character vector naming the latent variables #' for which to save draws. #' @param all A flag to indicate if draws of all variables defined in Stan's #' \code{parameters} block should be saved (default is \code{FALSE}). Saving #' these draws is required in order to apply the certain methods such as #' \code{bridge_sampler} and \code{bayes_factor}. #' @param manual A character vector naming Stan variable names which should be #' saved. These names should match the variable names inside the Stan code #' before renaming. This feature is meant for power users only and will rarely #' be useful outside of very special cases. #' #' @return A list of class \code{"save_pars"}. #' #' @examples #' \dontrun{ #' # don't store group-level coefficients #' fit <- brm(count ~ zAge + zBase * Trt + (1|patient), #' data = epilepsy, family = poisson(), #' save_pars = save_pars(group = FALSE)) #' variables(fit) #' } #' #' @export save_pars <- function(group = TRUE, latent = FALSE, all = FALSE, manual = NULL) { out <- list() if (is.logical(group)) { out$group <- as_one_logical(group) } else { out$group <- as.character(group) } if (is.logical(latent)) { out$latent <- as_one_logical(latent) } else { out$latent <- as.character(latent) } out$all <- as_one_logical(all) out$manual <- as.character(manual) class(out) <- "save_pars" out } # validate 'save_pars' argument # deprecated arguments: # @param save_ranef save varying effects per level? # @param save_mevars save noise-free variables? # @param save_all_pars save all variables from the 'parameters' block? # @return validated 'save_pars' argument validate_save_pars <- function(save_pars, save_ranef = NULL, save_mevars = NULL, save_all_pars = NULL) { if (is.null(save_pars)) { save_pars <- save_pars() } if (!is.save_pars(save_pars)) { stop2("Argument 'save_pars' needed to be created via 'save_pars()'.") } if (!is.null(save_ranef)) { warning2( "Argument 'save_ranef' is deprecated. Please use argument ", "'group' in function 'save_pars()' instead." ) save_pars$group <- as_one_logical(save_ranef) } if (!is.null(save_mevars)) { warning2( "Argument 'save_mevars' is deprecated. Please use argument ", "'latent' in function 'save_pars()' instead." ) save_pars$latent <- as_one_logical(save_mevars) } if (!is.null(save_all_pars)) { warning2( "Argument 'save_all_pars' is deprecated. Please use argument ", "'all' in function 'save_pars()' instead." ) save_pars$all <- as_one_logical(save_all_pars) } save_pars } is.save_pars <- function(x) { inherits(x, "save_pars") } brms/R/bayes_R2.R0000644000176200001440000000703415057747636013237 0ustar liggesusers#' Compute a Bayesian version of R-squared for regression models #' #' @aliases bayes_R2 #' #' @inheritParams predict.brmsfit #' @param ... Further arguments passed to #' \code{\link[brms:posterior_epred.brmsfit]{posterior_epred}}, #' which is used in the computation of the R-squared values. #' #' @return If \code{summary = TRUE}, an M x C matrix is returned #' (M = number of response variables and c = \code{length(probs) + 2}) #' containing summary statistics of the Bayesian R-squared values. #' If \code{summary = FALSE}, the posterior draws of the Bayesian #' R-squared values are returned in an S x M matrix (S is the number of draws). #' #' @details For an introduction to the approach, see Gelman et al. (2019) #' and \url{https://github.com/jgabry/bayes_R2/}. #' #' @references Andrew Gelman, Ben Goodrich, Jonah Gabry & Aki Vehtari. (2019). #' R-squared for Bayesian regression models, \emph{The American Statistician}, #' 73(3):307-309. \code{10.1080/00031305.2018.1549100} (Preprint available at #' \url{https://acris.aalto.fi/ws/portalfiles/portal/34206843/bayes_R2_v3.pdf}) #' #' @examples #' \dontrun{ #' fit <- brm(mpg ~ wt + cyl, data = mtcars) #' summary(fit) #' bayes_R2(fit) #' #' # compute R2 with new data #' nd <- data.frame(mpg = c(10, 20, 30), wt = c(4, 3, 2), cyl = c(8, 6, 4)) #' bayes_R2(fit, newdata = nd) #' } #' #' @method bayes_R2 brmsfit #' @importFrom rstantools bayes_R2 #' @export bayes_R2 #' @export bayes_R2.brmsfit <- function(object, resp = NULL, summary = TRUE, robust = FALSE, probs = c(0.025, 0.975), ...) { contains_draws(object) object <- restructure(object) resp <- validate_resp(resp, object) summary <- as_one_logical(summary) # check for precomputed values R2 <- get_criterion(object, "bayes_R2") has_stored <- is.matrix(R2) further_arg_names <- c("resp") use_stored <- !length(list(...)) && !any(further_arg_names %in% names(match.call())) if (has_stored && !use_stored) { message("Recomputing 'bayes_R2'") } if (has_stored && use_stored) { # assumes unsummarized 'R2' as ensured by 'add_criterion' take <- colnames(R2) %in% paste0("R2", resp) R2 <- R2[, take, drop = FALSE] if (summary) { R2 <- posterior_summary(R2, probs = probs, robust = robust) } return(R2) } family <- family(object, resp = resp) if (conv_cats_dpars(family)) { stop2("'bayes_R2' is not defined for unordered categorical models.") } if (is_ordinal(family)) { warning2( "Predictions are treated as continuous variables in ", "'bayes_R2' which is likely invalid for ordinal families." ) } args_y <- list(object, warn = TRUE, ...) args_ypred <- list(object, sort = TRUE, ...) R2 <- named_list(paste0("R2", resp)) for (i in seq_along(R2)) { # assumes expectations of different responses to be independent args_ypred$resp <- args_y$resp <- resp[i] y <- do_call(get_y, args_y) ypred <- do_call(posterior_epred, args_ypred) if (is_ordinal(family(object, resp = resp[i]))) { ypred <- ordinal_probs_continuous(ypred) } R2[[i]] <- .bayes_R2(y, ypred) } R2 <- do_call(cbind, R2) colnames(R2) <- paste0("R2", resp) if (summary) { R2 <- posterior_summary(R2, probs = probs, robust = robust) } R2 } # internal function of bayes_R2.brmsfit # see https://github.com/jgabry/bayes_R2/blob/master/bayes_R2.pdf .bayes_R2 <- function(y, ypred, ...) { e <- -1 * sweep(ypred, 2, y) var_ypred <- matrixStats::rowVars(ypred) var_e <- matrixStats::rowVars(e) as.matrix(var_ypred / (var_ypred + var_e)) } brms/R/brmsterms.R0000644000176200001440000010672415053305627013577 0ustar liggesusers#' Parse Formulas of \pkg{brms} Models #' #' Parse formulas objects for use in \pkg{brms}. #' #' @aliases parse_bf #' #' @inheritParams brm #' @param check_response Logical; Indicates whether the left-hand side #' of \code{formula} (i.e. response variables and addition arguments) #' should be parsed. If \code{FALSE}, \code{formula} may also be one-sided. #' @param resp_rhs_all Logical; Indicates whether to also include response #' variables on the right-hand side of formula \code{.$allvars}, #' where \code{.} represents the output of \code{brmsterms}. #' @param ... Further arguments passed to or from other methods. #' #' @return An object of class \code{brmsterms} or \code{mvbrmsterms} #' (for multivariate models), which is a \code{list} containing all #' required information initially stored in \code{formula} #' in an easier to use format, basically a list of formulas #' (not an abstract syntax tree). #' #' @details This is the main formula parsing function of \pkg{brms}. #' It should usually not be called directly, but is exported to allow #' package developers making use of the formula syntax implemented #' in \pkg{brms}. As long as no other packages depend on this functions, #' it may be changed without deprecation warnings, when new features make #' this necessary. #' #' @seealso #' \code{\link{brm}}, #' \code{\link{brmsformula}}, #' \code{\link{mvbrmsformula}} #' #' @export brmsterms <- function(formula, ...) { UseMethod("brmsterms") } # the name 'parse_bf' is deprecated as of brms 2.12.4 # remove it eventually in brms 3.0 #' @export parse_bf <- function(x, ...) { warning2("Method 'parse_bf' is deprecated. Please use 'brmsterms' instead.") UseMethod("brmsterms") } #' @rdname brmsterms #' @export brmsterms.default <- function(formula, ...) { brmsterms(validate_formula(formula), ...) } #' @rdname brmsterms #' @export brmsterms.brmsformula <- function(formula, check_response = TRUE, resp_rhs_all = TRUE, ...) { x <- validate_formula(formula) mv <- isTRUE(x$mv) rescor <- mv && isTRUE(x$rescor) mecor <- isTRUE(x$mecor) formula <- x$formula family <- x$family y <- nlist(formula, family, mv, rescor, mecor) y$cov_ranef <- x$cov_ranef class(y) <- "brmsterms" y$resp <- "" if (check_response) { # extract response variables y$respform <- validate_resp_formula(formula, empty_ok = FALSE) if (mv) { y$resp <- terms_resp(y$respform) } } # extract addition arguments adforms <- terms_ad(formula, family, check_response) advars <- str2formula(ulapply(adforms, all_vars)) y$adforms[names(adforms)] <- adforms # centering would lead to incorrect results for grouped threshold vectors # as each threshold vector only affects a subset of observations if (!is.null(get_ad_expr(y, "thres", "gr"))) { attr(formula, "center") <- FALSE dp_classes <- dpar_class(names(x$pforms)) mu_names <- names(x$pforms)[dp_classes == "mu"] for (dp in mu_names) { attr(x$pforms[[dp]], "center") <- FALSE } } # combine the main formula with formulas for the 'mu' parameters if (is.mixfamily(family)) { mu_dpars <- paste0("mu", seq_along(family$mix)) for (dp in mu_dpars) { x$pforms[[dp]] <- combine_formulas(formula, x$pforms[[dp]], dp) } x$pforms <- move2start(x$pforms, mu_dpars) for (i in seq_along(family$mix)) { # store the respective mixture index in each mixture component # this enables them to be easily passed along, e.g. in stan_log_lik y$family$mix[[i]]$mix <- i } } else if (conv_cats_dpars(x$family)) { mu_dpars <- str_subset(x$family$dpars, "^mu") for (dp in mu_dpars) { x$pforms[[dp]] <- combine_formulas(formula, x$pforms[[dp]], dp) } x$pforms <- move2start(x$pforms, mu_dpars) } else { x$pforms[["mu"]] <- combine_formulas(formula, x$pforms[["mu"]], "mu") x$pforms <- move2start(x$pforms, "mu") } # predicted distributional parameters dpars <- intersect(names(x$pforms), valid_dpars(family)) dpar_forms <- x$pforms[dpars] nlpars <- setdiff(names(x$pforms), dpars) y$dpars <- named_list(dpars) for (dp in dpars) { if (get_nl(dpar_forms[[dp]])) { y$dpars[[dp]] <- terms_nlf(dpar_forms[[dp]], nlpars, y$resp) } else { y$dpars[[dp]] <- terms_lf(dpar_forms[[dp]]) } y$dpars[[dp]]$family <- dpar_family(family, dp) y$dpars[[dp]]$dpar <- dp y$dpars[[dp]]$resp <- y$resp if (dpar_class(dp) == "mu") { y$dpars[[dp]]$respform <- y$respform y$dpars[[dp]]$adforms <- y$adforms } y$dpars[[dp]]$transform <- stan_eta_transform(y, y$dpars[[dp]]$family) check_cs(y$dpars[[dp]]) } y$nlpars <- named_list(nlpars) if (length(nlpars)) { nlpar_forms <- x$pforms[nlpars] for (nlp in nlpars) { if (is.null(attr(nlpar_forms[[nlp]], "center"))) { # design matrices of non-linear parameters will not be # centered by default to make prior specification easier attr(nlpar_forms[[nlp]], "center") <- FALSE } if (get_nl(nlpar_forms[[nlp]])) { y$nlpars[[nlp]] <- terms_nlf(nlpar_forms[[nlp]], nlpars, y$resp) } else { y$nlpars[[nlp]] <- terms_lf(nlpar_forms[[nlp]]) } y$nlpars[[nlp]]$nlpar <- nlp y$nlpars[[nlp]]$resp <- y$resp check_cs(y$nlpars[[nlp]]) } used_nlpars <- ufrom_list(c(y$dpars, y$nlpars), "used_nlpars") unused_nlpars <- setdiff(nlpars, used_nlpars) if (length(unused_nlpars)) { stop2( "The parameter '", unused_nlpars[1], "' is not a ", "valid distributional or non-linear parameter. ", "Did you forget to set 'nl = TRUE'?" ) } # sort non-linear parameters after dependency used_nlpars <- from_list(y$nlpars, "used_nlpars") sorted_nlpars <- sort_dependencies(used_nlpars) y$nlpars <- y$nlpars[sorted_nlpars] } # fixed distributional parameters valid_dpars <- valid_dpars(y) inv_fixed_dpars <- setdiff(names(x$pfix), valid_dpars) if (length(inv_fixed_dpars)) { stop2("Invalid fixed parameters: ", collapse_comma(inv_fixed_dpars)) } if ("sigma" %in% valid_dpars && no_sigma(y)) { # some models require setting sigma to 0 if ("sigma" %in% c(names(x$pforms), names(x$pfix))) { stop2("Cannot predict or fix 'sigma' in this model.") } x$pfix$sigma <- 0 } if ("nu" %in% valid_dpars && no_nu(y)) { if ("nu" %in% c(names(x$pforms), names(x$pfix))) { stop2("Cannot predict or fix 'nu' in this model.") } x$pfix$nu <- 1 } disc_pars <- valid_dpars[dpar_class(valid_dpars) %in% "disc"] for (dp in disc_pars) { # 'disc' is set to 1 and not estimated by default if (!dp %in% c(names(x$pforms), names(x$pfix))) { x$pfix[[dp]] <- 1 } } for (dp in names(x$pfix)) { y$fdpars[[dp]] <- list(value = x$pfix[[dp]], dpar = dp) } check_fdpars(y$fdpars) # make a formula containing all required variables y$unused <- attr(x$formula, "unused") lhsvars <- if (resp_rhs_all) all_vars(y$respform) y$allvars <- allvars_formula( lhsvars, advars, lapply(y$dpars, get_allvars), lapply(y$nlpars, get_allvars), y$time$allvars, get_unused_arg_vars(y), .env = environment(formula) ) if (check_response) { # add y$respform to the left-hand side of y$allvars # avoid using update.formula as it is inefficient for longer formulas formula_allvars <- y$respform formula_allvars[[3]] <- y$allvars[[2]] environment(formula_allvars) <- environment(y$allvars) y$allvars <- formula_allvars } y } #' @rdname brmsterms #' @export brmsterms.mvbrmsformula <- function(formula, ...) { x <- validate_formula(formula) x$rescor <- isTRUE(x$rescor) x$mecor <- isTRUE(x$mecor) out <- structure(list(), class = "mvbrmsterms") out$terms <- named_list(names(x$forms)) for (i in seq_along(out$terms)) { x$forms[[i]]$rescor <- x$rescor x$forms[[i]]$mecor <- x$mecor x$forms[[i]]$mv <- TRUE out$terms[[i]] <- brmsterms(x$forms[[i]], ...) } list_allvars <- lapply(out$terms, get_allvars) out$allvars <- allvars_formula( list_allvars, .env = environment(list_allvars[[1]]) ) # required to find variables used solely in the response part lhs_resp <- function(x) deparse0(lhs(x$respform)[[2]]) out$respform <- paste0(ulapply(out$terms, lhs_resp), collapse = ",") out$respform <- formula(paste0("mvbind(", out$respform, ") ~ 1")) out$responses <- ufrom_list(out$terms, "resp") out$rescor <- x$rescor out$mecor <- x$mecor out$cov_ranef <- x$cov_ranef out } # parse linear/additive formulas # @param formula an ordinary model formula # @return a 'btl' object terms_lf <- function(formula) { formula <- rhs(as.formula(formula)) y <- nlist(formula) formula <- terms(formula) check_accidental_helper_functions(formula) types <- setdiff(all_term_types(), excluded_term_types(formula)) for (t in types) { tmp <- do_call(paste0("terms_", t), list(formula)) if (is.data.frame(tmp) || is.formula(tmp)) { y[[t]] <- tmp } } y$allvars <- allvars_formula( get_allvars(y$fe), get_allvars(y$re), get_allvars(y$cs), get_allvars(y$sp), get_allvars(y$sm), get_allvars(y$gp), get_allvars(y$ac), get_allvars(y$offset) ) structure(y, class = "btl") } # parse non-linear formulas # @param formula non-linear model formula # @param nlpars names of all non-linear parameters # @param resp optional name of a response variable # @return a 'btnl' object terms_nlf <- function(formula, nlpars, resp = "") { if (!length(nlpars)) { stop2("No non-linear parameters specified.") } loop <- !isFALSE(attr(formula, "loop")) formula <- rhs(as.formula(formula)) y <- nlist(formula) all_vars <- all_vars(formula) y$used_nlpars <- intersect(all_vars, nlpars) covars <- setdiff(all_vars, nlpars) y$covars <- structure(str2formula(covars), int = FALSE) if (!"ac" %in% excluded_term_types(formula)) { y$ac <- terms_ac(attr(formula, "autocor")) } y$allvars <- allvars_formula(covars, get_allvars(y$ac)) y$loop <- loop structure(y, class = "btnl") } # extract addition arguments out of formula # @return a list of formulas each containg a single addition term terms_ad <- function(formula, family = NULL, check_response = TRUE) { x <- list() ad_funs <- lsp("brms", what = "exports", pattern = "^resp_") ad_funs <- sub("^resp_", "", ad_funs) families <- family_names(family) if (is.family(family) && any(nzchar(families))) { str_formula <- formula2str(formula) ad <- get_matches("(?<=\\|)[^~]*(?=~)", str_formula, perl = TRUE) valid_ads <- family_info(family, "ad") if (length(ad)) { ad_terms <- terms(str2formula(ad)) if (length(attr(ad_terms, "offset"))) { stop2("Offsets are not allowed in addition terms.") } ad_terms <- attr(ad_terms, "term.labels") for (a in ad_funs) { matches <- grep(paste0("^(resp_)?", a, "\\(.*\\)$"), ad_terms) if (length(matches) == 1L) { x[[a]] <- ad_terms[matches] if (!grepl("^resp_", x[[a]])) { x[[a]] <- paste0("resp_", x[[a]]) } ad_terms <- ad_terms[-matches] if (!is.na(x[[a]]) && a %in% valid_ads) { x[[a]] <- str2formula(x[[a]]) } else { stop2("Argument '", a, "' is not supported for ", "family '", summary(family), "'.") } } else if (length(matches) > 1L) { stop2("Each addition argument may only be defined once.") } } if (length(ad_terms)) { stop2("The following addition terms are invalid:\n", collapse_comma(ad_terms)) } } if (check_response && "wiener" %in% families && !is.formula(x$dec)) { stop2("Addition argument 'dec' is required for family 'wiener'.") } if (is.formula(x$cat)) { # 'cat' was replaced by 'thres' in brms 2.10.5 x$thres <- x$cat } } x } # extract fixed effects terms terms_fe <- function(formula) { if (!is.terms(formula)) { formula <- terms(formula) } all_terms <- all_terms(formula) sp_terms <- find_terms(all_terms, "all", complete = FALSE) re_terms <- all_terms[grepl("\\|", all_terms)] int_term <- attr(formula, "intercept") fe_terms <- setdiff(all_terms, c(sp_terms, re_terms)) out <- paste(c(int_term, fe_terms), collapse = "+") out <- str2formula(out) attr(out, "allvars") <- allvars_formula(out) attr(out, "decomp") <- get_decomp(formula) if (has_rsv_intercept(out, has_intercept(formula))) { attr(out, "int") <- FALSE } if (no_cmc(formula)) { attr(out, "cmc") <- FALSE } if (no_center(formula)) { attr(out, "center") <- FALSE } if (is_sparse(formula)) { attr(out, "sparse") <- TRUE } out } # gather information of group-level terms # @return a data.frame with one row per group-level term terms_re <- function(formula) { re_terms <- get_re_terms(formula, brackets = FALSE) if (!length(re_terms)) { return(NULL) } re_terms <- split_re_terms(re_terms) re_parts <- re_parts(re_terms) out <- allvars <- vector("list", length(re_terms)) type <- attr(re_terms, "type") for (i in seq_along(re_terms)) { gcall <- eval2(re_parts$rhs[i]) form <- str2formula(re_parts$lhs[i]) group <- paste0(gcall$type, collapse(gcall$groups)) out[[i]] <- data.frame( group = group, gtype = gcall$type, gn = i, id = gcall$id, type = type[i], cor = gcall$cor, stringsAsFactors = FALSE ) out[[i]]$gcall <- list(gcall) out[[i]]$form <- list(form) # gather all variables used in the group-level term # at this point 'cs' terms are no longer recognized as such ftype <- str_if(type[i] %in% "cs", "", type[i]) re_allvars <- get_allvars(form, type = ftype) allvars[[i]] <- allvars_formula(re_allvars, gcall$allvars) } out <- do_call(rbind, out) out <- out[order(out$group), ] attr(out, "allvars") <- allvars_formula(allvars) if (no_cmc(formula)) { # disabling cell-mean coding in all group-level terms # has to come last to avoid removal of attributes for (i in seq_rows(out)) { attr(out$form[[i]], "cmc") <- FALSE } } out } # extract category specific terms for ordinal models terms_cs <- function(formula) { out <- find_terms(formula, "cs") if (!length(out)) { return(NULL) } out <- ulapply(out, eval2, envir = environment()) out <- str2formula(out) attr(out, "allvars") <- allvars_formula(out) # do not test whether variables were supplied to 'cs' # to allow category specific group-level intercepts attr(out, "int") <- FALSE out } # extract special effects terms terms_sp <- function(formula) { types <- c("mo", "me", "mi") out <- find_terms(formula, types, complete = FALSE) if (!length(out)) { return(NULL) } uni_mo <- get_matches_expr(regex_sp("mo"), out) uni_me <- get_matches_expr(regex_sp("me"), out) uni_mi <- get_matches_expr(regex_sp("mi"), out) # remove the intercept as it is handled separately out <- str2formula(c("0", out)) attr(out, "int") <- FALSE attr(out, "uni_mo") <- uni_mo attr(out, "uni_me") <- uni_me attr(out, "uni_mi") <- uni_mi attr(out, "allvars") <- str2formula(all_vars(out)) # TODO: do we need sp_fake_formula at all? # attr(out, "allvars") <- sp_fake_formula(uni_mo, uni_me, uni_mi) out } # extract spline terms terms_sm <- function(formula) { out <- find_terms(formula, "sm") if (!length(out)) { return(NULL) } if (any(grepl("^(te|ti)\\(", out))) { stop2("Tensor product smooths 'te' and 'ti' are not yet ", "implemented in brms. Consider using 't2' instead.") } out <- str2formula(out) attr(out, "allvars") <- mgcv::interpret.gam(out)$fake.formula out } # extract gaussian process terms terms_gp <- function(formula) { out <- find_terms(formula, "gp") if (!length(out)) { return(NULL) } eterms <- lapply(out, eval2, envir = environment()) covars <- from_list(eterms, "term") byvars <- from_list(eterms, "by") allvars <- str2formula(unlist(c(covars, byvars))) allvars <- str2formula(all_vars(allvars)) if (!length(all_vars(allvars))) { stop2("No variable supplied to function 'gp'.") } out <- str2formula(out) attr(out, "allvars") <- allvars out } # extract autocorrelation terms terms_ac <- function(formula) { autocor <- attr(formula, "autocor") out <- c(find_terms(formula, "ac"), find_terms(autocor, "ac")) if (!length(out)) { return(NULL) } eterms <- lapply(out, eval2, envir = environment()) allvars <- unlist(c( from_list(eterms, "time"), from_list(eterms, "gr") )) allvars <- str2formula(all_vars(allvars)) out <- str2formula(out) attr(out, "allvars") <- allvars out } # extract offset terms terms_offset <- function(formula) { if (!is.terms(formula)) { formula <- terms(as.formula(formula)) } pos <- attr(formula, "offset") if (is.null(pos)) { return(NULL) } vars <- attr(formula, "variables") out <- ulapply(pos, function(i) deparse0(vars[[i + 1]])) out <- str2formula(out) attr(out, "allvars") <- str2formula(all_vars(out)) out } # extract multiple covariates in multi-membership terms terms_mmc <- function(formula) { out <- find_terms(formula, "mmc") if (!length(out)) { return(NULL) } # remove the intercept as it is handled separately out <- str2formula(c("0", out)) attr(out, "allvars") <- allvars_formula(out) attr(out, "int") <- FALSE out } # extract response variable names # assumes multiple response variables to be combined via mvbind terms_resp <- function(formula, check_names = TRUE) { formula <- lhs(as.formula(formula)) if (is.null(formula)) { return(NULL) } expr <- validate_resp_formula(formula)[[2]] if (length(expr) <= 1L) { out <- deparse_no_string(expr) } else { str_fun <- deparse_no_string(expr[[1]]) used_mvbind <- grepl("^(brms:::?)?mvbind$", str_fun) if (used_mvbind) { out <- ulapply(expr[-1], deparse_no_string) } else { out <- deparse_no_string(expr) } } if (check_names) { out <- make_stan_names(out) } out } #' Checks if argument is a \code{brmsterms} object #' #' @param x An \R object #' #' @seealso \code{\link[brms:brmsterms]{brmsterms}} #' #' @export is.brmsterms <- function(x) { inherits(x, "brmsterms") } #' Checks if argument is a \code{mvbrmsterms} object #' #' @param x An \R object #' #' @seealso \code{\link[brms:brmsterms]{brmsterms}} #' #' @export is.mvbrmsterms <- function(x) { inherits(x, "mvbrmsterms") } # useful for functions that require either of the two objects is.anybrmsterms <- function(x) { is.brmsterms(x) || is.mvbrmsterms(x) } is.btl <- function(x) { inherits(x, "btl") } is.btnl <- function(x) { inherits(x, "btnl") } # figure out if a certain distributional parameter is predicted is_pred_dpar <- function(bterms, dpar) { stopifnot(is.brmsterms(bterms)) if (!length(dpar)) { return(FALSE) } mix <- get_mix_id(bterms) any(paste0(dpar, mix) %in% names(bterms$dpars)) } # transform mvbrmsterms objects for use in stan_llh.brmsterms as.brmsterms <- function(x) { stopifnot(is.mvbrmsterms(x), x$rescor) families <- ulapply(x$terms, function(y) y$family$family) stopifnot(all(families == families[1])) out <- structure(list(), class = "brmsterms") out$family <- structure( list(family = families[1], link = "identity"), class = c("brmsfamily", "family") ) out$family$fun <- paste0(out$family$family, "_mv") info <- get(paste0(".family_", families[1]))() out$family[names(info)] <- info out$sigma_pred <- any(ulapply(x$terms, function(x) is_pred_dpar(x, "sigma") || has_ad_terms(x, "se") )) weight_forms <- rmNULL(lapply(x$terms, function(x) x$adforms$weights)) if (length(weight_forms)) { str_wf <- unique(ulapply(weight_forms, formula2str)) if (length(str_wf) > 1L) { stop2("All responses should use the same", "weights if 'rescor' is estimated.") } out$adforms$weights <- weight_forms[[1]] } miforms <- rmNULL(lapply(x$terms, function(x) x$adforms$mi)) if (length(miforms)) { out$adforms$mi <- miforms[[1]] } out } # names of supported term types all_term_types <- function() { c("fe", "re", "sp", "cs", "sm", "gp", "ac", "offset") } # avoid ambiguous parameter names # @param names names to check for ambiguity # @param bterms a brmsterms object avoid_dpars <- function(names, bterms) { dpars <- c(names(bterms$dpars), "sp", "cs") if (length(dpars)) { dpars_prefix <- paste0("^", dpars, "_") invalid <- any(ulapply(dpars_prefix, grepl, names)) if (invalid) { dpars <- paste0("'", dpars, "_'", collapse = ", ") stop2("Variable names starting with ", dpars, " are not allowed for this model.") } } invisible(NULL) } vars_prefix <- function() { c("dpar", "resp", "nlpar") } # check and tidy parameter prefixes check_prefix <- function(x, keep_mu = FALSE) { vpx <- vars_prefix() if (is.data.frame(x) && nrow(x) == 0) { # avoids a bug in data.frames with zero rows x <- list() } x[setdiff(vpx, names(x))] <- "" x <- x[vpx] for (i in seq_along(x)) { x[[i]] <- as.character(x[[i]]) if (!length(x[[i]])) { x[[i]] <- "" } x[[i]] <- ifelse( !keep_mu & names(x)[i] == "dpar" & x[[i]] %in% "mu", yes = "", no = x[[i]] ) x[[i]] <- ifelse( keep_mu & names(x)[i] == "dpar" & x[[i]] %in% "", yes = "mu", no = x[[i]] ) } x } # combined parameter prefixes # @param prefix object from which to extract prefixes # @param keep_mu keep the 'mu' prefix if available or remove it? # @param nlp include the 'nlp' prefix for non-linear parameters? combine_prefix <- function(prefix, keep_mu = FALSE, nlp = FALSE) { prefix <- check_prefix(prefix, keep_mu = keep_mu) if (is_nlpar(prefix) && nlp) { prefix$dpar <- "nlp" } prefix <- lapply(prefix, usc) sub("^_", "", do_call(paste0, prefix)) } # check validity of fixed distributional parameters check_fdpars <- function(x) { stopifnot(is.null(x) || is.list(x)) pos_pars <- c( "sigma", "shape", "nu", "phi", "kappa", "beta", "disc", "bs", "ndt", "theta" ) prob_pars <- c("zi", "hu", "bias", "quantile") for (dp in names(x)) { apc <- dpar_class(dp) value <- x[[dp]]$value if (apc %in% pos_pars && value < 0) { stop2("Parameter '", dp, "' must be positive.") } if (apc %in% prob_pars && (value < 0 || value > 1)) { stop2("Parameter '", dp, "' must be between 0 and 1.") } } invisible(TRUE) } # combine all variables in one formuula # @param x (list of) formulas or character strings # @return a formula with all variables on the right-hand side allvars_formula <- function(..., .env = parent.frame()) { out <- rmNULL(c(...)) out <- collapse(ulapply(out, plus_rhs)) all_vars <- all_vars(out) invalid_vars <- setdiff(all_vars, make.names(all_vars)) if (length(invalid_vars)) { stop2("The following variable names are invalid: ", collapse_comma(invalid_vars)) } out <- str2formula(c(out, all_vars), env = .env) # remove redundant terms to simplify the formula (#1786) formula(terms.formula(out, simplify = TRUE)) } # conveniently extract a formula of all relevant variables # @param x any object from which to extract 'allvars' # @param type predictor type; requires a 'parse_' function # @return a formula with all variables on the right-hand side # or NULL if 'allvars' cannot be found get_allvars <- function(x, type = "") { out <- attr(x, "allvars", TRUE) if (is.null(out) && "allvars" %in% names(x)) { out <- x[["allvars"]] } if (is.null(out) && is.formula(x)) { type <- as_one_character(type) type <- str_if(nzchar(type), type, "fe") terms_fun <- get(paste0("terms_", type), mode = "function") out <- attr(terms_fun(x), "allvars") } stopifnot(is.null(out) || is.formula(out)) out } # add 'x' to the right-hand side of a formula plus_rhs <- function(x) { if (is.formula(x)) { x <- sub("^[^~]*~", "", formula2str(x)) } if (length(x) && all(nzchar(x))) { out <- paste0(" + ", paste(x, collapse = "+")) } else { out <- " + 1" } out } # like stats::terms but keeps attributes if possible terms <- function(formula, ...) { old_attributes <- attributes(formula) formula <- stats::terms(formula, ...) new_attributes <- attributes(formula) sel_names <- setdiff(names(old_attributes), names(new_attributes)) attributes(formula)[sel_names] <- old_attributes[sel_names] formula } is.terms <- function(x) { inherits(x, "terms") } # combine formulas for distributional parameters # @param formula1 primary formula from which to take the RHS # @param formula2 secondary formula used to update the RHS of formula1 # @param lhs character string to define the left-hand side of the output # @param update a flag to indicate whether updating should be allowed. # Defaults to FALSE to maintain backwards compatibility # @return a formula object combine_formulas <- function(formula1, formula2, lhs = "", update = FALSE) { stopifnot(is.formula(formula1)) stopifnot(is.null(formula2) || is.formula(formula2)) lhs <- as_one_character(lhs) update <- as_one_logical(update) if (is.null(formula2)) { rhs <- str_rhs(formula1) att <- attributes(formula1) } else if (update && has_terms(formula1)) { # TODO: decide about intuitive updating behavior if (get_nl(formula1) || get_nl(formula2)) { stop2("Cannot combine non-linear formulas.") } old_formula <- eval2(paste0("~ ", str_rhs(formula1))) new_formula <- eval2(paste0("~ . + ", str_rhs(formula2))) rhs <- str_rhs(update(old_formula, new_formula)) att <- attributes(formula1) att[names(attributes(formula2))] <- attributes(formula2) } else { rhs <- str_rhs(formula2) att <- attributes(formula2) } out <- eval2(paste0(lhs, " ~ ", rhs)) attributes(out)[names(att)] <- att out } # does the formula contain any terms? # @return TRUE or FALSE has_terms <- function(formula) { stopifnot(is.formula(formula)) terms <- try(terms(rhs(formula)), silent = TRUE) is_try_error(terms) || length(attr(terms, "term.labels")) || length(attr(terms, "offset")) } # has a linear formula any terms except overall effects? has_special_terms <- function(x) { if (!is.btl(x)) { return(FALSE) } special_terms <- c("sp", "sm", "gp", "ac", "cs", "offset") NROW(x[["re"]]) > 0 || any(lengths(x[special_terms])) } # indicate if the predictor term belongs to a non-linear parameter is_nlpar <- function(x) { isTRUE(nzchar(x[["nlpar"]])) } # indicate if the intercept should be removed no_int <- function(x) { isFALSE(attr(x, "int", exact = TRUE)) } # indicate if cell mean coding should be disabled no_cmc <- function(x) { isFALSE(attr(x, "cmc", exact = TRUE)) } # indicate if centering of the design matrix should be disabled no_center <- function(x) { isFALSE(attr(x, "center", exact = TRUE)) } # indicate if the design matrix should be handled as sparse is_sparse <- function(x) { isTRUE(attr(x, "sparse", exact = TRUE)) } # get the decomposition type of the design matrix get_decomp <- function(x) { out <- attr(x, "decomp", exact = TRUE) if (is.null(out)) { out <- "none" } as_one_character(out) } # extract different types of effects get_effect <- function(x, ...) { UseMethod("get_effect") } #' @export get_effect.default <- function(x, ...) { NULL } #' @export get_effect.brmsfit <- function(x, ...) { get_effect(x$formula, ...) } #' @export get_effect.brmsformula <- function(x, ...) { get_effect(brmsterms(x), ...) } #' @export get_effect.mvbrmsformula <- function(x, ...) { get_effect(brmsterms(x), ...) } #' @export get_effect.mvbrmsterms <- function(x, ...) { ulapply(x$terms, get_effect, recursive = FALSE, ...) } # extract formulas of a certain effect type # @param target effect type to return # @param all logical; include effects of nlpars and dpars? # @return a list of formulas #' @export get_effect.brmsterms <- function(x, target = "fe", ...) { out <- named_list(c(names(x$dpars), names(x$nlpars))) for (dp in names(x$dpars)) { out[[dp]] <- get_effect(x$dpars[[dp]], target = target) } for (nlp in names(x$nlpars)) { out[[nlp]] <- get_effect(x$nlpars[[nlp]], target = target) } unlist(out, recursive = FALSE) } #' @export get_effect.btl <- function(x, target = "fe", ...) { x[[target]] } #' @export get_effect.btnl <- function(x, target = "fe", ...) { x[[target]] } all_terms <- function(x) { if (!length(x)) { return(character(0)) } if (!is.terms(x)) { x <- terms(as.formula(x)) } trim_wsp(attr(x, "term.labels")) } # generate a regular expression to extract special terms # @param type one or more special term types to be extracted # TODO: rule out expressions such as mi(y) + mi(x) regex_sp <- function(type = "all") { choices <- c("all", "sp", "sm", "gp", "cs", "mmc", "ac", all_sp_types()) type <- unique(match.arg(type, choices, several.ok = TRUE)) funs <- c( sm = "(s|(t2)|(te)|(ti))", gp = "gp", cs = "cse?", mmc = "mmc", ac = "((arma)|(ar)|(ma)|(cosy)|(unstr)|(sar)|(car)|(fcor))" ) funs[all_sp_types()] <- all_sp_types() if ("sp" %in% type) { # allows extracting all 'sp' terms at once type <- setdiff(type, "sp") type <- union(type, all_sp_types()) } if ("all" %in% type) { # allows extracting all special terms at once type <- names(funs) } funs <- funs[type] allow_colon <- c("cs", "mmc", "ac") inner <- ifelse(names(funs) %in% allow_colon, ".*", "[^:]*") out <- paste0("^(", funs, ")\\(", inner, "\\)$") paste0("(", out, ")", collapse = "|") } # find special terms of a certain type # @param x formula object of character vector from which to extract terms # @param type special terms type to be extracted. see regex_sp() # @param complete check if terms consist completely of single special terms? # @param ranef include group-level terms? # @return a character vector of matching terms find_terms <- function(x, type, complete = TRUE, ranef = FALSE) { if (is.formula(x)) { x <- all_terms(x) } else { x <- trim_wsp(as.character(x)) } complete <- as_one_logical(complete) ranef <- as_one_logical(ranef) regex <- regex_sp(type) is_match <- grepl_expr(regex, x) if (!ranef) { is_match <- is_match & !grepl("\\|", x) } out <- x[is_match] if (complete) { matches <- lapply(out, get_matches_expr, pattern = regex) # each term may contain only one special function call invalid <- out[lengths(matches) > 1L] if (!length(invalid)) { # each term must be exactly equal to the special function call invalid <- out[unlist(matches) != out] } # TODO: some terms can be part of I() calls (#1520); reflect this here? if (length(invalid)) { stop2("The term '", invalid[1], "' is invalid in brms syntax.") } } out } # validate a terms object (or one that can be coerced to it) # for use primarily in 'get_model_matrix' # @param x any R object # @return a (possibly amended) terms object or NULL # if 'x' could not be coerced to a terms object validate_terms <- function(x) { no_int <- no_int(x) no_cmc <- no_cmc(x) if (is.formula(x) && !is.terms(x)) { x <- terms(x) } if (!is.terms(x)) { return(NULL) } if (no_int || !has_intercept(x) && no_cmc) { # allows to remove the intercept without causing cell mean coding attr(x, "intercept") <- 1 attr(x, "int") <- FALSE } x } # checks if the formula contains an intercept has_intercept <- function(formula) { if (is.terms(formula)) { out <- as.logical(attr(formula, "intercept")) } else { formula <- as.formula(formula) try_terms <- try(terms(formula), silent = TRUE) if (is_try_error(try_terms)) { out <- FALSE } else { out <- as.logical(attr(try_terms, "intercept")) } } out } # check if model makes use of the reserved intercept variables # @param has_intercept does the model have an intercept? # if NULL this will be inferred from formula itself has_rsv_intercept <- function(formula, has_intercept = NULL) { .has_rsv_intercept <- function(terms, has_intercept) { has_intercept <- as_one_logical(has_intercept) intercepts <- c("intercept", "Intercept") out <- !has_intercept && any(intercepts %in% all_vars(rhs(terms))) return(out) } if (is.terms(formula)) { if (is.null(has_intercept)) { has_intercept <- has_intercept(formula) } return(.has_rsv_intercept(formula, has_intercept)) } formula <- try(as.formula(formula), silent = TRUE) if (is_try_error(formula)) { return(FALSE) } if (is.null(has_intercept)) { try_terms <- try(terms(formula), silent = TRUE) if (is_try_error(try_terms)) { return(FALSE) } has_intercept <- has_intercept(try_terms) } .has_rsv_intercept(formula, has_intercept) } # names of reserved variables rsv_vars <- function(bterms) { stopifnot(is.brmsterms(bterms) || is.mvbrmsterms(bterms)) .rsv_vars <- function(x) { rsv_int <- any(ulapply(x$dpars, has_rsv_intercept)) if (rsv_int) c("intercept", "Intercept") else NULL } if (is.mvbrmsterms(bterms)) { out <- unique(ulapply(bterms$terms, .rsv_vars)) } else { out <- .rsv_vars(bterms) } out } # are category specific effects present? has_cs <- function(bterms) { length(get_effect(bterms, target = "cs")) > 0L || any(get_re(bterms)$type %in% "cs") } # check if category specific effects are allowed check_cs <- function(bterms) { stopifnot(is.btl(bterms) || is.btnl(bterms)) if (has_cs(bterms)) { if (!is_equal(dpar_class(bterms$dpar), "mu")) { stop2("Category specific effects are only supported ", "for the main parameter 'mu'.") } if (!(is.null(bterms$family) || allow_cs(bterms$family))) { stop2("Category specific effects are not supported for this family.") } if (needs_ordered_cs(bterms$family)) { warning2("Category specific effects for this family should be ", "considered experimental and may have convergence issues.") } } invisible(NULL) } # check for the presence of helper functions accidentally used # within a formula instead of added to bf(). See #1103 check_accidental_helper_functions <- function(formula) { terms <- all_terms(formula) # see help("brmsformula-helpers") for the list of functions funs <- c("nlf", "lf", "acformula", "set_nl", "set_rescor", "set_mecor") regex <- paste0("(", funs, ")", collapse = "|") regex <- paste0("^(", regex, ")\\(") matches <- get_matches(regex, terms, first = TRUE) matches <- sub("\\($", "", matches) matches <- unique(matches) matches <- matches[nzchar(matches)] for (m in matches) { loc <- utils::find(m, mode = "function") if (is_equal(loc[1], "package:brms")) { stop2("Function '", m, "' should not be part of the right-hand side ", "of a formula. See help('brmsformula-helpers') for the correct syntax.") } } invisible(TRUE) } # extract names of variables added via the 'unused' argument get_unused_arg_vars <- function(x, ...) { UseMethod("get_unused_arg_vars") } #' @export get_unused_arg_vars.brmsformula <- function(x, ...) { all_vars(attr(x$formula, "unused")) } #' @export get_unused_arg_vars.mvbrmsformula <- function(x, ...) { unique(ulapply(x$forms, get_unused_arg_vars, ...)) } #' @export get_unused_arg_vars.brmsterms <- function(x, ...) { all_vars(x$unused) } #' @export get_unused_arg_vars.mvbrmsterms <- function(x, ...) { unique(ulapply(x$terms, get_unused_arg_vars, ...)) } # extract elements from objects # @param x object from which to extract elements # @param name name of the element to be extracted get_element <- function(x, name, ...) { UseMethod("get_element") } #' @export get_element.default <- function(x, name, ...) { x[[name]] } #' @export get_element.mvbrmsformula <- function(x, name, ...) { lapply(x$forms, get_element, name = name, ...) } #' @export get_element.mvbrmsterms <- function(x, name, ...) { lapply(x$terms, get_element, name = name, ...) } brms/R/launch_shinystan.R0000644000176200001440000000355314576305566015142 0ustar liggesusers#' Interface to \pkg{shinystan} #' #' Provide an interface to \pkg{shinystan} for models fitted with \pkg{brms} #' #' @aliases launch_shinystan #' #' @param object A fitted model object typically of class \code{brmsfit}. #' @param rstudio Only relevant for RStudio users. #' The default (\code{rstudio=FALSE}) is to launch the app #' in the default web browser rather than RStudio's pop-up Viewer. #' Users can change the default to \code{TRUE} #' by setting the global option \cr \code{options(shinystan.rstudio = TRUE)}. #' @param ... Optional arguments to pass to \code{\link[shiny:runApp]{runApp}} #' #' @return An S4 shinystan object #' #' @examples #' \dontrun{ #' fit <- brm(rating ~ treat + period + carry + (1|subject), #' data = inhaler, family = "gaussian") #' launch_shinystan(fit) #' } #' #' @seealso \code{\link[shinystan:launch_shinystan]{launch_shinystan}} #' #' @exportS3Method shinystan::launch_shinystan brmsfit launch_shinystan.brmsfit <- function( object, rstudio = getOption("shinystan.rstudio"), ... ) { contains_draws(object) if (object$algorithm != "sampling") { return(shinystan::launch_shinystan(object$fit, rstudio = rstudio, ...)) } inc_warmup <- isTRUE(object$fit@sim$n_save[1] > niterations(object)) draws <- as.array(object, inc_warmup = inc_warmup) warmup <- if (inc_warmup) nwarmup(object) else 0 sampler_params <- rstan::get_sampler_params(object$fit, inc_warmup = inc_warmup) control <- object$fit@stan_args[[1]]$control if (is.null(control)) { max_td <- 10 } else { max_td <- control$max_treedepth if (is.null(max_td)) { max_td <- 10 } } sso <- shinystan::as.shinystan( X = draws, model_name = object$fit@model_name, warmup = warmup, sampler_params = sampler_params, max_treedepth = max_td, algorithm = "NUTS" ) shinystan::launch_shinystan(sso, rstudio = rstudio, ...) } brms/R/predictive_error.R0000644000176200001440000001364614527413457015136 0ustar liggesusers#' Posterior Draws of Predictive Errors #' #' Compute posterior draws of predictive errors, that is, observed minus #' predicted responses. Can be performed for the data used to fit the model #' (posterior predictive checks) or for new data. #' #' @inheritParams posterior_predict.brmsfit #' @param method Method used to obtain predictions. Can be set to #' \code{"posterior_predict"} (the default), \code{"posterior_epred"}, #' or \code{"posterior_linpred"}. For more details, see the respective #' function documentations. #' #' @return An S x N \code{array} of predictive error draws, where S is the #' number of posterior draws and N is the number of observations. #' #' @examples #' \dontrun{ #' ## fit a model #' fit <- brm(rating ~ treat + period + carry + (1|subject), #' data = inhaler, cores = 2) #' #' ## extract predictive errors #' pe <- predictive_error(fit) #' str(pe) #' } #' #' @aliases predictive_error #' @method predictive_error brmsfit #' @importFrom rstantools predictive_error #' @export #' @export predictive_error predictive_error.brmsfit <- function( object, newdata = NULL, re_formula = NULL, re.form = NULL, method = "posterior_predict", resp = NULL, ndraws = NULL, draw_ids = NULL, sort = FALSE, ... ) { cl <- match.call() if ("re.form" %in% names(cl) && !missing(re.form)) { re_formula <- re.form } .predictive_error( object, newdata = newdata, re_formula = re_formula, method = method, type = "ordinary", resp = resp, ndraws = ndraws, draw_ids = draw_ids, sort = sort, ... ) } #' Posterior Draws of Residuals/Predictive Errors #' #' This method is an alias of \code{\link{predictive_error.brmsfit}} #' with additional arguments for obtaining summaries of the computed draws. #' #' @inheritParams predictive_error.brmsfit #' @param type The type of the residuals, #' either \code{"ordinary"} or \code{"pearson"}. #' More information is provided under 'Details'. #' @param summary Should summary statistics be returned #' instead of the raw values? Default is \code{TRUE}.. #' @param robust If \code{FALSE} (the default) the mean is used as #' the measure of central tendency and the standard deviation as #' the measure of variability. If \code{TRUE}, the median and the #' median absolute deviation (MAD) are applied instead. #' Only used if \code{summary} is \code{TRUE}. #' @param probs The percentiles to be computed by the \code{quantile} #' function. Only used if \code{summary} is \code{TRUE}. #' #' @return An \code{array} of predictive error/residual draws. If #' \code{summary = FALSE} the output resembles those of #' \code{\link{predictive_error.brmsfit}}. If \code{summary = TRUE} the output #' is an N x E matrix, where N is the number of observations and E denotes #' the summary statistics computed from the draws. #' #' @details Residuals of type \code{'ordinary'} are of the form \eqn{R = Y - #' Yrep}, where \eqn{Y} is the observed and \eqn{Yrep} is the predicted response. #' Residuals of type \code{pearson} are of the form \eqn{R = (Y - Yrep) / #' SD(Yrep)}, where \eqn{SD(Yrep)} is an estimate of the standard deviation of #' \eqn{Yrep}. #' #' @examples #' \dontrun{ #' ## fit a model #' fit <- brm(rating ~ treat + period + carry + (1|subject), #' data = inhaler, cores = 2) #' #' ## extract residuals/predictive errors #' res <- residuals(fit) #' head(res) #' } #' #' @export residuals.brmsfit <- function(object, newdata = NULL, re_formula = NULL, method = "posterior_predict", type = c("ordinary", "pearson"), resp = NULL, ndraws = NULL, draw_ids = NULL, sort = FALSE, summary = TRUE, robust = FALSE, probs = c(0.025, 0.975), ...) { summary <- as_one_logical(summary) out <- .predictive_error( object, newdata = newdata, re_formula = re_formula, method = method, type = type, resp = resp, ndraws = ndraws, draw_ids = draw_ids, sort = sort, ... ) if (summary) { out <- posterior_summary(out, probs = probs, robust = robust) } out } # internal function doing the work for predictive_error.brmsfit .predictive_error <- function(object, newdata, re_formula, method, type, resp, ndraws, draw_ids, sort, nsamples = NULL, subset = NULL, ...) { contains_draws(object) object <- restructure(object) method <- validate_pp_method(method) type <- match.arg(type, c("ordinary", "pearson")) resp <- validate_resp(resp, object) family <- family(object, resp = resp) if (is_polytomous(family)) { stop2("Predictive errors are not defined for ordinal or categorical models.") } ndraws <- use_alias(ndraws, nsamples) draw_ids <- use_alias(draw_ids, subset) draw_ids <- validate_draw_ids(object, draw_ids, ndraws) pred_args <- nlist( object, newdata, re_formula, resp, draw_ids, summary = FALSE, sort = sort, ... ) yrep <- do_call(method, pred_args) y <- get_y(object, resp, newdata = newdata, sort = sort, warn = TRUE, ...) if (length(dim(yrep)) == 3L) { # multivariate model y <- lapply(seq_cols(y), function(i) y[, i]) y <- lapply(y, data2draws, dim = dim(yrep)[1:2]) y <- abind(y, along = 3) dimnames(y)[[3]] <- dimnames(yrep)[[3]] } else { y <- data2draws(y, dim = dim(yrep)) } out <- y - yrep remove(y, yrep) if (type == "pearson") { # deprecated as of brms 2.10.6 warning2("Type 'pearson' is deprecated and will be removed in the future.") # get predicted standard deviation for each observation pred_args$summary <- TRUE pred <- do_call("predict", pred_args) if (length(dim(pred)) == 3L) { sd_pred <- array2list(pred[, 2, ]) sd_pred <- lapply(sd_pred, data2draws, dim = dim(out)[1:2]) sd_pred <- abind(sd_pred, along = 3) } else { sd_pred <- data2draws(pred[, 2], dim = dim(out)) } out <- out / sd_pred } out } brms/R/brm.R0000644000176200001440000007437315057500075012343 0ustar liggesusers#' Fit Bayesian Generalized (Non-)Linear Multivariate Multilevel Models #' #' Fit Bayesian generalized (non-)linear multivariate multilevel models #' using Stan for full Bayesian inference. A wide range of distributions #' and link functions are supported, allowing users to fit -- among others -- #' linear, robust linear, count data, survival, response times, ordinal, #' zero-inflated, hurdle, extended-support beta regression, and even self-defined mixture models all in a #' multilevel context. Further modeling options include non-linear and #' smooth terms, auto-correlation structures, censored data, meta-analytic #' standard errors, and quite a few more. In addition, all parameters of the #' response distributions can be predicted in order to perform distributional #' regression. Prior specifications are flexible and explicitly encourage #' users to apply prior distributions that actually reflect their beliefs. #' In addition, model fit can easily be assessed and compared with #' posterior predictive checks and leave-one-out cross-validation. #' #' @param formula An object of class \code{\link[stats:formula]{formula}}, #' \code{\link{brmsformula}}, or \code{\link{mvbrmsformula}} (or one that can #' be coerced to that classes): A symbolic description of the model to be #' fitted. The details of model specification are explained in #' \code{\link{brmsformula}}. #' @param data An object of class \code{data.frame} (or one that can be coerced #' to that class) containing data of all variables used in the model. #' @param family A description of the response distribution and link function to #' be used in the model. This can be a family function, a call to a family #' function or a character string naming the family. Every family function has #' a \code{link} argument allowing to specify the link function to be applied #' on the response variable. If not specified, default links are used. For #' details of supported families see \code{\link{brmsfamily}}. By default, a #' linear \code{gaussian} model is applied. In multivariate models, #' \code{family} might also be a list of families. #' @param prior One or more \code{brmsprior} objects created by #' \code{\link{set_prior}} or related functions and combined using the #' \code{c} method or the \code{+} operator. See also \code{\link[brms:default_prior.default]{default_prior}} #' for more help. #' @param data2 A named \code{list} of objects containing data, which #' cannot be passed via argument \code{data}. Required for some objects #' used in autocorrelation structures to specify dependency structures #' as well as for within-group covariance matrices. #' @param autocor (Deprecated) An optional \code{\link{cor_brms}} object #' describing the correlation structure within the response variable (i.e., #' the 'autocorrelation'). See the documentation of \code{\link{cor_brms}} for #' a description of the available correlation structures. Defaults to #' \code{NULL}, corresponding to no correlations. In multivariate models, #' \code{autocor} might also be a list of autocorrelation structures. #' It is now recommend to specify autocorrelation terms directly #' within \code{formula}. See \code{\link{brmsformula}} for more details. #' @param sparse (Deprecated) Logical; indicates whether the population-level #' design matrices should be treated as sparse (defaults to \code{FALSE}). For #' design matrices with many zeros, this can considerably reduce required #' memory. Sampling speed is currently not improved or even slightly #' decreased. It is now recommended to use the \code{sparse} argument of #' \code{\link{brmsformula}} and related functions. #' @param cov_ranef (Deprecated) A list of matrices that are proportional to the #' (within) covariance structure of the group-level effects. The names of the #' matrices should correspond to columns in \code{data} that are used as #' grouping factors. All levels of the grouping factor should appear as #' rownames of the corresponding matrix. This argument can be used, among #' others to model pedigrees and phylogenetic effects. #' It is now recommended to specify those matrices in the formula #' interface using the \code{\link{gr}} and related functions. See #' \code{vignette("brms_phylogenetics")} for more details. #' @param save_pars An object generated by \code{\link{save_pars}} controlling #' which parameters should be saved in the model. The argument has no #' impact on the model fitting itself. #' @param save_ranef (Deprecated) A flag to indicate if group-level effects for #' each level of the grouping factor(s) should be saved (default is #' \code{TRUE}). Set to \code{FALSE} to save memory. The argument has no #' impact on the model fitting itself. #' @param save_mevars (Deprecated) A flag to indicate if draws of latent #' noise-free variables obtained by using \code{me} and \code{mi} terms should #' be saved (default is \code{FALSE}). Saving these draws allows to better #' use methods such as \code{predict} with the latent variables but leads to #' very large \R objects even for models of moderate size and complexity. #' @param save_all_pars (Deprecated) A flag to indicate if draws from all #' variables defined in Stan's \code{parameters} block should be saved #' (default is \code{FALSE}). Saving these draws is required in order to #' apply the methods \code{bridge_sampler}, \code{bayes_factor}, and #' \code{post_prob}. Can be set globally for the current \R session via the #' \code{"brms.save_pars"} option (see \code{\link{options}}). #' @param sample_prior Indicate if draws from priors should be drawn #' additionally to the posterior draws. Options are \code{"no"} (the #' default), \code{"yes"}, and \code{"only"}. Among others, these draws can #' be used to calculate Bayes factors for point hypotheses via #' \code{\link{hypothesis}}. Please note that improper priors are not sampled, #' including the default improper priors used by \code{brm}. See #' \code{\link{set_prior}} on how to set (proper) priors. Please also note #' that prior draws for the overall intercept are not obtained by default #' for technical reasons. See \code{\link{brmsformula}} how to obtain prior #' draws for the intercept. If \code{sample_prior} is set to \code{"only"}, #' draws are drawn solely from the priors ignoring the likelihood, which #' allows among others to generate draws from the prior predictive #' distribution. In this case, all parameters must have proper priors. #' @param knots Optional list containing user specified knot values to be used #' for basis construction of smoothing terms. See #' \code{\link[mgcv:gamm]{gamm}} for more details. #' @param drop_unused_levels Should unused factors levels in the data be #' dropped? Defaults to \code{TRUE}. #' @param stanvars An optional \code{stanvars} object generated by function #' \code{\link{stanvar}} to define additional variables for use in #' \pkg{Stan}'s program blocks. #' @param stan_funs (Deprecated) An optional character string containing #' self-defined \pkg{Stan} functions, which will be included in the functions #' block of the generated \pkg{Stan} code. It is now recommended to use the #' \code{stanvars} argument for this purpose instead. #' @param fit An instance of S3 class \code{brmsfit} derived from a previous #' fit; defaults to \code{NA}. If \code{fit} is of class \code{brmsfit}, the #' compiled model associated with the fitted result is re-used and all #' arguments modifying the model code or data are ignored. It is not #' recommended to use this argument directly, but to call the #' \code{\link[brms:update.brmsfit]{update}} method, instead. #' @param init Initial values for the sampler. If \code{NULL} (the default) or #' \code{"random"}, Stan will randomly generate initial values for parameters #' in a reasonable range. If \code{0}, all parameters are initialized to zero #' on the unconstrained space. This option is sometimes useful for certain #' families, as it happens that default random initial values cause draws to #' be essentially constant. Generally, setting \code{init = 0} is worth a try, #' if chains do not initialize or behave well. Alternatively, \code{init} can #' be a list of lists containing the initial values, or a function (or #' function name) generating initial values. The latter options are mainly #' implemented for internal testing but are available to users if necessary. #' If specifying initial values using a list or a function then currently the #' parameter names must correspond to the names used in the generated Stan #' code (not the names used in \R). For more details on specifying initial #' values you can consult the documentation of the selected \code{backend}. #' @param inits (Deprecated) Alias of \code{init}. #' @param chains Number of Markov chains (defaults to 4). #' @param iter Number of total iterations per chain (including warmup; defaults #' to 2000). Can be set globally for the current \R session via the #' \code{"brms.iter"} option (see \code{\link{options}}). #' @param warmup A positive integer specifying number of warmup (aka burnin) #' iterations. This also specifies the number of iterations used for stepsize #' adaptation, so warmup draws should not be used for inference. The number #' of warmup should not be larger than \code{iter} and the default is #' \code{iter/2}. #' @param thin Thinning rate. Must be a positive integer. Set \code{thin > 1} to #' save memory and computation time if \code{iter} is large. #' @param cores Number of cores to use when executing the chains in parallel, #' which defaults to 1 but we recommend setting the \code{mc.cores} option to #' be as many processors as the hardware and RAM allow (up to the number of #' chains). For non-Windows OS in non-interactive \R sessions, forking is used #' instead of PSOCK clusters. #' @param threads Number of threads to use in within-chain parallelization. For #' more control over the threading process, \code{threads} may also be a #' \code{brmsthreads} object created by \code{\link{threading}}. Within-chain #' parallelization is experimental! We recommend its use only if you are #' experienced with Stan's \code{reduce_sum} function and have a slow running #' model that cannot be sped up by any other means. Can be set globally for #' the current \R session via the \code{"brms.threads"} option (see #' \code{\link{options}}). #' @param opencl The platform and device IDs of the OpenCL device to use for #' fitting using GPU support. If you don't know the IDs of your OpenCL device, #' \code{c(0,0)} is most likely what you need. For more details, see #' \code{\link{opencl}}. Can be set globally for the current \R session via #' the \code{"brms.opencl"} option #' @param normalize Logical. Indicates whether normalization constants should #' be included in the Stan code (defaults to \code{TRUE}). Setting it #' to \code{FALSE} requires Stan version >= 2.25 to work. If \code{FALSE}, #' sampling efficiency may be increased but some post processing functions #' such as \code{\link{bridge_sampler}} will not be available. Can be #' controlled globally for the current \R session via the `brms.normalize` #' option. #' @param algorithm Character string naming the estimation approach to use. #' Options are \code{"sampling"} for MCMC (the default), \code{"meanfield"} for #' variational inference with independent normal distributions, #' \code{"fullrank"} for variational inference with a multivariate normal #' distribution, \code{"pathfinder"} for the pathfinder algorithm, #' \code{"laplace"} for the laplace approximation, #' or \code{"fixed_param"} for sampling from fixed parameter #' values. Can be set globally for the current \R session via the #' \code{"brms.algorithm"} option (see \code{\link{options}}). #' @param backend Character string naming the package to use as the backend for #' fitting the Stan model. Options are \code{"rstan"} (the default) or #' \code{"cmdstanr"}. Can be set globally for the current \R session via the #' \code{"brms.backend"} option (see \code{\link{options}}). Details on the #' \pkg{rstan} and \pkg{cmdstanr} packages are available at #' \url{https://mc-stan.org/rstan/} and \url{https://mc-stan.org/cmdstanr/}, #' respectively. Additionally a \code{"mock"} backend is available to make #' testing \pkg{brms} and packages that depend on it easier. #' The \code{"mock"} backend does not actually do any fitting, it only checks #' the generated Stan code for correctness and then returns whatever is passed #' in an additional \code{mock_fit} argument as the result of the fit. #' @param control A named \code{list} of parameters to control the sampler's #' behavior. It defaults to \code{NULL} so all the default values are used. #' The most important control parameters are discussed in the 'Details' #' section below. For a comprehensive overview see #' \code{\link[rstan:stan]{stan}}. #' @param future Logical; If \code{TRUE}, the \pkg{\link[future:future]{future}} #' package is used for parallel execution of the chains and argument #' \code{cores} will be ignored. Can be set globally for the current \R #' session via the \code{"future"} option. The execution type is controlled via #' \code{\link[future:plan]{plan}} (see the examples section below). #' @param silent Verbosity level between \code{0} and \code{2}. #' If \code{1} (the default), most of the #' informational messages of compiler and sampler are suppressed. #' If \code{2}, even more messages are suppressed. The actual #' sampling progress is still printed. Set \code{refresh = 0} to turn this off #' as well. If using \code{backend = "rstan"} you can also set #' \code{open_progress = FALSE} to prevent opening additional progress bars. #' @param seed The seed for random number generation to make results #' reproducible. If \code{NA} (the default), \pkg{Stan} will set the seed #' randomly. #' @param save_model Either \code{NULL} or a character string. In the latter #' case, the model's Stan code is saved via \code{\link{cat}} in a text file #' named after the string supplied in \code{save_model}. #' @param file Either \code{NULL} or a character string. In the latter case, the #' fitted model object is saved via \code{\link{saveRDS}} in a file named #' after the string supplied in \code{file}. The \code{.rds} extension is #' added automatically. If the file already exists, \code{brm} will load and #' return the saved model object instead of refitting the model. #' Unless you specify the \code{file_refit} argument as well, the existing #' files won't be overwritten, you have to manually remove the file in order #' to refit and save the model under an existing file name. The file name #' is stored in the \code{brmsfit} object for later usage. #' @param file_compress Logical or a character string, specifying one of the #' compression algorithms supported by \code{\link{saveRDS}}. If the #' \code{file} argument is provided, this compression will be used when saving #' the fitted model object. #' @param file_refit Modifies when the fit stored via the \code{file} argument #' is re-used. Can be set globally for the current \R session via the #' \code{"brms.file_refit"} option (see \code{\link{options}}). #' For \code{"never"} (default) the fit is always loaded if it #' exists and fitting is skipped. For \code{"always"} the model is always #' refitted. If set to \code{"on_change"}, brms will #' refit the model if model, data or algorithm as passed to Stan differ from #' what is stored in the file. This also covers changes in priors, #' \code{sample_prior}, \code{stanvars}, covariance structure, etc. If you #' believe there was a false positive, you can use #' \code{\link{brmsfit_needs_refit}} to see why refit is deemed necessary. #' Refit will not be triggered for changes in additional parameters of the fit #' (e.g., initial values, number of iterations, control arguments, ...). A #' known limitation is that a refit will be triggered if within-chain #' parallelization is switched on/off. #' @param empty Logical. If \code{TRUE}, the Stan model is not created #' and compiled and the corresponding \code{'fit'} slot of the \code{brmsfit} #' object will be empty. This is useful if you have estimated a brms-created #' Stan model outside of \pkg{brms} and want to feed it back into the package. #' @param rename For internal use only. #' @param stan_model_args A \code{list} of further arguments passed to #' \code{\link[rstan:stan_model]{rstan::stan_model}} for \code{backend = #' "rstan"} or to \code{cmdstanr::cmdstan_model} for \code{backend = #' "cmdstanr"}, which allows to change how models are compiled. #' @param ... Further arguments passed to Stan. #' For \code{backend = "rstan"} the arguments are passed to #' \code{\link[rstan]{sampling}} or \code{\link[rstan]{vb}}. #' For \code{backend = "cmdstanr"} the arguments are passed to the #' \code{cmdstanr::sample} or \code{cmdstanr::variational} method. #' #' @return An object of class \code{brmsfit}, which contains the posterior #' draws along with many other useful information about the model. Use #' \code{methods(class = "brmsfit")} for an overview on available methods. #' #' @author Paul-Christian Buerkner \email{paul.buerkner@@gmail.com} #' #' @details Fit a generalized (non-)linear multivariate multilevel model via #' full Bayesian inference using Stan. A general overview is provided in the #' vignettes \code{vignette("brms_overview")} and #' \code{vignette("brms_multilevel")}. For a full list of available vignettes #' see \code{vignette(package = "brms")}. #' #' \bold{Formula syntax of brms models} #' #' Details of the formula syntax applied in \pkg{brms} can be found in #' \code{\link{brmsformula}}. #' #' \bold{Families and link functions} #' #' Details of families supported by \pkg{brms} can be found in #' \code{\link{brmsfamily}}. #' #' \bold{Prior distributions} #' #' Priors should be specified using the #' \code{\link[brms:set_prior]{set_prior}} function. Its documentation #' contains detailed information on how to correctly specify priors. To find #' out on which parameters or parameter classes priors can be defined, use #' \code{\link[brms:default_prior.default]{default_prior}}. Default priors are chosen to be #' non or very weakly informative so that their influence on the results will #' be negligible and you usually don't have to worry about them. However, #' after getting more familiar with Bayesian statistics, I recommend you to #' start thinking about reasonable informative priors for your model #' parameters: Nearly always, there is at least some prior information #' available that can be used to improve your inference. #' #' \bold{Adjusting the sampling behavior of \pkg{Stan}} #' #' In addition to choosing the number of iterations, warmup draws, and #' chains, users can control the behavior of the NUTS sampler, by using the #' \code{control} argument. The most important reason to use \code{control} is #' to decrease (or eliminate at best) the number of divergent transitions that #' cause a bias in the obtained posterior draws. Whenever you see the #' warning "There were x divergent transitions after warmup." you should #' really think about increasing \code{adapt_delta}. To do this, write #' \code{control = list(adapt_delta = )}, where \code{} should usually #' be value between \code{0.8} (current default) and \code{1}. Increasing #' \code{adapt_delta} will slow down the sampler but will decrease the number #' of divergent transitions threatening the validity of your posterior #' draws. #' #' Another problem arises when the depth of the tree being evaluated in each #' iteration is exceeded. This is less common than having divergent #' transitions, but may also bias the posterior draws. When it happens, #' \pkg{Stan} will throw out a warning suggesting to increase #' \code{max_treedepth}, which can be accomplished by writing \code{control = #' list(max_treedepth = )} with a positive integer \code{} that should #' usually be larger than the current default of \code{10}. For more details #' on the \code{control} argument see \code{\link[rstan:stan]{stan}}. #' #' @template parallelization #' #' @references #' Paul-Christian Buerkner (2017). brms: An R Package for Bayesian Multilevel #' Models Using Stan. \emph{Journal of Statistical Software}, 80(1), 1-28. #' \code{doi:10.18637/jss.v080.i01} #' #' Paul-Christian Buerkner (2018). Advanced Bayesian Multilevel Modeling #' with the R Package brms. \emph{The R Journal}. 10(1), 395–411. #' \code{doi:10.32614/RJ-2018-017} #' #' @seealso \code{\link{brms}}, \code{\link{brmsformula}}, #' \code{\link{brmsfamily}}, \code{\link{brmsfit}} #' #' @examples #' \dontrun{ #' # Poisson regression for the number of seizures in epileptic patients #' fit1 <- brm( #' count ~ zBase * Trt + (1|patient), #' data = epilepsy, family = poisson(), #' prior = prior(normal(0, 10), class = b) + #' prior(cauchy(0, 2), class = sd) #' ) #' #' # generate a summary of the results #' summary(fit1) #' #' # plot the MCMC chains as well as the posterior distributions #' plot(fit1) #' #' # predict responses based on the fitted model #' head(predict(fit1)) #' #' # plot conditional effects for each predictor #' plot(conditional_effects(fit1), ask = FALSE) #' #' # investigate model fit #' loo(fit1) #' pp_check(fit1) #' #' #' # Ordinal regression modeling patient's rating of inhaler instructions #' # category specific effects are estimated for variable 'treat' #' fit2 <- brm(rating ~ period + carry + cs(treat), #' data = inhaler, family = sratio("logit"), #' prior = set_prior("normal(0,5)"), chains = 2) #' summary(fit2) #' plot(fit2, ask = FALSE) #' WAIC(fit2) #' #' #' # Survival regression modeling the time between the first #' # and second recurrence of an infection in kidney patients. #' fit3 <- brm(time | cens(censored) ~ age * sex + disease + (1|patient), #' data = kidney, family = lognormal()) #' summary(fit3) #' plot(fit3, ask = FALSE) #' plot(conditional_effects(fit3), ask = FALSE) #' #' #' # Probit regression using the binomial family #' ntrials <- sample(1:10, 100, TRUE) #' success <- rbinom(100, size = ntrials, prob = 0.4) #' x <- rnorm(100) #' data4 <- data.frame(ntrials, success, x) #' fit4 <- brm(success | trials(ntrials) ~ x, data = data4, #' family = binomial("probit")) #' summary(fit4) #' #' #' # Non-linear Gaussian model #' fit5 <- brm( #' bf(cum ~ ult * (1 - exp(-(dev/theta)^omega)), #' ult ~ 1 + (1|AY), omega ~ 1, theta ~ 1, #' nl = TRUE), #' data = loss, family = gaussian(), #' prior = c( #' prior(normal(5000, 1000), nlpar = "ult"), #' prior(normal(1, 2), nlpar = "omega"), #' prior(normal(45, 10), nlpar = "theta") #' ), #' control = list(adapt_delta = 0.9) #' ) #' summary(fit5) #' conditional_effects(fit5) #' #' #' # Normal model with heterogeneous variances #' data_het <- data.frame( #' y = c(rnorm(50), rnorm(50, 1, 2)), #' x = factor(rep(c("a", "b"), each = 50)) #' ) #' fit6 <- brm(bf(y ~ x, sigma ~ 0 + x), data = data_het) #' summary(fit6) #' plot(fit6) #' conditional_effects(fit6) #' #' # extract estimated residual SDs of both groups #' sigmas <- exp(as.data.frame(fit6, variable = "^b_sigma_", regex = TRUE)) #' ggplot(stack(sigmas), aes(values)) + #' geom_density(aes(fill = ind)) #' #' #' # Quantile regression predicting the 25%-quantile #' fit7 <- brm(bf(y ~ x, quantile = 0.25), data = data_het, #' family = asym_laplace()) #' summary(fit7) #' conditional_effects(fit7) #' #' # use the future package for more flexible parallelization #' library(future) #' plan(multisession, workers = 4) #' fit7a <- update(fit7, future = TRUE) #' #' # we may also use mirai allowing the use of remote machines as #' # well, including the use of computer clusters managed by queuing #' # systems #' mirai::daemons(4) # distributed computing with url and remote argument #' plan(future.mirai::mirai_cluster) #' fit7b <- update(fit7, future = TRUE) #' mirai::daemons(0) # shuts down the 4 workers #' #' # fit a model manually via rstan #' scode <- stancode(count ~ Trt, data = epilepsy) #' sdata <- standata(count ~ Trt, data = epilepsy) #' stanfit <- rstan::stan(model_code = scode, data = sdata) #' # feed the Stan model back into brms #' fit8 <- brm(count ~ Trt, data = epilepsy, empty = TRUE) #' fit8$fit <- stanfit #' fit8 <- rename_pars(fit8) #' summary(fit8) #' } #' #' @import parallel #' @import methods #' @import stats #' @import Rcpp #' @export brm <- function(formula, data, family = gaussian(), prior = NULL, autocor = NULL, data2 = NULL, cov_ranef = NULL, sample_prior = "no", sparse = NULL, knots = NULL, drop_unused_levels = TRUE, stanvars = NULL, stan_funs = NULL, fit = NA, save_pars = getOption("brms.save_pars", NULL), save_ranef = NULL, save_mevars = NULL, save_all_pars = NULL, init = NULL, inits = NULL, chains = 4, iter = getOption("brms.iter", 2000), warmup = floor(iter / 2), thin = 1, cores = getOption("mc.cores", 1), threads = getOption("brms.threads", NULL), opencl = getOption("brms.opencl", NULL), normalize = getOption("brms.normalize", TRUE), control = NULL, algorithm = getOption("brms.algorithm", "sampling"), backend = getOption("brms.backend", "rstan"), future = getOption("future", FALSE), silent = 1, seed = NA, save_model = NULL, stan_model_args = list(), file = NULL, file_compress = TRUE, file_refit = getOption("brms.file_refit", "never"), empty = FALSE, rename = TRUE, ...) { # optionally load brmsfit from file # Loading here only when we should directly load the file. # The "on_change" option needs sdata and scode to be built file_refit <- match.arg(file_refit, file_refit_options()) if (!is.null(file) && file_refit == "never") { x <- read_brmsfit(file) if (!is.null(x)) { return(x) } } # validate arguments later passed to Stan algorithm <- match.arg(algorithm, algorithm_choices()) backend <- match.arg(backend, backend_choices()) normalize <- as_one_logical(normalize) silent <- validate_silent(silent) iter <- as_one_numeric(iter) warmup <- as_one_numeric(warmup) thin <- as_one_numeric(thin) chains <- as_one_numeric(chains) cores <- as_one_numeric(cores) init <- use_alias(init, inits) threads <- validate_threads(threads) opencl <- validate_opencl(opencl) future <- as_one_logical(future) && chains > 0L seed <- as_one_numeric(seed, allow_na = TRUE) empty <- as_one_logical(empty) rename <- as_one_logical(rename) # initialize brmsfit object if (is.brmsfit(fit)) { # re-use existing model x <- fit x$criteria <- list() sdata <- standata(x) if (!is.null(file) && file_refit == "on_change") { x_from_file <- read_brmsfit(file) if (!is.null(x_from_file)) { needs_refit <- brmsfit_needs_refit( x_from_file, scode = stancode(x), sdata = sdata, data = x$data, algorithm = algorithm, silent = silent ) if (!needs_refit) { return(x_from_file) } } } backend <- x$backend model <- compiled_model(x) exclude <- exclude_pars(x) } else { # build new model formula <- validate_formula( formula, data = data, family = family, autocor = autocor, sparse = sparse, cov_ranef = cov_ranef ) family <- get_element(formula, "family") bterms <- brmsterms(formula) data2 <- validate_data2( data2, bterms = bterms, get_data2_autocor(formula), get_data2_cov_ranef(formula) ) data <- validate_data( data, bterms = bterms, data2 = data2, knots = knots, drop_unused_levels = drop_unused_levels, data_name = substitute_name(data) ) bframe <- brmsframe(bterms, data) prior <- .validate_prior( prior, bframe = bframe, sample_prior = sample_prior ) stanvars <- validate_stanvars(stanvars, stan_funs = stan_funs) save_pars <- validate_save_pars( save_pars, save_ranef = save_ranef, save_mevars = save_mevars, save_all_pars = save_all_pars ) # generate Stan code model <- .stancode( bframe, prior = prior, stanvars = stanvars, save_model = save_model, backend = backend, threads = threads, opencl = opencl, normalize = normalize ) # initialize S3 object x <- brmsfit( formula = formula, data = data, data2 = data2, prior = prior, stanvars = stanvars, model = model, algorithm = algorithm, backend = backend, threads = threads, opencl = opencl, save_pars = save_pars, ranef = bframe$frame$re, family = family, basis = frame_basis(bframe, data = data), stan_args = nlist(init, silent, control, stan_model_args, ...) ) exclude <- exclude_pars(x, bframe = bframe) # generate Stan data before compiling the model to avoid # unnecessary compilations in case of invalid data sdata <- .standata( bframe, data = data, prior = prior, data2 = data2, stanvars = stanvars, threads = threads ) if (empty) { # return the brmsfit object with an empty 'fit' slot return(x) } if (!is.null(file) && file_refit == "on_change") { x_from_file <- read_brmsfit(file) if (!is.null(x_from_file)) { needs_refit <- brmsfit_needs_refit( x_from_file, scode = model, sdata = sdata, data = data, algorithm = algorithm, silent = silent ) if (!needs_refit) { return(x_from_file) } } } # compile the Stan model compile_args <- stan_model_args compile_args$model <- model compile_args$backend <- backend compile_args$threads <- threads compile_args$opencl <- opencl compile_args$silent <- silent model <- do_call(compile_model, compile_args) } # fit the Stan model fit_args <- nlist( model, sdata, algorithm, backend, iter, warmup, thin, chains, cores, threads, opencl, init, exclude, control, future, seed, silent, ... ) x$fit <- do_call(fit_model, fit_args) # rename parameters to have human readable names if (rename) { x <- rename_pars(x) } if (!is.null(file)) { x <- write_brmsfit(x, file, compress = file_compress) } x } brms/R/formula-ad.R0000644000176200001440000003465215053305627013610 0ustar liggesusers#' Additional Response Information #' #' Provide additional information on the response variable #' in \pkg{brms} models, such as censoring, truncation, or #' known measurement error. Detailed documentation on the use #' of each of these functions can be found in the Details section #' of \code{\link{brmsformula}} (under "Additional response information"). #' #' @name addition-terms #' @aliases se weights trials thres cat dec cens trunc #' @aliases index rate subset vreal vint #' #' @param x A vector; Ideally a single variable defined in the data (see #' Details). Allowed values depend on the function: \code{resp_se} and #' \code{resp_weights} require positive numeric values. \code{resp_trials}, #' \code{resp_thres}, and \code{resp_cat} require positive integers. #' \code{resp_dec} requires \code{0} and \code{1}, or alternatively #' \code{'lower'} and \code{'upper'}. \code{resp_subset} requires \code{0} and #' \code{1}, or alternatively \code{FALSE} and \code{TRUE}. \code{resp_cens} #' requires \code{'left'}, \code{'none'}, \code{'right'}, and #' \code{'interval'} (or equivalently \code{-1}, \code{0}, \code{1}, and #' \code{2}) to indicate left, no, right, or interval censoring. #' \code{resp_index} does not make any requirements other than the value being #' unique for each observation. #' @param sigma Logical; Indicates whether the residual standard deviation #' parameter \code{sigma} should be included in addition to the known #' measurement error. Defaults to \code{FALSE} for backwards compatibility, #' but setting it to \code{TRUE} is usually the better choice. #' @param scale Logical; Indicates whether weights should be scaled #' so that the average weight equals one. Defaults to \code{FALSE}. #' @param y2 A vector specifying the upper bounds in interval censoring. #' Will be ignored for non-interval censored observations. However, it #' should NOT be \code{NA} even for non-interval censored observations to #' avoid accidental exclusion of these observations. #' @param lb A numeric vector or single numeric value specifying #' the lower truncation bound. #' @param ub A numeric vector or single numeric value specifying #' the upper truncation bound. #' @param sdy Optional known measurement error of the response #' treated as standard deviation. If specified, handles #' measurement error and (completely) missing values #' at the same time using the plausible-values-technique. #' @param denom A vector of positive numeric values specifying #' the denominator values from which the response rates are computed. #' @param gr A vector of grouping indicators. #' @param df Degrees of freedom of baseline hazard splines for Cox models. #' @param ... For \code{resp_vreal}, vectors of real values. #' For \code{resp_vint}, vectors of integer values. In Stan, #' these variables will be named \code{vreal1}, \code{vreal2}, ..., #' and \code{vint1}, \code{vint2}, ..., respectively. #' #' @return A list of additional response information to be processed further #' by \pkg{brms}. #' #' @details #' These functions are almost solely useful when #' called in formulas passed to the \pkg{brms} package. #' Within formulas, the \code{resp_} prefix may be omitted. #' More information is given in the 'Details' section #' of \code{\link{brmsformula}} (under "Additional response information"). #' #' It is highly recommended to use a single data variable as input #' for \code{x} (instead of a more complicated expression) to make sure all #' post-processing functions work as expected. #' #' @seealso #' \code{\link{brm}}, #' \code{\link{brmsformula}} #' #' @examples #' \dontrun{ #' ## Random effects meta-analysis #' nstudies <- 20 #' true_effects <- rnorm(nstudies, 0.5, 0.2) #' sei <- runif(nstudies, 0.05, 0.3) #' outcomes <- rnorm(nstudies, true_effects, sei) #' data1 <- data.frame(outcomes, sei) #' fit1 <- brm(outcomes | se(sei, sigma = TRUE) ~ 1, #' data = data1) #' summary(fit1) #' #' ## Probit regression using the binomial family #' n <- sample(1:10, 100, TRUE) # number of trials #' success <- rbinom(100, size = n, prob = 0.4) #' x <- rnorm(100) #' data2 <- data.frame(n, success, x) #' fit2 <- brm(success | trials(n) ~ x, data = data2, #' family = binomial("probit")) #' summary(fit2) #' #' ## Survival regression modeling the time between the first #' ## and second recurrence of an infection in kidney patients. #' fit3 <- brm(time | cens(censored) ~ age * sex + disease + (1|patient), #' data = kidney, family = lognormal()) #' summary(fit3) #' #' ## Poisson model with truncated counts #' fit4 <- brm(count | trunc(ub = 104) ~ zBase * Trt, #' data = epilepsy, family = poisson()) #' summary(fit4) #' } #' NULL # TODO: split into separate docs for each function #' @rdname addition-terms #' @export resp_se <- function(x, sigma = FALSE) { se <- deparse0(substitute(x)) sigma <- as_one_logical(sigma) class_resp_special( "se", call = match.call(), vars = nlist(se), flags = nlist(sigma) ) } #' @rdname addition-terms #' @export resp_weights <- function(x, scale = FALSE) { weights <- deparse0(substitute(x)) scale <- as_one_logical(scale) class_resp_special( "weights", call = match.call(), vars = nlist(weights), flags = nlist(scale) ) } #' @rdname addition-terms #' @export resp_trials <- function(x) { trials <- deparse0(substitute(x)) class_resp_special("trials", call = match.call(), vars = nlist(trials)) } #' @rdname addition-terms #' @export resp_thres <- function(x, gr = NA) { thres <- deparse0(substitute(x)) gr <- deparse0(substitute(gr)) class_resp_special("thres", call = match.call(), vars = nlist(thres, gr)) } #' @rdname addition-terms #' @export resp_cat <- function(x) { # deprecated as of brms 2.10.5 # number of thresholds = number of response categories - 1 thres <- deparse0(substitute(x)) str_add(thres) <- " - 1" class_resp_special( "thres", call = match.call(), vars = nlist(thres, gr = "NA") ) } #' @rdname addition-terms #' @export resp_dec <- function(x) { dec <- deparse0(substitute(x)) class_resp_special("dec", call = match.call(), vars = nlist(dec)) } #' @rdname addition-terms #' @export resp_bhaz <- function(gr = NA, df = 5, ...) { gr <- deparse0(substitute(gr)) df <- as_one_integer(df) args <- nlist(df, ...) # non-power users shouldn't know they can change 'intercept' args$intercept <- args$intercept %||% TRUE class_resp_special("bhaz", call = match.call(), vars = nlist(gr), flags = args) } #' @rdname addition-terms #' @export resp_cens <- function(x, y2 = NA) { cens <- deparse0(substitute(x)) y2 <- deparse0(substitute(y2)) class_resp_special("cens", call = match.call(), vars = nlist(cens, y2)) } #' @rdname addition-terms #' @export resp_trunc <- function(lb = -Inf, ub = Inf) { lb <- deparse0(substitute(lb)) ub <- deparse0(substitute(ub)) class_resp_special("trunc", call = match.call(), vars = nlist(lb, ub)) } #' @rdname addition-terms #' @export resp_mi <- function(sdy = NA) { sdy <- deparse0(substitute(sdy)) class_resp_special("mi", call = match.call(), vars = nlist(sdy)) } #' @rdname addition-terms #' @export resp_index <- function(x) { index <- deparse0(substitute(x)) class_resp_special("index", call = match.call(), vars = nlist(index)) } #' @rdname addition-terms #' @export resp_rate <- function(denom) { denom <- deparse0(substitute(denom)) class_resp_special("rate", call = match.call(), vars = nlist(denom)) } #' @rdname addition-terms #' @export resp_subset <- function(x) { subset <- deparse0(substitute(x)) class_resp_special("subset", call = match.call(), vars = nlist(subset)) } #' @rdname addition-terms #' @export resp_vreal <- function(...) { vars <- as.list(substitute(list(...)))[-1] class_resp_special("vreal", call = match.call(), vars = vars) } #' @rdname addition-terms #' @export resp_vint <- function(...) { vars <- as.list(substitute(list(...)))[-1] class_resp_special("vint", call = match.call(), vars = vars) } # class underlying response addition terms # @param type type of the addition term # @param call the call to the original addition term function # @param vars named list of unevaluated variables # @param flags named list of (evaluated) logical indicators class_resp_special <- function(type, call, vars = list(), flags = list()) { type <- as_one_character(type) stopifnot(is.call(call), is.list(vars), is.list(flags)) label <- deparse0(call) out <- nlist(type, call, label, vars, flags) class(out) <- c("resp_special") out } # computes data for addition arguments eval_rhs <- function(formula, data = NULL) { formula <- as.formula(formula) eval(rhs(formula)[[2]], data, environment(formula)) } # get expression for a variable of an addition term # @param x list with potential $adforms elements # @param ad name of the addition term # @param target name of the element to extract # @type type of the element to extract # @return a character string or NULL get_ad_expr <- function(x, ad, name, type = "vars") { ad <- as_one_character(ad) name <- as_one_character(name) type <- as_one_character(type) if (is.null(x$adforms[[ad]])) { return(NULL) } out <- eval_rhs(x$adforms[[ad]])[[type]][[name]] if (type == "vars" && is_equal(out, "NA")) { out <- NULL } out } # get values of a variable used in an addition term # @return a vector of values or NULL get_ad_values <- function(x, ad, name, data) { expr <- get_ad_expr(x, ad, name, type = "vars") eval2(expr, data) } # get a flag used in an addition term # @return TRUE or FALSE get_ad_flag <- function(x, ad, name) { expr <- get_ad_expr(x, ad, name, type = "flags") as_one_logical(eval2(expr)) } # get variable names used in addition terms get_ad_vars <- function(x, ...) { UseMethod("get_ad_vars") } #' @export get_ad_vars.brmsterms <- function(x, ad, ...) { ad <- as_one_character(ad) all_vars(x$adforms[[ad]]) } #' @export get_ad_vars.mvbrmsterms <- function(x, ad, ...) { unique(ulapply(x$terms, get_ad_vars, ad = ad, ...)) } # coerce censored values into the right format # @param x vector of censoring indicators # @return transformed vector of censoring indicators prepare_cens <- function(x) { .prepare_cens <- function(x) { stopifnot(length(x) == 1L) regx <- paste0("^", x) if (grepl(regx, "left")) { x <- -1 } else if (grepl(regx, "none") || isFALSE(x)) { x <- 0 } else if (grepl(regx, "right") || isTRUE(x)) { x <- 1 } else if (grepl(regx, "interval")) { x <- 2 } return(x) } x <- unname(x) if (is.factor(x)) { x <- as.character(x) } ulapply(x, .prepare_cens) } # extract information on censoring of the response variable # @return vector of censoring indicators or NULL in case of no censoring get_cens <- function(bterms, data, resp = NULL) { if (!is.null(resp)) { bterms <- bterms$terms[[resp]] } out <- NULL if (is.formula(bterms$adforms$cens)) { out <- get_ad_values(bterms, "cens", "cens", data) out <- prepare_cens(out) } out } # indicates if the model may have interval censored observations has_interval_cens <- function(bterms) { !is.null(get_ad_expr(bterms, "cens", "y2")) } # extract truncation boundaries # @param bterms a brmsterms object # @param data data.frame containing the truncation variables # @param incl_family include the family in the derivation of the bounds? # @param stan return bounds in form of Stan syntax? # @return a list with elements 'lb' and 'ub' or corresponding Stan code trunc_bounds <- function(bterms, data = NULL, incl_family = FALSE, stan = FALSE, ...) { stopifnot(is.brmsterms(bterms)) if (is.formula(bterms$adforms$trunc)) { trunc <- eval_rhs(bterms$adforms$trunc) } else { trunc <- resp_trunc() } out <- list( lb = eval2(trunc$vars$lb, data), ub = eval2(trunc$vars$ub, data) ) if (incl_family) { family_bounds <- family_bounds(bterms) out$lb <- max(out$lb, family_bounds$lb) out$ub <- min(out$ub, family_bounds$ub) } if (stan) { if (any(out$lb > -Inf | out$ub < Inf)) { tmp <- c( if (out$lb > -Inf) paste0("lower=", out$lb), if (out$ub < Inf) paste0("upper=", out$ub) ) out <- paste0("<", paste0(tmp, collapse = ","), ">") } else { out <- "" } } out } # check if addition argument 'subset' is used in the model # works for both univariate and multivariate models has_subset <- function(bterms) { if (is.brmsterms(bterms)) { out <- has_ad_terms(bterms, "subset") } else if (is.mvbrmsterms(bterms)) { out <- any(ulapply(bterms$terms, has_ad_terms, "subset")) } else { out <- FALSE } out } # check if a model has certain addition terms has_ad_terms <- function(bterms, terms) { stopifnot(is.brmsterms(bterms), is.character(terms)) any(ulapply(bterms$adforms[terms], is.formula)) } # construct a list of indices for cross-formula referencing frame_index <- function(x, data) { out <- .frame_index(x, data) if (is.brmsterms(x)) { # ensure consistent format for both uni- and multivariate models out <- list(out) names(out)[1] <- terms_resp(x$respform) } out } # internal version of frame_index .frame_index <- function(x, ...) { UseMethod(".frame_index") } #' @export .frame_index.brmsterms <- function(x, data, ...) { out <- get_ad_values(x, "index", "index", data) if (is.null(out)) { return(NULL) } if (has_subset(x)) { subset <- as.logical(get_ad_values(x, "subset", "subset", data)) out <- out[subset] attr(out, "subset") <- TRUE } if (anyNA(out)) { stop2("NAs are not allowed in 'index' variables.") } if (anyDuplicated(out)) { stop2("Index of response '", x$resp, "' contains duplicated values.") } out } #' @export .frame_index.mvbrmsterms <- function(x, data, ...) { lapply(x$terms, .frame_index, data = data, ...) } # check if cross-formula referencing is possible in subsetted models check_cross_formula_indexing <- function(bterms) { sp_terms <- ulapply(get_effect(bterms, "sp"), all_terms) me_terms <- get_matches_expr(regex_sp("me"), sp_terms) if (length(me_terms)) { stop2("Cannot use me() terms in subsetted formulas.") } mi_terms <- get_matches_expr(regex_sp("mi"), sp_terms) idx_vars <- lapply(mi_terms, function(x) eval2(x)$idx) if (any(idx_vars == "NA")) { stop2("mi() terms in subsetted formulas require ", "the 'idx' argument to be specified.") } invisible(TRUE) } # does an expression consist of a single variable? is_single_variable <- function(x) { x <- as_one_character(x) is_equal(x, all_vars(x)) } brms/R/conditional_effects.R0000644000176200001440000013776315057542623015575 0ustar liggesusers#' Display Conditional Effects of Predictors #' #' Display conditional effects of one or more numeric and/or categorical #' predictors including two-way interaction effects. #' #' @aliases marginal_effects marginal_effects.brmsfit #' #' @param x An object of class \code{brmsfit}. #' @param effects An optional character vector naming effects (main effects or #' interactions) for which to compute conditional plots. Interactions are #' specified by a \code{:} between variable names. If \code{NULL} (the #' default), plots are generated for all main effects and two-way interactions #' estimated in the model. When specifying \code{effects} manually, \emph{all} #' two-way interactions (including grouping variables) may be plotted #' even if not originally modeled. #' @param conditions An optional \code{data.frame} containing variable values #' to condition on. Each effect defined in \code{effects} will #' be plotted separately for each row of \code{conditions}. Values in the #' \code{cond__} column will be used as titles of the subplots. If \code{cond__} #' is not given, the row names will be used for this purpose instead. #' It is recommended to only define a few rows in order to keep the plots clear. #' See \code{\link{make_conditions}} for an easy way to define conditions. #' If \code{NULL} (the default), numeric variables will be conditionalized by #' using their means and factors will get their first level assigned. #' \code{NA} values within factors are interpreted as if all dummy #' variables of this factor are zero. This allows, for instance, to make #' predictions of the grand mean when using sum coding. #' @param int_conditions An optional named \code{list} whose elements are #' vectors of values of the variables specified in \code{effects}. #' At these values, predictions are evaluated. The names of #' \code{int_conditions} have to match the variable names exactly. #' Additionally, the elements of the vectors may be named themselves, #' in which case their names appear as labels for the conditions in the plots. #' Instead of vectors, functions returning vectors may be passed and are #' applied on the original values of the corresponding variable. #' If \code{NULL} (the default), predictions are evaluated at the #' \eqn{mean} and at \eqn{mean +/- sd} for numeric predictors and at #' all categories for factor-like predictors. #' @param re_formula A formula containing group-level effects to be considered #' in the conditional predictions. If \code{NULL}, include all group-level #' effects; if \code{NA} (default), include no group-level effects. #' @param robust If \code{TRUE} (the default) the median is used as the #' measure of central tendency. If \code{FALSE} the mean is used instead. #' @param prob A value between 0 and 1 indicating the desired probability #' to be covered by the uncertainty intervals. The default is 0.95. #' @param probs (Deprecated) The quantiles to be used in the computation of #' uncertainty intervals. Please use argument \code{prob} instead. #' @param method Method used to obtain predictions. Can be set to #' \code{"posterior_epred"} (the default), \code{"posterior_predict"}, #' or \code{"posterior_linpred"}. For more details, see the respective #' function documentations. #' @param spaghetti Logical. Indicates if predictions should #' be visualized via spaghetti plots. Only applied for numeric #' predictors. If \code{TRUE}, it is recommended #' to set argument \code{ndraws} to a relatively small value #' (e.g., \code{100}) in order to reduce computation time. #' @param surface Logical. Indicates if interactions or #' two-dimensional smooths should be visualized as a surface. #' Defaults to \code{FALSE}. The surface type can be controlled #' via argument \code{stype} of the related plotting method. #' @param categorical Logical. Indicates if effects of categorical #' or ordinal models should be shown in terms of probabilities #' of response categories. Defaults to \code{FALSE}. #' @param ordinal (Deprecated) Please use argument \code{categorical}. #' Logical. Indicates if effects in ordinal models #' should be visualized as a raster with the response categories #' on the y-axis. Defaults to \code{FALSE}. #' @param transform A function or a character string naming #' a function to be applied on the predicted responses #' before summary statistics are computed. Only allowed #' if \code{method = "posterior_predict"}. #' @param resolution Number of support points used to generate #' the plots. Higher resolution leads to smoother plots. #' Defaults to \code{100}. If \code{surface} is \code{TRUE}, #' this implies \code{10000} support points for interaction terms, #' so it might be necessary to reduce \code{resolution} #' when only few RAM is available. #' @param too_far Positive number. #' For surface plots only: Grid points that are too #' far away from the actual data points can be excluded from the plot. #' \code{too_far} determines what is too far. The grid is scaled into #' the unit square and then grid points more than \code{too_far} #' from the predictor variables are excluded. By default, all #' grid points are used. Ignored for non-surface plots. #' @param select_points Positive number. #' Only relevant if \code{points} or \code{rug} are set to \code{TRUE}: #' Actual data points of numeric variables that #' are too far away from the values specified in \code{conditions} #' can be excluded from the plot. Values are scaled into #' the unit interval and then points more than \code{select_points} #' from the values in \code{conditions} are excluded. #' By default, all points are used. #' @param ... Further arguments such as \code{draw_ids} or \code{ndraws} #' passed to \code{\link{posterior_predict}} or \code{\link{posterior_epred}}. #' @inheritParams plot.brmsfit #' @param ncol Number of plots to display per column for each effect. #' If \code{NULL} (default), \code{ncol} is computed internally based #' on the number of rows of \code{conditions}. #' @param points Logical. Indicates if the original data points should be added #' via \code{\link[ggplot2:geom_jitter]{geom_jitter}}. Default is #' \code{FALSE}. Can be controlled globally via the \code{brms.plot_points} #' option. Note that only those data points will be added that match the #' specified conditions defined in \code{conditions}. For categorical #' predictors, the conditions have to match exactly. For numeric predictors, #' argument \code{select_points} is used to determine, which points do match a #' condition. #' @param rug Logical. Indicates if a rug representation of predictor values #' should be added via \code{\link[ggplot2:geom_rug]{geom_rug}}. Default is #' \code{FALSE}. Depends on \code{select_points} in the same way as #' \code{points} does. Can be controlled globally via the \code{brms.plot_rug} #' option. #' @param mean Logical. Only relevant for spaghetti plots. #' If \code{TRUE} (the default), display the mean regression #' line on top of the regression lines for each sample. #' @param jitter_width Only used if \code{points = TRUE}: #' Amount of horizontal jittering of the data points. #' Mainly useful for ordinal models. Defaults to \code{0} that #' is no jittering. #' @param stype Indicates how surface plots should be displayed. #' Either \code{"contour"} or \code{"raster"}. #' @param line_args Only used in plots of continuous predictors: #' A named list of arguments passed to #' \code{\link[ggplot2:geom_smooth]{geom_smooth}}. #' @param cat_args Only used in plots of categorical predictors: #' A named list of arguments passed to #' \code{\link[ggplot2:geom_point]{geom_point}}. #' @param errorbar_args Only used in plots of categorical predictors: #' A named list of arguments passed to #' \code{\link[ggplot2:geom_errorbar]{geom_errorbar}}. #' @param surface_args Only used in surface plots: #' A named list of arguments passed to #' \code{\link[ggplot2:geom_contour]{geom_contour}} or #' \code{\link[ggplot2:geom_raster]{geom_raster}} #' (depending on argument \code{stype}). #' @param spaghetti_args Only used in spaghetti plots: #' A named list of arguments passed to #' \code{\link[ggplot2:geom_smooth]{geom_smooth}}. #' @param point_args Only used if \code{points = TRUE}: #' A named list of arguments passed to #' \code{\link[ggplot2:geom_jitter]{geom_jitter}}. #' @param rug_args Only used if \code{rug = TRUE}: #' A named list of arguments passed to #' \code{\link[ggplot2:geom_rug]{geom_rug}}. #' @param facet_args Only used if if multiple conditions are provided: #' A named list of arguments passed to #' \code{\link[ggplot2:facet_wrap]{facet_wrap}}. #' #' @return An object of class \code{'brms_conditional_effects'} which is a #' named list with one data.frame per effect containing all information #' required to generate conditional effects plots. Among others, these #' data.frames contain some special variables, namely \code{estimate__} #' (predicted values of the response), \code{se__} (standard error of the #' predicted response), \code{lower__} and \code{upper__} (lower and upper #' bounds of the uncertainty interval of the response), as well as #' \code{cond__} (used in faceting when \code{conditions} contains multiple #' rows). #' #' The corresponding \code{plot} method returns a named #' list of \code{\link[ggplot2:ggplot]{ggplot}} objects, which can be further #' customized using the \pkg{ggplot2} package. #' #' @details When creating \code{conditional_effects} for a particular predictor #' (or interaction of two predictors), one has to choose the values of all #' other predictors to condition on. By default, the mean is used for #' continuous variables and the reference category is used for factors, but #' you may change these values via argument \code{conditions}. This also has #' an implication for the \code{points} argument: In the created plots, only #' those points will be shown that correspond to the factor levels actually #' used in the conditioning, in order not to create the false impression of #' bad model fit, where it is just due to conditioning on certain factor #' levels. #' #' To fully change colors of the created plots, one has to amend both #' \code{scale_colour} and \code{scale_fill}. See #' \code{\link[ggplot2:scale_color_grey]{scale_colour_grey}} or #' \code{\link[ggplot2:scale_color_gradient]{scale_colour_gradient}} for #' more details. #' #' @examples #' \dontrun{ #' fit <- brm(count ~ zAge + zBase * Trt + (1 | patient), #' data = epilepsy, family = poisson()) #' #' ## plot all conditional effects #' plot(conditional_effects(fit), ask = FALSE) #' #' ## change colours to grey scale #' library(ggplot2) #' ce <- conditional_effects(fit, "zBase:Trt") #' plot(ce, plot = FALSE)[[1]] + #' scale_color_grey() + #' scale_fill_grey() #' #' ## only plot the conditional interaction effect of 'zBase:Trt' #' ## for different values for 'zAge' #' conditions <- data.frame(zAge = c(-1, 0, 1)) #' plot(conditional_effects(fit, effects = "zBase:Trt", #' conditions = conditions)) #' #' ## also incorporate group-level effects variance over patients #' ## also add data points and a rug representation of predictor values #' plot(conditional_effects(fit, effects = "zBase:Trt", #' conditions = conditions, re_formula = NULL), #' points = TRUE, rug = TRUE) #' #' ## change handling of two-way interactions #' int_conditions <- list( #' zBase = setNames(c(-2, 1, 0), c("b", "c", "a")) #' ) #' conditional_effects(fit, effects = "Trt:zBase", #' int_conditions = int_conditions) #' conditional_effects(fit, effects = "Trt:zBase", #' int_conditions = list(zBase = quantile)) #' #' ## fit a model to illustrate how to plot 3-way interactions #' fit3way <- brm(count ~ zAge * zBase * Trt, data = epilepsy) #' conditions <- make_conditions(fit3way, "zAge") #' conditional_effects(fit3way, "zBase:Trt", conditions = conditions) #' ## only include points close to the specified values of zAge #' ce <- conditional_effects( #' fit3way, "zBase:Trt", conditions = conditions, #' select_points = 0.1 #' ) #' plot(ce, points = TRUE) #' } #' #' @export conditional_effects.brmsfit <- function(x, effects = NULL, conditions = NULL, int_conditions = NULL, re_formula = NA, prob = 0.95, robust = TRUE, method = "posterior_epred", spaghetti = FALSE, surface = FALSE, categorical = FALSE, ordinal = FALSE, transform = NULL, resolution = 100, select_points = 0, too_far = 0, probs = NULL, ...) { probs <- validate_ci_bounds(prob, probs = probs) method <- validate_pp_method(method) spaghetti <- as_one_logical(spaghetti) surface <- as_one_logical(surface) categorical <- as_one_logical(categorical) ordinal <- as_one_logical(ordinal) contains_draws(x) x <- restructure(x) new_formula <- update_re_terms(x$formula, re_formula = re_formula) bterms <- brmsterms(new_formula) if (!is.null(transform) && method != "posterior_predict") { stop2("'transform' is only allowed if 'method = posterior_predict'.") } if (ordinal) { warning2("Argument 'ordinal' is deprecated. ", "Please use 'categorical' instead.") } rsv_vars <- rsv_vars(bterms) use_def_effects <- is.null(effects) if (use_def_effects) { effects <- get_all_effects(bterms, rsv_vars = rsv_vars) } else { # allow to define interactions in any order effects <- strsplit(as.character(effects), split = ":") if (any(unique(unlist(effects)) %in% rsv_vars)) { stop2("Variables ", collapse_comma(rsv_vars), " should not be used as effects for this model") } if (any(lengths(effects) > 2L)) { stop2("To display interactions of order higher than 2 ", "please use the 'conditions' argument.") } all_effects <- get_all_effects( bterms, rsv_vars = rsv_vars, comb_all = TRUE ) ae_coll <- all_effects[lengths(all_effects) == 1L] ae_coll <- ulapply(ae_coll, paste, collapse = ":") matches <- match(lapply(all_effects, sort), lapply(effects, sort), 0L) if (sum(matches) > 0 && sum(matches > 0) < length(effects)) { invalid <- effects[setdiff(seq_along(effects), sort(matches))] invalid <- ulapply(invalid, paste, collapse = ":") warning2( "Some specified effects are invalid for this model: ", collapse_comma(invalid), "\nValid effects are ", "(combinations of): ", collapse_comma(ae_coll) ) } effects <- unique(effects[sort(matches)]) if (!length(effects)) { stop2( "All specified effects are invalid for this model.\n", "Valid effects are (combinations of): ", collapse_comma(ae_coll) ) } } if (categorical || ordinal) { int_effs <- lengths(effects) == 2L if (any(int_effs)) { effects <- effects[!int_effs] warning2( "Interactions cannot be plotted directly if 'categorical' ", "is TRUE. Please use argument 'conditions' instead." ) } } if (!length(effects)) { stop2("No valid effects detected.") } mf <- model.frame(x) conditions <- prepare_conditions( x, conditions = conditions, effects = effects, re_formula = re_formula, rsv_vars = rsv_vars ) int_conditions <- lapply(int_conditions, function(x) if (is.numeric(x)) sort(x, TRUE) else x ) int_vars <- get_int_vars(bterms) group_vars <- get_group_vars(bterms) out <- list() for (i in seq_along(effects)) { eff <- effects[[i]] cond_data <- prepare_cond_data( mf[, eff, drop = FALSE], conditions = conditions, int_conditions = int_conditions, int_vars = int_vars, group_vars = group_vars, surface = surface, resolution = resolution, reorder = use_def_effects ) if (surface && length(eff) == 2L && too_far > 0) { # exclude prediction grid points too far from data ex_too_far <- mgcv::exclude.too.far( g1 = cond_data[[eff[1]]], g2 = cond_data[[eff[2]]], d1 = mf[, eff[1]], d2 = mf[, eff[2]], dist = too_far) cond_data <- cond_data[!ex_too_far, ] } c(out) <- conditional_effects( bterms, fit = x, cond_data = cond_data, method = method, surface = surface, spaghetti = spaghetti, categorical = categorical, ordinal = ordinal, re_formula = re_formula, transform = transform, conditions = conditions, int_conditions = int_conditions, select_points = select_points, probs = probs, robust = robust, ... ) } structure(out, class = "brms_conditional_effects") } #' @rdname conditional_effects.brmsfit #' @export conditional_effects <- function(x, ...) { UseMethod("conditional_effects") } # compute expected values of MV models for use in conditional_effects # @return a list of summarized prediction matrices #' @export conditional_effects.mvbrmsterms <- function(x, resp = NULL, ...) { resp <- validate_resp(resp, x$responses) x$terms <- x$terms[resp] out <- lapply(x$terms, conditional_effects, ...) unlist(out, recursive = FALSE) } # conditional_effects for univariate model # @return a list with the summarized prediction matrix as the only element # @note argument 'resp' exists only to be excluded from '...' (#589) #' @export conditional_effects.brmsterms <- function( x, fit, cond_data, int_conditions, method, surface, spaghetti, categorical, ordinal, probs, robust, dpar = NULL, nlpar = NULL, resp = NULL, ... ) { stopifnot(is.brmsfit(fit)) effects <- attr(cond_data, "effects") types <- attr(cond_data, "types") catscale <- NULL pred_args <- list( fit, newdata = cond_data, allow_new_levels = TRUE, dpar = dpar, nlpar = nlpar, resp = if (nzchar(x$resp)) x$resp, incl_autocor = FALSE, ... ) if (method != "posterior_predict") { # 'transform' creates problems in 'posterior_linpred' pred_args$transform <- NULL } out <- do_call(method, pred_args) rownames(cond_data) <- NULL if (categorical || ordinal) { if (method != "posterior_epred") { stop2("Can only use 'categorical' with method = 'posterior_epred'.") } if (!is_polytomous(x)) { stop2("Argument 'categorical' may only be used ", "for categorical or ordinal models.") } if (categorical && ordinal) { stop2("Please use argument 'categorical' instead of 'ordinal'.") } catscale <- str_if(is_multinomial(x), "Count", "Probability") cats <- dimnames(out)[[3]] if (is.null(cats)) cats <- seq_dim(out, 3) cond_data <- repl(cond_data, length(cats)) cond_data <- do_call(rbind, cond_data) cond_data$cats__ <- factor(rep(cats, each = ncol(out)), levels = cats) effects[2] <- "cats__" types[2] <- "factor" } else { if (conv_cats_dpars(x$family) && is.null(dpar)) { stop2("Please set 'categorical' to TRUE.") } if (is_ordinal(x$family) && is.null(dpar) && method != "posterior_linpred") { warning2( "Predictions are treated as continuous variables in ", "'conditional_effects' by default which is likely invalid ", "for ordinal families. Please set 'categorical' to TRUE." ) if (method == "posterior_epred") { out <- ordinal_probs_continuous(out) } } } cond_data <- add_effects__(cond_data, effects) first_numeric <- types[1] %in% "numeric" second_numeric <- types[2] %in% "numeric" both_numeric <- first_numeric && second_numeric if (second_numeric && !surface) { # only convert 'effect2__' to factor so that the original # second effect variable remains unchanged in the data mde2 <- round(cond_data[[effects[2]]], 2) levels2 <- sort(unique(mde2), TRUE) cond_data$effect2__ <- factor(mde2, levels = levels2) labels2 <- names(int_conditions[[effects[2]]]) if (length(labels2) == length(levels2)) { levels(cond_data$effect2__) <- labels2 } } spag <- NULL if (first_numeric && spaghetti) { if (surface) { stop2("Cannot use 'spaghetti' and 'surface' at the same time.") } spag <- out if (categorical) { spag <- do_call(cbind, array2list(spag)) } sample <- rep(seq_rows(spag), each = ncol(spag)) if (length(types) == 2L) { # draws should be unique across plotting groups sample <- paste0(sample, "_", cond_data[[effects[2]]]) } spag <- data.frame(as.numeric(t(spag)), factor(sample)) colnames(spag) <- c("estimate__", "sample__") # ensures that 'cbind' works even in the presence of matrix columns cond_data_spag <- repl(cond_data, nrow(spag) / nrow(cond_data)) cond_data_spag <- Reduce(rbind, cond_data_spag) spag <- cbind(cond_data_spag, spag) } out <- posterior_summary(out, probs = probs, robust = robust) if (categorical || ordinal) { out <- do_call(rbind, array2list(out)) } colnames(out) <- c("estimate__", "se__", "lower__", "upper__") out <- cbind(cond_data, out) if (!is.null(dpar)) { response <- dpar } else if (!is.null(nlpar)) { response <- nlpar } else { response <- as.character(x$formula[2]) } attr(out, "effects") <- effects attr(out, "response") <- response attr(out, "surface") <- unname(both_numeric && surface) attr(out, "categorical") <- categorical attr(out, "catscale") <- catscale attr(out, "ordinal") <- ordinal attr(out, "spaghetti") <- spag attr(out, "points") <- make_point_frame(x, fit$data, effects, ...) name <- paste0(usc(x$resp, "suffix"), paste0(effects, collapse = ":")) setNames(list(out), name) } # get combinations of variables used in predictor terms # @param ... character vectors or formulas # @param alist a list of character vectors or formulas get_var_combs <- function(..., alist = list()) { dots <- c(list(...), alist) for (i in seq_along(dots)) { if (is.formula(dots[[i]])) { dots[[i]] <- attr(terms(dots[[i]]), "term.labels") } dots[[i]] <- lapply(dots[[i]], all_vars) } unique(unlist(dots, recursive = FALSE)) } # extract combinations of predictor variables get_all_effects <- function(x, ...) { UseMethod("get_all_effects") } #' @export get_all_effects.default <- function(x, ...) { NULL } #' @export get_all_effects.mvbrmsterms <- function(x, ...) { out <- lapply(x$terms, get_all_effects, ...) unique(unlist(out, recursive = FALSE)) } # get all effects for use in conditional_effects # @param bterms object of class brmsterms # @param rsv_vars character vector of reserved variables # @param comb_all include all main effects and two-way interactions? # @return a list with one element per valid effect / effects combination # excludes all 3-way or higher interactions #' @export get_all_effects.brmsterms <- function(x, rsv_vars = NULL, comb_all = FALSE, ...) { stopifnot(is_atomic_or_null(rsv_vars)) out <- list() for (dp in names(x$dpars)) { out <- c(out, get_all_effects(x$dpars[[dp]])) } for (nlp in names(x$nlpars)) { out <- c(out, get_all_effects(x$nlpars[[nlp]])) } out <- rmNULL(lapply(out, setdiff, y = rsv_vars)) if (comb_all) { # allow to combine all variables with each other out <- unique(unlist(out)) out <- c(out, get_group_vars(x)) if (length(out)) { int <- expand.grid(out, out, stringsAsFactors = FALSE) int <- int[int[, 1] != int[, 2], ] int <- as.list(as.data.frame(t(int), stringsAsFactors = FALSE)) int <- unique(unname(lapply(int, sort))) out <- c(as.list(out), int) } } unique(out[lengths(out) <= 2L]) } #' @export get_all_effects.btl <- function(x, ...) { c(get_var_combs(x[["fe"]], x[["cs"]]), get_all_effects_type(x, "sp"), get_all_effects_type(x, "sm"), get_all_effects_type(x, "gp")) } # extract variable combinations from special terms get_all_effects_type <- function(x, type) { stopifnot(is.btl(x)) type <- as_one_character(type) regex_type <- regex_sp(type) terms <- all_terms(x[[type]]) out <- named_list(terms) for (i in seq_along(terms)) { # some special terms can appear within interactions # we did not allow ":" within these terms so we can use it for splitting term_parts <- unlist(strsplit(terms[i], split = ":")) vars <- vector("list", length(term_parts)) for (j in seq_along(term_parts)) { matches <- get_matches_expr(regex_type, term_parts[j]) for (k in seq_along(matches)) { # evaluate special terms to extract variables tmp <- eval2(matches[[k]]) c(vars[[j]]) <- setdiff(unique(c(tmp$term, tmp$by)), "NA") } # extract all variables not part of any special term c(vars[[j]]) <- setdiff(all_vars(term_parts[j]), all_vars(matches)) } vars <- unique(unlist(vars)) out[[i]] <- str2formula(vars, collapse = "*") } get_var_combs(alist = out) } #' @export get_all_effects.btnl <- function(x, ...) { covars <- all_vars(rhs(x$covars)) out <- as.list(covars) if (length(covars) > 1L) { c(out) <- utils::combn(covars, 2, simplify = FALSE) } unique(out) } # extract names of predictor variables get_pred_vars <- function(x) { unique(unlist(get_all_effects(x))) } # extract names of variables treated as integers get_int_vars <- function(x, ...) { UseMethod("get_int_vars") } #' @export get_int_vars.mvbrmsterms <- function(x, ...) { unique(ulapply(x$terms, get_int_vars)) } #' @export get_int_vars.brmsterms <- function(x, ...) { adterms <- c("trials", "thres", "vint") advars <- ulapply(rmNULL(x$adforms[adterms]), all_vars) unique(c(advars, get_sp_vars(x, "mo"))) } # transform posterior draws of ordinal probabilities to a # continuous scale assuming equidistance between adjacent categories # @param x an ndraws x nobs x ncat array of posterior draws # @return an ndraws x nobs matrix of posterior draws ordinal_probs_continuous <- function(x) { stopifnot(length(dim(x)) == 3) for (k in seq_dim(x, 3)) { x[, , k] <- x[, , k] * k } x <- lapply(seq_dim(x, 2), function(s) rowSums(x[, s, ])) do_call(cbind, x) } #' Prepare Fully Crossed Conditions #' #' This is a helper function to prepare fully crossed conditions primarily #' for use with the \code{conditions} argument of \code{\link{conditional_effects}}. #' Automatically creates labels for each row in the \code{cond__} column. #' #' @param x An \R object from which to extract the variables #' that should be part of the conditions. #' @param vars Names of the variables that should be part of the conditions. #' @param ... Arguments passed to \code{\link{rows2labels}}. #' #' @return A \code{data.frame} where each row indicates a condition. #' #' @details For factor like variables, all levels are used as conditions. #' For numeric variables, \code{mean + (-1:1) * SD} are used as conditions. #' #' @seealso \code{\link{conditional_effects}}, \code{\link{rows2labels}} #' #' @examples #' df <- data.frame(x = c("a", "b"), y = rnorm(10)) #' make_conditions(df, vars = c("x", "y")) #' #' @export make_conditions <- function(x, vars, ...) { # rev ensures that the last variable varies fastest in expand.grid vars <- rev(as.character(vars)) if (!is.data.frame(x) && "data" %in% names(x)) { x <- x$data } x <- as.data.frame(x) out <- named_list(vars) for (v in vars) { tmp <- get(v, x) if (is_like_factor(tmp)) { tmp <- levels(as.factor(tmp)) } else { tmp <- mean(tmp, na.rm = TRUE) + (-1:1) * sd(tmp, na.rm = TRUE) } out[[v]] <- tmp } out <- rev(expand.grid(out)) out$cond__ <- rows2labels(out, ...) out } # extract the cond__ variable used for faceting get_cond__ <- function(x) { out <- x[["cond__"]] if (is.null(out)) { out <- rownames(x) } as.character(out) } #' Convert Rows to Labels #' #' Convert information in rows to labels for each row. #' #' @param x A \code{data.frame} for which to extract labels. #' @param digits Minimal number of decimal places shown in #' the labels of numeric variables. #' @param sep A single character string defining the separator #' between variables used in the labels. #' @param incl_vars Indicates if variable names should #' be part of the labels. Defaults to \code{TRUE}. #' @param ... Currently unused. #' #' @return A character vector of the same length as the number #' of rows of \code{x}. #' #' @seealso \code{\link{make_conditions}}, \code{\link{conditional_effects}} #' #' @export rows2labels <- function(x, digits = 2, sep = " & ", incl_vars = TRUE, ...) { x <- as.data.frame(x) incl_vars <- as_one_logical(incl_vars) out <- x for (i in seq_along(out)) { if (!is_like_factor(out[[i]])) { out[[i]] <- round(out[[i]], digits) } if (incl_vars) { out[[i]] <- paste0(names(out)[i], " = ", out[[i]]) } } paste_sep <- function(..., sep__ = sep) { paste(..., sep = sep__) } Reduce(paste_sep, out) } # prepare conditions for use in conditional_effects # @param fit an object of class 'brmsfit' # @param conditions optional data.frame containing user defined conditions # @param effects see conditional_effects # @param re_formula see conditional_effects # @param rsv_vars names of reserved variables # @return a data.frame with (possibly updated) conditions prepare_conditions <- function(fit, conditions = NULL, effects = NULL, re_formula = NA, rsv_vars = NULL) { mf <- model.frame(fit) new_formula <- update_re_terms(fit$formula, re_formula = re_formula) bterms <- brmsterms(new_formula) if (any(grepl_expr("^(as\\.)?factor(.+)$", bterms$allvars))) { # conditions are chosen based the variables stored in the data # this approach cannot take into account possible transformations # to factors happening inside the model formula warning2( "Using 'factor' or 'as.factor' in the model formula ", "might lead to problems in 'conditional_effects'.", "Please convert your variables to factors beforehand." ) } req_vars <- all_vars(rhs(bterms$allvars)) req_vars <- setdiff(req_vars, rsv_vars) req_vars <- setdiff(req_vars, names(fit$data2)) if (is.null(conditions)) { conditions <- as.data.frame(as.list(rep(NA, length(req_vars)))) names(conditions) <- req_vars } else { conditions <- as.data.frame(conditions) if (!nrow(conditions)) { stop2("Argument 'conditions' must have a least one row.") } conditions <- unique(conditions) if (any(duplicated(get_cond__(conditions)))) { stop2("Condition labels should be unique.") } req_vars <- setdiff(req_vars, names(conditions)) } # special treatment for 'trials' addition variables trial_vars <- all_vars(bterms$adforms$trials) trial_vars <- trial_vars[!vars_specified(trial_vars, conditions)] if (length(trial_vars)) { message("Setting all 'trials' variables to 1 by ", "default if not specified otherwise.") req_vars <- setdiff(req_vars, trial_vars) for (v in trial_vars) { conditions[[v]] <- 1L } } # use sensible default values for unspecified variables subset_vars <- get_ad_vars(bterms, "subset") int_vars <- get_int_vars(bterms) group_vars <- get_group_vars(bterms) req_vars <- setdiff(req_vars, group_vars) for (v in req_vars) { if (is_like_factor(mf[[v]])) { # factor-like variable if (v %in% subset_vars) { # avoid unintentional subsetting of newdata (#755) conditions[[v]] <- TRUE } else { # use reference category for factors levels <- levels(as.factor(mf[[v]])) ordered <- is.ordered(mf[[v]]) conditions[[v]] <- factor(levels[1], levels, ordered = ordered) } } else { # numeric-like variable if (v %in% subset_vars) { # avoid unintentional subsetting of newdata (#755) conditions[[v]] <- 1 } else if (v %in% int_vars) { # ensure valid integer values conditions[[v]] <- round(median(mf[[v]], na.rm = TRUE)) } else { conditions[[v]] <- mean(mf[[v]], na.rm = TRUE) } } } all_vars <- c(all_vars(bterms$allvars), "cond__") unused_vars <- setdiff(names(conditions), all_vars) if (length(unused_vars)) { warning2( "The following variables in 'conditions' are not ", "part of the model:\n", collapse_comma(unused_vars) ) } cond__ <- conditions$cond__ conditions <- validate_newdata( conditions, fit, re_formula = re_formula, allow_new_levels = TRUE, check_response = FALSE, incl_autocor = FALSE ) conditions$cond__ <- cond__ conditions } # prepare data to be used in conditional_effects # @param data data.frame containing only data of the predictors of interest # @param conditions see argument 'conditions' of conditional_effects # @param int_conditions see argument 'int_conditions' of conditional_effects # @param int_vars names of variables being treated as integers # @param group_vars names of grouping variables # @param surface generate surface plots later on? # @param resolution number of distinct points at which to evaluate # the predictors of interest # @param reorder reorder predictors so that numeric ones come first? prepare_cond_data <- function(data, conditions, int_conditions = NULL, int_vars = NULL, group_vars = NULL, surface = FALSE, resolution = 100, reorder = TRUE) { effects <- names(data) stopifnot(length(effects) %in% c(1L, 2L)) is_factor <- ulapply(data, is_like_factor) | names(data) %in% group_vars types <- ifelse(is_factor, "factor", "numeric") # numeric effects should come first if (reorder) { new_order <- order(types, decreasing = TRUE) effects <- effects[new_order] types <- types[new_order] } # handle first predictor if (effects[1] %in% names(int_conditions)) { # first predictor has pre-specified conditions int_cond <- int_conditions[[effects[1]]] if (is.function(int_cond)) { int_cond <- int_cond(data[[effects[1]]]) } values <- int_cond } else if (types[1] == "factor") { # first predictor is factor-like values <- factor(unique(data[[effects[1]]])) } else { # first predictor is numeric min1 <- min(data[[effects[1]]], na.rm = TRUE) max1 <- max(data[[effects[1]]], na.rm = TRUE) if (effects[1] %in% int_vars) { values <- seq(min1, max1, by = 1) } else { values <- seq(min1, max1, length.out = resolution) } } if (length(effects) == 2L) { # handle second predictor values <- setNames(list(values, NA), effects) if (effects[2] %in% names(int_conditions)) { # second predictor has pre-specified conditions int_cond <- int_conditions[[effects[2]]] if (is.function(int_cond)) { int_cond <- int_cond(data[[effects[2]]]) } values[[2]] <- int_cond } else if (types[2] == "factor") { # second predictor is factor-like values[[2]] <- factor(unique(data[[effects[2]]])) } else { # second predictor is numeric if (surface) { min2 <- min(data[[effects[2]]], na.rm = TRUE) max2 <- max(data[[effects[2]]], na.rm = TRUE) if (effects[2] %in% int_vars) { values[[2]] <- seq(min2, max2, by = 1) } else { values[[2]] <- seq(min2, max2, length.out = resolution) } } else { if (effects[2] %in% int_vars) { median2 <- median(data[[effects[2]]]) mad2 <- mad(data[[effects[2]]]) values[[2]] <- round((-1:1) * mad2 + median2) } else { mean2 <- mean(data[[effects[2]]], na.rm = TRUE) sd2 <- sd(data[[effects[2]]], na.rm = TRUE) values[[2]] <- (-1:1) * sd2 + mean2 } } } data <- do_call(expand.grid, values) } else { stopifnot(length(effects) == 1L) data <- structure(data.frame(values), names = effects) } # no need to have the same value combination more than once data <- unique(data) data <- data[do_call(order, unname(as.list(data))), , drop = FALSE] data <- replicate(nrow(conditions), data, simplify = FALSE) cond_vars <- setdiff(names(conditions), effects) cond__ <- get_cond__(conditions) for (j in seq_rows(conditions)) { data[[j]] <- fill_newdata(data[[j]], cond_vars, conditions, n = j) data[[j]]$cond__ <- cond__[j] } data <- do_call(rbind, data) data$cond__ <- factor(data$cond__, cond__) structure(data, effects = effects, types = types) } # which variables in 'vars' are specified in 'data'? vars_specified <- function(vars, data) { .fun <- function(v) isTRUE(v %in% names(data)) && any(!is.na(data[[v]])) as.logical(ulapply(vars, .fun)) } # prepare data points based on the provided conditions # allows to add data points to conditional effects plots # @return a data.frame containing the data points to be plotted make_point_frame <- function(bterms, mf, effects, conditions, select_points = 0, transform = NULL, ...) { stopifnot(is.brmsterms(bterms), is.data.frame(mf)) effects <- intersect(effects, names(mf)) points <- mf[, effects, drop = FALSE] points$resp__ <- model.response( model.frame(bterms$respform, mf, na.action = na.pass) ) req_vars <- names(mf) groups <- get_re_group_vars(bterms) if (length(groups)) { c(req_vars) <- unlist(strsplit(groups, ":")) } req_vars <- unique(setdiff(req_vars, effects)) req_vars <- intersect(req_vars, names(conditions)) if (length(req_vars)) { # find out which data point is valid for which condition cond__ <- get_cond__(conditions) mf <- mf[, req_vars, drop = FALSE] conditions <- conditions[, req_vars, drop = FALSE] points$cond__ <- NA points <- replicate(nrow(conditions), points, simplify = FALSE) for (i in seq_along(points)) { cond <- conditions[i, , drop = FALSE] # ensures correct handling of matrix columns not_na <- function(x) !any(is.na(x) | x %in% "zero__") not_na <- ulapply(cond, not_na) cond <- cond[, not_na, drop = FALSE] mf_tmp <- mf[, not_na, drop = FALSE] if (ncol(mf_tmp)) { is_num <- sapply(mf_tmp, is.numeric) is_num <- is_num & !names(mf_tmp) %in% groups if (sum(is_num)) { # handle numeric variables stopifnot(select_points >= 0) if (select_points > 0) { for (v in names(mf_tmp)[is_num]) { min <- min(mf_tmp[, v], na.rm = TRUE) max <- max(mf_tmp[, v], na.rm = TRUE) unit <- scale_unit(mf_tmp[, v], min, max) unit_cond <- scale_unit(cond[, v], min, max) unit_diff <- abs(unit - unit_cond) close_enough <- unit_diff <= select_points mf_tmp[[v]][close_enough] <- cond[, v] mf_tmp[[v]][!close_enough] <- NA } } else { # take all numeric values if select_points is zero cond <- cond[, !is_num, drop = FALSE] mf_tmp <- mf_tmp[, !is_num, drop = FALSE] } } } if (ncol(mf_tmp)) { # handle factors and grouping variables # do it like base::duplicated K <- do_call("paste", c(mf_tmp, sep = "\r")) %in% do_call("paste", c(cond, sep = "\r")) } else { K <- seq_rows(mf) } # cond__ allows to assign points to conditions points[[i]]$cond__[K] <- cond__[i] } points <- do_call(rbind, points) points <- points[!is.na(points$cond__), , drop = FALSE] points$cond__ <- factor(points$cond__, cond__) } points <- add_effects__(points, effects) if (!is.numeric(points$resp__)) { points$resp__ <- as.numeric(as.factor(points$resp__)) if (is_binary(bterms$family)) { points$resp__ <- points$resp__ - 1 } } if (!is.null(transform)) { points$resp__ <- do_call(transform, list(points$resp__)) } points } # add effect__ variables to the data add_effects__ <- function(data, effects) { for (i in seq_along(effects)) { data[[paste0("effect", i, "__")]] <- eval2(effects[i], data) } data } #' @export print.brms_conditional_effects <- function(x, ...) { plot(x, ...) } #' @rdname conditional_effects.brmsfit #' @method plot brms_conditional_effects #' @importFrom rlang .data #' @export plot.brms_conditional_effects <- function( x, ncol = NULL, points = getOption("brms.plot_points", FALSE), rug = getOption("brms.plot_rug", FALSE), mean = TRUE, jitter_width = 0, stype = c("contour", "raster"), line_args = list(), cat_args = list(), errorbar_args = list(), surface_args = list(), spaghetti_args = list(), point_args = list(), rug_args = list(), facet_args = list(), theme = NULL, ask = TRUE, plot = TRUE, ... ) { dots <- list(...) plot <- use_alias(plot, dots$do_plot) stype <- match.arg(stype) smooths_only <- isTRUE(attr(x, "smooths_only")) if (points && smooths_only) { stop2("Argument 'points' is invalid for objects ", "returned by 'conditional_smooths'.") } if (!is_equal(jitter_width, 0)) { warning2("'jitter_width' is deprecated. Please use ", "'point_args = list(width = )' instead.") } if (!is.null(theme) && !is.theme(theme)) { stop2("Argument 'theme' should be a 'theme' object.") } if (plot) { default_ask <- devAskNewPage() on.exit(devAskNewPage(default_ask)) devAskNewPage(ask = FALSE) } dont_replace <- c("mapping", "data", "inherit.aes") plots <- named_list(names(x)) for (i in seq_along(x)) { response <- attr(x[[i]], "response") effects <- attr(x[[i]], "effects") ncond <- length(unique(x[[i]]$cond__)) df_points <- attr(x[[i]], "points") categorical <- isTRUE(attr(x[[i]], "categorical")) catscale <- attr(x[[i]], "catscale") surface <- isTRUE(attr(x[[i]], "surface")) # deprecated as of brms 2.4.3 ordinal <- isTRUE(attr(x[[i]], "ordinal")) if (surface || ordinal) { # surface plots for two dimensional interactions or ordinal plots plots[[i]] <- ggplot(x[[i]]) + aes(.data[["effect1__"]], .data[["effect2__"]]) + labs(x = effects[1], y = effects[2]) if (ordinal) { width <- ifelse(is_like_factor(x[[i]]$effect1__), 0.9, 1) .surface_args <- nlist( mapping = aes(fill = .data[["estimate__"]]), height = 0.9, width = width ) replace_args(.surface_args, dont_replace) <- surface_args plots[[i]] <- plots[[i]] + do_call(geom_tile, .surface_args) + scale_fill_gradientn(colors = viridis6(), name = catscale) + ylab(response) } else if (stype == "contour") { .surface_args <- nlist( mapping = aes( z = .data[["estimate__"]], colour = after_stat(.data[["level"]]) ), bins = 30, linewidth = 1.3 ) replace_args(.surface_args, dont_replace) <- surface_args plots[[i]] <- plots[[i]] + do_call(geom_contour, .surface_args) + scale_color_gradientn(colors = viridis6(), name = response) } else if (stype == "raster") { .surface_args <- nlist(mapping = aes(fill = .data[["estimate__"]])) replace_args(.surface_args, dont_replace) <- surface_args plots[[i]] <- plots[[i]] + do_call(geom_raster, .surface_args) + scale_fill_gradientn(colors = viridis6(), name = response) } } else { # plot effects of single predictors or two-way interactions gvar <- if (length(effects) == 2L) "effect2__" spaghetti <- attr(x[[i]], "spaghetti") aes_tmp <- aes(x = .data[["effect1__"]], y = .data[["estimate__"]]) if (!is.null(gvar)) { aes_tmp$colour <- aes(colour = .data[[gvar]])$colour } plots[[i]] <- ggplot(x[[i]]) + aes_tmp + labs(x = effects[1], y = response, colour = effects[2]) if (is.null(spaghetti)) { aes_tmp <- aes(ymin = .data[["lower__"]], ymax = .data[["upper__"]]) if (!is.null(gvar)) { aes_tmp$fill <- aes(fill = .data[[gvar]])$fill } plots[[i]] <- plots[[i]] + aes_tmp + labs(fill = effects[2]) } # extract suggested colors for later use colors <- ggplot_build(plots[[i]]) colors <- unique(colors$data[[1]][["colour"]]) if (points && !categorical && !surface) { # add points first so that they appear behind the predictions .point_args <- list( mapping = aes(x = .data[["effect1__"]], y = .data[["resp__"]]), data = df_points, inherit.aes = FALSE, size = 2 / ncond^0.25, height = 0, width = jitter_width ) if (is_like_factor(df_points[, gvar])) { .point_args$mapping[c("colour", "fill")] <- aes(colour = .data[[gvar]], fill = .data[[gvar]]) } replace_args(.point_args, dont_replace) <- point_args plots[[i]] <- plots[[i]] + do_call(geom_jitter, .point_args) } if (!is.null(spaghetti)) { # add a regression line for each sample separately .spaghetti_args <- list( aes(group = .data[["sample__"]]), data = spaghetti, stat = "identity", linewidth = 0.5 ) if (!is.null(gvar)) { .spaghetti_args[[1]]$colour <- aes(colour = .data[[gvar]])$colour } if (length(effects) == 1L) { .spaghetti_args$colour <- alpha("blue", 0.1) } else { # workaround to get transparent lines plots[[i]] <- plots[[i]] + scale_color_manual(values = alpha(colors, 0.1)) } replace_args(.spaghetti_args, dont_replace) <- spaghetti_args plots[[i]] <- plots[[i]] + do_call(geom_smooth, .spaghetti_args) } if (is.numeric(x[[i]]$effect1__)) { # line plots for numeric predictors .line_args <- list(stat = "identity") if (!is.null(spaghetti)) { # display a white mean regression line if (!is.null(gvar)) { .line_args$mapping <- aes(group = .data[[gvar]]) } .line_args$colour <- alpha("white", 0.8) } replace_args(.line_args, dont_replace) <- line_args if (mean || is.null(spaghetti)) { plots[[i]] <- plots[[i]] + do_call(geom_smooth, .line_args) } if (rug) { .rug_args <- list( mapping = aes(x = .data[["effect1__"]]), sides = "b", data = df_points, inherit.aes = FALSE ) if (is_like_factor(df_points[, gvar])) { .rug_args$mapping["colour"] <- aes(colour = .data[[gvar]]) } replace_args(.rug_args, dont_replace) <- rug_args plots[[i]] <- plots[[i]] + do_call(geom_rug, .rug_args) } } else { # points and errorbars for factors .cat_args <- list( position = position_dodge(width = 0.4), size = 4 / ncond^0.25 ) .errorbar_args <- list( position = position_dodge(width = 0.4), width = 0.3 ) replace_args(.cat_args, dont_replace) <- cat_args replace_args(.errorbar_args, dont_replace) <- errorbar_args plots[[i]] <- plots[[i]] + do_call(geom_point, .cat_args) + do_call(geom_errorbar, .errorbar_args) } if (categorical) { plots[[i]] <- plots[[i]] + ylab(catscale) + labs(fill = response, color = response) } } if (ncond > 1L) { # one plot per row of conditions if (is.null(ncol)) { ncol <- max(floor(sqrt(ncond)), 3) } .facet_args <- nlist(facets = "cond__", ncol) replace_args(.facet_args, dont_replace) <- facet_args plots[[i]] <- plots[[i]] + do_call(facet_wrap, .facet_args) } plots[[i]] <- plots[[i]] + theme if (plot) { plot(plots[[i]]) if (i == 1) { devAskNewPage(ask = ask) } } } invisible(plots) } # the name 'marginal_effects' is deprecated as of brms 2.10.3 # do not remove it eventually as it has been used in the brms papers #' @export marginal_effects <- function(x, ...) { UseMethod("marginal_effects") } #' @export marginal_effects.brmsfit <- function(x, ...) { warning2("Method 'marginal_effects' is deprecated. ", "Please use 'conditional_effects' instead.") conditional_effects.brmsfit(x, ...) } #' @export print.brmsMarginalEffects <- function(x, ...) { class(x) <- "brms_conditional_effects" print(x, ...) } #' @export plot.brmsMarginalEffects <- function(x, ...) { class(x) <- "brms_conditional_effects" plot(x, ...) } brms/vignettes/0000755000176200001440000000000015057753140013234 5ustar liggesusersbrms/vignettes/me_rent1.pdf0000644000176200001440000002006213252451326015435 0ustar liggesusers%PDF-1.4 %ρ\r 1 0 obj << /CreationDate (D:20170908164932) /ModDate (D:20170908164932) /Title (R Graphics Output) /Producer (R 3.4.1) /Creator (R) >> endobj 2 0 obj << /Type /Catalog /Pages 3 0 R >> endobj 7 0 obj << /Type /Page /Parent 3 0 R /Contents 8 0 R /Resources 4 0 R >> endobj 8 0 obj << /Length 4217 /Filter /FlateDecode >> stream xZOGO;ߝk"@B bp$b$ķfwMp:3S]]ˏ_<_~iKIq?y{Z}t{S}}Omi>J۬7OmlxovlcY:`Mt`fJٷ[o0tߎ 6;̑\`-ŧFZz1K3z~B plP?AKf{!M>]n' <פ(@0xDoa9>6\Mepܯ=qʼ_kVɰ|X`jJޯ"y)Cj $ysn2up5"0uK(8r~ޗIx BOhR {c\BzVUĂDp l<# T'27*B:dd`EdtQ.L'K$ɘDr8fTFCÜEӪa`[=_22Lלҙג{ɣW^LW^ 3ϕa~۩:O9*Y>ҹk'ڡ;nK|nݒuҌK3up,3dYP\"ZaC,!`>Y&bXE$82z^ P-T`*:-l@ β,hF%0uZp&NGh-A{k)_I hQB䫀KCnǗ_?O'T=OYEU ]4S儇\[avFE6"u6yjuC絪 yߌ :U]T.c*]\]QҪ.zh yua,VLZg`:lVvU]8Eq5l\EZՇYbe'BYgkœņrCydAɒ=ucQW':˞,ܼhfU]4ݳhޯU]\]ԕ0\]%guQUENRsgua|Vj~Uf~\]R ^]$Ī.`k=.`7AìW]]. ؒ_.V[EruUݭYxZEruȺT4ZxEa%7Mwsba6a[]"U&5i.C5M.qdJ0kAS&u|Cq4x(8.A J0I![eSnn/_ ;L&[#()[folxXW*޽g?W.)Xؾ)Wo??~駯8LJ E"ch(>~1vtcoC@ǁ(^v8 =Eɴi}mޞ\'Z@w(3O75]n9h=y=/!b|.|İ"0҇8Tz,|dpv yڻ{kilȵ1W߽ns6uiYwE}ۿߺJ)W x7CnIxLgtn*Ӳdr `|Qur)æIlww `0mq_'ZPR6B< t Q XJ?gp$J4JCnW~i\ͷ_ž#8RgD-F\iy%e]w't-LmBD"s!0 %J+KP[4O`F1 M©mYne.%Y[~s7{X~I)PIF6_[dOl$h?߮ n[YI{j}_eQӧ:fm`1cWSßEԤ[a_.E=r`v-7%KoE7zQ0]2pmM tw}@:^-uq;r;ίӠ rݿ)1 R] 7_&[ 9LΧ 0bݿmr9Ew8Ӂ}1bZ)E)X[gJU}~*(lz]`#]4dBn;~|Ҿ{:gp *]ĢA dܮwn~av+ȺPpCN( J~渂0|͕ȜV$QW{'hKH~ȊU?ĭɾ_z%;˵gC*URO=Xzc(Zz-.!R^?f}j=،>|z2MKog}joN]?Cz[z"ޓ68JzEl蟪^;^gL~r=pm÷ˎ[2?uGͼE3#8>yQ闗^Zxl@G/g<)|?J/08#'?X^}C*.7x{t }'/?JP$7yNX 2 |A?|o3+Xs [f{z6%71 s>^0'n}K.z^ÁUj fژOySSB8Oiendstream endobj 3 0 obj << /Type /Pages /Kids [ 7 0 R ] /Count 1 /MediaBox [0 0 576 216] >> endobj 4 0 obj << /ProcSet [/PDF /Text] /Font <> /ExtGState << /GS1 11 0 R /GS257 12 0 R /GS258 13 0 R >> /ColorSpace << /sRGB 5 0 R >> >> endobj 5 0 obj [/ICCBased 6 0 R] endobj 6 0 obj << /Alternate /DeviceRGB /N 3 /Length 2596 /Filter /FlateDecode >> stream xwTSϽ7PkhRH H.*1 J"6DTpDQ2(C"QDqpId߼y͛~kg}ֺLX Xňg` lpBF|،l *?Y"1P\8=W%Oɘ4M0J"Y2Vs,[|e92<se'9`2&ctI@o|N6(.sSdl-c(2-yH_/XZ.$&\SM07#1ؙYrfYym";8980m-m(]v^DW~ emi]P`/u}q|^R,g+\Kk)/C_|Rax8t1C^7nfzDp 柇u$/ED˦L L[B@ٹЖX!@~(* {d+} G͋љς}WL$cGD2QZ4 E@@A(q`1D `'u46ptc48.`R0) @Rt CXCP%CBH@Rf[(t CQhz#0 Zl`O828.p|O×X ?:0FBx$ !i@ڐH[EE1PL ⢖V6QP>U(j MFkt,:.FW8c1L&ӎ9ƌaX: rbl1 {{{;}#tp8_\8"Ey.,X%%Gщ1-9ҀKl.oo/O$&'=JvMޞxǥ{=Vs\x ‰N柜>ucKz=s/ol|ϝ?y ^d]ps~:;/;]7|WpQoH!ɻVsnYs}ҽ~4] =>=:`;cܱ'?e~!ańD#G&}'/?^xI֓?+\wx20;5\ӯ_etWf^Qs-mw3+?~O~endstream endobj 9 0 obj << /Type /Encoding /BaseEncoding /WinAnsiEncoding /Differences [ 45/minus ] >> endobj 10 0 obj << /Type /Font /Subtype /Type1 /Name /F7 /BaseFont /Times-Roman /Encoding 9 0 R >> endobj 11 0 obj << /Type /ExtGState /CA 1.000 >> endobj 12 0 obj << /Type /ExtGState /ca 0.400 >> endobj 13 0 obj << /Type /ExtGState /ca 1.000 >> endobj xref 0 14 0000000000 65535 f 0000000021 00000 n 0000000163 00000 n 0000004581 00000 n 0000004664 00000 n 0000004816 00000 n 0000004849 00000 n 0000000212 00000 n 0000000292 00000 n 0000007544 00000 n 0000007638 00000 n 0000007737 00000 n 0000007786 00000 n 0000007835 00000 n trailer << /Size 14 /Info 1 0 R /Root 2 0 R >> startxref 7884 %%EOF brms/vignettes/me_zinb1.pdf0000644000176200001440000002005513051356434015432 0ustar liggesusers%PDF-1.4 %ρ\r 1 0 obj << /CreationDate (D:20170216181050) /ModDate (D:20170216181050) /Title (R Graphics Output) /Producer (R 3.3.2) /Creator (R) >> endobj 2 0 obj << /Type /Catalog /Pages 3 0 R >> endobj 7 0 obj << /Type /Page /Parent 3 0 R /Contents 8 0 R /Resources 4 0 R >> endobj 8 0 obj << /Length 4096 /Filter /FlateDecode >> stream x[͏G9Iw5D9!:!{꽚]d&vr뮮W}ퟷ?>gK{JXI{[{[nmo}ˣƃ|Bɻ?}-ݿ}~ͭսV澺I+mjRާĤK5iv.٤d@% }0v*5 {[% =ٓ sހ0L^²]hw'"d9]5tGPi5^TZ.'C@P}ړ s@} \BߧK@@YQ+ ګ7Ag]rt~>Cv1/Gٺ#4Ml.**a,dAgmc9bB9cs \t[)Ffk嗧mlفt/Eͽa@ fFHэ5gR}]q UiFS@,')dJiiqdCZ?_+'ջ8iw,G3U [q8E˲[v.x߫%yP CevO5!Om5253MieV,~^]z,e{cXFpdžO5-"P3 x7a"Ƭ@՛Ɓf/eըDY/:WOuo zDg\֫fLqݎR(Ok/e]+7 ~hi!r' ,hxQ=~ڻ<tu~XШ,8:|q+#JX8cT"3?~"Y#{FSvr/RlLJ*|H^maH*%{i(M)K Mc#5b4x"O7&7yhAd0rw6-A݉Ɣ 2W  "밹5,J)"Ğ?(`Bj'H;pFn 47H!9a՚|*Tm+c񟽸Y 6_H m/>Mls_}yK7->n6>H[A3;+H p$UCK@(H5 $5ZK@H-,wt;d؏6|*䇽ҚXpV8WЉ?|i b_9[%O#N(:}IU/ H$>Z3`24!F jQÚaRaad5&|FLCI[$_AWf_<"#x[i1/}/&[QMxL sTiHU/$_uDBS## $'PU;8" W 0RR%L~E\{#+WrzHHu@QL@C$֕ $KF@I6ɖ=hdLubdM)\W ̾^vG2Yɦiy ~dUՐ6c$z%,egW2mϳH(H֭p%V/Q:~OI5o#^GɥtGI2y}M UokB};U-/4x/Gkߗwۯү~1E槾~]y--lۡʭU1dQ 1 ;/x0g1WCL$CҍQJ(u xÅq-#:F;'ř-_S'uJ[A-wCyCzhl%]֊zib73_}ݛw'A\5].,;coSK8JcQݛωG8WV>\A&-z! Rw%y.\!7$p&qA $Hu$xyII^& TYOIS8(iXIsE*V 9s&t+XJKsɳi4ٚ@0@V!)m4Ɛ@} >5پCƌ d BnY ߞ,֋)2=&3L@V8,ZȹL z F5T\GC^5r UGaYbx-[cl-rJ9Pu@g%%pIb$Qdw&{A0ՒD"]22xrɍMcQd;ZD8/@*z[$ŁTvNR]R1At - 1ыR49)@+¿ F(>+ ,@ T547J!DDApкh9.bCeTUE5͕J{. *rEdЪ<* @oU*(KJPDv&p{%ږ A*@Rd}g4SK'cVdr 9@db< 02h\7%k[7bCy4-0Aă03A#ι# X^Ϊ||qB.m%Ypѝy^q"rX{f'Le!4e>eew=s>C .a{AբJ>C.G@Vq3\.&-]Bk:L5XĊ[%Ű9 (hL^fLm~eS3Ǵ>bҴ> endobj 4 0 obj << /ProcSet [/PDF /Text] /Font << /F1 10 0 R /F7 11 0 R >> /ExtGState << /GS1 12 0 R /GS257 13 0 R /GS258 14 0 R >> /ColorSpace << /sRGB 5 0 R >> >> endobj 5 0 obj [/ICCBased 6 0 R] endobj 6 0 obj << /Alternate /DeviceRGB /N 3 /Length 2596 /Filter /FlateDecode >> stream xwTSϽ7PkhRH H.*1 J"6DTpDQ2(C"QDqpId߼y͛~kg}ֺLX Xňg` lpBF|،l *?Y"1P\8=W%Oɘ4M0J"Y2Vs,[|e92<se'9`2&ctI@o|N6(.sSdl-c(2-yH_/XZ.$&\SM07#1ؙYrfYym";8980m-m(]v^DW~ emi]P`/u}q|^R,g+\Kk)/C_|Rax8t1C^7nfzDp 柇u$/ED˦L L[B@ٹЖX!@~(* {d+} G͋љς}WL$cGD2QZ4 E@@A(q`1D `'u46ptc48.`R0) @Rt CXCP%CBH@Rf[(t CQhz#0 Zl`O828.p|O×X ?:0FBx$ !i@ڐH[EE1PL ⢖V6QP>U(j MFkt,:.FW8c1L&ӎ9ƌaX: rbl1 {{{;}#tp8_\8"Ey.,X%%Gщ1-9ҀKl.oo/O$&'=JvMޞxǥ{=Vs\x ‰N柜>ucKz=s/ol|ϝ?y ^d]ps~:;/;]7|WpQoH!ɻVsnYs}ҽ~4] =>=:`;cܱ'?e~!ańD#G&}'/?^xI֓?+\wx20;5\ӯ_etWf^Qs-mw3+?~O~endstream endobj 9 0 obj << /Type /Encoding /BaseEncoding /WinAnsiEncoding /Differences [ 45/minus ] >> endobj 10 0 obj << /Type /Font /Subtype /Type1 /Name /F1 /BaseFont /ZapfDingbats >> endobj 11 0 obj << /Type /Font /Subtype /Type1 /Name /F7 /BaseFont /Times-Roman /Encoding 9 0 R >> endobj 12 0 obj << /Type /ExtGState /CA 1.000 >> endobj 13 0 obj << /Type /ExtGState /ca 0.400 >> endobj 14 0 obj << /Type /ExtGState /ca 1.000 >> endobj xref 0 15 0000000000 65535 f 0000000021 00000 n 0000000163 00000 n 0000004460 00000 n 0000004543 00000 n 0000004707 00000 n 0000004740 00000 n 0000000212 00000 n 0000000292 00000 n 0000007435 00000 n 0000007529 00000 n 0000007613 00000 n 0000007712 00000 n 0000007761 00000 n 0000007810 00000 n trailer << /Size 15 /Info 1 0 R /Root 2 0 R >> startxref 7859 %%EOF brms/vignettes/brms_missings.Rmd0000644000176200001440000002521115053072461016554 0ustar liggesusers--- title: "Handle Missing Values with brms" author: "Paul Bürkner" date: "`r Sys.Date()`" output: rmarkdown::html_vignette: toc: yes vignette: > %\VignetteIndexEntry{Handle Missing Values with brms} \usepackage[utf8]{inputenc} %\VignetteEngine{knitr::rmarkdown} params: EVAL: !r identical(Sys.getenv("NOT_CRAN"), "true") --- ```{r, SETTINGS-knitr, include=FALSE} stopifnot(require(knitr)) options(width = 90) knit_hooks$set(pngquant = knitr::hook_pngquant) opts_chunk$set( comment = NA, message = FALSE, warning = FALSE, eval = if (isTRUE(exists("params"))) params$EVAL else FALSE, dev = "ragg_png", dpi = 72, fig.retina = 1.5, fig.asp = 0.8, fig.width = 5, out.width = "60%", fig.align = "center", pngquant = "--speed=1 --quality=50" ) library(brms) ggplot2::theme_set(theme_default()) ``` ## Introduction Many real world data sets contain missing values for various reasons. Generally, we have quite a few options to handle those missing values. The easiest solution is to remove all rows from the data set, where one or more variables are missing. However, if values are not missing completely at random, this will likely lead to bias in our analysis. Accordingly, we usually want to impute missing values in one way or the other. Here, we will consider two very general approaches using **brms**: (1) Impute missing values *before* the model fitting with multiple imputation, and (2) impute missing values on the fly *during* model fitting[^1]. As a simple example, we will use the `nhanes` data set, which contains information on participants' `age`, `bmi` (body mass index), `hyp` (hypertensive), and `chl` (total serum cholesterol). For the purpose of the present vignette, we are primarily interested in predicting `bmi` by `age` and `chl`. ```{r} data("nhanes", package = "mice") head(nhanes) ``` ## Imputation before model fitting There are many approaches allowing us to impute missing data before the actual model fitting takes place. From a statistical perspective, multiple imputation is one of the best solutions. Each missing value is not imputed once but `m` times leading to a total of `m` fully imputed data sets. The model can then be fitted to each of those data sets separately and results are pooled across models, afterwards. One widely applied package for multiple imputation is **mice** (Buuren & Groothuis-Oudshoorn, 2010) and we will use it in the following in combination with **brms**. Here, we apply the default settings of **mice**, which means that all variables will be used to impute missing values in all other variables and imputation functions automatically chosen based on the variables' characteristics. ```{r} library(mice) m <- 5 imp <- mice(nhanes, m = m, print = FALSE) ``` Now, we have `m = 5` imputed data sets stored within the `imp` object. In practice, we will likely need more than `5` of those to accurately account for the uncertainty induced by the missingness, perhaps even in the area of `100` imputed data sets (Zhou & Reiter, 2010). Of course, this increases the computational burden by a lot and so we stick to `m = 5` for the purpose of this vignette. Regardless of the value of `m`, we can either extract those data sets and then pass them to the actual model fitting function as a list of data frames, or pass `imp` directly. The latter works because **brms** offers special support for data imputed by **mice**. We will go with the latter approach, since it is less typing. Fitting our model of interest with **brms** to the multiple imputed data sets is straightforward. ```{r, results = 'hide', message = FALSE} fit_imp1 <- brm_multiple(bmi ~ age*chl, data = imp, chains = 2) ``` The returned fitted model is an ordinary `brmsfit` object containing the posterior draws of all `m` submodels. While pooling across models is not necessarily straightforward in classical statistics, it is trivial in a Bayesian framework. Here, pooling results of multiple imputed data sets is simply achieved by combining the posterior draws of the submodels. Accordingly, all post-processing methods can be used out of the box without having to worry about pooling at all. ```{r} summary(fit_imp1) ``` In the summary output, we notice that some `Rhat` values are higher than $1.1$ indicating possible convergence problems. For models based on multiple imputed data sets, this is often a **false positive**: Chains of different submodels may not overlay each other exactly, since there were fitted to different data. We can see the chains on the right-hand side of ```{r} plot(fit_imp1, variable = "^b", regex = TRUE) ``` Such non-overlaying chains imply high `Rhat` values without there actually being any convergence issue. Accordingly, we have to investigate the convergence of the submodels separately, which we can do for example via: ```{r} library(posterior) draws <- as_draws_array(fit_imp1) # every dataset has nc = 2 chains in this example nc <- nchains(fit_imp1) / m draws_per_dat <- lapply(1:m, \(i) subset_draws(draws, chain = ((i-1)*nc+1):(i*nc)) ) lapply(draws_per_dat, summarise_draws, default_convergence_measures()) ``` The convergence of each of the submodels looks good. Accordingly, we can proceed with further post-processing and interpretation of the results. For instance, we could investigate the combined effect of `age` and `chl`. ```{r} conditional_effects(fit_imp1, "age:chl") ``` To summarize, the advantages of multiple imputation are obvious: One can apply it to all kinds of models, since model fitting functions do not need to know that the data sets were imputed, beforehand. Also, we do not need to worry about pooling across submodels when using fully Bayesian methods. The only drawback is the amount of time required for model fitting. Estimating Bayesian models is already quite slow with just a single data set and it only gets worse when working with multiple imputation. ### Compatibility with other multiple imputation packages **brms** offers built-in support for **mice** mainly because I use the latter in some of my own research projects. Nevertheless, `brm_multiple` supports all kinds of multiple imputation packages as it also accepts a *list* of data frames as input for its `data` argument. Thus, you just need to extract the imputed data frames in the form of a list, which can then be passed to `brm_multiple`. Most multiple imputation packages have some built-in functionality for this task. When using the **mi** package, for instance, you simply need to call the `mi::complete` function to get the desired output. ## Imputation during model fitting Imputation during model fitting is generally thought to be more complex than imputation before model fitting, because one has to take care of everything within one step. This remains true when imputing missing values with **brms**, but possibly to a somewhat smaller degree. Consider again the `nhanes` data with the goal to predict `bmi` by `age`, and `chl`. Since `age` contains no missing values, we only have to take special care of `bmi` and `chl`. We need to tell the model two things. (1) Which variables contain missing values and how they should be predicted, as well as (2) which of these imputed variables should be used as predictors. In **brms** we can do this as follows: ```{r, results = 'hide', message = FALSE} bform <- bf(bmi | mi() ~ age * mi(chl)) + bf(chl | mi() ~ age) + set_rescor(FALSE) fit_imp2 <- brm(bform, data = nhanes) ``` The model has become multivariate, as we no longer only predict `bmi` but also `chl` (see `vignette("brms_multivariate")` for details about the multivariate syntax of **brms**). We ensure that missings in both variables will be modeled rather than excluded by adding `| mi()` on the left-hand side of the formulas[^2]. We write `mi(chl)` on the right-hand side of the formula for `bmi` to ensure that the estimated missing values of `chl` will be used in the prediction of `bmi`. The summary is a bit more cluttered as we get coefficients for both response variables, but apart from that we can interpret coefficients in the usual way. ```{r} summary(fit_imp2) conditional_effects(fit_imp2, "age:chl", resp = "bmi") ``` The results look pretty similar to those obtained from multiple imputation, but be aware that this may not be generally the case. In multiple imputation, the default is to impute all variables based on all other variables, while in the 'one-step' approach, we have to explicitly specify the variables used in the imputation. Thus, arguably, multiple imputation is easier to apply. An obvious advantage of the 'one-step' approach is that the model needs to be fitted only once instead of `m` times. Also, within the **brms** framework, we can use multilevel structure and complex non-linear relationships for the imputation of missing values, which is not achieved as easily in standard multiple imputation software. On the downside, it is currently not possible to impute discrete variables, because **Stan** (the engine behind **brms**) does not allow estimating discrete parameters. ### Combining measurement error and missing values Missing value terms in **brms** cannot only handle missing values but also measurement error, or arbitrary combinations of the two. In fact, we can think of a missing value as a value with infinite measurement error. Thus, `mi` terms are a natural (and somewhat more verbose) generalization of the now soft deprecated `me` terms. Suppose we had measured the variable `chl` with some known error: ```{r} nhanes$se <- rexp(nrow(nhanes), 2) ``` Then we can go ahead an include this information into the model as follows: ```{r, results = 'hide', message = FALSE, eval = FALSE} bform <- bf(bmi | mi() ~ age * mi(chl)) + bf(chl | mi(se) ~ age) + set_rescor(FALSE) fit_imp3 <- brm(bform, data = nhanes) ``` Summarizing and post-processing the model continues to work as usual. [^1]: Actually, there is a third approach that only applies to missings in response variables. If we want to impute missing responses, we just fit the model using the observed responses and than impute the missings *after* fitting the model by means of posterior prediction. That is, we supply the predictor values corresponding to missing responses to the `predict` method. [^2]: We don't really need this for `bmi`, since `bmi` is not used as a predictor for another variable. Accordingly, we could also -- and equivalently -- impute missing values of `bmi` *after* model fitting by means of posterior prediction. ## References Buuren, S. V. & Groothuis-Oudshoorn, K. (2010). mice: Multivariate imputation by chained equations in R. *Journal of Statistical Software*, 1-68. doi.org/10.18637/jss.v045.i03 Zhou, X. & Reiter, J. P. (2010). A Note on Bayesian Inference After Multiple Imputation. *The American Statistician*, 64(2), 159-163. doi.org/10.1198/tast.2010.09109 brms/vignettes/brms_distreg.Rmd0000644000176200001440000002537415053072461016373 0ustar liggesusers--- title: "Estimating Distributional Models with brms" author: "Paul Bürkner" date: "`r Sys.Date()`" output: rmarkdown::html_vignette: toc: yes vignette: > %\VignetteIndexEntry{Estimating Distributional Models with brms} %\VignetteEngine{knitr::rmarkdown} \usepackage[utf8]{inputenc} params: EVAL: !r identical(Sys.getenv("NOT_CRAN"), "true") --- ```{r, SETTINGS-knitr, include=FALSE} stopifnot(require(knitr)) options(width = 90) knit_hooks$set(pngquant = knitr::hook_pngquant) opts_chunk$set( comment = NA, message = FALSE, warning = FALSE, eval = if (isTRUE(exists("params"))) params$EVAL else FALSE, dev = "ragg_png", dpi = 72, fig.retina = 1.5, fig.asp = 0.8, fig.width = 5, out.width = "60%", fig.align = "center", pngquant = "--speed=1 --quality=50" ) library(brms) ggplot2::theme_set(theme_default()) ``` ## Introduction This vignette provides an introduction on how to fit distributional regression models with **brms**. We use the term *distributional model* to refer to a model, in which we can specify predictor terms for all parameters of the assumed response distribution. In the vast majority of regression model implementations, only the location parameter (usually the mean) of the response distribution depends on the predictors and corresponding regression parameters. Other parameters (e.g., scale or shape parameters) are estimated as auxiliary parameters assuming them to be constant across observations. This assumption is so common that most researchers applying regression models are often (in my experience) not aware of the possibility of relaxing it. This is understandable insofar as relaxing this assumption drastically increase model complexity and thus makes models hard to fit. Fortunately, **brms** uses **Stan** on the backend, which is an incredibly flexible and powerful tool for estimating Bayesian models so that model complexity is much less of an issue. Suppose we have a normally distributed response variable. Then, in basic linear regression, we specify a predictor term $\eta_{\mu}$ for the mean parameter $\mu$ of the normal distribution. The second parameter of the normal distribution -- the residual standard deviation $\sigma$ -- is assumed to be constant across observations. We estimate $\sigma$ but do not try to *predict* it. In a distributional model, however, we do exactly this by specifying a predictor term $\eta_{\sigma}$ for $\sigma$ in addition to the predictor term $\eta_{\mu}$. Ignoring group-level effects for the moment, the linear predictor of a parameter $\theta$ for observation $n$ has the form $$\eta_{\theta n} = \sum_{i = 1}^{K_{\theta}} b_{\theta i} x_{\theta i n}$$ where $x_{\theta i n}$ denotes the value of the $i$th predictor of parameter $\theta$ for observation $n$ and $b_{\theta i}$ is the $i$th regression coefficient of parameter $\theta$. A distributional normal model with response variable $y$ can then be written as $$y_n \sim \mathcal{N}\left(\eta_{\mu n}, \, \exp(\eta_{\sigma n}) \right)$$ We used the exponential function around $\eta_{\sigma}$ to reflect that $\sigma$ constitutes a standard deviation and thus only takes on positive values, while a linear predictor can be any real number. ## A simple distributional model Unequal variance models are possibly the most simple, but nevertheless very important application of distributional models. Suppose we have two groups of patients: One group receives a treatment (e.g., an antidepressive drug) and another group receives placebo. Since the treatment may not work equally well for all patients, the symptom variance of the treatment group may be larger than the symptom variance of the placebo group after some weeks of treatment. For simplicity, assume that we only investigate the post-treatment values. ```{r} group <- rep(c("treat", "placebo"), each = 30) symptom_post <- c(rnorm(30, mean = 1, sd = 2), rnorm(30, mean = 0, sd = 1)) dat1 <- data.frame(group, symptom_post) head(dat1) ``` The following model estimates the effect of `group` on both the mean and the residual standard deviation of the normal response distribution. ```{r, results='hide'} fit1 <- brm(bf(symptom_post ~ group, sigma ~ group), data = dat1, family = gaussian()) ``` Useful summary statistics and plots can be obtained via ```{r, results='hide'} summary(fit1) plot(fit1, N = 2, ask = FALSE) plot(conditional_effects(fit1), points = TRUE) ``` The population-level effect `sigma_grouptreat`, which is the contrast of the two residual standard deviations on the log-scale, reveals that the variances of both groups are indeed different. This impression is confirmed when looking at the `conditional_effects` of `group`. Going one step further, we can compute the residual standard deviations on the original scale using the `hypothesis` method. ```{r} hyp <- c("exp(sigma_Intercept) = 0", "exp(sigma_Intercept + sigma_grouptreat) = 0") hypothesis(fit1, hyp) ``` We may also directly compare them and plot the posterior distribution of their difference. ```{r} hyp <- "exp(sigma_Intercept + sigma_grouptreat) > exp(sigma_Intercept)" (hyp <- hypothesis(fit1, hyp)) plot(hyp, chars = NULL) ``` Indeed, the residual standard deviation of the treatment group seems to larger than that of the placebo group. Moreover the magnitude of this difference is pretty similar to what we expected due to the values we put into the data simulations. ## Zero-Inflated Models Another important application of the distributional regression framework are so called zero-inflated models. These models are helpful whenever there are more zeros in the response variable than one would naturally expect. For example, if one seeks to predict the number of cigarettes people smoke per day and also includes non-smokers, there will be a huge amount of zeros which, when not modeled appropriately, can seriously distort parameter estimates. Here, we consider an example dealing with the number of fish caught by various groups of people. On the UCLA website (\url{https://stats.idre.ucla.edu/stata/dae/zero-inflated-poisson-regression}), the data are described as follows: "The state wildlife biologists want to model how many fish are being caught by fishermen at a state park. Visitors are asked how long they stayed, how many people were in the group, were there children in the group and how many fish were caught. Some visitors do not fish, but there is no data on whether a person fished or not. Some visitors who did fish did not catch any fish so there are excess zeros in the data because of the people that did not fish." ```{r} zinb <- read.csv("https://paul-buerkner.github.io/data/fish.csv") head(zinb) ``` As predictors we choose the number of people per group, the number of children, as well as whether the group consists of campers. Many groups may not even try catching any fish at all (thus leading to many zero responses) and so we fit a zero-inflated Poisson model to the data. For now, we assume a constant zero-inflation probability across observations. ```{r, results='hide'} fit_zinb1 <- brm(count ~ persons + child + camper, data = zinb, family = zero_inflated_poisson()) ``` Again, we summarize the results using the usual methods. ```{r} summary(fit_zinb1) plot(conditional_effects(fit_zinb1), ask = FALSE) ``` According to the parameter estimates, larger groups catch more fish, campers catch more fish than non-campers, and groups with more children catch less fish. The zero-inflation probability `zi` is pretty large with a mean of 41%. Please note that the probability of catching no fish is actually higher than 41%, but parts of this probability are already modeled by the Poisson distribution itself (hence the name zero-*inflation*). If you want to treat all zeros as originating from a separate process, you can use hurdle models instead (not shown here). Now, we try to additionally predict the zero-inflation probability by the number of children. The underlying reasoning is that we expect groups with more children to not even try catching fish. Most children are just terribly bad at waiting for hours until something happens. From a purely statistical perspective, zero-inflated (and hurdle) distributions are a mixture of two processes and predicting both parts of the model is natural and often very reasonable to make full use of the data. ```{r, results='hide'} fit_zinb2 <- brm(bf(count ~ persons + child + camper, zi ~ child), data = zinb, family = zero_inflated_poisson()) ``` ```{r} summary(fit_zinb2) plot(conditional_effects(fit_zinb2), ask = FALSE) ``` To transform the linear predictor of `zi` into a probability, **brms** applies the logit-link: $$logit(zi) = \log\left(\frac{zi}{1-zi}\right) = \eta_{zi}$$ The logit-link takes values within $[0, 1]$ and returns values on the real line. Thus, it allows the transition between probabilities and linear predictors. According to the model, trying to fish with children not only decreases the overall number fish caught (as implied by the Poisson part of the model) but also drastically increases your change of catching no fish at all (as implied by the zero-inflation part) most likely because groups with more children are not even trying. ## Additive Distributional Models In the examples so far, we did not have multilevel data and thus did not fully use the capabilities of the distributional regression framework of **brms**. In the example presented below, we will not only show how to deal with multilevel data in distributional models, but also how to incorporate smooth terms (i.e., splines) into the model. In many applications, we have no or only a very vague idea how the relationship between a predictor and the response looks like. A very flexible approach to tackle this problems is to use splines and let them figure out the form of the relationship. For illustration purposes, we simulate some data with the **mgcv** package, which is also used in **brms** to prepare smooth terms. ```{r} dat_smooth <- mgcv::gamSim(eg = 6, n = 200, scale = 2, verbose = FALSE) head(dat_smooth[, 1:6]) ``` The data contains the predictors `x0` to `x3` as well as the grouping factor `fac` indicating the nested structure of the data. We predict the response variable `y` using smooth terms of `x1` and `x2` and a varying intercept of `fac`. In addition, we assume the residual standard deviation `sigma` to vary by a smoothing term of `x0` and a varying intercept of `fac`. ```{r, results='hide'} fit_smooth1 <- brm( bf(y ~ s(x1) + s(x2) + (1|fac), sigma ~ s(x0) + (1|fac)), data = dat_smooth, family = gaussian(), chains = 2, control = list(adapt_delta = 0.95) ) ``` ```{r} summary(fit_smooth1) plot(conditional_effects(fit_smooth1), points = TRUE, ask = FALSE) ``` This model is likely an overkill for the data at hand, but nicely demonstrates the ease with which one can specify complex models with **brms** and to fit them using **Stan** on the backend. brms/vignettes/me_rent2.pdf0000644000176200001440000005450313252451326015445 0ustar liggesusers%PDF-1.4 %ρ\r 1 0 obj << /CreationDate (D:20170908165032) /ModDate (D:20170908165032) /Title (R Graphics Output) /Producer (R 3.4.1) /Creator (R) >> endobj 2 0 obj << /Type /Catalog /Pages 3 0 R >> endobj 7 0 obj << /Type /Page /Parent 3 0 R /Contents 8 0 R /Resources 4 0 R >> endobj 8 0 obj << /Length 18771 /Filter /FlateDecode >> stream xMnQWJTv嫗OM_q~jؾr2q5x7 k m5q[պ}nO.W%~_62'/KҴ|-o2MGeWZ)j߶=vkE{?3Zj[\_uR5~_Cq_5bʕb_&;Ugd⭆?oq__?N|+;}gk3q~_ `=e|b2.;V-UHLg;ɓMk ɾwĽfg+.bXQ/Yek+}K{-k,[u}|/lw pq;lva=2"ުl"܋fm]:{C{g$/9Vw~;BqozӢq%W2%q[lOX.*v־pwae_վުRZcope|ִ4q_n""IϣL'= X֬z|Pz.w~}t\hV&&~ՂwbkF{9`e7틤L{쁔߲oȼxK n/}r2ߢgǽĭ1qh+}P[h<$މx[4}(W]~NJѺ8T^ NBݚ v/}!Caen;1tb]MIa)vb\y(1,D:~MbYuj_^kjLLIbƃ24 ˣP\-&0mڴ/@-x,2v2ia%2e|V͆vSqYQ#ӰD+=5-_ l#GgEmq_[[Qtٷ8eCkKxL܆)v_mI[hR 4Ta\9m}_bFB_~eOfkb5WaA#CzѮC;v4bOpv.,hL'^/a@#;ct3녥~lәa蓭tm`˶dX:6mO7E>Ƕt[4+)୆m0|9l>FV ;:W8 d+"84fpL“=-"Xe+,} + VJWr_JUւ2Vi2>y #I\1LiҎ$A,M"2#fDZ}QvB?ѤO[Z,a4MvnFtZOLjRnyb3[!TivԌDl АtrLАs!xp)_а ?AЖs96d_hA͐s3o8}֥qjo{˵Wah|\CA{M` KkJsPWB dxZ|fx՛\0xM6^r{+S|7`/ ^ւwcmZ^lqs+v<4^׸;[~ 41E;dnq;ʹ[eXL b8 \!nXG[*%L~IPJ6hE4R̜Mbs)8T72ŕlҜ~oᰩV6uMztoFEQ`VI# A2ѩ_0ġmߵcDjt_}al^Ƅ̆}o}\ؑ`P2fuZ 3 " c:$P$a1$hv0$eUI 3 X14ǓNL qi, Z1> 3Rn2 3DjM0MlGc6A).Kl6lLLc6&. F̌NP&?NeSj.-wShۇ;2uRro;52C)ۗ o0v[܋a j쇼0vݎ8o%D*~V:n`ؾ4l!.Iv9j2l Pl%&B>R@ٺ>:u@Ú<.?,i-=g㲅4/$s٩l#lg\e2 H+A[>:8GPEVqɨ00R@+d+]O|?V+2Xh؂g' :,eE^ u<^Ejl1Y'.f{{me:GU_o Lۀi2Y.&C,2=e+\:jKTXer?oc]&YMu%^ .[~`*6'r][^X{;űy^:vAp;lRJ leb&[w(b@z -VL@BZ7[>Gz/~[c,ru`cx HaF0ɪ_@_vp@!B[D#?P@}g?ZAb R?`˰yS*A$ÿ8bb&)ʤ DB,&"3ay8J [L- 2Zx<(xGݬrxro'eP15_k2QXǢcڢFL0/BGd Yd ێA$7,m؎Hdಠh[2N/DZxA'y"+3p;Ar;D',--kkز m[ȶ.CB2$2{~$ +O'Va¢Yn2+O^V$U$QW+ǟ Yr-yN"}.b⑘⒐\2.R^".$&h!B*J"G3 -ϛ aMXԤ׃HD[D@*"`^F8͎G/"2пLJ 0*A11fC"qx:}o FH()$!F }.(2GH< ijHEm^ޙV;4 & И'\JB%+d`rܫ niãcGaNY6`cK!kt{+,b ]b玸=ii=xh3h"/ iDw l@=KWpV~&Π MQA=0`PŸY=$aY#@b)F`e7Ib"-2u]@|o) ҂Dq\P뀅4+HDt,Gv-8k_/8 gqPƞec;˸~rK1>d ;[^ G{$ܘ14͖+e7%Ԁ1nU'ܔBcL)Ɠ0Sbt)sXnۄ"R&l/LQ@0St'HaDj3` fqvˀ<Œ7%P/C?e/Bxr^+׍-`2~a /M|B2~/Oc!`E>a.oK}}/[7TeVlYA^*Cwish(;";բ3WFVjg>`R Xi -VJ, ,xn?aelL։ʖFXn'tdɤē鉡“&I5dzNd+MhCK>uʖ,[%s}Vk7 ʖ Xn+u`ŖjX1t.t.BK..LzV+n) S#dL7B9<ŶSu\WW2=o>dcΫ A0/tY?.rX TW(BvT[n+Dc'gbE @-W=7<QmÜDLϸ CrnY E $<\:K"Sy;!qHNE $- !*wMQ,A :! :! SIH8.2HH ?. !BZ<Β,c!UƱED5)zeoƏ4nҶ jE&!UIHfQ@@ &D":2ID&_Y|!ʍ""񀈪rXIDqQU =A"26QͯJ*Ђ0Y?T.{MD$7~MD5VsPeEH=HBE $5Q-"U[HD8=cnzEB]d2 *w(1$Bj{P5#$΀(3$G)þoLX5\ADK0:6J"D9$FDR}S :ʝoz;6 YGïhxMeZ@ii8T3gxBhӒN9[d뇝EKEKaΊ;yd[`'יN'jܱeX6ozq:2)o vr v '3G$:1=I'( v/vr޴"*Rd;% +ЂPd vj}N`C9$e9IMd|SwEo@L;~@ +( P@gQg%d͗pQ HK-Xs 7[W S\Dd¤5Y&:DId<诌XL`"o7h݌F+-`.1̼.j=b$1\O3hJRx&b 1tdJP5f 2#>ьinULHAd4%#jU6B6LVb&/LIL+%F#ɋ"&S҇l+E& шEzNٸ`JwZUTu$F#LFb4 B&єԵ垮/fdB1jl)fBs2[d!/MgUe|1\ۓt̯ǝG̦1Bbr22$fSZ̦|11[%n_/:sf `n fb6[-)fkm'HYn]gղ*idd1[+_bVmy(,^VJP ٮU[dTb2S"ٲ{{3fb֣>Й{I]L KۄJT lt i KFs+yBu XiɮdLG?n(V\)[ cڥPi"KwHVA NWp'dDaEQmPdWnƚHkȬh;vF,%ZYsS\RdĆHJyp2j#EofsP'hg Pẁ =jl1PgE;FB^f($z!rQy_cCfM5zO&]= `  Ms726^GбWwgp` Ltj'uyL6jzab`a"3cz*aݯ0;>7oƾg.*4z,ёu>poi>{Fb`M"gxc@Y唴ă#-C@#b hăv0Lhz|)w?%^!fB#HcL1 L?oh|P/h]u0}Wh&vk@#[ N!f hl4Ns[u"Uu AT\_uCx\4? 4(9И<}TdD9J3% Gq QT5_O;-3̓ʀᓐCțCJ~Ot?'?O:?%9ֽm'Ο{K5woAe&?GtHdP Ah4i?Ń]:vmߕÊ^tly+v9tl`bw+:[սJ)VhNVN:t?צH(tM'=|Gb;*M}8ïg}`EŒA6.Xi)XӃol],Vt"5\Wו8ĊmsrIۤ+JY)q>hE!VLNRV(Ǫ$+B3={IA]WtljATo\$段@G_l-JeXcʁCR茪/Vv }U"SU߬ά5 yvgvfELU7߉m̥+ M~GÅ xlp X@YU(lݲLj;5YDT;C!Nusw*$*V~lV׻qȝ;$;;ΐɝ!;zqʉŝQLT+qgt%w2'SOܩ#$w&ogט qʣŝ*gwq+9SęL}g7-SĝC ɝJw58S~Tq9 .%ws;׻W`Δ8UDh]r;k\(#ř#iˑ3GVxnr֡zcGg3: S0DL ͛tAԼf0!ˆA:0ٕ&t,!i.D :1+QL}r :'{ uń & :E, k1aNbB2(cw751!s mx2񹻘`5:'VHw9h>*$]*$,h]0!D$ D!aULdbCl!aG+qE A@1VaBT˛HS&Df>EP9sqČ6'BB&p[WɈ_1g¦acj~6 hS/}%Gvercp㍭ב{Wǚ8qd}v$;Z&&umHe#U>_&ג#a]36C\]H!x?pdٌ"ȡNQ54֒ lA|qt.n$Gv6yGFCrd'7#kI ա׋#Un/켿Hq8kN*92NNGj# + qő',lB#Ȯy]<4D&He#G+*WT8XOF5u'ϕB3d^iA|n"g,ऻ+w0%;;E;u1{IF_gwJA|H׽5CһP|BI:ǃC߃~?Tg%*2y>o}($yCɫNQ`M)`|]lyYLӣ?OJz0>ca#%9u_Ro۪5/KȎ+*Շuz>|3ks*OȎ-ZdvOȈB,AU$Z;R=ّMW}yԜwE,ٱ?P {ر5ϓu.9XbŪ"48lGVrbǘ2_(!V\jw,vL2w؍8;=Ǹ؍8%‚Ȏ#|dG'=^bA;ʖ5=#E/XrMɎ>!7:aɩv䔏8"`ǙE3uNweT8UQ ';LV#;NeB2ɎdǩdG88ɎS#ɎS ɎSdǩd)"q&eN'qj^q5q˜ vj8Mv4S>dLL)2`C1~?qÊ7ؓ8$+N<ɊSMȊՆ|녕?`ǙvY<`Ǚ58aljr`YĎ0qSȊ=;ĊzΊZ idE/FΩ i^)+N꧆ͤ6S3jDyͽgu7 +xj[xvpFSʙqV .u`E%I`^g'b:c5qYdpdDp,;FFU׬;IFQ=&8؃Z`62ű0DmjG/F#N Ytdbĥ`Dk&cmAuGf1h6 B0ÿVg^kY3dƮDdos(gŌ#fSYsbơ,F2GC&31'3*/fdC0cTsP G 9>ĐEIFE?&bHgCvťɐ׊!^ŐG ĄdȦ,3noi2dʦEdŔMqk2%;S1cʟ*d˔``'ƔW-ɔ]Ydʮ3Y]4dJNd ߘrhh )Xcʲ d3f:XZcNm8v}ɘ|_-1W *oAJK֡CAz`LfRay +W0|'$h;9( #2}t8_M%e= F02uAf~Xi`0iX2S%j^z:|hNtجpd""=.epk Z?C4|yr,kL@y ɲQ0cȁpd,vA.88R4g.ɲqg #SȲ̉*_ȒExYvk-4 JvYVFp( WP#WIQk(þm$CͶM~ ˡ٧σH^_R4"=yT?Ez"hAz"KEڞ ى45;Wdg;!U.#YΤqh-dGҴa Ecɑ4gQ$d95N/MGN^9E2"M޼ K7d5!22AK~#ɯ (2\fQ$iRKF^/o$NF K "o$Hs@4-+42i;7i #Hs1H3I(R\D\Eu ϕ8K-+IʬiBs=I+AK$ϥ+'\! 4<"3?IjHooJ@ ϥY$8z \3IKI҂<{ΌF$M"iiG}@{@ }$Ŋd[H}$Py C}݇|=ʰy|Gs@<ۛ*4-/-}6qݫrX7xg!#:i.e c!b bDr'w5_fA`ս<=wXÃ9>N- AypF6]72IL7!V} dY F$n O9_OBJ9U$.Mvl]2>t.dL1 FLiRύ͢(2V 2VVH'FFܬ)irV"nޑa&cwcbjqxo0psqSl ̈́&H2и*?$q ɨE")ȾyIdId"$C$؇vL$A3A" L?hRI$sMy" @Y }Ni+I-::+S7Ks׭nK --d 0:?-:Jln5>9msI1R$#JܡdRdϯIiϲP$=N̶c R0,E=*d +D:.lX[!k0^k$+~)A(SY Ob',I: xBӒ;ԕR$-1=@ӄG%? KaI|Կ;]c= QӒtCW|#⻲QhI6 a|0MS\fjd129&&^<̅ۦtdIX+$*=6C[*4 m=' ZW m0AzLc숾.m `N`i;,o6jxSڦRkl%_m$^bD`ŪӑqZy3&M4 &BIq. 'Tk*LzZ[([>'TkkD.dGH?~1uͩכKOj.z鶁5/ёb!%:]A\y}!:#/%@Fh~tJB'@ (:G EtLtEj:!=j3yW`h!>:$,% 壓4TT>K8O-!QlU4-I\-ry~cX[ͭ0JB{2@[-Y)&"ȱ7fWSw\:[;coB s@l LJj֔sut %pqʰ&io6272=T}^{kFzLd%@8Xi3R'c&D{ӔNLp^h3&uxPFGF6#ڌ s1 \ݴ*ҥTf[1` &2"HPGXm3<q,$\0?=4W xf >_[2>=2^Dnڢ_[LId7cKXQm? Z7=Y.gb`oyu rT|lUVe0{'H(,{}eq6Dda7\M:۹7WTYࢳBCqd]}cSt:)scSt6\x#ǦxufbܹKѾԲ(woU[~SZ>Gk.s{Sq@r 1m).<ȱVk`Uyt8 gDkte~ip9'RD  h?_kPAU8%bb!g Z}ph/NOF7}'6d3 O>kV30Z-m8!ʼn5<+/~cqV6h5r-N:&kqBDX_k{Y} ^cIؽ8E c+6܈}o辷Nwi8꾷hXu]AV!׍n추#7\سFBƺZ:\sR7!D8׍n Yĝ}^5b]rl?w6)/w>3[?mYx7y>ŏɞ[w퇋~AOŏ~w__}?rTܨ_?ooy5]gR yQxx/}t/#Oǽ-k}d"ONFr9P<΄)^wL;0\XDEqE%w]j){Ox@)^wC<+S?߽mol3ڏzqYTVۇ"Ğjgw?g|r}`v( e17_~~~IH^kIsysg =_ן?Zole _^|vo.ڟb؋qFfW_ /:;_\*w/o} ͹Lgß>9o?CL1+(^w~Fu'y3 3`;x<~<~~p>#~q>#~q>#~q~ǿ+J pendstream endobj 9 0 obj << /Type /XObject /Subtype /Image /Width 1 /Height 12 /ColorSpace 5 0 R /BitsPerComponent 8 /Length 45 /Interpolate true /Filter /FlateDecode >> stream x{DoǦK)Ҝ6VoҪLvpvSHTn2endstream endobj 3 0 obj << /Type /Pages /Kids [ 7 0 R ] /Count 1 /MediaBox [0 0 288 216] >> endobj 4 0 obj << /ProcSet [/PDF /Text /ImageC] /Font <> /XObject << /Im0 9 0 R >> /ExtGState << >> /ColorSpace << /sRGB 5 0 R >> >> endobj 5 0 obj [/ICCBased 6 0 R] endobj 6 0 obj << /Alternate /DeviceRGB /N 3 /Length 2596 /Filter /FlateDecode >> stream xwTSϽ7PkhRH H.*1 J"6DTpDQ2(C"QDqpId߼y͛~kg}ֺLX Xňg` lpBF|،l *?Y"1P\8=W%Oɘ4M0J"Y2Vs,[|e92<se'9`2&ctI@o|N6(.sSdl-c(2-yH_/XZ.$&\SM07#1ؙYrfYym";8980m-m(]v^DW~ emi]P`/u}q|^R,g+\Kk)/C_|Rax8t1C^7nfzDp 柇u$/ED˦L L[B@ٹЖX!@~(* {d+} G͋љς}WL$cGD2QZ4 E@@A(q`1D `'u46ptc48.`R0) @Rt CXCP%CBH@Rf[(t CQhz#0 Zl`O828.p|O×X ?:0FBx$ !i@ڐH[EE1PL ⢖V6QP>U(j MFkt,:.FW8c1L&ӎ9ƌaX: rbl1 {{{;}#tp8_\8"Ey.,X%%Gщ1-9ҀKl.oo/O$&'=JvMޞxǥ{=Vs\x ‰N柜>ucKz=s/ol|ϝ?y ^d]ps~:;/;]7|WpQoH!ɻVsnYs}ҽ~4] =>=:`;cܱ'?e~!ańD#G&}'/?^xI֓?+\wx20;5\ӯ_etWf^Qs-mw3+?~O~endstream endobj 10 0 obj << /Type /Encoding /BaseEncoding /WinAnsiEncoding /Differences [ 45/minus ] >> endobj 11 0 obj << /Type /Font /Subtype /Type1 /Name /F7 /BaseFont /Times-Roman /Encoding 10 0 R >> endobj xref 0 12 0000000000 65535 f 0000000021 00000 n 0000000163 00000 n 0000019378 00000 n 0000019461 00000 n 0000019609 00000 n 0000019642 00000 n 0000000212 00000 n 0000000292 00000 n 0000019136 00000 n 0000022337 00000 n 0000022432 00000 n trailer << /Size 12 /Info 1 0 R /Root 2 0 R >> startxref 22532 %%EOF brms/vignettes/flowchart.pdf0000644000176200001440000013154413202254050015712 0ustar liggesusers%PDF-1.5 % 6 0 obj << /Length 1630 /Filter /FlateDecode >> stream xKs68ʓqMLfzp[#1R=N~ "!yޚR^ {DyO(+nS6w67\̭'rr J'u.iT!*Jt@f06TpD9ZK[iDlP(K9 iyCId7+Tr#.b|xe`2,֯GXXfaI[WA71j9=qPư[;, &`rEwM9_?}Ƕ~T~r84̬4)O9;~=;g}P Sei̗٬~plAY)1uMmHK40^@ Hrb\ aϊ@r "KD^RcTy D5,wH5$EDAl A!0d հ1ub6$߈eP eanʎVCwX2J9>}&h j(x-en?zc{ALvV>{} s\Q/PCR,4N0UhM`gBfq03( MTSM9dmzn2/\b3lFf3 h>86F96Ćp3ǦoDw7Vp37ZP}g%-=NC1% xj0 _7߯r:nwOv&*–D{:tlL(Yrggǖ \I/r|+Jp=>˕hKsRؙ:KK$=o#DSS sb(L Z1?фaF)M8;yv: rm_dRR!rScF8l"(kFQע![z5$X'Ì9ù=vXpA\6GWM(L^{D@NX96nmP1 #zgwr >^TS]`N %[sJ6ByTpҖ9 vx9D1 ߓV(%\*ʵj~a!rSUѱW*{aR0q0h&w*hPrj@7!SKjZ|avsFbMy\{> endobj 4 0 obj << /ColorSpace 3 0 R /Pattern 2 0 R /ExtGState 1 0 R /Font << /F8 7 0 R /F15 8 0 R /F16 9 0 R /F17 10 0 R >> /ProcSet [ /PDF /Text ] >> endobj 1 0 obj <<>> endobj 2 0 obj <<>> endobj 3 0 obj << /pgfprgb [/Pattern /DeviceRGB] >> endobj 12 0 obj [777.8 277.8 333.3 277.8 500 500 500 500 500 500 500 500 500 500 500 277.8 277.8 319.4 777.8 472.2 472.2 666.7 666.7 666.7 638.9 722.2 597.2 569.4 666.7 708.3 277.8 472.2 694.4 541.7 875 708.3 736.1 638.9 736.1 645.8] endobj 13 0 obj [555.6 694.4 769.4 755.6 1033.3 755.6 755.6 611.1 280 544.4 280 500 277.8 277.8 486.1 555.6 444.4 555.6 466.7 305.6 500 555.6 277.8 305.6 527.8 277.8 833.3 555.6 500 555.6 527.8 427.8 394.4 390.3] endobj 14 0 obj [525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525] endobj 15 0 obj [555.6 555.6 833.3 833.3 277.8 305.6 500 500 500 500 500 750 444.4 500 722.2 777.8 500 902.8 1013.9 777.8 277.8 277.8 500 833.3 500 833.3 777.8 277.8 388.9 388.9 500 777.8 277.8 333.3 277.8 500 500 500 500 500 500 500 500 500 500 500 277.8 277.8 277.8 777.8 472.2 472.2 777.8 750 708.3 722.2 763.9 680.6 652.8 784.7 750 361.1 513.9 777.8 625 916.7 750 777.8 680.6 777.8 736.1 555.6 722.2 750 750 1027.8 750 750 611.1 277.8 500 277.8 500 277.8 277.8 500 555.6 444.4 555.6 444.4 305.6 500 555.6 277.8 305.6 527.8 277.8 833.3 555.6 500 555.6 527.8 391.7 394.4 388.9 555.6 527.8 722.2] endobj 16 0 obj << /Length1 1486 /Length2 7258 /Length3 0 /Length 8243 /Filter /FlateDecode >> stream xڍ46\{JĈ{"1bӢjjE(JkԮUUԫ'$usɪgȯh~P@a PFr<<( <`LF!^HK$@(!C ;($̓S wrFߤ$$~\ap( Іa7~ -FI @\=PN>p3 9~@\a0 9=>FCaH/p`u!0Àgm  BQnp#`]U-/A:2 V.ZS] MI,:~E:;%N9#_/S!!AlK /ܩɸ`y^~]D|vgqZEJ5 fzI`u|o`^:7NcX<̝//a1#$l$3öMKOcqA}bW` p/ֆE\vاj jqex,dZdfK@ }wDL8Yҙ:+.|%M^x-@ .!ENS4Fm AZʈc rT?F#M8?t [#ve"r'?oXH流jw=QpN]#),zg6聫$lg *?8F&߸G_jZV1F1lj%^4y|=BC@g^d_mP1fg˴Qo]vTu{Y|dI&6^8J#AOۓAIHzI-|7;v~8S ?>KiLɌ8ΥDM'\FmY$^E`2I}ۇ(=7[.e]AW$4>rZe EVKpPۨ?^'60a8]Hkhg쓃J TW].՞څu@m>Ạ̊́ FǬsDZCd#h${zw4a@ЪTn_J }E1"lX$_e.]˯h,}z826oIkZ[pتsw}72$O$*E~v!˟$o7&gBK5#_Wハ[߽*36 ;K9I \$keC볺!a֚i\;@Їw[LO毜ʲ_p'-3*=s32#vg:X-w |_ f]q(,̈K%:~taPo]EJ ?) vB=x\g!Yyt/nwKgN?#dM {wʋ3 sltw|S9a+V>1D v:G~4!O5Rz|Lrdj"alüVB]}KQ[~qM Qekc YIa{nO` \Z>ZʝNjBh&ΞgURdI]tksRrF }6ةܱ{oh<*A\x~I~63#aMY? NuA }:Be Sy kY,$߱B:_9[s]rxܙtK!曮enng±%Պ:h\]0|0a:PanvgL!E0"k#T"ʂA˪wO y "d}XM@rbZ?[7Hõ[ͮDݷڊ۱N|-NFQjPTv`XO=L9/[?ZY"\[9;BbNOלm=Ŏ?,O@zGI a2EAgOvRvjn&_%&J!5Nt(~,'Qy K(AyK40Niz('N{$͘lpa%ib. –l*-!x3ITOQhju;\: R!|}=z;q[|Fa=usT\E 'ɸ*퉙% ãƆpz]L㴥ƐjF/GUˉfCQN8W,"f䳞QJ\<3Kb]v<~yy$O{W8ឬO d=3C9$8O҃هtgN30/X#_6g!δ=W,PB={XRg(%4]pAC\P^DúOϖʛL6{ӂ\ai*Dӳ-gaRv]vA G|Ns^4z$7w n =/ 36:Tǽc=ĶzTkxYM0#>bX ms`,FTi~qp{Rϝ;cs\#,g@Ow(zP.VGpZ/X˰?ww \QLx VS*ϣY wI& 1Ro:ZIySܟz7v*0ףϚ~gu瑍Y!NѤd2!+3{lSzk"IX̞݉s>ed%C$Ƙe7GFvBchĄĴIP^/ [nz8VcIB06ͣH^ T~SҥxF}([;6G;OnѼhJj^!D#1W{v Ie0s4i+pv@eUnYםWDKF<jX%Ġ ]WOS蓖4ni,>E(ߑ{EOo(p)`Lۑ:nr0W6w"*0ZG)EEFfc1O)T1e9!s{]u{:%uݬ*NC^U,>A(- V!kYաİR^oVSUe(*UlZ|R|;䝬T/o!Qm\[W3GIUDpmC /'W2\Iu5/r oIS㘔'_WӠH䓩87%=q^$adlAes;1hj*`$/-yA\Axĕ+SFR(*UC@Ʌ܀δr5G5?\Iv61[J;o;@L%6w#z7'Dh ;x"Lmj.4,ѴS4֥~I P\Ph.fTRI$>6Pu-aAeeέ'f<3At ]yPxTP~[=iFxK6g#|x?%W-~x!)?2'B;Y&T8c([ӓЉ!62.psA![G"#8> `_ ӪwRk&pTO;bٖ]4++tGI{jG߳MB4Yډ <a!bAOs?+J>BFy^ .-bM^6/.ɣf p@\l9,-Z}rdgVO؂ɉ>5~jԅ˒I'^Wy>.9yaEoZ]?BZx /+{*V7xY,lOI9ӅDŽ 1:4OLpɖͺVrd#R&ՏYaX(<* -;wN}Db2+dP?diVvjϕ k#GD٩s佸D2Pw$@FLuG.-^^j64T9JGngѪbi:OjpZ(zv~lnU9u:ρjdiNPDPT#X#C/)|/J(2rYx/?2puG]oY6Wƒ;I%LD8Xsc{]ߵ5X~we*r|l0i/AH-U^g =0WǘZ2ooy|^)L) Cw4~h܇an)780YH*# yYY{In䄳B#k"gE:_ƻZn284?j+ >GdkE0#&70Xm3$w X %+B~*=ff7W1w }D@iM}-eYAu虊KƗczKˡvKVaaĄpW@s RO` ?Ɇd&tB`..ꓕC$ aCzz E1LC!(5-@NJ ؒS 穿̈́ψ}'vEPGsv择$! _ym;]GKJ].Ҏ{5Of2Vԩ|gj׊$-1F%S÷)T+YztGBf̒#ӚqG S'$a"f %֮S%/BH]dN {!dhgd/ݨV % "glS 1Ij0y)y"@D-ąxz~) 898<jJ[mfEQsȼUOA &)ZVEˑ*#& RR,[9}#'22PqwA^8Ķ߫N[?DAlaQNߞ߮60o{(2WEꪕ 3 N~v(ࣦg _?:9d endstream endobj 17 0 obj << /Type /FontDescriptor /FontName /NBPXCR+CMB10 /Flags 4 /FontBBox [-62 -250 1011 750] /Ascent 694 /CapHeight 686 /Descent -194 /ItalicAngle 0 /StemV 108 /XHeight 444 /CharSet (/S/a/b/m/n/r/s/t) /FontFile 16 0 R >> endobj 18 0 obj << /Length1 1777 /Length2 13171 /Length3 0 /Length 14290 /Filter /FlateDecode >> stream xڍP `ݝ@$;]8r9jf^mwPj0Y:AnLl̬ %u6V++3++;=o16/ ]&iSrl6n~6~VV;++.I3[K3@tEptvq{#ւ9@bka(#Z4-lnV͉ӓZifP]{l?>=#eQWRPaL&v.VC~_7TQdO+Cʎ 3\_lOs IS6s>nkKJ@K[ws3{_1U hjfa mA@UGW?{},>?(S|ߧ )pcعf..fG\_ z9fۻ < (!?_4XA|"wX Xa i9,mlޟsX3|OO,r,9 /_=ۿ /kKavua5bL{B3T{:tLK.(Itՙ!.bI#}h;R7ˤ/' m jO~&_ԧ'q,<$'b{q -O΋y9 U?X21_ͭ\60,Uy91=ƥ F7R/ E|*4]{)!o0Ʀ}q|KV/z  321gT۪ǀk=Ɩvsa41wjKL\UMb0j9>:n{Rz6'A-O k#ߙ"RGGwzu Y{KDg@C=x}C~?mBs_xܵ9`aʭfޝryYo!eA!1o=FM8ZrY,YMukeLBHa_vV{Se@Rt4kz%'мϧ_!1Ck_is ) 5NPWu-Oeڌ1(q NV,SY@a)Mb|BݶO#i\Pa:֍`xa8冤H13wRδLh0=׶j>1la A ;NQ 'p8C89Ẹ_ꘪRydaL4蛯b(Ku`ne`<0ܵړ='ss 1,( ֞\q4(߂'&RLHXKۏ.3Gl.s6*kj2DFMEyOpMr yT9戯~˂-" p(q%|xB4_wi^:m}wU0(lsж=J:sxTK'y  ,V7YTRy$bt,e8\ebwYU?zi)uA0_bRx}h\B*9*!`Ϥo}DU:|*ϭ53s&Ua;cEMBc0)3fPt <}C9ypjQ[Z&59XHvb1̝"|+8p:ƣfP1TU7m;xyIBO#­s 6Eɥ75̟RtiZ6]#k9,Ka`ƩƆ[3(v.j6Vj,sK/leA!J9EWEk-=7x<|J㕠މxg11Qi|{ 0ɽP|`+>v:-Ҵ;y6AЀl\87AW{eYOfEvsD [i2φHrn q<$`\ɰ Co[xKj|0(d5Yn(D ɾstםڝ|gZX1ga z# r55}~CMaKlM2TO^7'^,/i%.|)A-zlnew%`#gcjsg zg샥ia?)_G lnYV=D{ޠ^3YS'(,!e}o92@0!]9=HYI>qʷw NcSI|견Xt::s3L* ciLNQjO9ˮsYT`\8st\^hԻZ-|HZR4}٪&ίCceIihafrO\5zKQ 晞3пv(nQ/R7„4TО9TO4ujrKnToə=%t<]Ϲ6,Z#=&_4.i, Pb"m(BAtFeb_ƍK}3S#B%[&u>U9E;U$&gy>6GK' m8.71eh&EdPrL:I5ƀlq$5g% U/-‰jN_"gz"Xb`5i[owݠkDChYeF&ڰWԜ!>%~ФiFw&-+J% R, 8OLIh0G 49哕GÒi4R‘GXxu^~t+fѲɕ3՜Z݃K`Sd?NffJfr-[NI2ė4`3m6(cj6ezL{!.f\%U=ҹI>X"#)\=0pQkS_CG$e"v\]CV'竫~~HZN@f5g8?"U{R\%]'#X[83pze=h1Vw^vVU^'ap+7d~ fgRiy, Om Rni«=pz4vGl +l3C:I͋MА3͸Ndؒ3)ON>ͼD}QqS;L}[˧YرKMΏl('Ia'}2k>JǒAp# EV[rBϡv]9 + =t[Ωi =#bɛ[eKX"5@: SY<#vYYHO>oopx| _4Jt)w=GTB !bB h:иX4ِP~ٮR?qq0p0>p C8n~/ AUqJ=uؐx%{2x9ڠz"tkL*ϓԌ)gJ, n`D z0 uB 6m9DRm/_s4#r{FĤ8E=\y`* 0m(3M?_q-i#WѭesplGrإoZ>Sfs1uZ*&!; o8Etٍ9Kd3ҍ{'uZgHwE_N}/NgCTJF ( ~p+z'UAiϗ'̥b]oh[d=+<(=z$pDv+KbH QݭpB7y{uz)VS8'd=ƵԖQgd8qŮy-4fi)un4ZOR&Y&qH9TZԱ1U~[y niKO}p9,6|hZ5Q_:|Cvbfn3ݣ˝l$1$@|߱:@p Y}Mme2&Kc\3)59 UX|/Va틜F H..4Ii4FeLhZe^+ߓ="gokt6:0VҒ6q+̋tSL$ OF(})I wzFKiCEW-.8\ PHlݯCa2Zhria#&O#s|r83例pZ>JgZA-ߨnIGzU]ZcFvߴ(j^ŎuB,puDfj)C^6 _пq /Pk.*s'q7> eޠ޲y1Y>p t/[ h쪞W1y>FR?pIja ZDP!+" Tg\|eևGk:p0+uO0tџv\*|"q]R,$MY>?P^38 ǃt4TcƫdhBpVq'Ǥ.'eUyzqIvuFG0,Ρ3N%ֺicEs4vZX0DK4,EMb0Dw"}ʭ܃ vpU*7=Dim1.b׉S*. K-k;f%Y/4˸d/ě)=jxnMuh|jyR~4r&@y~;|NVNLMw q?Db* p6u$T{ -de6h%VڜKaTm1aȫkYudkWd_1p(E2~.]r`OdExCCkt);pciG*R5Nq?nȷ=( PteI;73l_A jؓL\nf0]1(/oeOt9؏G|{LJ=Ch>_""BePy&B5ı>ڲ .eB+K-Fe wT[)y,xK'.#[ԝ]Q~7+mVCcmJ>e9QEb%rnsÇ#5)VY~$#~4e_]0J:doOZ]0sۢHCq:ҩ!)da"<~2 |LuZ% _ۜ6%D7¹b)xbo9_v[e.h6xZ1VV#Վ.kᄨa⚃ WWrZ11ܱv}+ttGb ^Q#͝تϹ u8g +O/1}.>aE45=2 D$vmY 7b$D1LZ4?;nPL%fj T/k1LTmf"ܕc00K%\9e1ja}3OaŘTE894J2:h Y/wa%eY9!ؔ3iD?98dՑ-_.pR)gq=|b 4%'9 ae[ZYTZrexZU}0 ZecCH ԫvr Zl(.L6$Ӱk>|͇QnPUIōsnfxRYVH录N\`uyuUȑZ%-v&luӝGJ xa+{dfҁDI^^O\25;xEfv*Sh{ ir[²JZՃo(p 2To5#0- r nMpA8f}a/5ģ;F'P탋 Qj>I.CvgjQ|l/4bxvNbػՖ`Šg T>HÞIIBᇓ鼴yRbsz_D;d+-_P"<{jqw{ٙPǐAzÐ%)eTh`InuO(EԨfAb@ʦ07-*-;lb[l޽p4C5_찫{Y2!nP pV䷸ܳ,|ӌ O .up-hp9ld`6HhP> j~zd;PYyܚ]b+0e}6QQ"kop#' P:a4:3 ZRU6wϥ5%2ג@糣Cr͔kN P:F77CQBx\ZƈVUdJOfs?!t vzKl-af+SM)?Kr0gSkPOC>qֲp3yJuC]_@!ʬ.u }=|ZzĄY^J|9d̎vP#:=)uʣ3b = bԺʖo+#JL1>&B3גyV9eAݣk:n K+|'6x֩0*NvK9 WvIBd~OGˑ~P?)-B?-cB JK7Ӄ{dE?[N|YKÖ9Lvf!Q"QiVJՏj)>-ETyn!ٴ6KǠ!xC/B"?w3hvvP?%wT,D/WPNMlĺ  lhgjQG@i >Z:+d :C]37ks89GtIu~Oݵwz) @Ǻ$&6ip6|mɉ[^k&SW3mbg&DM#.f_D8UNnmsJn*(oȹQ/(Y_Wd-Ht*'T6G#uQ )2?>@SB=LudMM$TMOǴeE0a Uh;%j.+/b/y>(h]b? 9ѰYlZ g9j`Le&:j!z&ݫrHą y|qi` 2ߤO~EJm1i%YX\7H98=Tߒ\=tm18-oy\̲`,6׮$x6⛇VR_`H$uNAtS{h{ x`|zs9kuV)~lS3[om75q WjTޙ(d5DAˆuCEa1Ϲo?~D* ϏcJ/f{k/{ŏ1lkm`H\r=G][O$P+ ϖ7>0i3̸'jJ6HJ`297 QH`u?_~ a$ًXkE^iv: `st!.Hd )i0lj8tSqNfB# n/4`ܹ=??^*phqdb/y @L[h7f&, V atzGS+9v׺0 w,Jjo&N9!';9z|*/4\54V ==j2ү*>ho{A_ʤ&]Y!PqXMUp5X>\\:ő$|H(f2n[`7wF1ca>;4qlmck' Syu{OZt\mӸaÀ`6QR'Wx#5xC[~Η-O{ ֭ NPZ,ة/{~ rP.zC3R0lqkXh(1Բfn4kdP]n _P_p ӓTw> ?f3ђKGggvGUU4~ox[!NAEٶs${$*QPإ\M"QFW[Ϲ'վ:fpol{cH@ABR[+Tm. kh;֬̑KxE,&18M 6AGhI}=$1#i:D|C}(Vux״9y֡A΂nLEOd`Bb1h~A9><Ͷ e}i!gt'_%YQ$Y1Z,MSUU`F4Ս~}"p9ex&R@^m q0iB<n͊deB G,,)m\ŝe r+ΧI_)f٬fs/x Y 0Qak lZJ"Pvw[2&AۭhxM0lO$TKw ^<0 n rE,zCQ> endobj 20 0 obj << /Length1 1423 /Length2 6170 /Length3 0 /Length 7131 /Filter /FlateDecode >> stream xڍwTk6R?t@ڂa&qh vP_%8Q(7I~~///>+p(G@ U a>P`u|(o]|'>:P7 C"n($#27cV)]]!0}\3 ۲Ѱp{@T`n\x9@P wmwPC  Cn~`OBx@w`E6( ?oG@3 _,n6skj8_#vAܬFjKϚ;GUQ\$ @QmpS _oW؍lo*țh-`p_ta""J ޿Q7) ub/oK\\<j@Hfo!o-V*̩*g칅g&]Q"(\?GʩRt&J#iv2gUrPhJ]{ymz;8àXJ"n.{UXjJf䪩& 3&Ӣe7oǚ0,>Ǔ"R= T @Ɵ7Q,ŧ}'+EzGhy]j2_52hl"' B#h}vfxbDc~okAiXàQC#. WowMjk,lJ&go/(!9R6E'Ϭ&D`r-0UR\}U:KϛM_g%sRiy[ Ykk>=KQXHqEGb{UM5 Jѡ bz["WrC-8,|j^IDh*]Ջ;(ﭵlyK)06xSӻjA/C8lȤ!ΐͭ&t`)ŒsM%x7rZXsb‰Toh5C5;,36_:@r`Ξly*^y ے> pۑKdH xԯl'}h`&Ĝ-݆49љ+h|qҞɹ6";={%(oSǜR 'v۬?+nPllz|FYn>9QMeg0 ?OLz!$VT.Iݚ+B`Ia}gpv@0nQ.-,ZOl3&tNiDݾ^M#Ve AbX5kTz؉(;{)Y\oD}Cj\wdp+"Ri 4T7O,I-K%uGhضeh)cͳ犃CYf4~adF;!Pi#{=UѼXj964ԟSؒ捞-Vіmm$Ga)^/'-m6not<8?tTlr՞r_-\t`Wg66?-_=7|lLJt)>-N&Ae#)~ִ9&0VjP+ h\/#4a$ÚݽYaẓ_Zz-snJM].0ƭM( I٢MGQiu}>g3 INx҉vE%ֺJ% 2SrJzW> }=ֻaKI<B| WrIVd|I%up[ .i! ^EN &O-kV41rI\XߐٜζrrS$v~Tv~M@Y:NC.E8֭q-js!34PVb3C9h:>զM/tujZa-zbUBF'*5ۮr;>5qf rBdg 㬧ckl[?O7$#Q+ceAUj.!X[WPn2GdE- >\މYfWwi=< 8:|HR cyɦ;R۴ӠFyND 27c{,wO%6ƺkw2 1$Q4#"r$16p4^?WokD+=NJZ쉴27ӊ_~O ()0hK 9C+CT|B9o2А9\$>箴P3U*4llGt a;o_+T'zW ) 6uEA~>e-.Qu.7g_%Hr!_|O<4زSf-]R1U<Í])+&)D[6nYaˈުb}= $dZI#uِqF4ިɸ&@%4G+Oޘ ǖͩ %;zg;Հm)15eRaǧHB36YZ*kMϫC Ρ_!|m=#+&z 'c _4YwwP*³#оVdÇ0c^? M`gky*G @YE ]-OsO//^NeYg:RRT}{NV_vjmG:w02#ϝpHBRA·5ߔ}!n@=橽R̪zR"mo,~qzCt.95f-upNlycNwgš:Gj QY?&-cK'*پu>{d>UΕ#y)˜QZUڒ{ԠTț!цiUhzދPF2N!sJX}/Q,xpKHAYQV^5MqNG-UAp27mIqE~ϳz`L%̉7Zeqg.UicS $P>yg3n,nMR5A2']A5ߕ7zSh .9TO6+YVΆg[[2ݽcJ/j|ͲI>"Kw?^m.eguE ଅe vfհA49a\4k'/.xOlymP4-5vK“ZKԉ'&,w=j2W`}Um[$ LҴIGj3hc}9[T)ԣ*d &O{,°/ڃ a#[#,墧tn@UkJ@zcXH"](޷@Є\KV〚sq>LaqAf|2  .YM"R,bT \BS2ibb+z ԫeM32gaC#Y=,pVYфA 񚐐"#S+?*7<; LMS{dG-d{7%2Bg5SI,DpS>ٖa{*c(ֽ!ӛEw_ѯV#@bN7yLᙕYԧ{*po\->>Au3XO$G|Oأ qJjo|BUAsb`uFgWhҺMi mRJ[+i=nd-HX+);H4Mq"s\#"]wưRHGsCo吗g RGFR-10l擛ڙP&n>INq +e􊘛j  TV.(Oy'7x/f^Mh)LZcos)>:j$zRF%YUkld)~«9z9=?7Q*.~ (HX!uUd>D R]B jڬ?Y]~T]CMJτ"]0i\dl7"Ghe[|G.oQѡλ N<fyXV=W3UYt\;=YJxry!xgD5Oꟁc`=i:Bo+ /IO~Cأ2N:_-JÐgߧx\O}Wth# N; B/z ֱ_Ə{,t$y:"A˲g J]iH *]&Y]ҪQ3wi$/*}Tgsu#|xgVg#loDU%mĚͽ1s"uw/j*ThFM/ozIfT՗_!M=GٚYXu2/ 2 i&rw oJ8t'X ?1S1/1eB/sÓlg7ll_>y$#E)]⤃o\\դMMQ2 =cIꪴ16a {|lewžGFߟq!cF)ެbx/T92RR߶G Qc x~BИ e'ɦ8A.lNN}>9i8DFղ6LvG{~hJɧF|_aj`anPX>[Xbݔ9q]R=3GK):$?TYབl*@١폅rA?pUy~dF_sY:3۲QA=/@i;1h0uP7k^\ L~]nĖ:k^ya^\f=/2z N Br>_"joCYo9DI{:#V]&s(Io4\5s͝ *~S +(Pi]_h#ѵΫҔg@J췍qaB Ű;垖SS:XJ!/Q&m]+V ' {%yH X e`]`Cx.]#wͨqF?y>;2?hc(iKekʒ~x 0W_p:۹S= gCDDHnK濯yP=ce5X iFx;_7ٵsD[&a@PiuRU@bQ;!Æ*AѧROD9V=$/=7?0}= o5_L(j^-&<8٦ M":/ZgS}?71f~D,dj~/zv̊ endstream endobj 21 0 obj << /Type /FontDescriptor /FontName /MNZTUE+CMSS10 /Flags 4 /FontBBox [-61 -250 999 759] /Ascent 694 /CapHeight 694 /Descent -194 /ItalicAngle 0 /StemV 78 /XHeight 444 /CharSet (/C/R/plus) /FontFile 20 0 R >> endobj 22 0 obj << /Length1 1553 /Length2 9000 /Length3 0 /Length 10018 /Filter /FlateDecode >> stream xڍP\-]4@c{ݝ,[ЄGsUծ5sUSUQg5 vLl̬qE 6V++3++;J +Bt~I_!v9w đ tr;8laO)t-l (-A/M6u)_%h-YXܘNG !:Fr9)1#Q4,N:!n@G`69ؙ/ e{ݟ 03?]lG2bkY6 3#hg;hy6@?H/ dwvbv6KڙClmAvNH'v_kmq0sgѴ;d%y1!frpr@%?l/|! 9t]@>^v7BbcM& AwY_`e038bqMuMuY(8L.77翫oXUzvߟ^ow%ȋA=+UI3ڂm6`; 0eL_z(ig 1=z\#E_\\/5!m %`qD}|<oӟb`1^ٿ /R_%?E,v/AN _/./|ٖ72EZ [U1LNcZrlwy@CH \w!4܃-I{#L먹!%A(Nmziq o`HICdV5l3tU /J>[{mXn1 Gs|`x?VEHIG@{56M%,U\n!j}{ ,>Ok-KN/ b掺=}trSaPm#k ܍эIͤ爾"jؚ0Ex]./^V3e.hHIi FɌ0Cud eZH.}l_m+̋P=ثGsBˤq&gd;O}I^U)lyd~lq%@%%$y`E o鳁(s|2l;Yw\Wm~ D VIAXfDGS DZy% ;Ty 2eRZQ4_ ^iZɉ][ bLtK !\Pwʩ^a<3MRlE(״T^fPݤZfCˆȧ S<0cC 4W$7݇qjj ~Q\l2Qj2†A.E!dr Má1ZgQcMIg\.n< aNB&Uۦ= Ӡo͠`fJn(1+{EsHpf:3Ӊ_ٿcvL}uKsh,-vԴ/2JWG⫉ۭ6P]&o yn %pQ4;==(1ev2@61/?cH)&_G}WּCfty1˱+ $*ccb`Z~~fc<_~L?,iNLRSDzuvٖ ɨɚcfrB>o&ݭ^+q/0f,0_d͖Nh=i_6K͔60%~ԇ2 r2[k"ӢU[- kwy`%QobPWHܗoRA[ro~y ~d$l̐29\:L|]Yc_rlO9Y!nW8)=+lé*`%AM~ >>e}s.GVثf_Iک mVOkpQ=Y3eh:(?,A-*NFl| ]ZgݫJf6*GPqI·SQqګ[SO4g~Vr%oYhB1X{澕iGP.ܥs2$n.m"-aB,`m-_g+,$ B<Ǧ~ eP408avMJSilQ{~!/=k*3=/s`FzHNZ_G-@ B(%z"+ i%[~' O&A?#vf8(^)u(W%LooЃj~2j;w+"Tr.3o[BpL?|@C3՘Nb b?0vY鼜-4> i](cNFTD)5͉A)t:$ CP.-xpYĀA?ⷰן;c4* GB{SrS6<h Y퀷x~Rvp~AWJv]'4\T!k.|H%FiGFY:>}C6{ċ hW1jhS" ˘H>$cD,grbi{uEz2{$MxS*w2 x\;xxTӷI }8T`dݒ.A֊!up߱r0덧KAIbd?"ؽt`qڱkM+0fHu*٫k(]c>WxIwjXSRV&2 fi2`R :Kʅ < M 3!7yCʝe4VN. x)q<! ^̻)iRw>7AThXfNxJ E\Ҿ~=M !{$ɬY1tĶ'M$P[4M'L!;9Rˇp\hbF<&I/Lmw<':ɹ&. ͨl21vY{ '"/:hy y?h$GV+r2gTuy reΔ7˻ uڠ7sSN%sZ)twWrZu]l?(놄3LTш:Mfrګ-l|Rt'\!!p8m>ެ\nDYkZ|K9Ci4#r_i,C1kd8NjN>F#>=q0u[UMӋȤ󌩵k߁E$ּ/=wD۲3oQ5"J)g?AoPKvצ >)"ifs,.1fn tכA ׊qY-D]-<4wŧDBSt?HۺdNp?(J2ka5cqDhםqǐLo@BR>jwSw6{kN( M)~ vЎ ]VVg;S!ғ+ z,lY)ɾ:m9>!,n7c /PiE[74$Baۡ#~4W@qL{ "DnV s:l47S 'iϮAF Cd"2#D2 r/R0w ^~kXs作Rˠu 4ּj铁MvK SՀ2 {$]YypƎ[3512k୶NBA,Ƒqrx@X /TCb;J(5¯XS O~)%}A]v/T`9q.$̉ޛut'Vqdrp$MߩaVtxI~NFHVT)dxW'T kP u"tߍUwݧmn/չ#vAݝo9_jX`/NM˜fZ:)4bpNdcGZ/;6 Z΍++TW-IQ_P1'۳Q:_1+qkw1/% f]'lieOz+FQ .uKx"iQL CvC(4ɔcVk 7T8߼+^+{*K9_ h, {j}U 巾wo>H&5%R7,`6~qPewb* ^ 樹7JVp}&>Iԁyo/E*JFAg#.%J F#Á+ě!^D'$ 'gYeG c~ًvκbh ^(YhiƤ1EcLa:W߮ӟy6򊍴f^EܐNϹ"7 ]*fC$a6Qù yTCFķhͮ|BEul'+@ (NbQsXK<2DVkWJ 1y;;Դ#d[A56b/?tc\<8*1Mm.Ӣ㒢o!AF*_LaJN1.^ ʣ㬡[B6j.oLBeO(2Ndc`C(&->7ҷaB3WJiۙ*L麤6V Y(ZsA k8߉sj⯟H>-3`䖧n[XHb7 æ,ÕX&Σ,}"P@G9`&F6((eT?UmZ:\`f$TP-<0L,T'Lz@3dw5!MDns$sqj$˜e4%y}+y h}uzcPO ixé$]"FȃafJJ6x(kmQnL /JM6B}oFHz38v{@ScX ,B q(s?ʡݒ7*( 4gGRPq%{9!yxPmhAkUGs%GKl9(䰘GY,!sLS2A զu10q䡩OkP|c3MFR)=J=_g>mfc7jӓdD(g#c['ZwԃpM$2||=;ԝA$+^6*)˘RÃgIJj*L v_Z-6 ZpǕ+ &p ulHp 48Mq@{IU%xRƄhID 3uT <~&+~FkYQ^![@~3z*86fi{=UJdWly2/:t3^1@Gӂ^,~ =d7&3VIָj`VU5J ] V.8>J娇^gϓY~(>ZERw֛]z/ӉM0o1:F}1G'zEp't3ѹ+[Wt]{-iaB5DHr fk}mf*i>9Kcp]lu5BW6ͽ'Աu{ISބ,7)jl`x#|嚮nVe`b "Ʀ JUn7Fo9C&ئZftq[Gη<0í0XWaCZv +cͼv\c|CbOѻ J bsfwC;@+TC$JZ-q?܏ G]J.SIҋ*9/|E4®C֍mnV6/B0ʬ+ ۑf߬&Mեx d`/Ň'8(g٧d7V폸!XW?VR(Uv;Mqz=r Q\}e`ϔv r_$yRE .c-&N9(!BV5oea;U6ryxljƭm LPu&٭^WyGa\qRrlA"*'ɁI,}C,n%6[r2uT~; Vuщeuey}%a+B}<޷=k$UoKy~h;6L +7Z1|ڽA *'.{"}fjo%MһZd:MUi׎D:dm[$:4$qK ^xswwAq&blvZ.fD7l'MEŞ7wQ&G#+5~)l6@4K"}ƅOЏfU|^ RsݴYWTQR6ǦH:!%]Fa)A+St2ydU515|қ)LZ/WԦAZiBKyNkgؙ{:O1_ ^͡e9b lh1AT?}YXW_E+Bhb˿dɬ4*U4 M+DDpPF5*~n4)U^#uS$ ۺviU?2uZ]g#箊@qYFq޸ߨwsݰ2\p)kSm4Cn^sl|M(PVkBYq~tCnzYE>^gY!DiDJ$I{d$z^(Gơgw lhMgv{j+EEWQ>\I\WHTTQsIӎyq}kq~[[,XDd]EZz}"]661neQ[uz8n(hg>Qt V"C *8{27 3Q\Anϓh)pX0UZ(vCnbqzU&STN@SN3u Af" :mR xaCv=F`?pnw$Yb%P{ %=;zZtg0&L~č-ДoQ뛬Y?65 %zf0.}4Rfei],\ UpTwH~|?t&Ėu;ye7@mj%D?ߑ]5>kdčZc6/},~?Q 1oXd+# ~D Y/(;& |#V|mĺ \V\jz` SOAA2;acrwěohGqpfx`RC΅! /C #EwI8w(ޝ6x ? ]'QSZ\A1 vu}1q tQFJ2J4w=dðP> endobj 9 0 obj << /Type /Font /Subtype /Type1 /BaseFont /NBPXCR+CMB10 /FontDescriptor 17 0 R /FirstChar 83 /LastChar 116 /Widths 13 0 R >> endobj 7 0 obj << /Type /Font /Subtype /Type1 /BaseFont /RMUKLW+CMR10 /FontDescriptor 19 0 R /FirstChar 12 /LastChar 119 /Widths 15 0 R >> endobj 10 0 obj << /Type /Font /Subtype /Type1 /BaseFont /MNZTUE+CMSS10 /FontDescriptor 21 0 R /FirstChar 43 /LastChar 82 /Widths 12 0 R >> endobj 8 0 obj << /Type /Font /Subtype /Type1 /BaseFont /CUSUSI+CMTT10 /FontDescriptor 23 0 R /FirstChar 97 /LastChar 116 /Widths 14 0 R >> endobj 11 0 obj << /Type /Pages /Count 1 /Kids [5 0 R] >> endobj 24 0 obj << /Type /Catalog /Pages 11 0 R >> endobj 25 0 obj << /Producer (MiKTeX pdfTeX-1.40.14) /Creator (TeX) /CreationDate (D:20151111142744+01'00') /ModDate (D:20151111142744+01'00') /Trapped /False /PTEX.Fullbanner (This is MiKTeX-pdfTeX 2.9.4902 (1.40.14)) >> endobj xref 0 26 0000000000 65535 f 0000001990 00000 n 0000002010 00000 n 0000002030 00000 n 0000001837 00000 n 0000001724 00000 n 0000000015 00000 n 0000044497 00000 n 0000044776 00000 n 0000044358 00000 n 0000044636 00000 n 0000044916 00000 n 0000002083 00000 n 0000002317 00000 n 0000002530 00000 n 0000002628 00000 n 0000003226 00000 n 0000011588 00000 n 0000011820 00000 n 0000026230 00000 n 0000026509 00000 n 0000033759 00000 n 0000033983 00000 n 0000044120 00000 n 0000044974 00000 n 0000045025 00000 n trailer << /Size 26 /Root 24 0 R /Info 25 0 R /ID [<6480FFBB824EB7A26FB56374AB07DD8B> <6480FFBB824EB7A26FB56374AB07DD8B>] >> startxref 45247 %%EOF brms/vignettes/brms_customfamilies.Rmd0000644000176200001440000003246115053072461017751 0ustar liggesusers--- title: "Define Custom Response Distributions with brms" author: "Paul Bürkner" date: "`r Sys.Date()`" output: rmarkdown::html_vignette: toc: yes vignette: > %\VignetteIndexEntry{Define Custom Response Distributions with brms} %\VignetteEngine{knitr::rmarkdown} \usepackage[utf8]{inputenc} params: EVAL: !r identical(Sys.getenv("NOT_CRAN"), "true") --- ```{r, SETTINGS-knitr, include=FALSE} stopifnot(require(knitr)) options(width = 90) knit_hooks$set(pngquant = knitr::hook_pngquant) opts_chunk$set( comment = NA, message = FALSE, warning = FALSE, eval = if (isTRUE(exists("params"))) params$EVAL else FALSE, dev = "ragg_png", dpi = 72, fig.retina = 1.5, fig.asp = 0.8, fig.width = 5, out.width = "60%", fig.align = "center", pngquant = "--speed=1 --quality=50" ) library(brms) ggplot2::theme_set(theme_default()) ``` ## Introduction The **brms** package comes with a lot of built-in response distributions -- usually called *families* in R -- to specify among others linear, count data, survival, response times, or ordinal models (see `help(brmsfamily)` for an overview). Despite supporting over two dozen families, there is still a long list of distributions, which are not natively supported. The present vignette will explain how to specify such *custom families* in **brms**. By doing that, users can benefit from the modeling flexibility and post-processing options of **brms** even when using self-defined response distributions. If you have built a custom family that you want to make available to other users, you can submit a pull request to this [GitHub repository](https://github.com/paul-buerkner/custom-brms-families). ## A Case Study As a case study, we will use the `cbpp` data of the **lme4** package, which describes the development of the CBPP disease of cattle in Africa. The data set contains four variables: `period` (the time period), `herd` (a factor identifying the cattle herd), `incidence` (number of new disease cases for a given herd and time period), as well as `size` (the herd size at the beginning of a given time period). ```{r cbpp} data("cbpp", package = "lme4") head(cbpp) ``` In a first step, we will be predicting `incidence` using a simple binomial model, which will serve as our baseline model. For observed number of events $y$ (`incidence` in our case) and total number of trials $T$ (`size`), the probability mass function of the binomial distribution is defined as $$ P(y | T, p) = \binom{T}{y} p^{y} (1 - p)^{N-y} $$ where $p$ is the event probability. In the classical binomial model, we will directly predict $p$ on the logit-scale, which means that for each observation $i$ we compute the success probability $p_i$ as $$ p_i = \frac{\exp(\eta_i)}{1 + \exp(\eta_i)} $$ where $\eta_i$ is the linear predictor term of observation $i$ (see `vignette("brms_overview")` for more details on linear predictors in **brms**). Predicting `incidence` by `period` and a varying intercept of `herd` is straight forward in **brms**: ```{r fit1, results='hide'} fit1 <- brm(incidence | trials(size) ~ period + (1|herd), data = cbpp, family = binomial()) ``` In the summary output, we see that the incidence probability varies substantially over herds, but reduces over the course of the time as indicated by the negative coefficients of `period`. ```{r fit1_summary} summary(fit1) ``` A drawback of the binomial model is that -- after taking into account the linear predictor -- its variance is fixed to $\text{Var}(y_i) = T_i p_i (1 - p_i)$. All variance exceeding this value cannot be not taken into account by the model. There are multiple ways of dealing with this so called *overdispersion* and the solution described below will serve as an illustrative example of how to define custom families in **brms**. ## The Beta-Binomial Distribution The *beta-binomial* model is a generalization of the *binomial* model with an additional parameter to account for overdispersion. In the beta-binomial model, we do not predict the binomial probability $p_i$ directly, but assume it to be beta distributed with hyperparameters $\alpha > 0$ and $\beta > 0$: $$ p_i \sim \text{Beta}(\alpha_i, \beta_i) $$ The $\alpha$ and $\beta$ parameters are both hard to interpret and generally not recommended for use in regression models. Thus, we will apply a different parameterization with parameters $\mu \in [0, 1]$ and $\phi > 0$, which we will call $\text{Beta2}$: $$ \text{Beta2}(\mu, \phi) = \text{Beta}(\mu \phi, (1-\mu) \phi) $$ The parameters $\mu$ and $\phi$ specify the mean and precision parameter, respectively. By defining $$ \mu_i = \frac{\exp(\eta_i)}{1 + \exp(\eta_i)} $$ we still predict the expected probability by means of our transformed linear predictor (as in the original binomial model), but account for potential overdispersion via the parameter $\phi$. ## Fitting Custom Family Models The beta-binomial distribution is natively supported in **brms** nowadays, but we will still use it as an example to define it ourselves via the `custom_family` function. This function requires the family's name, the names of its parameters (`mu` and `phi` in our case), corresponding link functions (only applied if parameters are predicted), their theoretical lower and upper bounds (only applied if parameters are not predicted), information on whether the distribution is discrete or continuous, and finally, whether additional non-parameter variables need to be passed to the distribution. For our beta-binomial example, this results in the following custom family: ```{r beta_binomial2} beta_binomial2 <- custom_family( "beta_binomial2", dpars = c("mu", "phi"), links = c("logit", "log"), lb = c(0, 0), ub = c(1, NA), type = "int", vars = "vint1[n]" ) ``` The name `vint1` for the variable containing the number of trials is not chosen arbitrarily as we will see below. Next, we have to provide the relevant **Stan** functions if the distribution is not defined in **Stan** itself. For the `beta_binomial2` distribution, this is straight forward since the ordinal `beta_binomial` distribution is already implemented. ```{r stan_funs} stan_funs <- " real beta_binomial2_lpmf(int y, real mu, real phi, int T) { return beta_binomial_lpmf(y | T, mu * phi, (1 - mu) * phi); } int beta_binomial2_rng(real mu, real phi, int T) { return beta_binomial_rng(T, mu * phi, (1 - mu) * phi); } " ``` For the model fitting, we will only need `beta_binomial2_lpmf`, but `beta_binomial2_rng` will come in handy when it comes to post-processing. We define: ```{r stanvars} stanvars <- stanvar(scode = stan_funs, block = "functions") ``` To provide information about the number of trials (an integer variable), we are going to use the addition argument `vint()`, which can only be used in custom families. Similarly, if we needed to include additional vectors of real data, we would use `vreal()`. Actually, for this particular example, we could more elegantly apply the addition argument `trials()` instead of `vint()`as in the basic binomial model. However, since the present vignette is meant to give a general overview of the topic, we will go with the more general method. We now have all components together to fit our custom beta-binomial model: ```{r fit2, results='hide'} fit2 <- brm( incidence | vint(size) ~ period + (1|herd), data = cbpp, family = beta_binomial2, stanvars = stanvars ) ``` The summary output reveals that the uncertainty in the coefficients of `period` is somewhat larger than in the basic binomial model, which is the result of including the overdispersion parameter `phi` in the model. Apart from that, the results looks pretty similar. ```{r summary_fit2} summary(fit2) ``` ## Post-Processing Custom Family Models Some post-processing methods such as `summary` or `plot` work out of the box for custom family models. However, there are three particularly important methods, which require additional input by the user. These are `posterior_epred`, `posterior_predict` and `log_lik` computing predicted mean values, predicted response values, and log-likelihood values, respectively. They are not only relevant for their own sake, but also provide the basis of many other post-processing methods. For instance, we may be interested in comparing the fit of the binomial model with that of the beta-binomial model by means of approximate leave-one-out cross-validation implemented in method `loo`, which in turn requires `log_lik` to be working. The `log_lik` function of a family should be named `log_lik_` and have the two arguments `i` (indicating observations) and `prep`. You don't have to worry too much about how `prep` is created (if you are interested, check out the `prepare_predictions` function). Instead, all you need to know is that parameters are stored in slot `dpars` and data are stored in slot `data`. Generally, parameters take on the form of a $S \times N$ matrix (with $S =$ number of posterior draws and $N =$ number of observations) if they are predicted (as is `mu` in our example) and a vector of size $N$ if the are not predicted (as is `phi`). We could define the complete log-likelihood function in R directly, or we can expose the self-defined **Stan** functions and apply them. The latter approach is usually more convenient, but the former is more stable and the only option when implementing custom families in other R packages building upon **brms**. For the purpose of the present vignette, we will go with the latter approach. ```{r} expose_functions(fit2, vectorize = TRUE) ``` and define the required `log_lik` functions with a few lines of code. ```{r log_lik} log_lik_beta_binomial2 <- function(i, prep) { mu <- brms::get_dpar(prep, "mu", i = i) phi <- brms::get_dpar(prep, "phi", i = i) trials <- prep$data$vint1[i] y <- prep$data$Y[i] beta_binomial2_lpmf(y, mu, phi, trials) } ``` The `get_dpar` function will do the necessary transformations to handle both the case when the distributional parameters are predicted separately for each row and when they are the same for the whole fit. With that being done, all of the post-processing methods requiring `log_lik` will work as well. For instance, model comparison can simply be performed via ```{r loo} loo(fit1, fit2) ``` Since larger `ELPD` values indicate better fit, we see that the beta-binomial model fits somewhat better, although the corresponding standard error reveals that the difference is not that substantial. Next, we will define the function necessary for the `posterior_predict` method: ```{r posterior_predict} posterior_predict_beta_binomial2 <- function(i, prep, ...) { mu <- brms::get_dpar(prep, "mu", i = i) phi <- brms::get_dpar(prep, "phi", i = i) trials <- prep$data$vint1[i] beta_binomial2_rng(mu, phi, trials) } ``` The `posterior_predict` function looks pretty similar to the corresponding `log_lik` function, except that we are now creating random draws of the response instead of log-likelihood values. Again, we are using an exposed **Stan** function for convenience. Make sure to add a `...` argument to your `posterior_predict` function even if you are not using it, since some families require additional arguments. With `posterior_predict` to be working, we can engage for instance in posterior-predictive checking: ```{r pp_check} pp_check(fit2) ``` When defining the `posterior_epred` function, you have to keep in mind that it has only a `prep` argument and should compute the mean response values for all observations at once. Since the mean of the beta-binomial distribution is $\text{E}(y) = \mu T$ definition of the corresponding `posterior_epred` function is not too complicated, but we need to get the dimension of parameters and data in line. ```{r posterior_epred} posterior_epred_beta_binomial2 <- function(prep) { mu <- brms::get_dpar(prep, "mu") trials <- prep$data$vint1 trials <- matrix(trials, nrow = nrow(mu), ncol = ncol(mu), byrow = TRUE) mu * trials } ``` A post-processing method relying directly on `posterior_epred` is `conditional_effects`, which allows to visualize effects of predictors. ```{r conditional_effects} conditional_effects(fit2, conditions = data.frame(size = 1)) ``` For ease of interpretation we have set `size` to 1 so that the y-axis of the above plot indicates probabilities. ## Turning a Custom Family into a Native Family Family functions built natively into **brms** are safer to use and more convenient, as they require much less user input. If you think that your custom family is general enough to be useful to other users, please feel free to open an issue on [GitHub](https://github.com/paul-buerkner/brms/issues) so that we can discuss all the details. Provided that we agree it makes sense to implement your family natively in brms, the following steps are required (`foo` is a placeholder for the family name): * In `family-lists.R`, add function `.family_foo` which should contain basic information about your family (you will find lots of examples for other families there). * In `families.R`, add family function `foo` which should be a simple wrapper around `.brmsfamily`. * In `stan-likelihood.R`, add function `stan_log_lik_foo` which provides the likelihood of the family in Stan language. * If necessary, add self-defined Stan functions in separate files under `inst/chunks`. * Add functions `posterior_predict_foo`, `posterior_epred_foo` and `log_lik_foo` to `posterior_predict.R`, `posterior_epred.R` and `log_lik.R`, respectively. * If necessary, add distribution functions to `distributions.R`. brms/vignettes/brms_overview.ltx0000644000176200001440000017472314571050211016661 0ustar liggesusers\documentclass[article, nojss]{jss} %\VignetteIndexEntry{Overview of the brms Package} %\VignetteEngine{R.rsp::tex} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %% declarations for jss.cls %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %% almost as usual \author{Paul-Christian B\"urkner} \title{\pkg{brms}: An \proglang{R} Package for Bayesian Multilevel Models using \pkg{Stan}} %% for pretty printing and a nice hypersummary also set: \Plainauthor{Paul-Christian B\"urkner} %% comma-separated \Plaintitle{brms: An R Package for Bayesian Multilevel Models using Stan} %% without formatting \Shorttitle{\pkg{brms}: Bayesian Multilevel Models using Stan} %% a short title (if necessary) %% an abstract and keywords \Abstract{ The \pkg{brms} package implements Bayesian multilevel models in \proglang{R} using the probabilistic programming language \pkg{Stan}. A wide range of distributions and link functions are supported, allowing users to fit -- among others -- linear, robust linear, binomial, Poisson, survival, response times, ordinal, quantile, zero-inflated, hurdle, and even non-linear models all in a multilevel context. Further modeling options include autocorrelation of the response variable, user defined covariance structures, censored data, as well as meta-analytic standard errors. Prior specifications are flexible and explicitly encourage users to apply prior distributions that actually reflect their beliefs. In addition, model fit can easily be assessed and compared using posterior-predictive checks and leave-one-out cross-validation. If you use \pkg{brms}, please cite this article as published in the Journal of Statistical Software \citep{brms1}. } \Keywords{Bayesian inference, multilevel model, ordinal data, MCMC, \proglang{Stan}, \proglang{R}} \Plainkeywords{Bayesian inference, multilevel model, ordinal data, MCMC, Stan, R} %% without formatting %% at least one keyword must be supplied %% publication information %% NOTE: Typically, this can be left commented and will be filled out by the technical editor %% \Volume{50} %% \Issue{9} %% \Month{June} %% \Year{2012} %% \Submitdate{2012-06-04} %% \Acceptdate{2012-06-04} %% The address of (at least) one author should be given %% in the following format: \Address{ Paul-Christian B\"urkner\\ E-mail: \email{paul.buerkner@gmail.com}\\ URL: \url{https://paul-buerkner.github.io} } %% It is also possible to add a telephone and fax number %% before the e-mail in the following format: %% Telephone: +43/512/507-7103 %% Fax: +43/512/507-2851 %% for those who use Sweave please include the following line (with % symbols): %% need no \usepackage{Sweave.sty} %% end of declarations %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \begin{document} %% include your article here, just as usual %% Note that you should use the \pkg{}, \proglang{} and \code{} commands. \section{Introduction} Multilevel models (MLMs) offer a great flexibility for researchers across sciences \citep{brown2015, demidenko2013, gelmanMLM2006, pinheiro2006}. They allow the modeling of data measured on different levels at the same time -- for instance data of students nested within classes and schools -- thus taking complex dependency structures into account. It is not surprising that many packages for \proglang{R} \citep{Rcore2015} have been developed to fit MLMs. Possibly the most widely known package in this area is \pkg{lme4} \citep{bates2015}, which uses maximum likelihood or restricted maximum likelihood methods for model fitting. Although alternative Bayesian methods have several advantages over frequentist approaches (e.g., the possibility of explicitly incorporating prior knowledge about parameters into the model), their practical use was limited for a long time because the posterior distributions of more complex models (such as MLMs) could not be found analytically. Markov chain Monte Carlo (MCMC) algorithms allowing to draw random samples from the posterior were not available or too time-consuming. In the last few decades, however, this has changed with the development of new algorithms and the rapid increase of general computing power. Today, several software packages implement these techniques, for instance \pkg{WinBugs} \citep{lunn2000, spiegelhalter2003}, \pkg{OpenBugs} \citep{spiegelhalter2007}, \pkg{JAGS} \citep{plummer2013}, \pkg{MCMCglmm} \citep{hadfield2010} and \pkg{Stan} \citep{stan2017, carpenter2017} to mention only a few. With the exception of the latter, all of these programs are primarily using combinations of Metropolis-Hastings updates \citep{metropolis1953,hastings1970} and Gibbs-sampling \citep{geman1984,gelfand1990}, sometimes also coupled with slice-sampling \citep{damien1999,neal2003}. One of the main problems of these algorithms is their rather slow convergence for high-dimensional models with correlated parameters \citep{neal2011,hoffman2014,gelman2014}. Furthermore, Gibbs-sampling requires priors to be conjugate to the likelihood of parameters in order to work efficiently \citep{gelman2014}, thus reducing the freedom of the researcher in choosing a prior that reflects his or her beliefs. In contrast, \pkg{Stan} implements Hamiltonian Monte Carlo \citep{duane1987, neal2011} and its extension, the No-U-Turn Sampler (NUTS) \citep{hoffman2014}. These algorithms converge much more quickly especially for high-dimensional models regardless of whether the priors are conjugate or not \citep{hoffman2014}. Similar to software packages like \pkg{WinBugs}, \pkg{Stan} comes with its own programming language, allowing for great modeling flexibility (cf., \citeauthor{stanM2017} \citeyear{stanM2017}; \citeauthor{carpenter2017} \citeyear{carpenter2017}). Many researchers may still hesitate to use \pkg{Stan} directly, as every model has to be written, debugged and possibly also optimized. This may be a time-consuming and error prone process even for researchers familiar with Bayesian inference. The package \pkg{brms}, presented in this paper, aims at closing this gap (at least for MLMs) allowing the user to benefit from the merits of \pkg{Stan} only by using simple, \pkg{lme4}-like formula syntax. \pkg{brms} supports a wide range of distributions and link functions, allows for multiple grouping factors each with multiple group-level effects, autocorrelation of the response variable, user defined covariance structures, as well as flexible and explicit prior specifications. The purpose of the present article is to provide a general overview of the \pkg{brms} package (version 0.10.0). We begin by explaining the underlying structure of MLMs. Next, the software is introduced in detail using recurrence times of infection in kidney patients \citep{mcgilchrist1991} and ratings of inhaler instructions \citep{ezzet1991} as examples. We end by comparing \pkg{brms} to other \proglang{R} packages implementing MLMs and describe future plans for extending the package. \section{Model description} \label{model} The core of every MLM is the prediction of the response $y$ through the linear combination $\eta$ of predictors transformed by the inverse link function $f$ assuming a certain distribution $D$ for $y$. We write $$y_i \sim D(f(\eta_i), \theta)$$ to stress the dependency on the $i\textsuperscript{th}$ data point. In many \proglang{R} packages, $D$ is also called the `family' and we will use this term in the following. The parameter $\theta$ describes additional family specific parameters that typically do not vary across data points, such as the standard deviation $\sigma$ in normal models or the shape $\alpha$ in Gamma or negative binomial models. The linear predictor can generally be written as $$\eta = \mathbf{X} \beta + \mathbf{Z} u$$ In this equation, $\beta$ and $u$ are the coefficients at population-level and group-level respectively and $\mathbf{X}, \mathbf{Z}$ are the corresponding design matrices. The response $y$ as well as $\mathbf{X}$ and $\mathbf{Z}$ make up the data, whereas $\beta$, $u$, and $\theta$ are the model parameters being estimated. The coefficients $\beta$ and $u$ may be more commonly known as fixed and random effects. However, we avoid these terms in the present paper following the recommendations of \cite{gelmanMLM2006}, as they are not used unambiguously in the literature. Also, we want to make explicit that $u$ is a model parameter in the same manner as $\beta$ so that uncertainty in its estimates can be naturally evaluated. In fact, this is an important advantage of Bayesian MCMC methods as compared to maximum likelihood approaches, which do not treat $u$ as a parameter, but assume that it is part of the error term instead (cf., \citeauthor{fox2011}, \citeyear{fox2011}). Except for linear models, we do not incorporate an additional error term for every observation by default. If desired, such an error term can always be modeled using a grouping factor with as many levels as observations in the data. \subsection{Prior distributions} \subsubsection{Regression parameters at population-level} In \pkg{brms}, population-level parameters are not restricted to have normal priors. Instead, every parameter can have every one-dimensional prior implemented in \pkg{Stan}, for instance uniform, Cauchy or even Gamma priors. As a negative side effect of this flexibility, correlations between them cannot be modeled as parameters. If desired, point estimates of the correlations can be obtained after sampling has been done. By default, population level parameters have an improper flat prior over the reals. \subsubsection{Regression parameters at group-level} The group-level parameters $u$ are assumed to come from a multivariate normal distribution with mean zero and unknown covariance matrix $\mathbf{\Sigma}$: $$u \sim N(0, \mathbf{\Sigma})$$ As is generally the case, covariances between group-level parameters of different grouping factors are assumed to be zero. This implies that $\mathbf{Z}$ and $u$ can be split up into several matrices $\mathbf{Z_k}$ and parameter vectors $u_k$, where $k$ indexes grouping factors, so that the model can be simplified to $$u_k \sim N(0, \mathbf{\Sigma_k})$$ Usually, but not always, we can also assume group-level parameters associated with different levels (indexed by $j$) of the same grouping factor to be independent leading to $$u_{kj} \sim N(0, \mathbf{V_k})$$ The covariance matrices $\mathbf{V_k}$ are modeled as parameters. In most packages, an Inverse-Wishart distribution is used as a prior for $\mathbf{V_k}$. This is mostly because its conjugacy leads to good properties of Gibbs-Samplers \citep{gelman2014}. However, there are good arguments against the Inverse-Wishart prior \citep{natarajan2000, kass2006}. The NUTS-Sampler implemented in \pkg{Stan} does not require priors to be conjugate. This advantage is utilized in \pkg{brms}: $\mathbf{V_k}$ is parameterized in terms of a correlation matrix $\mathbf{\Omega_k}$ and a vector of standard deviations $\sigma_k$ through $$\mathbf{V_k} = \mathbf{D}(\sigma_k) \mathbf{\Omega_k} \mathbf{D}(\sigma_k)$$ where $\mathbf{D}(\sigma_k)$ denotes the diagonal matrix with diagonal elements $\sigma_k$. Priors are then specified for the parameters on the right hand side of the equation. For $\mathbf{\Omega_k}$, we use the LKJ-Correlation prior with parameter $\zeta > 0$ by \cite{lewandowski2009}\footnote{Internally, the Cholesky factor of the correlation matrix is used, as it is more efficient and numerically stable.}: $$\mathbf{\Omega_k} \sim \mathrm{LKJ}(\zeta)$$ The expected value of the LKJ-prior is the identity matrix (implying correlations of zero) for any positive value of $\zeta$, which can be interpreted like the shape parameter of a symmetric beta distribution \citep{stanM2017}. If $\zeta = 1$ (the default in \pkg{brms}) the density is uniform over correlation matrices of the respective dimension. If $\zeta > 1$, the identity matrix is the mode of the prior, with a sharper peak in the density for larger values of $\zeta$. If $0 < \zeta < 1$ the prior is U-shaped having a trough at the identity matrix, which leads to higher probabilities for non-zero correlations. For every element of $\sigma_k$, any prior can be applied that is defined on the non-negative reals only. As default in \pkg{brms}, we use a half Student-t prior with 3 degrees of freedom. This prior often leads to better convergence of the models than a half Cauchy prior, while still being relatively weakly informative. Sometimes -- for instance when modeling pedigrees -- different levels of the same grouping factor cannot be assumed to be independent. In this case, the covariance matrix of $u_k$ becomes $$\mathbf{\Sigma_k} = \mathbf{V_k} \otimes \mathbf{A_k}$$ where $\mathbf{A_k}$ is the known covariance matrix between levels and $\otimes$ is the Kronecker product. \subsubsection{Family specific parameters} For some families, additional parameters need to be estimated. In the current section, we only name the most important ones. Normal and Student's distributions need the parameter $\sigma$ to account for residual error variance. By default, $\sigma$ has a half Cauchy prior with a scale parameter that depends on the standard deviation of the response variable to remain only weakly informative regardless of response variable's scaling. Furthermore, Student's distributions needs the parameter $\nu$ representing the degrees of freedom. By default, $\nu$ has a wide gamma prior as proposed by \cite{juarez2010}. Gamma, Weibull, and negative binomial distributions need the shape parameter $\alpha$ that also has a wide gamma prior by default. \section{Parameter estimation} The \pkg{brms} package does not fit models itself but uses \pkg{Stan} on the back-end. Accordingly, all samplers implemented in \pkg{Stan} can be used to fit \pkg{brms} models. Currently, these are the static Hamiltonian Monte-Carlo (HMC) Sampler sometimes also referred to as Hybrid Monte-Carlo \citep{neal2011, neal2003, duane1987} and its extension the No-U-Turn Sampler (NUTS) by \cite{hoffman2014}. HMC-like algorithms produce samples that are much less autocorrelated than those of other samplers such as the random-walk Metropolis algorithm \citep{hoffman2014, Creutz1988}. The main drawback of this increased efficiency is the need to calculate the gradient of the log-posterior, which can be automated using algorithmic differentiation \citep{griewank2008} but is still a time-consuming process for more complex models. Thus, using HMC leads to higher quality samples but takes more time per sample than other algorithms typically applied. Another drawback of HMC is the need to pre-specify at least two parameters, which are both critical for the performance of HMC. The NUTS Sampler allows setting these parameters automatically thus eliminating the need for any hand-tuning, while still being at least as efficient as a well tuned HMC \citep{hoffman2014}. For more details on the sampling algorithms applied in \pkg{Stan}, see the \pkg{Stan} user's manual \citep{stanM2017} as well as \cite{hoffman2014}. In addition to the estimation of model parameters, \pkg{brms} allows drawing samples from the posterior predictive distribution as well as from the pointwise log-likelihood. Both can be used to assess model fit. The former allows a comparison between the actual response $y$ and the response $\hat{y}$ predicted by the model. The pointwise log-likelihood can be used, among others, to calculate the widely applicable information criterion (WAIC) proposed by \cite{watanabe2010} and leave-one-out cross-validation (LOO; \citealp{gelfand1992}; \citealp{vehtari2015}; see also \citealp{ionides2008}) both allowing to compare different models applied to the same data (lower WAICs and LOOs indicate better model fit). The WAIC can be viewed as an improvement of the popular deviance information criterion (DIC), which has been criticized by several authors (\citealp{vehtari2015}; \citealp{plummer2008}; \citealp{vanderlinde2005}; see also the discussion at the end of the original DIC paper by \citealp{spiegelhalter2002}) in part because of problems arising from fact that the DIC is only a point estimate. In \pkg{brms}, WAIC and LOO are implemented using the \pkg{loo} package \citep{loo2016} also following the recommendations of \cite{vehtari2015}. \section{Software} \label{software} The \pkg{brms} package provides functions for fitting MLMs using \pkg{Stan} for full Bayesian inference. To install the latest release version of \pkg{brms} from CRAN, type \code{install.packages("brms")} within \proglang{R}. The current developmental version can be downloaded from GitHub via \begin{Sinput} devtools::install_github("paul-buerkner/brms") \end{Sinput} Additionally, a \proglang{C++} compiler is required. This is because \pkg{brms} internally creates \pkg{Stan} code, which is translated to \proglang{C++} and compiled afterwards. The program \pkg{Rtools} \citep{Rtools2015} comes with a \proglang{C++} compiler for Windows\footnote{During the installation process, there is an option to change the system \code{PATH}. Please make sure to check this options, because otherwise \pkg{Rtools} will not be available within \proglang{R}.}. On OS X, one should use \pkg{Xcode} \citep{Xcode2015} from the App Store. To check whether the compiler can be called within \proglang{R}, run \code{system("g++ -v")} when using \pkg{Rtools} or \code{system("clang++ -v")} when using \pkg{Xcode}. If no warning occurs and a few lines of difficult to read system code are printed out, the compiler should work correctly. For more detailed instructions on how to get the compilers running, see the prerequisites section on \url{https://github.com/stan-dev/rstan/wiki/RStan-Getting-Started}. Models are fitted in \pkg{brms} using the following procedure, which is also summarized in Figure~\ref{flowchart}. First, the user specifies the model using the \code{brm} function in a way typical for most model fitting \proglang{R} functions, that is by defining \code{formula}, \code{data}, and \code{family}, as well as some other optional arguments. Second, this information is processed and the \code{stancode} and \code{standata} functions are called. The former generates the model code in \pkg{Stan} language and the latter prepares the data for use in \pkg{Stan}. These two are the mandatory parts of every \pkg{Stan} model and without \pkg{brms}, users would have to specify them themselves. Third, \pkg{Stan} code and data as well as additional arguments (such as the number of iterations and chains) are passed to functions of the \pkg{rstan} package (the \proglang{R} interface of \pkg{Stan}; \citeauthor{stan2017}, \citeyear{stan2017}). Fourth, the model is fitted by \pkg{Stan} after translating and compiling it in \proglang{C++}. Fifth, after the model has been fitted and returned by \pkg{rstan}, the fitted model object is post-processed in \pkg{brms} among others by renaming the model parameters to be understood by the user. Sixth, the results can be investigated in \proglang{R} using various methods such as \code{summary}, \code{plot}, or \code{predict} (for a complete list of methods type \code{methods(class = "brmsfit")}). \begin{figure}[ht] \centering \includegraphics[height = 0.4\textheight, keepaspectratio]{flowchart.pdf} \caption{High level description of the model fitting procedure used in \pkg{brms}.} \label{flowchart} \end{figure} \subsection{A worked example} In the following, we use an example about the recurrence time of an infection in kidney patients initially published by \cite{mcgilchrist1991}. The data set consists of 76 entries of 7 variables: \begin{Sinput} R> library("brms") R> data("kidney") R> head(kidney, n = 3) \end{Sinput} \begin{Soutput} time censored patient recur age sex disease 1 8 0 1 1 28 male other 2 23 0 2 1 48 female GN 3 22 0 3 1 32 male other \end{Soutput} Variable \code{time} represents the recurrence time of the infection, \code{censored} indicates if \code{time} is right censored (\code{1}) or not censored (\code{0}), variable \code{patient} is the patient id, and \code{recur} indicates if it is the first or second recurrence in that patient. Finally, variables \code{age}, \code{sex}, and \code{disease} make up the predictors. \subsection[Fitting models with brms]{Fitting models with \pkg{brms}} The core of the \pkg{brms} package is the \code{brm} function and we will explain its argument structure using the example above. Suppose we want to predict the (possibly censored) recurrence time using a log-normal model, in which the intercept as well as the effect of \code{age} is nested within patients. Then, we may use the following code: \begin{Sinput} fit1 <- brm(formula = time | cens(censored) ~ age * sex + disease + (1 + age|patient), data = kidney, family = lognormal(), prior = c(set_prior("normal(0,5)", class = "b"), set_prior("cauchy(0,2)", class = "sd"), set_prior("lkj(2)", class = "cor")), warmup = 1000, iter = 2000, chains = 4, control = list(adapt_delta = 0.95)) \end{Sinput} \subsection[formula: Information on the response and predictors]{\code{formula}: Information on the response and predictors} Without doubt, \code{formula} is the most complicated argument, as it contains information on the response variable as well as on predictors at different levels of the model. Everything before the $\sim$ sign relates to the response part of \code{formula}. In the usual and most simple case, this is just one variable name (e.g., \code{time}). However, to incorporate additional information about the response, one can add one or more terms of the form \code{| fun(variable)}. \code{fun} may be one of a few functions defined internally in \pkg{brms} and \code{variable} corresponds to a variable in the data set supplied by the user. In this example, \code{cens} makes up the internal function that handles censored data, and \code{censored} is the variable that contains information on the censoring. Other available functions in this context are \code{weights} and \code{disp} to allow different sorts of weighting, \code{se} to specify known standard errors primarily for meta-analysis, \code{trunc} to define truncation boundaries, \code{trials} for binomial models\footnote{In functions such as \code{glm} or \code{glmer}, the binomial response is typically passed as \code{cbind(success, failure)}. In \pkg{brms}, the equivalent syntax is \code{success | trials(success + failure)}.}, and \code{cat} to specify the number of categories for ordinal models. Everything on the right side of $\sim$ specifies predictors. Here, the syntax exactly matches that of \pkg{lme4}. For both, population-level and group-level terms, the \code{+} is used to separate different effects from each other. Group-level terms are of the form \code{(coefs | group)}, where \code{coefs} contains one or more variables whose effects are assumed to vary with the levels of the grouping factor given in \code{group}. Multiple grouping factors each with multiple group-level coefficients are possible. In the present example, only one group-level term is specified in which \code{1 + age} are the coefficients varying with the grouping factor \code{patient}. This implies that the intercept of the model as well as the effect of age is supposed to vary between patients. By default, group-level coefficients within a grouping factor are assumed to be correlated. Correlations can be set to zero by using the \code{(coefs || group)} syntax\footnote{In contrast to \pkg{lme4}, the \code{||} operator in \pkg{brms} splits up the design matrix computed from \code{coefs} instead of decomposing \code{coefs} in its terms. This implies that columns of the design matrix originating from the same factor are also assumed to be uncorrelated, whereas \pkg{lme4} estimates the correlations in this case. For a way to achieve \pkg{brms}-like behavior with \pkg{lme4}, see the \code{mixed} function of the \pkg{afex} package by \cite{afex2015}.}. Everything on the right side of \code{formula} that is not recognized as part of a group-level term is treated as a population-level effect. In this example, the population-level effects are \code{age}, \code{sex}, and \code{disease}. \subsection[family: Distribution of the response variable]{\code{family}: Distribution of the response variable} Argument \code{family} should usually be a family function, a call to a family function or a character string naming the family. If not otherwise specified, default link functions are applied. \pkg{brms} comes with a large variety of families. Linear and robust linear regression can be performed using the \code{gaussian} or \code{student} family combined with the \code{identity} link. For dichotomous and categorical data, families \code{bernoulli}, \code{binomial}, and \code{categorical} combined with the \code{logit} link, by default, are perfectly suited. Families \code{poisson}, \code{negbinomial}, and \code{geometric} allow for modeling count data. Families \code{lognormal}, \code{Gamma}, \code{exponential}, and \code{weibull} can be used (among others) for survival regression. Ordinal regression can be performed using the families \code{cumulative}, \code{cratio}, \code{sratio}, and \code{acat}. Finally, families \code{zero_inflated_poisson}, \code{zero_inflated_negbinomial}, \code{zero_inflated_binomial}, \code{zero_inflated_beta}, \code{hurdle_poisson}, \code{hurdle_negbinomial}, and \code{hurdle_gamma} can be used to adequately model excess zeros in the response. In our example, we use \code{family = lognormal()} implying a log-normal ``survival'' model for the response variable \code{time}. \subsection[prior: Prior distributions of model parameters]{\code{prior}: Prior distributions of model parameters} Every population-level effect has its corresponding regression parameter. These parameters are named as \code{b\_}, where \code{} represents the name of the corresponding population-level effect. The default prior is an improper flat prior over the reals. Suppose, for instance, that we want to set a normal prior with mean \code{0} and standard deviation \code{10} on the effect of \code{age} and a Cauchy prior with location \code{1} and scale \code{2} on \code{sexfemale}\footnote{When factors are used as predictors, parameter names will depend on the factor levels. To get an overview of all parameters and parameter classes for which priors can be specified, use function \code{get\_prior}. For the present example, \code{get\_prior(time | cens(censored) $\sim$ age * sex + disease + (1 + age|patient), data = kidney, family = lognormal())} does the desired.}. Then, we may write \begin{Sinput} prior <- c(set_prior("normal(0,10)", class = "b", coef = "age"), set_prior("cauchy(1,2)", class = "b", coef = "sexfemale")) \end{Sinput} To put the same prior (e.g., a normal prior) on all population-level effects at once, we may write as a shortcut \code{set_prior("normal(0,10)", class = "b")}. This also leads to faster sampling, because priors can be vectorized in this case. Note that we could also omit the \code{class} argument for population-level effects, as it is the default class in \code{set_prior}. A special shrinkage prior to be applied on population-level effects is the horseshoe prior \citep{carvalho2009, carvalho2010}. It is symmetric around zero with fat tails and an infinitely large spike at zero. This makes it ideal for sparse models that have many regression coefficients, although only a minority of them is non-zero. The horseshoe prior can be applied on all population-level effects at once (excluding the intercept) by using \code{set_prior("horseshoe(1)")}. The $1$ implies that the Student-$t$ prior of the local shrinkage parameters has 1 degrees of freedom. In \pkg{brms} it is possible to increase the degrees of freedom (which will often improve convergence), although the prior no longer resembles a horseshoe in this case\footnote{This class of priors is often referred to as hierarchical shrinkage family, which contains the original horseshoe prior as a special case.}. For more details see \cite{carvalho2009, carvalho2010}. Each group-level effect of each grouping factor has a standard deviation parameter, which is restricted to be non-negative and, by default, has a half Student-$t$ prior with $3$ degrees of freedom and a scale parameter that is minimally $10$. For non-ordinal models, \pkg{brms} tries to evaluate if the scale is large enough to be considered only weakly informative for the model at hand by comparing it with the standard deviation of the response after applying the link function. If this is not the case, it will increase the scale based on the aforementioned standard deviation\footnote{Changing priors based on the data is not truly Bayesian and might rightly be criticized. However, it helps avoiding the problem of too informative default priors without always forcing users to define their own priors. The latter would also be problematic as not all users can be expected to be well educated Bayesians and reasonable default priors will help them a lot in using Bayesian methods.}. \pkg{Stan} implicitly defines a half Student-$t$ prior by using a Student-$t$ prior on a restricted parameter \citep{stanM2017}. For other reasonable priors on standard deviations see \cite{gelman2006}. In \pkg{brms}, standard deviation parameters are named as \code{sd\_\_} so that \code{sd\_patient\_Intercept} and \code{sd\_patient\_age} are the parameter names in the example. If desired, it is possible to set a different prior on each parameter, but statements such as \code{set_prior("student_t(3,0,5)", class = "sd", group = "patient")} or even \code{set_prior("student_t(3,0,5)", class = "sd")} may also be used and are again faster because of vectorization. If there is more than one group-level effect per grouping factor, correlations between group-level effects are estimated. As mentioned in Section~\ref{model}, the LKJ-Correlation prior with parameter $\zeta > 0$ \citep{lewandowski2009} is used for this purpose. In \pkg{brms}, this prior is abbreviated as \code{"lkj(zeta)"} and correlation matrix parameters are named as \code{cor\_}, (e.g., \code{cor_patient}), so that \code{set_prior("lkj(2)", class = "cor", group = "patient")} is a valid statement. To set the same prior on every correlation matrix in the model, \code{set_prior("lkj(2)", class = "cor")} is also allowed, but does not come with any efficiency increases. Other model parameters such as the residual standard deviation \code{sigma} in normal models or the \code{shape} in Gamma models have their priors defined in the same way, where each of them is treated as having its own parameter class. A complete overview on possible prior distributions is given in the \pkg{Stan} user's manual \citep{stanM2017}. Note that \pkg{brms} does not thoroughly check if the priors are written in correct \pkg{Stan} language. Instead, \pkg{Stan} will check their syntactical correctness when the model is parsed to \proglang{C++} and return an error if they are not. This, however, does not imply that priors are always meaningful if they are accepted by \pkg{Stan}. Although \pkg{brms} tries to find common problems (e.g., setting bounded priors on unbounded parameters), there is no guarantee that the defined priors are reasonable for the model. \subsection[control Adjusting the sampling behavior of Stan]{\code{control}: Adjusting the sampling behavior of \pkg{Stan}} In addition to choosing the number of iterations, warmup samples, and chains, users can control the behavior of the NUTS sampler by using the \code{control} argument. The most important reason to use \code{control} is to decrease (or eliminate at best) the number of divergent transitions that cause a bias in the obtained posterior samples. Whenever you see the warning \code{"There were x divergent transitions after warmup."}, you should really think about increasing \code{adapt_delta}. To do this, write \code{control = list(adapt_delta = )}, where \code{} should usually be a value between \code{0.8} (current default) and \code{1}. Increasing \code{adapt_delta} will slow down the sampler but will decrease the number of divergent transitions threatening the validity of your posterior samples. Another problem arises when the depth of the tree being evaluated in each iteration is exceeded. This is less common than having divergent transitions, but may also bias the posterior samples. When it happens, \pkg{Stan} will throw out a warning suggesting to increase \code{max_treedepth}, which can be accomplished by writing \code{control = list(max_treedepth = )} with a positive integer \code{} that should usually be larger than the current default of \code{10}. \subsection{Analyzing the results} The example model \code{fit1} is fitted using 4 chains, each with 2000 iterations of which the first 1000 are warmup to calibrate the sampler, leading to a total of 4000 posterior samples\footnote{To save time, chains may also run in parallel when using argument \code{cluster}.}. For researchers familiar with Gibbs or Metropolis-Hastings sampling, this number may seem far too small to achieve good convergence and reasonable results, especially for multilevel models. However, as \pkg{brms} utilizes the NUTS sampler \citep{hoffman2014} implemented in \pkg{Stan}, even complex models can often be fitted with not more than a few thousand samples. Of course, every iteration is more computationally intensive and time-consuming than the iterations of other algorithms, but the quality of the samples (i.e., the effective sample size per iteration) is usually higher. After the posterior samples have been computed, the \code{brm} function returns an \proglang{R} object, containing (among others) the fully commented model code in \pkg{Stan} language, the data to fit the model, and the posterior samples themselves. The model code and data for the present example can be extracted through \code{stancode(fit1)} and \code{standata(fit1)} respectively\footnote{Both model code and data may be amended and used to fit new models. That way, \pkg{brms} can also serve as a good starting point in building more complicated models in \pkg{Stan}, directly.}. A model summary is readily available using \begin{Sinput} R> summary(fit1, waic = TRUE) \end{Sinput} \begin{Soutput} Family: lognormal (identity) Formula: time | cens(censored) ~ age * sex + disease + (1 + age | patient) Data: kidney (Number of observations: 76) Samples: 4 chains, each with iter = 2000; warmup = 1000; thin = 1; total post-warmup samples = 4000 WAIC: 673.51 Group-Level Effects: ~patient (Number of levels: 38) Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat sd(Intercept) 0.40 0.28 0.01 1.01 1731 1 sd(age) 0.01 0.01 0.00 0.02 1137 1 cor(Intercept,age) -0.13 0.46 -0.88 0.76 3159 1 Population-Level Effects: Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat Intercept 2.73 0.96 0.82 4.68 2139 1 age 0.01 0.02 -0.03 0.06 1614 1 sexfemale 2.42 1.13 0.15 4.64 2065 1 diseaseGN -0.40 0.53 -1.45 0.64 2664 1 diseaseAN -0.52 0.50 -1.48 0.48 2713 1 diseasePKD 0.60 0.74 -0.86 2.02 2968 1 age:sexfemale -0.02 0.03 -0.07 0.03 1956 1 Family Specific Parameters: Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat sigma 1.15 0.13 0.91 1.44 4000 1 Samples were drawn using sampling(NUTS). For each parameter, Eff.Sample is a crude measure of effective sample size, and Rhat is the potential scale reduction factor on split chains (at convergence, Rhat = 1). \end{Soutput} On the top of the output, some general information on the model is given, such as family, formula, number of iterations and chains, as well as the WAIC. Next, group-level effects are displayed separately for each grouping factor in terms of standard deviations and correlations between group-level effects. On the bottom of the output, population-level effects are displayed. If incorporated, autocorrelation and family specific parameters (e.g., the residual standard deviation \code{sigma}) are also given. In general, every parameter is summarized using the mean (\code{Estimate}) and the standard deviation (\code{Est.Error}) of the posterior distribution as well as two-sided 95\% Credible intervals (\code{l-95\% CI} and \code{u-95\% CI}) based on quantiles. The \code{Eff.Sample} value is an estimation of the effective sample size; that is the number of independent samples from the posterior distribution that would be expected to yield the same standard error of the posterior mean as is obtained from the dependent samples returned by the MCMC algorithm. The \code{Rhat} value provides information on the convergence of the algorithm (cf., \citeauthor{gelman1992}, \citeyear{gelman1992}). If \code{Rhat} is considerably greater than 1 (i.e., $> 1.1$), the chains have not yet converged and it is necessary to run more iterations and/or set stronger priors. To visually investigate the chains as well as the posterior distribution, the \code{plot} method can be used (see Figure~\ref{kidney_plot}). An even more detailed investigation can be achieved by applying the \pkg{shinystan} package \citep{gabry2015} through method \code{launch_shiny}. With respect to the above summary, \code{sexfemale} seems to be the only population-level effect with considerable influence on the response. Because the mean of \code{sexfemale} is positive, the model predicts longer periods without an infection for females than for males. Effects of population-level predictors can also be visualized with the \code{conditional_effects} method (see Figure~\ref{kidney_conditional_effects}). \begin{figure}[ht] \centering \includegraphics[width=0.95\textwidth]{kidney_plot.pdf} \caption{Trace and Density plots of all relevant parameters of the kidney model discussed in Section~\ref{software}.} \label{kidney_plot} \end{figure} \begin{figure}[ht] \centering \includegraphics[height=0.90\textheight]{kidney_conditional_effects.pdf} \caption{Conditional effects plots of all population-level predictors of the kidney model discussed in Section~\ref{software}.} \label{kidney_conditional_effects} \end{figure} Looking at the group-level effects, the standard deviation parameter of \code{age} is suspiciously small. To test whether it is smaller than the standard deviation parameter of \code{Intercept}, we apply the \code{hypothesis} method: \begin{Sinput} R> hypothesis(fit1, "Intercept - age > 0", class = "sd", group = "patient") \end{Sinput} \begin{Soutput} Hypothesis Tests for class sd_patient: Estimate Est.Error l-95% CI u-95% CI Evid.Ratio Intercept-age > 0 0.39 0.27 0.03 Inf 67.97 * --- '*': The expected value under the hypothesis lies outside the 95% CI. \end{Soutput} The one-sided 95\% credibility interval does not contain zero, thus indicating that the standard deviations differ from each other in the expected direction. In accordance with this finding, the \code{Evid.Ratio} shows that the hypothesis being tested (i.e., \code{Intercept - age > 0}) is about $68$ times more likely than the alternative hypothesis \code{Intercept - age < 0}. It is important to note that this kind of comparison is not easily possible when applying frequentist methods, because in this case only point estimates are available for group-level standard deviations and correlations. When looking at the correlation between both group-level effects, its distribution displayed in Figure~\ref{kidney_plot} and the 95\% credibility interval in the summary output appear to be rather wide. This indicates that there is not enough evidence in the data to reasonably estimate the correlation. Together, the small standard deviation of \code{age} and the uncertainty in the correlation raise the question if \code{age} should be modeled as a group specific term at all. To answer this question, we fit another model without this term: \begin{Sinput} R> fit2 <- update(fit1, formula. = ~ . - (1 + age|patient) + (1|patient)) \end{Sinput} A good way to compare both models is leave-one-out cross-validation (LOO)\footnote{The WAIC is an approximation of LOO that is faster and easier to compute. However, according to \cite{vehtari2015}, LOO may be the preferred method to perform model comparisons.}, which can be called in \pkg{brms} using \begin{Sinput} R> LOO(fit1, fit2) \end{Sinput} \begin{Soutput} LOOIC SE fit1 675.45 45.18 fit2 674.17 45.06 fit1 - fit2 1.28 0.99 \end{Soutput} In the output, the LOO information criterion for each model as well as the difference of the LOOs each with its corresponding standard error is shown. Both LOO and WAIC are approximately normal if the number of observations is large so that the standard errors can be very helpful in evaluating differences in the information criteria. However, for small sample sizes, standard errors should be interpreted with care \citep{vehtari2015}. For the present example, it is immediately evident that both models have very similar fit, indicating that there is little benefit in adding group specific coefficients for \code{age}. \subsection{Modeling ordinal data} In the following, we want to briefly discuss a second example to demonstrate the capabilities of \pkg{brms} in handling ordinal data. \cite{ezzet1991} analyze data from a two-treatment, two-period crossover trial to compare 2 inhalation devices for delivering the drug salbutamol in 286 asthma patients. Patients were asked to rate the clarity of leaflet instructions accompanying each device, using a four-point ordinal scale. Ratings are predicted by \code{treat} to indicate which of the two inhaler devices was used, \code{period} to indicate the time of administration, and \code{carry} to model possible carry over effects. \begin{Sinput} R> data("inhaler") R> head(inhaler, n = 1) \end{Sinput} \begin{Soutput} subject rating treat period carry 1 1 1 0.5 0.5 0 \end{Soutput} Typically, the ordinal response is assumed to originate from the categorization of a latent continuous variable. That is there are $K$ latent thresholds (model intercepts), which partition the continuous scale into the $K + 1$ observable, ordered categories. Following this approach leads to the cumulative or graded-response model \citep{samejima1969} for ordinal data implemented in many \proglang{R} packages. In \pkg{brms}, it is available via family \code{cumulative}. Fitting the cumulative model to the inhaler data, also incorporating an intercept varying by subjects, may look this: \begin{Sinput} fit3 <- brm(formula = rating ~ treat + period + carry + (1|subject), data = inhaler, family = cumulative) \end{Sinput} While the support for ordinal data in most \proglang{R} packages ends here\footnote{Exceptions known to us are the packages \pkg{ordinal} \citep{christensen2015} and \pkg{VGAM} \citep{yee2010}. The former supports only cumulative models but with different modeling option for the thresholds. The latter supports all four ordinal families also implemented in \pkg{brms} as well as category specific effects but no group-specific effects.}, \pkg{brms} allows changes to this basic model in at least three ways. First of all, three additional ordinal families are implemented. Families \code{sratio} (stopping ratio) and \code{cratio} (continuation ratio) are so called sequential models \citep{tutz1990}. Both are equivalent to each other for symmetric link functions such as \code{logit} but will differ for asymmetric ones such as \code{cloglog}. The fourth ordinal family is \code{acat} (adjacent category) also known as partial credits model \citep{masters1982, andrich1978a}. Second, restrictions to the thresholds can be applied. By default, thresholds are ordered for family \code{cumulative} or are completely free to vary for the other families. This is indicated by argument \code{threshold = "flexible"} (default) in \code{brm}. Using \code{threshold = "equidistant"} forces the distance between two adjacent thresholds to be the same, that is $$\tau_k = \tau_1 + (k-1)\delta$$ for thresholds $\tau_k$ and distance $\delta$ (see also \citealp{andrich1978b}; \citealp{andrich1978a}; \citealp{andersen1977}). Third, the assumption that predictors have constant effects across categories may be relaxed for non-cumulative ordinal models \citep{vanderark2001, tutz2000} leading to category specific effects. For instance, variable \code{treat} may only have an impact on the decision between category 3 and 4, but not on the lower categories. Without using category specific effects, such a pattern would remain invisible. To illustrate all three modeling options at once, we fit a (hardly theoretically justified) stopping ratio model with equidistant thresholds and category specific effects for variable \code{treat} on which we apply an informative prior. \begin{Sinput} fit4 <- brm(formula = rating ~ period + carry + cs(treat) + (1|subject), data = inhaler, family = sratio, threshold = "equidistant", prior = set_prior("normal(-1,2)", coef = "treat")) \end{Sinput} Note that priors are defined on category specific effects in the same way as for other population-level effects. A model summary can be obtained in the same way as before: \begin{Sinput} R> summary(fit4, waic = TRUE) \end{Sinput} \begin{Soutput} Family: sratio (logit) Formula: rating ~ period + carry + cs(treat) + (1 | subject) Data: inhaler (Number of observations: 572) Samples: 4 chains, each with iter = 2000; warmup = 1000; thin = 1; total post-warmup samples = 4000 WAIC: 911.9 Group-Level Effects: ~subject (Number of levels: 286) Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat sd(Intercept) 1.05 0.23 0.56 1.5 648 1 Population-Level Effects: Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat Intercept[1] 0.72 0.13 0.48 0.99 2048 1 Intercept[2] 2.67 0.35 2.00 3.39 969 1 Intercept[3] 4.62 0.66 3.36 5.95 1037 1 period 0.25 0.18 -0.09 0.61 4000 1 carry -0.26 0.22 -0.70 0.17 1874 1 treat[1] -0.96 0.30 -1.56 -0.40 1385 1 treat[2] -0.65 0.49 -1.60 0.27 4000 1 treat[3] -2.65 1.21 -5.00 -0.29 4000 1 Family Specific Parameters: Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat delta 1.95 0.32 1.33 2.6 1181 1 Samples were drawn using sampling(NUTS). For each parameter, Eff.Sample is a crude measure of effective sample size, and Rhat is the potential scale reduction factor on split chains (at convergence, Rhat = 1). \end{Soutput} Trace and density plots of the model parameters as produced by \code{plot(fit4)} can be found in Figure~\ref{inhaler_plot}. We see that three intercepts (thresholds) and three effects of \code{treat} have been estimated, because a four-point scale was used for the ratings. The treatment effect seems to be strongest between category 3 and 4. At the same time, however, the credible interval is also much larger. In fact, the intervals of all three effects of \code{treat} are highly overlapping, which indicates that there is not enough evidence in the data to support category specific effects. On the bottom of the output, parameter \code{delta} specifies the distance between two adjacent thresholds and indeed the intercepts differ from each other by the magnitude of \code{delta}. \begin{figure}[ht] \centering \includegraphics[width=0.95\textwidth]{inhaler_plot.pdf} \caption{Trace and Density plots of all relevant parameters of the inhaler model discussed in Section~\ref{software}.} \label{inhaler_plot} \end{figure} \section[Comparison]{Comparison between packages} Over the years, many \proglang{R} packages have been developed that implement MLMs, each being more or less general in their supported models. Comparing all of them to \pkg{brms} would be too extensive and barely helpful for the purpose of the present paper. Accordingly, we concentrate on a comparison with four packages. These are \pkg{lme4} \citep{bates2015} and \pkg{MCMCglmm} \citep{hadfield2010}, which are possibly the most general and widely applied \proglang{R} packages for MLMs, as well as \pkg{rstanarm} \citep{rstanarm2016} and \pkg{rethinking} \citep{mcelreath2016}, which are both based on \pkg{Stan}. As opposed to the other packages, \pkg{rethinking} was primarily written for teaching purposes and requires the user to specify the full model explicitly using its own simplified \pkg{BUGS}-like syntax thus helping users to better understand the models that are fitted to their data. Regarding model families, all five packages support the most common types such as linear and binomial models as well as Poisson models for count data. Currently, \pkg{brms} and \pkg{MCMCglmm} provide more flexibility when modeling categorical and ordinal data. In addition, \pkg{brms} supports robust linear regression using Student's distribution, which is also implemented on a GitHub branch of \pkg{rstanarm}. \pkg{MCMCglmm} allows fitting multinomial models that are currently not available in the other packages. Generalizing classical MLMs, \pkg{brms} and \pkg{MCMCglmm} allow fiting zero-inflated and hurdle models dealing with excess zeros in the response. Furthermore, \pkg{brms} supports non-linear models similar to the \pkg{nlme} package \citep{nlme2016} providing great flexibility but also requiring more care to produce reasonable results. Another flexible model class are generalized additive mixed models \citep{hastie1990,wood2011,zuur2014}, which can be fitted with \pkg{brms} and \pkg{rstanarm}. In all five packages, there are quite a few additional modeling options. Variable link functions can be specified in all packages except for \pkg{MCMCglmm}, in which only one link is available per family. \pkg{MCMCglmm} generally supports multivariate responses using data in wide format, whereas \pkg{brms} currently only offers this option for families \code{gaussian} and \code{student}. It should be noted that it is always possible to transform data from wide to long format for compatibility with the other packages. Autocorrelation of the response can only be fitted in \pkg{brms}, which supports auto-regressive as well as moving-average effects. For ordinal models in \pkg{brms}, effects of predictors may vary across different levels of the response as explained in the inhaler example. A feature currently exclusive to \pkg{rethinking} is the possibility to impute missing values in the predictor variables. Information criteria are available in all three packages. The advantage of WAIC and LOO implemented in \pkg{brms}, \pkg{rstanarm}, and \pkg{rethinking} is that their standard errors can be easily estimated to get a better sense of the uncertainty in the criteria. Comparing the prior options of the Bayesian packages, \pkg{brms} and \pkg{rethinking} offer a little more flexibility than \pkg{MCMCglmm} and \pkg{rstanarm}, as virtually any prior distribution can be applied on population-level effects as well as on the standard deviations of group-level effects. In addition, we believe that the way priors are specified in \pkg{brms} and \pkg{rethinking} is more intuitive as it is directly evident what prior is actually applied. A more detailed comparison of the packages can be found in Table~\ref{comparison1} and Table~\ref{comparison2}. To facilitate the understanding of the model formulation in \pkg{brms}, Table~\ref{syntax} shows \pkg{lme4} function calls to fit sample models along with the equivalent \pkg{brms} syntax. So far the focus was only on capabilities. Another important topic is speed, especially for more complex models. Of course, \pkg{lme4} is usually much faster than the other packages as it uses maximum likelihood methods instead of MCMC algorithms, which are slower by design. To compare the efficiency of the four Bayesian packages, we fitted multilevel models on real data sets using the minimum effective sample size divided by sampling time as a measure of sampling efficiency. One should always aim at running multiple chains as one cannot be sure that a single chain really explores the whole posterior distribution. However, as \pkg{MCMCglmm} does not come with a built-in option to run multiple chains, we used only a single chain to fit the models after making sure that it leads to the same results as multiple chains. The \proglang{R} code allowing to replicate the results is available as supplemental material. The first thing that becomes obvious when fitting the models is that \pkg{brms} and \pkg{rethinking} need to compile the \proglang{C++} model before actually fitting it, because the \pkg{Stan} code being parsed to \proglang{C++} is generated on the fly based on the user's input. Compilation takes about a half to one minute depending on the model complexity and computing power of the machine. This is not required by \pkg{rstanarm} and \pkg{MCMCglmm}, although the former is also based on \pkg{Stan}, as compilation takes place only once at installation time. While the latter approach saves the compilation time, the former is more flexible when it comes to model specification. For small and simple models, compilation time dominates the overall computation time, but for larger and more complex models, sampling will take several minutes or hours so that one minute more or less will not really matter, anymore. Accordingly, the following comparisons do not include the compilation time. In models containing only group-specific intercepts, \pkg{MCMCglmm} is usually more efficient than the \pkg{Stan} packages. However, when also estimating group-specific slopes, \pkg{MCMCglmm} falls behind the other packages and quite often refuses to sample at all unless one carefully specifies informative priors. Note that these results are obtained by running only a single chain. For all three \pkg{Stan} packages, sampling efficiency can easily be increased by running multiple chains in parallel. Comparing the \pkg{Stan} packages to each other, \pkg{brms} is usually most efficient for models with group-specific terms, whereas \pkg{rstanarm} tends to be roughly $50\%$ to $75\%$ as efficient at least for the analyzed data sets. The efficiency of \pkg{rethinking} is more variable depending on the model formulation and data, sometimes being slightly ahead of the other two packages, but usually being considerably less efficient. Generally, \pkg{rethinking} loses efficiency for models with many population-level effects presumably because one cannot use design matrices and vectorized prior specifications for population-level parameters. Note that it was not possible to specify the exact same priors across packages due to varying parameterizations. Of course, efficiency depends heavily on the model, chosen priors, and data at hand so that the present results should not be over-interpreted. \begin{table}[hbtp] \centering \begin{tabular}{llll} & \parbox{2cm}{\pkg{brms}} & \parbox{2cm}{\pkg{lme4}} & \parbox{2cm}{\pkg{MCMCglmm}} \\ \hline \\ [-1.5ex] \parbox{6cm}{Supported model types:} & & & \\ [1ex] Linear models & yes & yes & yes \\ Robust linear models & yes & no & no \\ Binomial models & yes & yes & yes \\ Categorical models & yes & no & yes \\ Multinomial models & no & no & yes \\ Count data models & yes & yes & yes \\ Survival models & yes$^1$ & yes & yes \\ Ordinal models & various & no & cumulative \\ Zero-inflated and hurdle models & yes & no & yes \\ Generalized additive models & yes & no & no \\ Non-linear models & yes & no & no \\ \hline \\ [-1.5ex] \parbox{5cm}{Additional modeling options:} & & & \\ [1ex] Variable link functions & various & various & no \\ Weights & yes & yes & no \\ Offset & yes & yes & using priors \\ Multivariate responses & limited & no & yes \\ Autocorrelation effects & yes & no & no \\ Category specific effects & yes & no & no \\ Standard errors for meta-analysis & yes & no & yes \\ Censored data & yes & no & yes \\ Truncated data & yes & no & no \\ Customized covariances & yes & no & yes \\ Missing value imputation & no & no & no \\ \hline \\ [-1.5ex] Bayesian specifics: & & & \\ [1ex] parallelization & yes & -- & no \\ population-level priors & flexible & --$^3$ & normal \\ group-level priors & normal & --$^3$ & normal \\ covariance priors & flexible & --$^3$ & restricted$^4$ \\ \hline \\ [-1.5ex] Other: & & & \\ [1ex] Estimator & HMC, NUTS & ML, REML & MH, Gibbs$^2$ \\ Information criterion & WAIC, LOO & AIC, BIC & DIC \\ \proglang{C++} compiler required & yes & no & no \\ Modularized & no & yes & no \\ \hline \end{tabular} \caption{Comparison of the capabilities of the \pkg{brms}, \pkg{lme4} and \pkg{MCMCglmm} package. Notes: (1) Weibull family only available in \pkg{brms}. (2) Estimator consists of a combination of both algorithms. (3) Priors may be imposed using the \pkg{blme} package \citep{chung2013}. (4) For details see \cite{hadfield2010}.} \label{comparison1} \end{table} \begin{table}[hbtp] \centering \begin{tabular}{llll} & \parbox{2cm}{\pkg{brms}} & \parbox{2cm}{\pkg{rstanarm}} & \parbox{2cm}{\pkg{rethinking}} \\ \hline \\ [-1.5ex] \parbox{6cm}{Supported model types:} & & & \\ [1ex] Linear models & yes & yes & yes \\ Robust linear models & yes & yes$^1$ & no \\ Binomial models & yes & yes & yes \\ Categorical models & yes & no & no \\ Multinomial models & no & no & no \\ Count data models & yes & yes & yes \\ Survival models & yes$^2$ & yes & yes \\ Ordinal models & various & cumulative$^3$ & no \\ Zero-inflated and hurdle models & yes & no & no \\ Generalized additive models & yes & yes & no \\ Non-linear models & yes & no & limited$^4$ \\ \hline \\ [-1.5ex] \parbox{5cm}{Additional modeling options:} & & & \\ [1ex] Variable link functions & various & various & various \\ Weights & yes & yes & no \\ Offset & yes & yes & yes \\ Multivariate responses & limited & no & no \\ Autocorrelation effects & yes & no & no \\ Category specific effects & yes & no & no \\ Standard errors for meta-analysis & yes & no & no \\ Censored data & yes & no & no \\ Truncated data & yes & no & yes \\ Customized covariances & yes & no & no \\ Missing value imputation & no & no & yes \\ \hline \\ [-1.5ex] Bayesian specifics: & & & \\ [1ex] parallelization & yes & yes & yes \\ population-level priors & flexible & normal, Student-t & flexible \\ group-level priors & normal & normal & normal \\ covariance priors & flexible & restricted$^5$ & flexible \\ \hline \\ [-1.5ex] Other: & & & \\ [1ex] Estimator & HMC, NUTS & HMC, NUTS & HMC, NUTS \\ Information criterion & WAIC, LOO & AIC, LOO & AIC, LOO \\ \proglang{C++} compiler required & yes & no & yes \\ Modularized & no & no & no \\ \hline \end{tabular} \caption{Comparison of the capabilities of the \pkg{brms}, \pkg{rstanarm} and \pkg{rethinking} package. Notes: (1) Currently only implemented on a branch on GitHub. (2) Weibull family only available in \pkg{brms}. (3) No group-level terms allowed. (4) The parser is mainly written for linear models but also accepts some non-linear model specifications. (5) For details see \url{https://github.com/stan-dev/rstanarm/wiki/Prior-distributions}.} \label{comparison2} \end{table} \begin{table}[hbtp] \centering %\renewcommand{\arraystretch}{2} \begin{tabular}{ll} Dataset & \parbox{10cm}{Function call} \\ \hline \\ [-1.5ex] \parbox{2cm}{cake} & \\ [1ex] \pkg{lme4} & \parbox{13cm}{\code{lmer(angle $\sim$ recipe * temperature + (1|recipe:replicate), \\ \hspace*{5ex} data = cake)}} \\ [3ex] \pkg{brms} & \parbox{13cm}{\code{brm(angle $\sim$ recipe * temperature + (1|recipe:replicate), \\ \hspace*{4ex} data = cake)}} \\ [2ex] \hline \\ [-1.5ex] \parbox{2cm}{sleepstudy} & \\ [1ex] \pkg{lme4} & \parbox{13cm}{\code{lmer(Reaction $\sim$ Days + (Days|Subject), data = sleepstudy)}} \\ [1.5ex] \pkg{brms} & \parbox{13cm}{\code{brm(Reaction $\sim$ Days + (Days|Subject), data = sleepstudy)}} \\ [2ex] \hline \\ [-1.5ex] \parbox{2cm}{cbpp$^1$} & \\ [1ex] \pkg{lme4} & \parbox{13cm}{\code{glmer(cbind(incidence, size - incidence) $\sim$ period + (1 | herd), \\ \hspace*{6ex} family = binomial("logit"), data = cbpp)}} \\ [3ex] \pkg{brms} & \parbox{13cm}{\code{brm(incidence | trials(size) $\sim$ period + (1 | herd), \\ \hspace*{4ex} family = binomial("logit"), data = cbpp)}} \\ [2ex] \hline \\ [-1.5ex] \parbox{2cm}{grouseticks$^1$} & \\ [1ex] \pkg{lme4} & \parbox{13cm}{\code{glmer(TICKS $\sim$ YEAR + HEIGHT + (1|BROOD) + (1|LOCATION), \\ \hspace*{6ex} family = poisson("log"), data = grouseticks)}} \\ [3ex] \pkg{brms} & \parbox{13cm}{\code{brm(TICKS $\sim$ YEAR + HEIGHT + (1|BROOD) + (1|LOCATION), \\ \hspace*{4ex} family = poisson("log"), data = grouseticks)}} \\ [2ex] \hline \\ [-1ex] \parbox{2cm}{VerbAgg$^2$} & \\ [1ex] \pkg{lme4} & \parbox{13cm}{\code{glmer(r2 $\sim$ (Anger + Gender + btype + situ)\^{}2 + (1|id) \\ \hspace*{6ex} + (1|item), family = binomial, data = VerbAgg)}} \\ [3ex] \pkg{brms} & \parbox{13cm}{\code{brm(r2 $\sim$ (Anger + Gender + btype + situ)\^{}2 + (1|id) \\ \hspace*{4ex} + (1|item), family = bernoulli, data = VerbAgg)}} \\ [2ex] \hline \\ [-1.5ex] \end{tabular} \caption{Comparison of the model syntax of \pkg{lme4} and \pkg{brms} using data sets included in \pkg{lme4}. Notes: (1) Default links are used to that the link argument may be omitted. (2) Fitting this model takes some time. A proper prior on the population-level effects (e.g., \code{prior = set\_prior("normal(0,5)")}) may help in increasing sampling speed.} \label{syntax} \end{table} \section{Conclusion} The present paper is meant to provide a general overview on the \proglang{R} package \pkg{brms} implementing MLMs using the probabilistic programming language \pkg{Stan} for full Bayesian inference. Although only a small selection of the modeling options available in \pkg{brms} are discussed in detail, I hope that this article can serve as a good starting point to further explore the capabilities of the package. For the future, I have several plans on how to improve the functionality of \pkg{brms}. I want to include multivariate models that can handle multiple response variables coming from different distributions as well as new correlation structures for instance for spatial data. Similarily, distributional regression models as well as mixture response distributions appear to be valuable extensions of the package. I am always grateful for any suggestions and ideas regarding new features. \section*{Acknowledgments} First of all, I would like to thank the Stan Development Team for creating the probabilistic programming language \pkg{Stan}, which is an incredibly powerful and flexible tool for performing full Bayesian inference. Without it, \pkg{brms} could not fit a single model. Two anonymous reviewers provided very detailed and thoughtful suggestions to substantially improve both the package and the paper. Furthermore, Prof. Philipp Doebler and Prof. Heinz Holling have given valuable feedback on earlier versions of the paper. Lastly, I want to thank the many users who reported bugs or had ideas for new features, thus helping to continuously improve \pkg{brms}. \bibliography{citations_overview} \end{document} brms/vignettes/brms_phylogenetics.Rmd0000644000176200001440000002741015053072461017600 0ustar liggesusers--- title: "Estimating Phylogenetic Multilevel Models with brms" author: "Paul Bürkner" date: "`r Sys.Date()`" output: rmarkdown::html_vignette: toc: yes vignette: > %\VignetteIndexEntry{Estimating Phylogenetic Multilevel Models with brms} %\VignetteEngine{knitr::rmarkdown} \usepackage[utf8]{inputenc} params: EVAL: !r identical(Sys.getenv("NOT_CRAN"), "true") --- ```{r, SETTINGS-knitr, include=FALSE} stopifnot(require(knitr)) options(width = 90) knit_hooks$set(pngquant = knitr::hook_pngquant) opts_chunk$set( comment = NA, message = FALSE, warning = FALSE, eval = if (isTRUE(exists("params"))) params$EVAL else FALSE, dev = "ragg_png", dpi = 72, fig.retina = 1.5, fig.asp = 0.8, fig.width = 5, out.width = "60%", fig.align = "center", pngquant = "--speed=1 --quality=50" ) library(brms) ggplot2::theme_set(theme_default()) ``` ## Introduction In the present vignette, we want to discuss how to specify phylogenetic multilevel models using **brms**. These models are relevant in evolutionary biology when data of many species are analyzed at the same time. The usual approach would be to model species as a grouping factor in a multilevel model and estimate varying intercepts (and possibly also varying slopes) over species. However, species are not independent as they come from the same phylogenetic tree and we thus have to adjust our model to incorporate this dependency. The examples discussed here are from chapter 11 of the book *Modern Phylogenetic Comparative Methods and the application in Evolutionary Biology* (de Villemeruil & Nakagawa, 2014). The necessary data can be downloaded from the corresponding website (https://www.mpcm-evolution.com/). Some of these models may take a few minutes to fit. ## A Simple Phylogenetic Model Assume we have measurements of a phenotype, `phen` (say the body size), and a `cofactor` variable (say the temperature of the environment). We prepare the data using the following code. ```{r} phylo <- ape::read.nexus("https://paul-buerkner.github.io/data/phylo.nex") data_simple <- read.table( "https://paul-buerkner.github.io/data/data_simple.txt", header = TRUE ) head(data_simple) ``` The `phylo` object contains information on the relationship between species. Using this information, we can construct a covariance matrix of species (Hadfield & Nakagawa, 2010). ```{r} A <- ape::vcv.phylo(phylo) ``` Now we are ready to fit our first phylogenetic multilevel model: ```{r, results='hide'} model_simple <- brm( phen ~ cofactor + (1|gr(phylo, cov = A)), data = data_simple, family = gaussian(), data2 = list(A = A), prior = c( prior(normal(0, 10), "b"), prior(normal(0, 50), "Intercept"), prior(student_t(3, 0, 20), "sd"), prior(student_t(3, 0, 20), "sigma") ) ) ``` With the exception of `(1|gr(phylo, cov = A))` instead of `(1|phylo)` this is a basic multilevel model with a varying intercept over species (`phylo` is an indicator of species in this data set). However, by using `cov = A` in the `gr` function, we make sure that species are correlated as specified by the covariance matrix `A`. We pass `A` itself via the `data2` argument which can be used for any kinds of data that does not fit into the regular structure of the `data` argument. Setting priors is not required for achieving good convergence for this model, but it improves sampling speed a bit. After fitting, the results can be investigated in detail. ```{r} summary(model_simple) plot(model_simple, N = 2, ask = FALSE) plot(conditional_effects(model_simple), points = TRUE) ``` The so called phylogenetic signal (often symbolize by $\lambda$) can be computed with the `hypothesis` method and is roughly $\lambda = 0.7$ for this example. ```{r} hyp <- "sd_phylo__Intercept^2 / (sd_phylo__Intercept^2 + sigma^2) = 0" (hyp <- hypothesis(model_simple, hyp, class = NULL)) plot(hyp) ``` Note that the phylogenetic signal is just a synonym of the intra-class correlation (ICC) used in the context phylogenetic analysis. ## A Phylogenetic Model with Repeated Measurements Often, we have multiple observations per species and this allows to fit more complicated phylogenetic models. ```{r} data_repeat <- read.table( "https://paul-buerkner.github.io/data/data_repeat.txt", header = TRUE ) data_repeat$spec_mean_cf <- with(data_repeat, sapply(split(cofactor, phylo), mean)[phylo]) head(data_repeat) ``` The variable `spec_mean_cf` just contains the mean of the cofactor for each species. The code for the repeated measurement phylogenetic model looks as follows: ```{r, results='hide'} model_repeat1 <- brm( phen ~ spec_mean_cf + (1|gr(phylo, cov = A)) + (1|species), data = data_repeat, family = gaussian(), data2 = list(A = A), prior = c( prior(normal(0,10), "b"), prior(normal(0,50), "Intercept"), prior(student_t(3,0,20), "sd"), prior(student_t(3,0,20), "sigma") ), sample_prior = TRUE, chains = 2, cores = 2, iter = 4000, warmup = 1000 ) ``` The variables `phylo` and `species` are identical as they are both identifiers of the species. However, we model the phylogenetic covariance only for `phylo` and thus the `species` variable accounts for any specific effect that would be independent of the phylogenetic relationship between species (e.g., environmental or niche effects). Again we can obtain model summaries as well as estimates of the phylogenetic signal. ```{r} summary(model_repeat1) ``` ```{r} hyp <- paste( "sd_phylo__Intercept^2 /", "(sd_phylo__Intercept^2 + sd_species__Intercept^2 + sigma^2) = 0" ) (hyp <- hypothesis(model_repeat1, hyp, class = NULL)) plot(hyp) ``` So far, we have completely ignored the variability of the cofactor within species. To incorporate this into the model, we define ```{r} data_repeat$within_spec_cf <- data_repeat$cofactor - data_repeat$spec_mean_cf ``` and then fit it again using `within_spec_cf` as an additional predictor. ```{r, results='hide'} model_repeat2 <- update( model_repeat1, formula = ~ . + within_spec_cf, newdata = data_repeat, chains = 2, cores = 2, iter = 4000, warmup = 1000 ) ``` The results are almost unchanged, with apparently no relationship between the phenotype and the within species variance of `cofactor`. ```{r} summary(model_repeat2) ``` Also, the phylogenetic signal remains more or less the same. ```{r} hyp <- paste( "sd_phylo__Intercept^2 /", "(sd_phylo__Intercept^2 + sd_species__Intercept^2 + sigma^2) = 0" ) (hyp <- hypothesis(model_repeat2, hyp, class = NULL)) ``` ## A Phylogenetic Meta-Analysis Let's say we have Fisher's z-transformed correlation coefficients $Zr$ per species along with corresponding sample sizes (e.g., correlations between male coloration and reproductive success): ```{r} data_fisher <- read.table( "https://paul-buerkner.github.io/data/data_effect.txt", header = TRUE ) data_fisher$obs <- 1:nrow(data_fisher) head(data_fisher) ``` We assume the sampling variance to be known and as $V(Zr) = \frac{1}{N - 3}$ for Fisher's values, where $N$ is the sample size per species. Incorporating the known sampling variance into the model is straight forward. One has to keep in mind though, that **brms** requires the sampling standard deviation (square root of the variance) as input instead of the variance itself. The group-level effect of `obs` represents the residual variance, which we have to model explicitly in a meta-analytic model. ```{r, results='hide'} model_fisher <- brm( Zr | se(sqrt(1 / (N - 3))) ~ 1 + (1|gr(phylo, cov = A)) + (1|obs), data = data_fisher, family = gaussian(), data2 = list(A = A), prior = c( prior(normal(0, 10), "Intercept"), prior(student_t(3, 0, 10), "sd") ), control = list(adapt_delta = 0.95), chains = 2, cores = 2, iter = 4000, warmup = 1000 ) ``` A summary of the fitted model is obtained via ```{r} summary(model_fisher) plot(model_fisher) ``` The meta-analytic mean (i.e., the model intercept) is $0.16$ with a credible interval of $[0.08, 0.25]$. Thus the mean correlation across species is positive according to the model. ## A phylogenetic count-data model Suppose that we analyze a phenotype that consists of counts instead of being a continuous variable. In such a case, the normality assumption will likely not be justified and it is recommended to use a distribution explicitly suited for count data, for instance the Poisson distribution. The following data set (again retrieved from mpcm-evolution.org) provides an example. ```{r} data_pois <- read.table( "https://paul-buerkner.github.io/data/data_pois.txt", header = TRUE ) data_pois$obs <- 1:nrow(data_pois) head(data_pois) ``` As the Poisson distribution does not have a natural overdispersion parameter, we model the residual variance via the group-level effects of `obs` (e.g., see Lawless, 1987). ```{r, results='hide'} model_pois <- brm( phen_pois ~ cofactor + (1|gr(phylo, cov = A)) + (1|obs), data = data_pois, family = poisson("log"), data2 = list(A = A), chains = 2, cores = 2, iter = 4000, control = list(adapt_delta = 0.95) ) ``` Again, we obtain a summary of the fitted model via ```{r} summary(model_pois) plot(conditional_effects(model_pois), points = TRUE) ``` Now, assume we ignore the fact that the phenotype is count data and fit a linear normal model instead. ```{r, results='hide'} model_normal <- brm( phen_pois ~ cofactor + (1|gr(phylo, cov = A)), data = data_pois, family = gaussian(), data2 = list(A = A), chains = 2, cores = 2, iter = 4000, control = list(adapt_delta = 0.95) ) ``` ```{r} summary(model_normal) ``` We see that `cofactor` has a positive relationship with the phenotype in both models. One should keep in mind, though, that the estimates of the Poisson model are on the log-scale, as we applied the canonical log-link function in this example. Therefore, estimates are not comparable to a linear normal model even if applied to the same data. What we can compare, however, is the model fit, for instance graphically via posterior predictive checks. ```{r} pp_check(model_pois) pp_check(model_normal) ``` Apparently, the distribution of the phenotype predicted by the Poisson model resembles the original distribution of the phenotype pretty closely, while the normal models fails to do so. We can also apply leave-one-out cross-validation for direct numerical comparison of model fit. ```{r} loo(model_pois, model_normal) ``` Since smaller values of loo indicate better fit, it is again evident that the Poisson model fits the data better than the normal model. Of course, the Poisson model is not the only reasonable option here. For instance, you could use a negative binomial model (via family `negative_binomial`), which already contains an overdispersion parameter so that modeling a varying intercept of `obs` becomes obsolete. ## Phylogenetic models with multiple group-level effects In the above examples, we have only used a single group-level effect (i.e., a varying intercept) for the phylogenetic grouping factors. In **brms**, it is also possible to estimate multiple group-level effects (e.g., a varying intercept and a varying slope) for these grouping factors. However, it requires repeatedly computing Kronecker products of covariance matrices while fitting the model. This will be very slow especially when the grouping factors have many levels and matrices are thus large. ## References de Villemeruil P. & Nakagawa, S. (2014) General quantitative genetic methods for comparative biology. In: *Modern phylogenetic comparative methods and their application in evolutionary biology: concepts and practice* (ed. Garamszegi L.) Springer, New York. pp. 287-303. Hadfield, J. D. & Nakagawa, S. (2010) General quantitative genetic methods for comparative biology: phylogenies, taxonomies, and multi-trait models for continuous and categorical characters. *Journal of Evolutionary Biology*. 23. 494-508. Lawless, J. F. (1987). Negative binomial and mixed Poisson regression. *Canadian Journal of Statistics*, 15(3), 209-225. brms/vignettes/me_rent3.pdf0000644000176200001440000013306613252451326015450 0ustar liggesusers%PDF-1.4 %ρ\r 1 0 obj << /CreationDate (D:20170908174613) /ModDate (D:20170908174613) /Title (R Graphics Output) /Producer (R 3.4.1) /Creator (R) >> endobj 2 0 obj << /Type /Catalog /Pages 3 0 R >> endobj 7 0 obj << /Type /Page /Parent 3 0 R /Contents 8 0 R /Resources 4 0 R >> endobj 8 0 obj << /Length 42286 /Filter /FlateDecode >> stream xKtKr7?Z1EۂȀDH= 2Dk܇%ѧOt[k̈'OۿOQox[VWZ?_k97~~KʘgV~_~'Ͽ\oپ_w5ϪZy_g_H?˯|ߚzh_ySLg_ ~s> ı$~Mq֟M=ׯڿ.\^Nרs>r9wr3Zz9_9QW_k%~ 3c֑1}]戼J ߞsSWn?'p<wfgi #/kwug?~lu=-ۓVwOv-slOݿ&8?"nQ?_]yTnşWk2jyٲ]7!9lf޼;?bf8wu;tiztKvU'zn>X?sLJ[2qe8r~?Mqn^xe30&cb2+2ӷw7ۣGts[B|kn8WS5tsf qBq/MWqkom?Vf'?zܗ6fz>\=r=%`zdiISد 2QbEW$[W4y/ʣzğ%bɣ7Fȏy)+A}:}8F1u{ݜ,WW KH-Od(%Н< /P0ECl(_ StRe:} t52B_PIbxn](WNeR4r=PG4r=Z&.霟G5=O,0еa;v8/BqzϳsݗwuX ~#ʫ=a?c]VjV w]!ͣ/h1+{`0ܙ+i%羴ǤX,uSN|46 ٯ-/f*cy;m@q3.^n ߬pR&{Y\g۷S|ܯ=ngW]K7{Wq=8 =&&C&GMp7ol/8 !l*.sw3M=Z Y yq-h9hcæΖşBT}|[İ#5¦|>-ʂ뾃LokbL3abIFG5ltdbAEGl'&Tt`AZ\`b =Nax“3X:|,11Ȁ^ok;95nAX28?Tg#Z"3 4( tQ}^xeDh~ tfX-5XgspM7^c0,w{k}F@ȶ'=/JGRG2apI4X"myN)z}nȒI_NA+K[ǀ@̀+na\摒'pJMB8 8,OQ Fop(/rd߯ed c*o#'>6Fݏ<%ö=c7e X_cY+Ŵ'C^[fWh;ܲw #Y`iqyGI. H!8Z.^j󈯡?b~|R=JR%}~rCv?!JL 8ʴ_ #MgO<&1vE.8*\HgAʿ[fd h` rdcBݐ^ i\˿GdԮ6]e3k#kq-g- 8W}o ԭ,.e@6u C3~CM6 u&Oĩe#ϿxqS `t0J68l\h,t'\d{~<6wm>d4ot綀p%l #u8b2[) ʐJ% >:LA&;2+1`SY~ VT!A;2~ȏx^dȀ`,Fl? B2 :&2ȰdrFlPf Lud&PUk[u u`l>L" 3)&7]_&C-UC)W(`&c' a2GUdZQ^hld}090H-rə\G3qH :4+"p ɼ഑'lAJXh(9㾄=$@…|b?il ޠu?#hbEb7C`F`Ha ,הw>{TF̯ Z|nI;cyR~?;`D#[Ȅ5Ö׭$ZVJ;_n-@?MJv+!1znSU< 'm'6~ѭB"КB=H= s`zKMT ]="iFBaI[y+D *ttT9=(T^z !! M4[y&DCiVUg~G4AjGisU&HCM)9ҏetUiTp4=_ytI?-NH^ v+$~ݖIVK\?3TOvڷ*2~lfd{ Zse O恙 -ou0 04-f׌=[wp<*Y(#,Tq'X Yibs瞩Fzy#gM0 ƨi$؛^X "b;};#l!q$yvq>]Î8qa]faI;T+/CV]|!w: = B* n/0>hkLV4NwVWVM4.Hj"#XhNUU-yp5|-3|{4,UVVoUR{dV*kX-ͪ҇))p CHjl)USa5)Mj s; Vן+7,%K'X5;*~ʮ:}mT<15t<0S˪H5N-&@@A*~TSE5Uܶ\ HYSlFmL0'"h쩥Pki~ ~SN`,PR+t[~AtDp KnKrTNzVtS{>p?2i/88ޘne=C "8'UMZ,ZTv %Û2A֤IdM#ư$$fYSb5{ ZLZT(Z'Zg֢vD&^D\Pk +BJ C"Дm|j\F! -6TFP_&" wT"tQP*fO"A" [؞)-z u& Y'Mؔ^zF@#ĶTDb8+6U$6 x?Kl6d%uO۲[RFl0[A<$."%0[o'C{ Hֿ=Ba$qeYtLb*3'MbElGĦGNhcPs4\_ІUUq=ЛK^׆w:&{~Σ.77|ňކץ-6<(M冗鬽yw\,`9`9,=N<d ; ;aS<Uyz ;/ C$7{;8yu ;gź-opVr>Rsk\:S7A7=x%b*l"dϪeBlBvf!{#2"cϷo3 Ի213سFv=O˨ "FЅxgJ{W"D®zw"aH JD^4ve{hXA HأHxdzA2 򭯷$7hHQ!ЌyoB*!P[9p((G ._!pAHM$T7ok yCD?1#jɠfm>a(9&Oͭ2$ΐ0/׺Wzv $CzcC&.=}͒b.Uo𺳀 ߄]BX cxEZ6r6 #nQ[>](9: %BIE%%@IWANw``S߄+[M6=Q`YL`!E%K l#T$ڮt`p(鐻"`90` f«wO,5{`Pk%h >aI`9g $vXf%Hk=[/=Xz%Ilf۪\+ .I6Ev>Tq>$;@U` d-|kb APucB$IF,߶rΧxgpH2+I@1$֎j:$N؊f$I> p$66QkFHFm6?!56IzFFDGML(F]$˨MLQ{Vu5&$Ȩ$`R!TqfQo1+KF vM1bԡAF1 QuJ:՟JFU?u߁i6biuaO2O;ȨO:>pA8E f(~^%~D{,:C??/ ~(v;`W,Y<*E2؝ ~'`=IA?6P*3D ~5;uG?[s=1%CďL#H2lDISe.?/?L '#,8sIǎn#+%H2U}B@NHZ }N`N?wB庀(1t0E`k*FhkѩE wt(5oWDηI詑)#hjL? E#\PGE{hDIzBͰc(г儢QHUF-c US(h[((O7^c~d`Csk~Ѐ(:2+ o}Ę>葁2DѡVL(_pQUw&(:4ٞ(:ECTh\/Qtd:DSjVEsWE@)h|?Q&%(c 1؁^DѡVq: %#Z K( qs"&ՠ$Zυ]Έ]DϮdC&UkPTs𨣧gS㱡*S㲉K㵉K5DE"\m0O4AT h#Н^!@C ݌5BC[1wJ@tbzcV4U>-CgO#*UN,HQ CI 7C"f?ˉ&]0f9?0F3nQY09NC"gM"ДS|H1 aF!sޮ'ct]$0cqq5Y $HgĞ ep"A"X#$c6ZXG +j7 ɘbr1'/ 1b{l[=Ō0yPFgMپ2f1U(A>e<12'Ę[)|))L& c*L0<0&4+Ǧ1GS'SUgbL51p P6\*F1RbLTNH2s1#I 'c.i29~ǘ NJ1猩^1(ŘcYdiGƌL2fTm1dL71ɘ#Ɯߪ̡Y1Ve\a*1fOɘTVK 1Xbʥyh c ^2fCN2LD2Llp%sp!WU]SNdY 9:,|~ɘSU2e&SZݟ4 `UΔ9_s_Lw0g_~ ϡ{996dx[ŲdL?͹\ n΂7q,9, v1ysshp!o:p&1=sXV,ݸǙtfBPQ8࿌y(?0`<`RdyD[o)ɠTc"=W?da/$.u*O`dYj3s.HDY̭M( YV8WJ}W0xSGх>_Lɒuu%&P@gO ZH:зF/%Y;gPr#Jv6pyPs |@^*`bPp %ǧO T .ʱRM݉%cLvI8cETGȒ*vM= "vK6Sdf9RcÎSoX%uXR[KnKnXr& KU=dɩdɩYԸZ_Jm%MASd:XKNr$K%gKV}{gs%M~{qe`:~w KNu%P3,9,9uYrfgbySɒS[0#,~#&FdYxȒp\]NvUf~q4dG p}W&KjxXR7c=JKĎ[W&b9@쨎3:Ďv14GvvWZ'캧/Dv٣sUdGZ1 vCVdo5\y:q>& hEvΎ8xOCIǶT6r";?1츱b@N+vVanD 9o,:"dy|h CH澞 2M`d4X0`Gd*#z;2 U:4e7 vbp}Q߉9;`GFh ;w숌-?E0"ΑDz!*#a;2bǪ[`GFy 7ֆ|HUl$FLW0\Qv1ܸ:1"z6{58 7Gz'0P85a62Gx9ʹ,d¡`62bWĈs$F\bD}1digɈ512Ĉ:D11⸧:#*g+FT11bDuɋudQň%F*+&:!L8uT5pj<30Zv0.>#Nw%~2EńCLB1RLqb}T/b Lm99L8}#C$&ߺ[Vq1[_x=L Yz]~s&܉qAo5 n[D7+FyO #~ !ȕ-79.~2pnRpE缑afM:S7-=ϴf{ؘ/~#?, sB\߀!4gH߈M0qN`^~ =k<870'N4DM(s&g&o@A e)o&V9CF9]7D؈ aVX$mz% vv#/M7bzwJ&w, OǞMh-gT/`F 2\O QlɆ ;t#E  P(ӵWPpjD[8E1`wS~KQx'4zgZ9mZ)wmHK~?K(n .Ҷ#90Då#ሂK+Rx(hUoy$%jMofrǥ;Kc WahG N! z*_DťrJ*+ˁKIF@ T\^@T\Dŕ40ZyHHhڕt Wy t\hBt\:mt:q4=G\J\QI\ %f% %WVy#P^\ W6vz%:8>dn&:zF8踊N?]?DUߥfc=­DGY=z):.?x1IzE zI#b=z"F@1vN; Gع~D] gb+$N!LB\O")B^mC*ByD$ĮbNBT1w: bMbJP=6u&q(_"GbDKzG}vosBXl10xqwv#H#/s{&zzIgd|&"Jd!1AzHOQnz XKxzH _2ggu}\}Mh,zҺ@;B㊎#wځ* =ozhGJgVa%Q RQ. Ýډ; M ӗ6 @ѰXe`9PbYU)z~_E oٱ6A1!b9R"˲@Y8|})\#O^oYNؑph #%ד=%-,r#38'X8u&)qV^ MZ&JT.1.Fj3"%x@+jH@3Rc{TPYH(2R)Q^ 5LJ\QkiJ%qHq753L+MJDK_{پo;!qo#K/%nM5$%b>ԥ#s8(qgR"9%>߶]Iyi-nN"w55Țu.qsq>R?M$EnM$EnH[eȭ2PR֙uH1(r'>H['>"w%"-c8#)RSE¢zvF鎐8kb;{LHGXѳ""{7h*COVbxB+\IT 큨Y!c,6yš`1F5ɁE72Ƅǭ!aqg+{vaqG!ny#,n(y[5ǭqrqOq78u. q(x,{×f Q 9)ᑀG u@`q+L8,z^W}ɽ^wKE,.$aQ!Sf=Я__`qq*aq|{^btBroMՀEs!w#|Bڄݸ [3OoV}-qYr1u朓K*b<+Ⱥl`ƌv0<֟O( DV݁l{A7UpS_$hY:#fhY8J{9o 0KX#̗c?UܱH48⎆U`;7_n2KmѲhL Bc2&40p ⎁N8!ܑ1WAfa@.wp@fYg8H$qG84cΦ24,@cN Ef;z_ -6Q$Иi?K_ Sd, ^<eh; ʹ"ǮJaXġB !̎1{ +,]t5Z@ݺاߋDڸQB̲`7@ 1'OŁ:p avfR!c3i.C51HCaT璪bΨ#Ypf)ICǒkk1,%2F ?`r `GvfpaNI3t73 &;j| R.~a}F;%=9,`#yZmtKXǍ7;'mk`3 v̧ d݉a.`m:*4ŽHp5E;Q,;+Ǩ Xv l cXjvGjp?ia:202\0|K_d$6qxelRgaxL԰i^N L~5ZO &\EHEDaC1|klœ e̲T06?d$q l gN*5&gR$Nj 0\,Il@ϵT03WF ,m? Mp鬅K:ʳ'A߆ְTK KœjedyxL"{9"LLfG$&ӻ÷eIlMfy9DO[&3Q6I&qkVyLP(.)i vܗW 'ՙ$o9>OIIR6ḠЙ}ET=۳O%\5$ؾ?xPV䃫3BI"CJJg6M\D>$oh 5J=$~' ʅRP0]:sYJWJN}$Ƽ]%Ix!$)*Ox( Z%4ZwqQCXJpw#@\WI}g~zh 8aB+R2"˫~%qKhEńW+V~׈mߥ~r7(H^XHҊTC~,:6]5yz+TUT,$DuFv"ʕ`pY芫PG!!FR\CH[#b(.;ʊc.Ub͡?ѥR\ԁ#FFc~tc]*g-{XqO*WTJOɡc P\r3vӣg*d0;h }CmU8 䣝+}"DXIt&hJdT>avAw׾D lnڛ rCvwQ'±}TǣW?Om$oqio[埿-D[sV^J%{=U!>o?'?? ?y18w4??kk'?/8Ÿ?ϋ]gğ=sJ?Im>vCϱqǟCƫzZ3^>|u>8Z"J3/ׇd;lstƋt׻gu$:Ŀ3(Et1 Z_w~ޫ/Ϟ%w[f/M/׏Y7Lg-7S|? ˏ'eݽt7X=B+i{?ǫYw, 2&A7~|?[oy |Z>Ǟz8Ŀ3)^z:D7P~ߑwq}G}7}dG mRxxR|GR|GR|GR|GRS]˟⍵ vl?;|IaLH/Y9wש_݋mbZ&)axi<A){ۓ7ٵ |19?Yx}(}m~ z,絘 W .&gH }ك˸OidfufџAr]C '@ y!k{kblLorc\sk**~&8=ݫVᶁN\Sq}}k xyLOe6dLO !5z^<+kZ-k}`(QY{L)g غ<7]g_h]ujc],eu&:%{+u3Uors-OZ ֿ'c4JaML>a#/>7~F)l[7|hܞ&}, @'>!:GJC{)l 'o0hu >jS>Wftµwu b*l݋Q>9h]3[@&o>i J7|-#[/H Qxy"z[}Z?+fzݢzl868%=g?K}YNcC]G׼NCZϸoi}x\sڈ>O~^Ҿ| zzƾ/麌}ϑ"ZuyWz(O 9&gTlk|mhX<^5lC& j&RCM)|~ ab-%ȡBOy9v>qҐlzNE =UU@&1;Vz65i1w1̳=g}_~j]:~*޹~Tu-bې5UC+\ =ǡ~Z?x:s ֯ݛhMvGq?!=O=;؁z{JJo/hn7 =[>I<˘χmyL˞MЧp=5%8;#=Ygiր)5&gvm, =-f`]kNԐ =͙g\Ž9甴Fv9I q։h1gnp]屴ɓ̿~zCoP'GcWw2ʋz.>5-7vL!]<2bZb xؙc93ryYl1J(Hd)g * [[AW䊂ϭdPqb+(* .ejq.Kx0>GΟGC؃~: ZFEح̺$٩awyE/<43G Zڮ*11I8ݸz]ks=4/8Mqlkk܏a׸[~h[h߀_w6îOiI}vMv}">:Et[v|ˎnw ;(;QvN7~!GyhwI-o^_=IO!MKP^PP' 8Fv^NAS/6𮳉۾zLof@%Ќd^4-EN(70I$C *, <0-,,rVd8BаЍKD4ЊÊMC+%A \ib$m;c \{k%N H] Y䤈 -V|Cqd,r Ef== ܨd<+h\OU1P6Kך>}"!}85S#mv?J?SD౞Sč2Е;* ߞ/CןcŪ~酙y^ĉp.ĤO6镕芌R3N<O=?=ws^QT"sapa2BeŅll\q?S9P(q2BeāC\H䐲 K_ 09PDȑa~QRpV 9PxrH$|oqnQC8pde6Fȁ<ج|fXXm?NhyEAX8P&WtǼ7VҊ'c~Uj~BG(96BhU`Cx{Ǘۓ쮠S=?3{R`nN8:5E/bz^R|&ޗNE^h/"e}]Rm^QWI#C{VE{MQ+^FOvK.Co e6Mj<:O)5z =׿5ζv-p*걞raF}7wDD\oA]iWy*. v-v];Hݡ(%iw A$rӭgx}SGܷ<ҢE,ep8\ ~Š X,%KAMz՝ʀlҭ tGI$%ҭ@8+=}I07VU۪lU:p{xNU-鶉nCo!vюL8!Zu>.c7ދN)X0VχV -G&Z`ciuŰb=?9*HU-/\ىsLEx=V*,o6%)Ex2u0VyF3[LŴdجL0lr0Pa b6`1Df:i'dLy'Cd2G,L;#\ 1IA3_0t0,}`,fbuVď S+[0s0lJC psAS39&#s re.  f^82X"+_WGyǦJ] Ff &^8'߆```3b^ڼ3?Z-^hyΗa{D>zc|}1i08.VD%N  d$1V3L qފ|n2jʩFdT2o#"ԏH/JL=qTĐ`o è}I1؟x?P+PoP|E\0'e0'{D-1{D%A2Ȳ<񲨖mKv0P<=g.{(bOes+b/bf2"blJ>0Z*>MN*Mތɢ; M_ZBs.0IEk4?E{L*"K@@{vR /WVA ~{Ov:UϸMiBB!kT2>h/t[ Dp2њ:k{QhMWк>mL 2MBVYMq*{u?p%c,BWbuXB{ [>ӽu`[г>IKow*n,: P_(Vj@ j´߆"c2™r*\ JPyr8BEІ\UUUOFU"] W5h؞@:}Bc *ҕD Mc.*"*t+**]BrP`hP {Uh MWaj,*(-Waj ]2]DWa *o2b$n [t\b S aLb i~~^o݊(69cQkSI 0:L֊j63}=|r AS2\s`I.wba/e=pF\ʹ&{,"1nqCľ^5/H]iܪg/PT86Em/f>Ckǡ/ R%jfݪJj/ jzkN_3%bA7cLw^D.*RD}z_D.AP_D.A8mo}\E#hR2iR.Mpg7@%- B )O { (:J*:?BrO}{D] @(s96_ȕM({\ Na,tK<>O.\"$ @<t.7'\ oOh7!u1bͨ.\r1|\R1dԗ1Pjg= fYpbLv˥7ƔL^O]o{N>\RL"W*?.wˬӇփ/ǥKzׅKI ~"ȥtzayCuGIOJ ^ 7*?4 k_d +KBS_eߐ7o.KM,CutYޔeerIpYBpqY#tYˢd,Q1Deȅ2>7$72]I%tY*~oP_\?25.ZzeˢjrY],*,~eQ\54 cL \eoeQ=5cSg(StQ-Lq̆\x4]Ut4WՄ9?S"(S"((5eFy9R$[wYxg,rT,y`gJ9eڋlTG"eF;\T-~T3_V߀ 3>JҜN(JGh)IKYQ2o$}q%} Ƣ5 >JfNI+VQgH'9(3IeU#)QNaӆFEtJ.V$(VRnCwT:Ӆ#CCEW=8ڟ [H WNITcs8%Ćp蔨N"Ž*)ir 67p.7[5ه3_popr`6D6!!:'EΈiGsf\9#U9CrNYj%s!ɻp z^ 8?F\u~9PpFJ97kcT>v:#Q*1SϊY4 2jR8?Ǽsɯ9IU/ gItF|:#[&.oO`L9'840aMuv0~|:;(Mުϯp)|#/ʵg'cHG8;͟yΎwU>Mј72/i2Flݟ47uJm(83r)”El=}v,QL5QKZGz9S Fșp؜SW!dgȏV79T>Ky^tԋViXΔ@y`P;hY I!S6عExaճsyRW̺48OSt۫G7`?34 9 `*Giȷ9̇1xV3Qi*#˜ tONMs2coC|LҞchbMzK‰"QxKI}:$xKY-u wReJR&ã4Rouio \y}}8hޥ(G3|8xK*nit&Ly/[*2846 /RcV5=N۶=gr^,χѬ`VVC$iQ&/M^H^xeE%C^SSS).j1)5 Uh2?Z ^E9I!ݔZ/-r|{0zMu^[W|SP򚊼W@Uu55Fc]*EL땁JRC3 z0zMI^ŽåD-/L^Rl0r'0yI}ӻ/ BA^CKhe^/ !ueB/'aPxaփ0zacy>xzM x  免 I^ؘv,/l, 6免%/ ^Gz{;&3x3^XAIx]E'Bs$tx^=(8:\^(jY$/opԨ׫MUIE)]I^ސF/o< FH!DJukTUI^Rxu BSTA^ЁVNEMvC?Pͬ(([TT-;u, }>c)}Pa/f2Y5)n^,(`Nn^Tș^oT;.ih|zu&CE+W75L^h\zu&U|&MA2'yu>yu'NU&WW@Dʎ^]ҫũ[^\ezqjo^V@.Ꚛ55bЫC!.âWQ~0(yq]8+W'W-yuq(: W삼mSU(M=uGˋ[d?yq ^{qӆ-=-Q+KX]U K 10l ,_HϮ\m77j#UZUU{f,I(NDqRU#^@qMm7m%XG @8WY%{{TKr^\PK 'YO5B,I倰MUm]m\R܅{dkZlFe؁.*ͥk)#f6A,LǑ #Ou^ ۛnMa(Ǚaa4ّ 0ivګ2a=V+4rUvP񛅗"(j|E6)7W⪾ M͑2Wܴf |H-J6TIge!WI'ci.qfLJoUPHOrVuU^Y&Q%'z‡ߺ>wrp8u!⩲Ē ۹+'7. Cx笜[C딭߼īaX,ݫrhVfrzΆ  eaK[SI="P:ǃU4,5 Ǭ)OY.Tvƒ"s㱻n-9sg J^wGg`Ax R`GAv% \4CxrGo,D/}M|)UKuY _ΗS/}2$/}2"(ݝQNr,:i/H_<@$ex% |iO K$#hQvϻr+KܜϚ ͟G[{6H؞<';{^}oms/$b.6H)a9lQ,ޫ(7xLtÎ*;kSj80IyW* (풮5t+F%@)m FE.7gʰKG"*XVQl,B昘`*-hr FEjPNnpN[k$0r 嵙t=q /%A0r1lESX^`;R/V `QH@Ό&gKF 29>Q~#:Q2$y%*}$eLmGD]SD#zM \Q]fخ(qi4VDSYBD( A)r^~JdψJ5QP)enTE`I"JB?'Ѻr}(FVP\R"Q.Qhj"eM8 PR&jm|!( qQ`HwE jq'w#݄CCBPȄj˗,gWM}NkEd  s_F[!u(BQn%m1sQ.5ܮҞQYIZ>˰~=+g5遼Z%V(kI[xĬikc^,b3]eZ4B282VVOQ(]uҞswM`GC'jBͰBU-=UKyJ[*+Y콲8]e(KS^yeoYYV&$fiE51ԼCKe< u5+~JެJ>WF%BZ 5: ]"ϗ,PP{u`HZZ^u꣑B[Qtl({G:Q} ePAk'ix=B=B{Z| 2 uk-GuȔ=B@[Dٻ=l-P]'Q@,@,dԽ5:{ u6s#!W9eoUAeWFwm$Nԭni ukPFeS;(D5@VEV{zVOx5ig#~N//]94Z=ՄC ` NjҎ$/.羹&"V!q;89 m#R%ɱ gsԃ)w MMjc x t)fm )WvDL'4^)?/cyywq/aVV պV N.em DGpHNrU9B'RVMրD>bᖷ/RNyi8B|IupWbeODUɉh!妒3+=f"C]CO@r:o8$V'ap D)lw'arafg$ .BoJC߅b9\83}Z6* ~k1'0XJa&061ޓ06~JЄ=ix?0,!F}`"L57p}gLm)04d&OKZ_OwHw1~Xըܞ'cfU|-G13y'n=cbax9J%)+[j#bk2Gr $F4z_ɕԻ3a0.є ;H҅j0T5w}oo %fU.H̾5d80 Sno]\}7F'&p0Q50V%1~ػbB2|%so %댹VubJvblPz#Mͦ soItsososodsoUs;f$qbns?R'~>[z^kdZF榞cnd sw s/@}+1特>O=IǨ5>S[ܪ\ox0fn[b[`[܏ԕ}i-dd`nAs7{`&a(`R4U9=D]/iք5vXcTE/!|Wl@p'O7!$Bp% } ^bH؅ÈEl xU@^Chګ;̦7s9YIKu_ZjSuPN4+tt.}Za9{0S\]U w`b@hƙBWU3W701wS)< j-9%vEpuK% :@ԡ?!bȱ>!;m$VoKy*ܒ>97V} +`gpӺ]vLPcK}B%rCiL4c}@jn poYR6T=³Ul_Eb>>;{6+r &?j#I< ƽ, /p`Wʷ /Zgp/0^srpO0^| {q=6 ƟT6 0eep0Q̓2s{ʹ_*upO0SOO,$0L>yGdsMb8LlA&6<@͖ۆ+cCI11Ye `JÏNgsB}R-$^gy3:w}z1Ob|}\5G&w19H;facK ?mci3\޹͗Rtx'Y8ʐ޹fjSNpߩP~3X,N:pIϲ{Ua^k EK$HNz~> an* ?$*XʀC=qF҄Mi4I#Z$5I+wrC"9&Mi`VIS㿦@M3P fLJmtzWAVϽ{iI uXIj,i5I M~'5ƽX_* uB'%$5AHw ᯓX"1HjԠ&!e"51"5Hjlu޽["5wIjll!Q[cHZDR"=HRw^$Nb $CSCY}ΥH G$-(iq$!FBAH &iK").B]$)$HR"$)ﮂS?&Iq4G28v$-IYG@š";&nA\,öCWA54~X/bɚ0=I 3#i!G2S7Ŕ.H{C*^l"_i_s0.I :x$7a{oHaHW HZ0糍FaQ\1^Q~ K|z0UV ᨪáR^w4Jd!3gV@i@ckY!!QbmTdbMD0Y;(JaԲ3(rQ)b8-T G#ͫvĶ;hQl;wl(1>[C ͸=q' <%DJám- XRN,=[?hN \w7Nu'r?{wvoTK v(+E?;(pXn qK:x}øNut<JN)(,L :ռ[cVp);: xUM^;ι݃ %q{͞gf8-sJ:7㺣Eحf}h͜P!v;//XsJx'a}wי5i9E SXnenS3sXX+.攷ҍr׹Db4NT\LTG*q1`\L\Ѐs^3SAS笠ybb .F[\L.h1S4 A.h=/q1G-buس<+.%p10+}\S4:]sP%.󑋹.s1m.뜬k r1Gɽ5D{zԽD.Fe˷fS+\Q "jRqzr5 !Wbwq5AnFf0\q3+1nK.sQ>q3V{;,&U,R5]%5jP5MՈ U_?M8:jX-Ɵ4SLF*$"U#6T WUCpӥ\]6xD9X~~d'NKׄ1Tbg,I=r%15">OX.X. ؔ2>gϐ,œgy+~$_wD3ݵvMSL,m< qL3dL $c&|i*߄CYp(w;h Wm՘*F1q &9ED2FfvNdZ6?hHƨ.z:_7pR'd*dLpB%%bdLQVH 1T5ɘ' Jf1Y]*$D7ӲDYui$dzᶝ"b N@)1"}]@Th`Ȅ@cJ@T*aN"+@Aq]p8 n&=!73|ba >Sq$A}5dil<6V#+3Tbml429!և(h:CFebe;#k2}ЃX2,N&Q`B/!+*JQh=8t>g}X-KjD8|K}CO,N,k\tPbq =KNy;ؠ Ö֏, ϓ"켝Bv+/BQGbX1,Q0-DRKDb&e6vqY2iKԸx)h!1T2!8Yʯ"KĶOD"-oեgхI-tgnS]uz5 nU6m>%ziM"FBHҨY4:c\J:Hi~%IƻAHSI鱴gcܫP@4A{4%H#oi$O{KT)i`˒9U$x DMP`^ ~`L❽ xF]p ]-Z: }3}wӥ otGokvloBUBUV3u! d_&m:Y/:؜+?w .ykw>fuXWU`TTg ,b"!_Á1 q8%F, fKKUZzQC]Tt#$v ,Q43Ov­k<MNke%gk̎g;P)\l6n)D-= vi*,tond ʞllCQ''&26G?(FU(QrF{0,(F=JtgJ<(CgEtsT_@8EJc}Z*E~&]4Bɠd-ڴ4QWea睎+G*)ς"} [D5K;$fA'G#TM֋~\Kt[[w4Д0nDQK,]繾鏈pQeg<2^G  !>.GF|\v7.Ոm w5Pčgz^bJX'&bTN8}D3Je8N|K8m50f Q540͚lA5Y!уWH~JP5274Ʊ.W*%LI^m}T3^5a2(΄WD|*\cbP;l;k1k튕*ȝk \hv]-QINLrJM?'L*…#'̬:^Ep}*] #Y_|Y0gz Ȟ`dOb PY;TDTGOnDb9@,@AT 'ˠ P*4) -q@p$E; d ]+HUU]/- @>bBTH0*  3J"ܯ^_1C*ApHV^9s}#PO![֔p B($ \D1C2 v|vʴ 0]|hꮝ K _ȉ9`1]b:G2Qb8`PMҲ̎ HggOApcQ0Dwi*R eVϖ2oU ?Vu =ɭu? &uY8~L~Ta*ۖ]u[c{] v(GQ*'½ICzG :C垪֡HH83ǵꔅ1OHH8:LԺ alTQ&UG纾Xs.3vr? ?W랛7i e9 M[s"M(ׯ)ʫGd&?J?WtǤA I?lzgע)-Jз4) 91`I*5зWozWiTwbt5w%fLs5 ԫrW{k*ju1oMu}2ʝ gq:3Yvb{|8@ZhMƵp0!XvqLjp˪g]4c,nY]r܅fz.솇0ӻ$)?uKsz`?\KrV0kJ,Xt4E$J ?0kDccJ=ۇ5A=5d3,mY8io{vڛǬT!jev%!f<!>Ge֎ 6fa!`?l}3 LJi.ǔS=d9-e`L7~Ä&W }6Ic 00ڣ&J n>x?Z'/J6 dh}Ywk';A:vK֩G~NllhTM'Y?Z'ތN!ڐ͆|P&26dVZ-ähLu1ad4!"7Y lQT`,~ #?Q Sx5:a4 +4dZ*h! a"mv ]W,{Y,EL2yn%pף3eyɕHʝ5d;,<.uK +s+1bix^=%İb0 v<iaгf>N0  w|J1,iUò J$Ri10x,?)^uL 3c+A{lw6v v zd$jv0$. cɞ(si-gq.| % jⲺ_~.y\?Џr+DgLLK>D{D;8(G$% ixDŹl-M}ͩ7żnȗN ?v+cԑ(1wW>iuM(Bnߏ2)TFR1[ Rw'{TcdBql(z#cxR?f5?ߊ)ϷC s^㴿 8;j~Yk~pix3ZWp~T|}zv7#2.y_2^uu.,XO*7-C K9 Vx?\0}z$}}j_.3O~~\$} >j.+oa?-+^]˷s[w_.Ϳ~W_nfzT+?? >~+>A5>g% .څ0Ms&^*/p]XOz|a{!ށ}ǨV׸|k_k z_kPubendstream endobj 9 0 obj << /Type /XObject /Subtype /Image /Width 1 /Height 13 /ColorSpace 5 0 R /BitsPerComponent 8 /Length 48 /Interpolate true /Filter /FlateDecode >> stream xt-׊ 36ԨkҪHtipSqendstream endobj 10 0 obj << /Type /XObject /Subtype /Image /Width 1 /Height 12 /ColorSpace 5 0 R /BitsPerComponent 8 /Length 45 /Interpolate true /Filter /FlateDecode >> stream x{p-!1{ski1﵍rrjuwMxendstream endobj 3 0 obj << /Type /Pages /Kids [ 7 0 R ] /Count 1 /MediaBox [0 0 576 216] >> endobj 4 0 obj << /ProcSet [/PDF /Text /ImageC] /Font <> /XObject << /Im0 9 0 R /Im1 10 0 R >> /ExtGState << >> /ColorSpace << /sRGB 5 0 R >> >> endobj 5 0 obj [/ICCBased 6 0 R] endobj 6 0 obj << /Alternate /DeviceRGB /N 3 /Length 2596 /Filter /FlateDecode >> stream xwTSϽ7PkhRH H.*1 J"6DTpDQ2(C"QDqpId߼y͛~kg}ֺLX Xňg` lpBF|،l *?Y"1P\8=W%Oɘ4M0J"Y2Vs,[|e92<se'9`2&ctI@o|N6(.sSdl-c(2-yH_/XZ.$&\SM07#1ؙYrfYym";8980m-m(]v^DW~ emi]P`/u}q|^R,g+\Kk)/C_|Rax8t1C^7nfzDp 柇u$/ED˦L L[B@ٹЖX!@~(* {d+} G͋љς}WL$cGD2QZ4 E@@A(q`1D `'u46ptc48.`R0) @Rt CXCP%CBH@Rf[(t CQhz#0 Zl`O828.p|O×X ?:0FBx$ !i@ڐH[EE1PL ⢖V6QP>U(j MFkt,:.FW8c1L&ӎ9ƌaX: rbl1 {{{;}#tp8_\8"Ey.,X%%Gщ1-9ҀKl.oo/O$&'=JvMޞxǥ{=Vs\x ‰N柜>ucKz=s/ol|ϝ?y ^d]ps~:;/;]7|WpQoH!ɻVsnYs}ҽ~4] =>=:`;cܱ'?e~!ańD#G&}'/?^xI֓?+\wx20;5\ӯ_etWf^Qs-mw3+?~O~endstream endobj 11 0 obj << /Type /Encoding /BaseEncoding /WinAnsiEncoding /Differences [ 45/minus ] >> endobj 12 0 obj << /Type /Font /Subtype /Type1 /Name /F7 /BaseFont /Times-Roman /Encoding 11 0 R >> endobj xref 0 13 0000000000 65535 f 0000000021 00000 n 0000000163 00000 n 0000043139 00000 n 0000043222 00000 n 0000043384 00000 n 0000043417 00000 n 0000000212 00000 n 0000000292 00000 n 0000042651 00000 n 0000042896 00000 n 0000046112 00000 n 0000046207 00000 n trailer << /Size 13 /Info 1 0 R /Root 2 0 R >> startxref 46307 %%EOF brms/vignettes/kidney_plot.pdf0000644000176200001440000077260313202254050016251 0ustar liggesusers%PDF-1.4 %ρ\r 1 0 obj << /CreationDate (D:20170125183859) /ModDate (D:20170125183859) /Title (R Graphics Output) /Producer (R 3.3.2) /Creator (R) >> endobj 2 0 obj << /Type /Catalog /Pages 3 0 R >> endobj 7 0 obj << /Type /Page /Parent 3 0 R /Contents 8 0 R /Resources 4 0 R >> endobj 8 0 obj << /Length 255677 /Filter /FlateDecode >> stream x콽.MGq&*3\@ $0 A>ʌ(`t_־Ɋ\k+J˴ut߿[O?Ogk?ϟqS+qQ7Ͱ<>8 +8?+.n8t\gċSpV'j/?juY-X՚gZh5wNm7? guwY 'Ɵ'.+jO%<p O%<CGT@^8k$;c-64e?gqlvSpΪ`YqVypV;pV8G{T<:p`W?h.\o.K %#{q)\ןfgu>x;ߺDZoݮZvpOӖ/ޗ;*>8+FЯhgEna96C}V>ӱ;^4 aprj|2x~ԴSFxAf:z6p3 xD3‹3;}ԲAp7^@XkNgi]ma۞ak9Cϟ~9^Y궐bE1T^u#|AdX.sPn\ިE P/BZzu{zq>7laWأ3737z@-k 8ޗ_%n O14~_hʦ%*Ꝗ~ S<@׋m6:?Tⴃ =\xwGW8?;Cupa_3]؄GNxH-@=@t^_PP^\ DMق2ee˛!9jzgXc^n}hTzzejLMSt-9oc*&t:Y-+J6cs^7g,c ZR}UE~Qνj>*T^jB8FeM~d]/?}W8T0UP^X/C2V($֫<|[{ 'xx\ER{+zn2}MAB`f^.3J8~z<3d h8?['!sr08?yp|ڿ!P^|:C8o}­60q>A~0\WZUl|>={ƷzAuʦzAu*M-aҎ?^~p<+K︞mM0YZ}kkt=G%|=Uv!+g;i?_ Y1Vګo Kyұ,>L ՇEf+ջ#~\K{c\&3x]73IEI|}񬑡;ywOdw*ډW:~ފ|Ⱦ0 ފ<ޭ#,w+]{#wĻc9"DŽ|wyNw"8&/ӅaKޖO<ջ,[3FH N3#ĻNsMĻk%ŪJvﲤa=0|]d&xznwO]eCǵWߖ]pҺ53K;Tp=K|+ao;xw2ջw0f#W;衧)mf#wŻ͌wKn3g(ޑ晎_[W: |ߑ-rmi>{||zz~?G\W<3_mn3m=_|s-^ϙ7x=Gl. ozesw%S{<6x~Gm.dz\l9ŻwGoN)=9Ż#ǻ _9ޝxw#^!zC[\y6xw{Sz1pwZon9ix˛KwZoNN-~g`3 x=GNN))x|1bkx|O/O|;; 7o|]wGߕ+}|n਷v>8p[;8ꭝчS=;r[GzKQoxxz+;9ޱpnd}~Yߩa%g}~)ޱ_#rKǏrJzK$R?J9;lfLo9Żyg}~)ot8;+nIopMzKRRU䨷ԯ9;{9ޱ_fS9Żg}~IoJzKg[7<|]wedUF[z\YoViYop9;oSc+ƕbݓݓݓݓuݓeݓUݓEݓ5ݓ%7$0+6⊍chczqW jlߘ%ܝܝܝ۝۝۝meFƕ gQ47lID!R` `2dKf1xBYͬfj3봙e*mf6FY4s0 &nF$&$P%Q1N~$\)Jɺ$̚ldI6"YFc#Zld)&$a$(d>;EkcM8RaNx%ueueueueueueճYtd[dy<`>i [ Px k P K P[X-KVe}ղjY]IrtsauÖˆ5W KNڗO+;/[y97jnGK}GI}GG}dT*#*/J6IIoA1>~¬At.&{ 8݈w 71{8'G};,=G\|8AlT&>In#0AGObO=!\bbvH.@72eV1o(q;B<9?I+Cx]x-0!ݺH:Gsrq$ްD[;!p귒(/ PpkvtzS:HvCȃwtSX 8O voc!aͺXf8E# 0ioo,fŏiih 'CZUE:_,iu_5 ,P4Hw|~Z.9w@u?-_ }`qx7% , cxvt/ eq 8`Kv>,ioFП?$ HOȿn;RćE E5q[+d=1t7=>TZ^5$ q#dSxa~2eĭCbkגgI1CH񄌚1QȸO -TQ3zk;t u-IF!%oPJ{R7mb\H;i\ 2cQp"j (2,5[c85AoLg(DxY!El E;l1X/q~WWoc|qcXWAc]j3sÁB1>*p.8Q0 c|uK2xqЮqzŘ|kyb[ ](UEh]P^燊qd m4+8DEITx1-k1W܌`FEUT+g G(*~"*pb!+]z uec5+k\\ iu4ؠQc8DQ1]Hy-Yl+r̛Xr ko|1oziL:jQ165^q6@E*B*KywcDE|[sc|uc:ܡƭfr*mኊ1oT -=ڸuj/6n:|ё w,p{xpdQcbA/UGq zgt#"[3{G xcot8F;AEO`tr11s:j/8#ǟxx17;|㇎{(F[oX::} zc\/:}Bǔ1):,dw珎,C }_'^#_$Aǘv{ qfLB|бMo<ޘw3n:lzk C7tY|#BkW4 Ļ6 ^ #X4濇wC_@Ǥq C):26ޡn:NjܑvS}yh5}::^EGpȣwJ}7ثw ;z`[z*6wP::]Xv}ߛ[r\-wAoqMuE8O6xqNH8?wW]}JpLZU ĪXxep'ˉA쒢{s>ss=ss?~]?ϣ~Wh>\H.H nnC_:,^L= \I.kvnx=қkN)Ix'=8;)Io9i=N=;G6ﴞ \nz \h=)i8;x֫[wxpﴞk8;tpz%;63w+;Gߕ+}W>|]wG19-#G|r䨷>HNWwʧ))NYߩ^N1ީ^g[Io9-c"xzN䚮xzQToUcSpwNYߩ^w'zꅑ{ꑛYꝇWw)ީz8;kg}zo/;Փg}zTώᑣR==r[)ީ{w'8rYߩ_pww|e}~Yߩ"rw׈#-R?I䨷ԏ9;DN0/9;DNg}~Yߩ(rw=;NJ[[w:\RT䨷o9-kEN^gw;’BLBDY8%p(%0k%ȊldA6YFc#kL`’ d,`E2J7HJ9vžԕווווuוeWϪgճ EǕP< vIbT?jI'4[ P y9%V eղjY^$S 6\Ǟ+=[\6jXrҾ|rXV^yAw˹Ws3/>Z#>J#>:eQQPy WIN㠟û`%zo ީ틉^AxĈ-><;6p,{!u\9`5\67bG|z@I+q^F|qK@@%x0K@a. gqBxxBh>; gqų #'>E`$S`{O:sU_L]D|]jD\<+7ŻLx_]8F#Gx>w^O젋6'I78s̰w~Z;. $ ?H"8=?/#-‘q|~Jz,R*O CoE:v 1Ԧ w_$)$C`2h &7D)e#i)b8 ޓCԞQS;7~zBjqOB%#.RPLiOld,xΡ=Α5# Scy@hsd\+2ý hNd|(GFؘС1c8r[욅7dDF{.#mLG?5]17 9+?1Q'bsi9179ٱ͊1 *Ƹhs{xw)sٔC98aE zc:!ըwŵ9'=k.!2HG|'<7TD˘{{E 9dE{@f)*vsŊ1OIoqO1wh|Qoni|"i=;ci=Q4濇 [Ml_Ao &*\{vKR1sz ~c'_UT7D|c o=--{T̍xgri{ƈo_AoxEtL4VUǁ1s*ޑ0/FcME-}]l:j=cxMI-}K{[[zбa=ڎ|0FGG1;FG<:J,vf 9zt8cw7kў73C­G{C@az?ߋ|z0#ȯ_z(:G~_xб+Awxh(A xxCǕO8!4߃[t|˸O8nm?ݚ}h5Bbбvwty<7= :񾢣Θt*}t_wMn;]מxHxPeG0aJot?Ď=߱>_sC):JEbw'_lNow̺yGq {Л>wSsyw}7vRɱ[.:>+n; Xvߛ[rP$K zK{lczQvT譪ٮHm;]?ÁߦxEG17;]Qбt[`c8A뇰/p>wc;l}='/x>踟c;o,.3vz(8?W:|}Us>z O8l}G1 S_Xׇp/#חSK8t)3YSֿxplzX{8>|} G<ݘ#:N_dWȭ7/X"~ txAg /`v/dE:vv6Ff _8#h'r</ʑyqsHt$9Ñޔ&r3OǓʔ~TD~*[vji;:vV0gG)3:̺g ipW(m'$xJ:v:n'C۹R:v*iϹRΕ$-<p$|3΅5;MG΄1ߕǥs؃~}::wŸ]#t :Jw큎]#u2X= G.d'8 n:ȬʆCjCtnfR+|!qw*{\W<3_mn3m=_|ף8pKk%_S`sKWԆ \Rf=XOz.pI_c3d5]OMm'[n.9INNz:pwSpDN)1_txx|Uϊa[[̧Yo1wx|f91_xxx|]wGߕ+}W>|];s#G|p䨷Oчgwg))~JN=;#t~Y)8; 6Yߩ9;+"tLzK#-S"GzLTω\T/McS*rwwNYߩv8;T;ܒR0rOSR=r3땑cSJN3;[g}zTe}zT>ّR=|]wGߕ+#2*W[zK[[eUjwx~1ީXxhVbJɺɲɪɢɚɒNMšFyfQ\` mjB?؅#55 8/ met@AA8A81Bx&Sd8×c8TY,fi3˴U"mf6D;aLp#ru5cIX1Np(uKFd#+zld96YFb,I0ʢc>FQtk 8R:91{ PW^W^WV^W^W]W]=Eט-~LK~̔LjٳMcX9O +zn̫s-R%RQQ_ p% k$k>|_~,衃^AxĈ->?rAЇE Csq@Kr_3+~WWxu#><|8v9(Sz s<{G5Ȉk~zhr pG% FAǞ4q๧7/A'Wdz㙘 ك8~[?8vwpxO SO"8O. /ɱ$q$ƢyH:Cse b=S R7)@+@(@(@amΎGXzS!dӛ] ۻw(o7F,}kݑXH8Y2z_8rKK0ܒ~% qb3dSjP_^v,Ƃ08oXbk t%Y2_qV_8@2`FFX:>?- e!v{EKn8ǚtrQ$ D0Vh ᯟP4f#=1KBbȶԆH| 1A&H=Qp2!c8~JTsĻ;z4C"3 &C H? kWJN6n:oʊ{ĖH{g>H523Q3AȍAD;c8 c:sOx(!)ukRdBFrܓK=Mz7qkOkd\[p_b Z7%37?116c e[{[1#m 32pT"mLG<ဇB#Θ1(DݘB{ɴ+=M+)* tw@/swH ,:v燊[8{{X"G0*&[y iOOzc8QhxG!7paJT ?r̛*zWxV ~6RIGiT䌯7C+zt{Ϙ{CИx(~h|=荧y1c4GEta=TTǣ=Qq5lĬ4UE_g"lccT$#3*D1oA8'A?8wWԍ缥eJZBG*E/+Rɥ!͎IDtcP }gBC`5:"G=tTG>?vd=ѱQ vtŎR8_#x?Q +Ht_A?8} 5CǍq z;ĕA!߈':Cp(2߅1?ր:,ݠ@Ǔ1[bǔc$X%:4ݣ/d#7uTeǗ1:|~Pv6hOzwzg%8m>[r̛z0{ Ry[fǜzc3:|ytc|:]/1: 껛P-]x︇5;&M/qv)G:FGqtcTtt~C=3:F](u/>xBn|^AoŶrCGg8ة:R5^kJ}Cǯ}wwp`HIpV;]DGz7=XKʱ/c{ '" ;}wvGq z_3;}ʼn߇[{x%::}:~ݸ-wp'_aǽ=AKF~YpWd&>C_|#0ޓړAR zBd,@ X{?H=Ó+<#d Ht8q zCV+C_XY{7\#fgPj 5ߟJ59cg2:~v6lch(r*IG>IC_tci'hKste9cYy&l;IIa|uRt9z%1qt9ο ySf?A}pl/wct0{;wLGMft8w&(G:; NN yUpN1ο 3ߏ NguC~)]ՠԹ.X5:Zw ]a#9A 2tz CGбAtZDGpk"y xGrb0ќxpD'Vүm+ŪW.XU_dɪYG*ZQx.'W:E*A16ll.}?~m$σ撮g?o{<36x~g|sso[:W6x~Gl.^"o=;zlsw撎zH?O5]OUwÁSx7|x#[wZ{-^SK6^%NN)i8;77^rzwsN%;xzz?pMOuʐi6_zSS>dsN%;cN)1_txx|Uϊa[[̧Yo1wx|f91_xxx|]wGߕ+}W>|];s#G|p䨷Oчgwg))~JN=;#t~Y)8; 6Yߩ9;+"tLzK#-S"GzLTω\T/McS*rwwNYߩv8;T;ܒR0rOSR=r3땑cSJN3;[g}zmXMe}zrXىb=|]wedUF[z{[eUZ[xWjwہ7)ڱxJɺɲɪɢɚɒNMšFyfQ\` mjB?؅#55 8/ met@AA8A81Bx&Sd8×c8TY,fi3˴U"mf6D;aLp#ru5cIX1Np(uKFd#+zld96YFb,I0ʢc>FQtk 8R:91{ PW^W^WV^W^W]W]=EWϚ+)cyFs¨~Rϱi[ P )@{(u-k%V eղjY^$?\:rsaeÚ%''Iaݝtw^ϭy57b>R꣤,>:#>*#*/J6II|. AD|/߈w"k = /A"pVx"pVxu#>`zP8% D\Qħ@a.=DF\#׈CAzЏń>8}>g t\{tx>Ocx=mOێ}OcOk 'p=tICL8/p~")O"zj xw<zCxr~VgzCo,ɀhstAyOb=Rґp%oDC @ (B;|ɕam jl|Yaņb}GnIpVčw}M]¤)ޗ(A1>2,~F(6]cYe؏K2C&7Ptcg,&q, ك>z9{_F3>0v<{zO5Նك;N 7Ć\7~Z, oō/(n4!`8u> ;"yae2I$M )KH$\ !sɿdqL唂N&zdcEY-IT A|H0Se$^tSW/׏VɝiR1CyJCҸ(3n{6*#W eƮt ̌^ -3E{2cX)3L.UFYrqf0+#Z eLdeF ikt2#[GƶhXft Ao=.SdF,:q.r(2#]e 3hxǒt3#2X1zў̸̌p`3c2Qd_bEkTɩx~8Ԫ=/_W}GEV*x wE6:Y15|Qqy +2!ȊMT:T`WE_'<㠯ڃ:XFEn<*^6 N>oV*'UԪ\՞߬U7V[}Ta6+U_\`EцY'[{y;-U9YԈ*6,娷pfEߑR![3֞^{[kE_CŶVtG^ {Tþ*/'_7ގCG=*az\H%cww=6z~TБ;~6yhM{Db'vdT}U{cWv|T}a!U_d`=qbx0cq̎zq~_S5c쨱?Ao=:rҞyhyVVuÎ1c=:ŽJG:,:t?d ;tx~#HCߕF$;mNp#} Ú˅_LRGsx\0uDAt{tT=q/#[_HaǶx/#ܗ\4([p*;}-셬׭=/ni?Fǻ/Mt{'Uu8Fxv_: `  dBxpwdHG3@"la? [pL\  0 :2q=7aKuE7ў $8F.}O -)C NJg'=bt_J px:+A\ʍ9΅=#AL_ch(\$I2}a$s1_m䅜"O;JG1w.krWpt9aK_Hcysp$/0HgY"_ȝw!yy | <t}p^w̭1x];}8WTu~pDc\?΍l?/7~|]ws%u-%3#G=BG$4y=w]ꡣvu#:rw]wW==8C oa؃8|#=xxpD'f\w2Ax ۉW,X5?3o8wAqUQ?^kr'̿G糙;?3?Kc^~mWߛ<敟撮g?o/'qƣ wqwޗ-y6t~}B3t[:~Ǔ%^ωG6x='mnz/x~t~[:5_U eOU|J䩊+^-^5^@ίS\H+jC\I.6SOx~sK:Rocs#j;ٜXz8pwӁSﴞszdsN=_ôz*pף)i8;x֫[wZn9ixv^\x 63ף|D!kwʧl.9)#F&qw$N3; |"p[ȇnYo!f|\y |x|agwGߕ+}W>|]wMb>9q[G)1xx|x+;Oe}|X/8|g}zCXH3-CXOI1cc='qMSSc(qw7%1ޱ8;g}z[X ܓb/pKz=]OIzIww&1ޱ8;sg}zpXOсc=;q['zQoxxz~+;9ޡ pnd}~Y߱%g}~)]3ǟk&~Qo_$pOz&[[W \sCKex~)8;%Ng}~Y߱_)pKzNk[JG~)ޡ+bGw7 g}~)޵O8;O?Nz~W[ |]wz8ҳ*-Ҳ*5ǻRsC?oP>xhV+ź'K'+' ''˺'''k'K:4eI``Wj?ŕЦ&1]8RXSJAM,,,,Vn+K7 + )3(#(#W a2UL1|q0/A3KBmf6LY,fh3K4fF$(d$dd"Bt0)ُ+E)YY,FVd# rld56Y,d$d ;eg(:5a P)@J=+k+K+++ ++ˮUWϢgulб< 9vIaT?j)4-c=XR:Rǖ5VeղjY_,ZVWm|}.\9p T6jXrҾ|rXV^yAw˹Ws3/>Z#>B꣣>2꣢>"ꫡdat͝dA_qWhSfnčxĀv7!?6Vh7bXTASeڈWҟˡ\ zgKPUg^x rnī[>7bokAre(U o7ڋ6"0p gQҼ[4Cޅ]imfX= =N { q¨4>s:܁MSQ~d4Vi$WZk9Vv&rtIs}=\+w['f8mcIES~4xQ.OALTZ)5*1L6RT:)q*;;) `yTJdU«r92CTJ{ }xSVE(; كЛG)CEH_SV)p+֣ PW)+֕kJ5Eye1%{d[RW7s1`1.,*\Hˌ^k.B7KЙo/o,zlD\ &r.Zڋ.(KJ+7lVeԝ{/kťP\(eȬܬKʽ@ }\ÌK}\qa\ 粹r[._|h%w㞴\7n1z\̛}-8ݱL<ψIV=R V0_FU> &/76djхy MRAs'\lsC=1eTL4cil^eѻ I8>H!5Fo&COm&^>̘jlgE*LSfM{x2ִG43nZaFqODeQCFY"NƯ=t1#ش.3rNFʌc/.G%3H͗!rX3#ګΡp1cbVoQoAPv驌s=m1~[3O8cFK2c0PF9y)#nyC=$q{63#o8ґړ~sjfp G%+]{Ҳ1s*H<̺ht/U<^9+"f䒣hyT\.9Y gÙANKeV";Ug= kw钣_8{F"f/AUv]Vұ̊aTcp=V/}UXNJ]?cWÒOdrWG=ɮY{8?Tl=/D{isVGxGV/=iOsVha`żksVԻ-Agp#>o:Y>Z=1`f*8~#XaȦl;:PŽG<:&:mr|O~1]{c C{t|CGHÛ#{d{vt:^ԑEݱ2;Z%:5v^dw=荹g<$ܞq2;v,Li?Q# {Op#++ޱ#+~c [%Azb-u}SIQNMȑNQ0~ci|rSqwcwi8-}i{Xk:6hGG\1טaQG]Ao"ut<]4t8xi~wctCߵ&<˗k|mQU:Q*ee#ZcqVG`OEړV=Q:N[#Z[ӱZ9򗖍t/ȿpAוꨵe'RwU{#͎][޿[[>#͎a[|lm>8.:m~cYyu4W~Mu==ɀCǴCJh#pģc.9 }:#uqc\_4RGyrCU~Kuر^vW~OJ"#q͎ygߡaGФ:v X {;_d: HAǁ"GB{wh㟎%䈨Q4ucCII9:>O:BcDP9J DS9Rvñ/REK9^#F]9fFa9n7#Gie9v{O9Ÿazxa^HǑr$g_ Iz9ɗ#Jy9Tj:vS쀣kF: G.1I}e8̴>:tEcч]}t~c{G#?hAGGY?LǢJor4n'JrL t\#xJ=/gC}XUI˒AQa{U&74IMnfqr9x=O܃>fnf>>>>}WAx>Ipw;޿}O>~}O<t''ģW';q⥸ }ⱸ;\@\}W[+p[ʇmnYo)f|yb69)_yx|]wGߕ+}W>|];s#G|p䨷Oчgwg))~JN=;#t~Y)8; 6Yߩ9;+"tLzK#-S"GzLTω\T/McS*rwwNYߩv8;T;ܒR0rOSR=r3땑cSJN3;[g}zTe}zT>ّR=|]wzʕVYoViYo]9ޱ7rwlxhV+ź'K'+' ''˺'''k'K:6eoI`;`Wl&1}Ha81K;+; ;;˷;;M&JBJL2JH"JBLc!` _2sKFRmf6PY,fVi35M-ܓ^GؒZ`JJ1N~$\)Jɺ$̚ldI6"YFc#Zld)&$a$(d>;E1 c:7HW Pl)@]Y{]Yz]Yy]Yx]Yw]Yvz]=kc[QϱK 9VKa>Ǧ l)@'uԱ:ZX-+Veyղj㓼saυÖ- k/'Ա, zn̫s-5(訏j+Y$]s'YqwtK'bn_K=7ٷDC ->}xbЇCqp];`xVݚ~ ~I+ x>`q_]ǹ_lǵ_.C!Xwq<8ϧ@sAx>P8wM 4.Qna{}CoÔx] L'|Swbr4f}s|h}4|qɵͤ勺Uqi۰= {S~$ 81"8 }&C]8? و yd(|mAZvn:p7AB^t?3Ao7q.LJ{]f%PCH5v7'nQ pqyP]A:톰67cQn-솓z PWٛ[2Y }`藀7ba/QEg0,o Y7©_&*CmIoK2CXr_A=vY(N-@] LCXvK:o(5wK~q^¸_ccl jClKn8-\77yCbo见D@Y >#`)C=/#鉎%/ '7uq_@$>{BZ-HAG .>1~q$k ⴃ1Ļ;DM׼Q$ SnS>ڑ2gzAwBR:{.9ojP40foAD :.32j!Œ_4Cc{HqsWdqz1g<(5yx;MG_1SDzƶEFQlg|qמ&?:18/ŮYx*ԕph\ȫY(ҁ1PX0fԍ¦a{cbl{T!d"+X[c!xp_wxwCT&}4k4 {#~oo#st 6j{sޑ`\ަ` xx#6ӡb:.q0.AZxRT#sĘ_av&eQɑ(EE=yc GrSw.GPmܞÀ{fdTɂc8Y]R:3ԇ|}.c׋k~"c#q5@EIAЭxPttT CEG.9_I zk?zkHϠ >Q}T@בz*l='M{7[ѿІ3W@E 6C x:o8Iq}7Fťe y=']#Ao\2aAoxE'X;*dEXm~"r8!ŅYQn~kEVQ ݸxŻP*dޟT1ߵ+w"7wt'+- zEljOp7! Gb'm؃ E/}w!*#}j8:n#fCz!+k7OM㣣Y~8^$1w/p~N+tވwZQ#(&G(:O5L:t<%8$:OV4#!ƃWdsz1P ]"W;G[x?+2]ztw72eȫDp,&~p<n>E(zLGgxx[>))%t~&&|̤Glo7N:<x=p&^zNYw.L"ީ=|ČwxGnw3oWsf#;g;xwΊ?x7 _-2)_[|]o~YwzyYwjmO/ݞ|O~w<+|ǣ_īxw;x?ow~wwz|zE\#.^_=%x~AωK:AՋ'MqMz9ŻwW;xwswW;xw<#;'{w84 E5L-^SKǜʫSx/pw?9isxչxsNeہSx=pKs/pf>!ף|D!5;SKwLj =SSyx|UgNzK0i5-Kw牕s9)_rSyxW]wKߕ/}W]wKߕ/}W򹁣|p਷<8-G;&rwω\4_9;7ENUc|4_vINm|.4_)Ioi>ҙc|K/4z9;^N{:4|9;G_Nّ|x䨷49-_~R|.XOpxd}zYߩyd}zYߩ"rw׈O[EkcM%Üp%5YzF^#뮑eWϪgճmQb?I?Ijy1j4-(Y<5(C%(YK-k%V eղjY^Þg{8lyްiÚg KNڗW +v<[y87hnܓTR_JKH}/DԷCM5;ɚ/}CGqПϗA-Qkc/L{#Μ)6vb7Sg->>:tn؃ l@hdp(rfqò mRxVkj94 ֔mR{xC?bB{ ^ \_]LsrD L/q8],(&52b% (6?<D3_A0,b%7n%z @{pM ܆zCVA]: ûfl wEvV;*ؽ"zްzijxiwrzjװzl{mlzn..cO:m&& LjXC?"kuD}ICnI݃: m2?eW٫-_\UB{d{ 'GbJɃ: 7H5^gf9M[(~݃ˆܭWdo z+-" Nzifd0hv09(C;9h CZ@\?Nu>?t݆d݃63zC[ ڀͷA6@=(CYջ }Z6ƆUGg=_hXP?p:/C|'@-렷~д%bH@Xjl鉃?ZO:X4ԟ"Y#ibZ̟f܃ 6ptA!YsT{؎DxnI"G)$+} lH?4in:ܷA{H{c5H1o kQ;=qB3(+7(;LEF%GdJQU(,Rr)94'GE0a@dL^38s%G%2mɁS8+ǻeqa8QB;e=O&2ևDF52⇋3q ĚcpP"#a:-o~X'zc~?hQ33qB3!1q{یa7̈XaC>mJcFұo3.wpr̟6ft15 gAS+fs5_kOx:{6efN!$یa\fϰa)o3rVHm0; /f}0cxx1"ݬtDbƱ <=1cy=譐S|Y! A+J`ƴQm"f\XYc mI'A{|cFظ`\3ʇq?1|H7_3և|1|ExT8n1#n,͘rԟxhOn̸7_3 O7ƞiF?GE_8?8ZQQ`/kT$1_p<*+䣣9tQ1ax=ܭbt2CGEa:X.A~q~tC؝6x'gro?#8荑޴@arO\ *+yzVg8N#8VV51?[\•ﴢ;Ao_ĻY8.?E{W;g;rSdCS#w;g;P#?wΌwqīY[w Bo[bČwx G[x7<3{9Qsf#O;7R#o;Usx8sn z+Čwx^pd&f#?wx +ǻo$ʗ+_|ʗ+_|ʗS>7p[Gh糝<8;3-q~Qo|L|>'pMSS1|S|*pw>ϗ9g}mY|sOz[[>_)Io|XcNϗ:|9;u{t~Y|sw>gzG遣x';w9ީxzݓ.g}z%.g}z)ޱ^#rK?IoHzK$R=JX9;8^&rw]Nhz o mpG'XtZ8$+\RpA*  ~(*sY48pZnk .o 8l.WAu)ܒCBG'bz)h̟tۏ;7oYib.'l:(y1R: --R_z49hO) .!cœn/͒rœn# dQ "t=9#t 6:)렯 w-)v1@&nPB0"xz՞FraH(PK$2W؃0kx5X~n-TDwxp[fJ_ו7?^j Ǻ _+JሷScUVObjyNV=Vkbg/ay[Xn-9ԡá}w^pCnqV+88}Abk6?^Qm xG:*h/w\-s6?^nW`EyÞHOq~؃nq V'od0+[~]\AQo=-xzo#X<b'Ҟ+zqa }[\񃎏p72*a{8N4rglkE6LFwxxGފw+]ϫxx(pUaMy Sb;P#?wxp\6GV╎_[_ Ybƻw:.;g;nx*93a 21y+93alw]UΙt|x71ÉKpX*93u}Gv}xGv}xGv}xGv}Gv}xƃ-xQĹx|sN5SS'pw9or~rSʙIo)ܲR>͹f|sN<};; Ww7:ʗ+_|ʗ+_|ʗS>7p[Gh糝<8;3-q~Qo|L|>'pMSS1|S|*pwgǛ9;O z[>ܒ=]OIzKΜ;/4_zyxYirwe}Yi>rwώ#GQoi>/Xpxz-ǻ';+\N#;K\NScF䖎R=I"Gz)ޱ%rwqfLXo9Ży.g}z)Tot9;+]nIorMzKRRU䨷T9;{]9ޱ^.g}zYߩ-rw-;]Nxά׻R/ϤToxIzKSccX/9;[^NKߕ/}W]wK߱4rwW]#'z˨q#xz1ޱqhRbǕbݛݛݛݛuݛeݛUݛEݛ5ݛ%kX,FqB1=` l,`w|RXcHAYvp;뷝mgv[YJBjL2jͤ`}5l{`\\l)~qŒbRmf6PY,fVi35 Q0p1%u.$`XRI1N~tq(Ŭɞ,ɞȞ,ȞǞ,Ǟƞ,ƞŞ,`X0,bE0EƵ1@vI #(.F^#Kkd5Yu,z\-^\I1%#FeĨ}`ӼRbM Ћ%(XK[X-KVe}ղjY]+yS=RDxR4M-*XtEFZMG+ B+ F+ JkW Ĩ U #4 Z+ ^֫dAlm~+^W4A*-ߡjA6ޡ ;]m>P`XfArT*X\0F͇-xL rLתGAu)ZyBdW+l*: kAߕ RO`0 ((\E|Y~SAўXa-p2Wԟ? _W狂}OزUg4П|C>zp ʫa8(\E`Bye`d}0<.'CD<& W*N}wl-4tOG*2K^8 pR )ahZp_b̠ahA jb>,h9Ȗׂ4-@ÏO3T|>\6X2hX*\Pix*\Pvh*y zK+DАU&\ae ]+UW4#؇џPV? gghO+ kF<] o4}ud;P4xGd+񈆿y LaPse2!>]?ȐX iC53'ca>E E- ZxWӍc~ L_M-+Cӗ^0n+MJPme8 ZV#C:]i2jYbx E -s ܳ+Rep&T{rd:TFp)л2kyq,a2,oeh.>chcߗv&ޗ0[~S}~`>A*ߗ/\'3;zf󠟵ce `tCIw3nmIO/q KX|Gܜ9<%`bS YE,L/Z+YY XYw^ψ=l/wK@`hq'bK@̋XY!b^dzpų`ƳwqB?KE`.ZqK@K@K@ij)-5TI I=S r+bXhZ.b%K01(PGԈ1@AF 9b P / /00R°"b۠$b !M.6^F[cX-b P])@axQŚƨK PF -l5lc6t8%`1( "ŚRK PHx8"1(dS"\ř29hiQ t%aŚ \K PH9"qqŕ2wg P%+T dU*YAJVP%+(C#adj l g PL_|bb)=(&#xVIA1;~1)(wRPG y-<' N9D †CtG/Ź!@q&&bPljg.&9IAqbRPأ "x % N9b.bPbg/&ʋIAq3bgR/&ʼn؋IAq7b6 #a O P8RŞ/8/1)(;Xp1)(VD [<†-IwGaJ- a\)@bI 5 cBIzRP,O["ՓbŤXwsEaê5 D †CaQPtqZO P.&*1@Xv1)(V8†e W6m8ae' E UycgPx1)(N9JVP%+J/fUBe(lP1 p^lIؠbM K P>6iVӛӛӛӛӛӛtӛdӛTӛDjT2('t @!9PD(vzbBӈQNI$vH;)Nh'y:ZIiEł2x 蝞VPz4bA~qP(hh&14I ͤfB3頙dL*h&FL`t N5XFJ-0D  <,N+_yyyyyyyyy؁yȩDQ?`X NBDI*# YN=FHf$m3Iٌ$lz5=ɚT |mN+J 8/] 3 D{N-F8j( :Q6bZ1-i$LK %Ӓ~iONqniɦZjiq阜Ic:;tV4ΙiJ+YdJ*YdR$Ď(ni}PfiV+YW 655l: `q+GGڣc{8L6iV}KqۓGom؅mѩ{ѱrh΋Mg%[5؃N؁DEoV?Q[LS4Dk* v6kj`;^]]ju)u,ܶNh":ڠ_TM(M/J fm-/f ЬEۇHBUіw8ڄdz}sp:o8ܓW4{We8khcxk1nWY8}L+lñS8p(NO(M@ w x$|=6[<#Ί1nzsέz=ZiJ8n>qw7;On*A;ۂ/$ rSpn=m;3pC8Ew{(O*;v$&;[9d{? ߹ 6[?b+0ËPGg%C1aY)aPgHUz> GC>[ !Yvun筷wü>鍶!`ܵ܆5:vnae_BpC1T0!ngoogaIR>?RwraYb[1?3GcmCΈ(x2' 0CbЇ6H_ zCcpSDCEdQqH|=R0ľ ׎hH !(Ekm)jfomBeШ,&rX' 1dZe L[ȎH/OYRY;8<6 봢?Cvg'[6 +oF&yơȑ<|pe0VA~shrd?AdNa^ocۋ|Y;\#2'^=K(fJH~wSqoZ` jHc `fy.o\jR'>lcR]GmsKt%4XXΚ>*n&v;F'ƢԴM):d4*ƍIY&_Txh WW.cu-@HړƹCNN 6ZSx7(Oj iA}Va _Ckm+5PuԚ6vKk RSkT#jfRW@UkډzP*@Y!./m\گVz2 `Q`%~nitߡ^`j&&jSkrrNN e׉;-t <ƁZ&VdAgw.0VɲWj #BsSa-`V``։` }`Am{],u8a}ygޗx^/Bj@w_ +1/htѹ+?6Ɔo^C]aڕGݗ{<Ӳ! Ǯy4үѮ ݺѬk ҇r©FYuJ#}yItnx " ,0?\eGu\-7׭b8IUڕ\yU\tnexGO\4Ґwc ;.ܸf{qwӮF+3N@#>MomZ.\p7=L˂̾Lˀ9o7Anۀ a^ۀg MA]vg#Lw8ۀo8[i%G+ [@xk3 07O_ #sX"QXʉ,GdӤ6 s88&4tqrm=2@9"@ ]n8q2@9x06q[@; 6&j_bU5PͧQI| 5_`͗_ͩ|ck5?Y-nSpV K8D <`g߱ת旮Wұǃ:;xBc a %xrl<9pV =BcgpXY)8pVމ8pw@5΋qKnѱK.ձKرijRWNTGYI$8pV.0K8+'DIec gɱă%jc=\ 9/A"1(@1@4uec P.O P.w P.ʼn=(Ė{'<S'Ͽ?ݟ??+$$Rqck oſw 7nل_rp&fEKo_\owyd6K}Y;EW}$Yӊ(Rw3]>&_9wxV·k;x?X={V_=cl?{ByLg>gğE3gf.?Y~.iѭUs(_mVg3"aqOS~JhSI9cSV3gE36x? ks/N7?Έ 5*v_ء_?c?ŷ#olBώCg$+tqjNDG8dGQy(WL~M @@ǶtTy)pq ο80z ҟ_7?@6 6fS[\蟟~D'S$V_\onBe؍_ ,}UV_P~|ag_#`SKQٛ1wmLqVC:'aQ|5_ٖ5i>k?nm_n8;>a~ώC ׶ѾG{/.7aVmW}KkT[l9׿m\ض,,n[YbğN1V 8#\#~|n='?J>}۲e_my׿mn[Q۶ȿuS^3BTu?GW֪'ȿާYyD-׈}y5޺Ǐ/Z??X]!G}y԰fE :Zt{a}#NGy9=g -EzwKE/һ6ie8B1[fnCzG{#_^onf*fv1%+ʻ|t3<~Ezy3e*N|?0fƙ?g] I?g]?g}3rYϰ ?g=oIXbtiOӏg-5uߏ?;c/q:>_Y'~ݬfçN;LSO+Nc_ǖ߭c-ßr>o<}nt4[{C~_7_熅7W?˾Y?s<ߖ|h?#s?#}{wߓm;0::W_~Ym9`[k> ZCX@|q~DYRܖq30ז͹ϟBn5c=4<֪̅٧}c ^x9ɻ4_h{[c{1TUuvw[Y{樥gڍ<2s)^~wX͟A>fާiɫDCdk,[\ve=M^~_YrT߃ۋx7'\ndk\E~9 %=A{䢖o\Gŗ@9b5><'X*KxVؾߟxv="fw_x}e?lŪ_a# tZ3.{x=8%[<8m5p[<lzއx7m.3$WrGaYx >Y1lI>L}N,zqüf5kg<"x=4}lkX9<[ƹa k)ةiXZ^f=y_ok|ck.2Ѿhx__}~ڣi?lZNx?|'9?lZ_Lv>韟U{VZ[+v:sg|׺aƳ]XI\vZ/lgKEJBwoUlkՇ-5ƃmmsY{6^_?wEWħԿ"#;+;D}׎SÝE'?wۖڕ;U~xfxmlgG+~܂ס=~oOzNGV]D<z^sg<K+^g܀@~vg7g){#q(}}6^>}YN]xu_/xoܯ)~qC]AکO2_U?sWoAʕ#oU<+Wnr~_E#?gR$ކu6߳w~:l+w:ΊC>YE0C<|;Wh߁U__(z,g?cm+|ٿ".'X>|׺uWDߩN_ oaZK p}Kl]g׻ѿnx[+x;t,,s@_4~y_Eׄ_?/G"U,j;־y$5=jDy_s')%] :<8_7_u p 'c|F1磑3o<=>~=y0~-OO{Co.> k0D _p3Tz+"/Aпj7Q6Ww]2ѿ6]F<_'<zpcqxa3A?H'UJ>.oOLZ-LQƯ~UƯSߔB\bkC%;W_9^xa ^+տ~ K=y!XSGbMuB 8~*W?wCʍχ7Wď+Cx6D{CpK_:p^7שϊocZ0YއEnԿaߛVBi+ǫ7|\ U_υ2Mr ׏şJ^H@"OxZG}S?-c:x_+1:1P|yQyqqnWGQ>A{4~@r{ֿY'%'xֹy9ޯdG%>υxޱߚF`2ĝٗ|0dzBܩ?:+xzzxpO}0ӋWn Ys;o7@~n.2Ï?~5w_qzxAXzqzxan\/m| 2*Q~?_QjÜoeJ~1hpç=/7gLOR~c!q_>_??o3諾5~-=K=ѿݯv|׋x_;@Q;n @>(_wǢQyUznTxzߟkr:W=4^=Ư~_?gtyePv}q8u|Wij3 sc(?x4߅6G(? 2_ϒb??&#w>ܑoB_u^aޯ+Au[cqbW=l?zû{,2 Cs?ElS;[;lG7OUCOG:u+{s;0~Ç{>C+ޟS_xk xy4뱎%3?xL凗xD|;o~,_9=,UOSѿ6=x6oyvujd-hI^#Y4~E?+7=c1+ mofE~XS._'ho̦/}φuòTrd֓@̎Pz9F;qx@t 1aIyϟn`|ak8}͉z'#?oW|\hU߷f{Zg/\_B%wv2IU5TOg=]q[s s=h;!~GT}ާ=[_xA}v~8ߍUvmx[W|WEZ/Yc<[Wjk =7SxОwQ~z͢ϙY)Y|zMz~Xǟx5>ި/T~fOW{)?W۽ok|Ff{P&FfozyC^SzMj\mko5^k^s^k𚡿~WzM/f^SaoUx^krB&ևٿB,loW= zͮB]8ϯk"~;4~ zM?+|zMC^k6+wjoz}S#aw=6gީz!^]hl|?O=wi zͮտ}yu}[]zM`i05e~<^zqㅮ5ߥUgfdS^uSWk߇UߴɌg]]տIVKV="OSoq~C%3g,7^?0kNh\~M^/afg&s/!x} q:ȋ~I|kN|ף*y^s~^wij084~XͿFxKEsZ}׬:_kw]ɚd3_k{Ud!6 Oc&3sfn~[ꭟzMW^U}׬=5x[S>Կ"ޡ;ľ2WzMŗ6@Ѽ^KCkГOc&aο|^zML/}]$ܣlh9~E{C~cox:XYi]h0/Q/}?={F;}=ϹSD>87<}s=q_Oy^黡/hKRt橃/2n}/:}5\_zo]Nf]B{#y~79+T]7#軞'xB=ooＱn]1n?'_z}sy<9;g|OK?:~"O2ŬӁoOI|]>W0_9'}TO |?/>Ñ/%_`/7t"˗u:E>':>/}ɗ+/xK]#Y/AWKoq}sʷ/_d{/}y!assҹҧ|U>}u;ҩ/?NQΔIyys$_oCsV[ga=sϛ4H9}>AYG|S><$7sVޡ[򙷠ݗ0Y> |Zt՝/]'}隗p_/uDKaWKoʗ%_:%KgSt=t}җ|Kk] ҵn|7"_:}~xI_z}~KZ7At=Oݷ;<)//yN-?K׺k{]u?ؙ^gqlOa0@`ө,;~$+ݝNخJwN\M[?G Jfߺ~+YW:d|gKåeނt]W ǻ]zMM֥_:m9w<\z\O{ǥ{u:<ոnxQl}?$z9 kӥW<.=|:Kn]ݺq>.t@n^(\zu~K7vygr{N^?ugr\z߶G-3Kou·)\zq>K/.]:N5];_>ԩӟ]WM>.L:gt].]KOgK]ҋN׏ҥw{sեnqEۥG.t}sFv8|!qYd_"]Htҗ7t啸IÈåש\=W83oq#wX| nSθ&]zgboWkg߆s^Q뮺s]E{\y^^rc0?\C7Nf3Χ.}wKw8]ν:SgK/ӿ:yteuΡ3/>.sa"Bp`6y":[ҟ:u篾<8+'Odwt}ӥg;'N'']eK]z:YN>CGD_ I\hWm]C:]zYܟt]yftm;t'׻.xԥ93^3tkZ o]y'q7v<]zWKog=}\yt/\޺tuīK7.]:NP./\yDN .#]yuw]Gf+۝8mu/ۥ㼛x֥2^~\yRtoZᶩ#t{>k8?mvmg+K7/vҋyׇK~ӥR~K7 .xtvg]>k~פMfW+-ut}\tJo..}/Jtu;v5;y$.xt~=n4]Y]ÙWX_Ofѵ6O~_qxq=K'ojKG~;|K/r񚷮x=K7t[02Z]tG̋@GK׭Sѭ?x|/hӟťsեqe3^3]ӥ3_NN]vBG!pkԬ#T?.]'ZkvkFSt+um\ҡzItzc5m8ѥۭT>yuǥwnoxkN .1/S'?GܯpyӥNh#uggz.=_]Uz|^g:B8˺hqqҍ:\:N~¥KwZ^;kxKW~1]zm:M|>.ϐ.]K?_zqWtW]zq߮׏Kե?xIKo췦KgH~.K/̗ӥߞ#xӥ"!np|Ft;\>.pJx͸t?]m5u%'.}uҥ/{]#t.]z۩;+\zottn҉ҥMuұ8]:^Y`b=P]z _ׯ3oY{Y_yX|åʯu{=D\3&ﯙЮ֭m?1:.9S'."Lp٬sN7ӥ7|q]}{=>K7NK'N^tu6Nz8|u(GsR<\zy/l<3v+zYON^77Gi8q:v%}gxҩ/~ٟQ_2N֝t뎯6n..q}\-\:v]g|ߏuN닥KǝK_s]D]z/뜍vcݩg]z^ws|Qu u&K:3QGOޘqڏq\$OcV|9k~ԥ?ҳt˙780&L3=pҥw/۸nhè}9~]z;ǥK:Gw:'xץWa6mSINDtgueC7_=:vб/z霟X'K.?9 ެwKߎ>uЗy"Bt8b9Х܁.=]sq|so~]qitҥ?ۙ[v~zcwr:'9ӥK/gj5OK8.}mgn~A< ]UtW#FĮtgbIW[7>ܷ+ҝ.ۥYbG3l;?.}pҭoK=_ץY+"on.N~L#.L^^qKe9Z]kéǥ؝Fq|LN>tOѥw]yStl]zkO Qެ>?t}[/8V]qt'OK:ty?ѥ7wgtUKq͗סc_KO'KayN>t%tt䱊yt~=\^:[淾iҧhFatҭߪKХ[Zn\讗z6q6sΙÏg}ѝS?Y?<:K.K G:BΜ<̗nxKoM.=-.ݼt/tvؙ⎋nzٸgC7_K|?YK׵zCNqK'3[zG}h֙[p&U5|=k>ǕgXԥS;^:M^pxt]#@t2қypƩKҳ9.PKwAnW].| Enӥ9]zg/Ν+n=ᎉۭ{&^]޶3'$U:ut`}^Gft}өu7ҥ;ӥS䨗~{/6.g]ҳ}:tԥû^:wfM^p35ҥ}Kh+m5oWMNOqץq\:ډ4.҉MKͯ=ׇqyΙGK֥i^KftW]wzԥT.EC>9WWmnPes O:nϛ.YG=aqҭ3wKz.]/g;u 3'd~\];%^Z?қ/ׇogqLХ[RwK_n]]M^{YGh.Vt]ݬNc'^3U:s]ݼjӥ#]:tgԥtUeێOҥ[nt]/҇yyiOo|~bw>usSp8<\z%.d=z\z~#N.(һ/#/_μFF}qǥ+ҽ~u^5dɳ|\MեǍ8ץ7}k>:sW_S/vCg+`һӥԥg*]ÏxVwe҉O=tMG>nݼsϥKou^bu:5]gS[9ffGgkf5>.t]]9=:]cC Vo{kwיǤ6ǝ/\/[&^SGK׵bu˿nGw^瓳^n<~K~_~:;Օ qks\zM|Sܹ޼uxMHK۩>'^sz}nsK:v3rttz?]/}Ku~\:ҳzNn:2^3~Q/} >]ҩNffޗ/:t_qkҹw]r¥YnWm\Сu^9k1?\:ǧyՆΜ93kN+WYNnKo:#uK~[2oi'^kZoN~rK7.8>o~/qf|6up/;ҳ^|k^sp}\K7/vatu9Х~s1[ɏKǑIt麔^mqsK8zw]@sv?7ǥs_μNҗN~ԭn|uҋvt<DZ/.Xo=9:mKON\?z+Y/x~cxҭ7KO?2ߡΜq'm`EuúO}KNt:]J^_׎kz#?أ3gfnkm"sZXq"]Gѥ_:o.u^z]:ʣ^:;Oo>9z7ʾb}?.ݶx?;tnveK/xG< Kƥ7lgts~<,G]ytO{MmlL:7ɳ:CK.}`{h#_NtOC'}9{OZ/.p:gk#]q:c]׫.Y$sur8u"n_Ouq\zt|9͛Kϼü/|a\?^z\ۥ/?b|i\z3.ȧy6SZuKyy6M+gtgt-ҫtE\_#En}\\ftK^.}mN^52뜬K7ECr̍mNqѬs.닳9w=tt"EӕwxqK>.ݸb]p:gc}XlvڌCgGnuߺ濿7ȓ.O׈ե[I~qY/'.=.}/kusɿqGhMޗ.֟#Ptp]7O~s`q5k707 _:s9qsvw7.=:'.֙p~nצC'5޻y>5?]];y.yaѶ^ݯzxtrXUz%.}qץ̌יOY/BĝKå;Kt˸:\z8+ׇu꺹A+/ 8i\.}X;\z>.oKҽ_tƁҟԩ77=>~e׌Нc>qK:u每wǥKw>.ݸN\zw}n.~w|őKwfK~.ݸe]zХwK.}Zo|8^zש?^.K:s:s0ܛotl>mSo.93~/\z>m~\:qқ^p=]K/tċv;nX/<=^zut$:ଯN=q?]uWW\rm¥I!.]Nf~/_9ץG~[ן/^ϴ|8a.8w]zq|ԥߺzqGҳ:.Kևo|t_9y_3ӥiKOKﾾWm~\nN^u.b>̫ןvS}8_F޾[G6+y p;yc]z6]C>C謗^u_M~>t[[ѝO[^:N^o]Х۟қå׸tӥO^wtq̫6kR/]v㸹X?ҥwif&oo\^:+]:.$]:yu .ϋK/Y2oiK7o.Ou]g/:_u3^39|s!^ ]yytML&qGqzw+n^]ХЭshXzq/_KokotK.>znvy~#^3't]tԧtꌯҳ|K>uҳ:\Ц?z^:xͩ.WZt3ץ7gf8]/}yx֙3r\z}#ե#]z:;'НWm&sk?5oK_抮xͥ;oqҥ3'^S]zיڍSg}3_/Ut6]EwNc'^gtuAz6<;^Swn.뼉׼].}X)Y/}Kn8p鱍v.}n^ ]Kk^֛*m4]9#t\z/lʿ\syEz|KK?:uҩ㻢.}.ON]tN|8:Գ7ݺr!?/zg:h&m̏Kַ_}m^myҥ7pv0i#?7]e5:ӥK.Ct:ҭK'*]:ҧ$q[KwKKNZ ]/Ѝ'8qGu.yY.}ҟُJ>uөOB;ӿwf9YcC&-?Q߿bWJ_\wԹ:G}s~nkw]O踉ڼ]7w#MmpW<[;!u8 ~{~ɿ릿]S]7ѵhߺ^gkOb8ѭgN~u_?# >¹EuOk֯m~׹y(G[~ܗqù{'\M8{hhwzu\?{=pk6?{m<[/q>nqug{|PpY}D?:ҽ~{Ѿ^mꉿsG.`'=+x~M9i~n;Y? {5Onw=vcszY:'?q~u\uW듿릿Gg׎/gtg8w{lg]7}ù>Yuofp=x]8߿Oݲ? ^߾~2>}D8?:|xO\oqsϯNz}Ϸh?|ϸ?q{+p_yQ¹ƻ¹ߎvtp>ùѿ_wugwtgԯM~b|5/F8w﨧}EXu|=;]kگҽ8_'/¹g9p'pt 6k={Ko6k:+~Yo:uuumޣσ_1s?o{yuw+W8p+po?qGD;Ź>Oùۼ"v-w;g2o»n.۟9~sw[џùoF4{}3jpSg|:Ff@= ^_w{5ת~||:{{MGO|+W#ڸk8=sW~;{g|ףy¹/oڝv:_g7c|33tsϳpϗN{8_ùS]7}v~Oq7KgƑs=Rj\o8|¹}ҭ8_.O\o8\sso16~8p~swpzڟcs|u+㌯}tmssW^hJ8wG\_+O,띏_u~W]m8wЩ֛l?ù.~>Rhc>sù8?O{>ù s?op+w6q~~wq8s^_7m MIs_:k׵8h1¹){>_mf:lX/y|=ת_qp=G¹'hk蟘Z+¹pgJ^5'7 3us}i#@/m3]۟}믿߷Ц?8){q;w:x8'_b|z ~h37{DC1s?UG=spz4=WwS/>B};׹$޻^^h8; ;ο>i-]~թ_7ݴ^XosF{|c8y7Ipֳ1f8۟1_ֳ>r|Mb<%r｢?K.tI+3]P8=~s_ùvKaׇq%W8s{==hۓ%]nSb@\¹kv瓩{ùK뎯|1~w]:vG <_ӱ#s8\z=8ݴ}$>?+:֎ 'W<{^׹9vϷ?{+Wù+`~b}<pއsG۟4gYjpy!zw8w~[4 8:H׍!c=>_mWu8yZY+]妽X֭8Ebhްpog:eFpֽ>K8z9s0tO\ӟùMYmӟV>}J}¹]8sXcg|׿xB5¹}_q5s}܏sj^p߄s8}=ss߿Ѯ1ѿ@׿rz\>s]=q^b|%/)=׫q'{Y#opem>\uw_v߇s8w|;{B{8~{x=q~_$֎%hΧUο_c7t_'Cz\v_|-i=w z6ùEscA{S$@6@wz⟘S1ףp?s?;~wԙù$v|]Y:fgM8wiG}s羟ùpW+כ}sI{3>8=ޅs/O?y3O8<}?sWIb 8O<;ړx+^8}sϯNU9]:%p߄s=pss/t쌯M8>c|<y?ܟߑW`9_0;o:x毗x];]E|a}ww2y{yoߠg|mqkg5Iygu|=txf&߇xM'swև:kvՙ.]'):vGn}3._?s?Y~x=V]$^ӼixF7yޯxMGssyxMKO5sǛF}_xf=zk}8ߋ{g}Kw_qkhUצ{g|tx{Gl2>دx~>8S}Ϗ鬻q]_>;+q=ѱ׸_7){Ʒ2^3{p{3Q>5q8k{;k='֎p{?uiפn}t]E%_M_~н#8ܯ¹y8i3ùpo1iӟ];MQO5{?8?ױ8__'i/֓:Jp&m|Sxi=i=͋xM qߋsB{S/[/\'I|:#psFN&}߃xM6$postK7:v}=q 񚷮r5/hSOxM8|ҽ1^P}=׬nTY_3~_ss=>b5[i͇vcu8o3>s'^SZzwu#'\=5קk3_9zO_n+#^n{s}=8oǹxͬߖe6tēĿ_/=Dxe}lYvnxNGA{Ij|SޕxͣSg3Sx͢opyqy+f?8\¹| )k]|6;$z5+=}psx'^3+#^3¹ϧsk83瞞 ~z<k>ŏx_#^:{G}.篏}O85y]CHбkNjx=瞾 kg}ugU>|so;s~5Ib| 87ZNf?;>xn֝]WTux{ip {s=羯6Eŏc u%櫑"{Opjkv|<k>:y5JG'o&?=Wp${pp/s`{s>s]/P:ťWUwu+^]{_߻_zևN^_^^^tYhttY?p}pۥS/=98qYK*.v uMG_suĉ:t~u}s}ñ;spXo>9Օ>.ݸt ]Ftycw~ 9ҧΧJX_IgܷKl3}q:)]zùҭ:gtuKwmq:v~8]:åS8N:smpU7wٷu#%W+pyҡWܦGKҥ?\.tһGèލ Kҥ]onf]`̯z8ɧK'qt{rsx<n}ҧk:zW#s\yX=]t[tvqһ/`oKG:gxtsً=9cѥϐ.|CKo<.}tCGxәӥե3Хo|;RuN.}X?6ku8]ҭGK\ExNљs϶K}j?-9Yѭ덋 GuK/Sh?{]vsvٰ3}s38}_qKGts\+Kn]z:bޗ#A^\ҩ?K=LgKzѥ*]z-}.=OsYyɧ.yn:g.=wm<5:#qMgKoKo.wt+=~[OuNHou҉֥wkt(e=}ĸtz۹9ucutѥOS]z1Ιʋq}֥:cǥ:]q\<tq[wԥb=tog7]m=[g?.v:'μx~Jitޏy_Y/dt`9?#uuۥKY~_u_:g:g?:y6>vtҍӥ\'.=ܮΩ;ouoť?.qt҇0^ܴnjK7NOť6mǥOn:q]gZN~[?Yn\.tϧzsK7Nuqb8ʿ.WҭK/]:ӥw:׬yX.g^kťwoҥ늶K_Kևå.8u\ҍs.]8k\zݔ\\u`I|Riot룕\uU:sYo]>hq֋ե7:gљS ֥WߺqUӥuNޏK_:nHuzz|t_y_m|;.ݸA]:Q}Gkܿtҗ}ڟ狼 b;]=<қzztutu;̫6?.}X|n}8]tk;|P{tT9gKtꋸa]9/sJލťg!\Xkե[Vq:SNqݼ ~q}{хW"N<ҳ{n:\53pn}roktҭK'Wp~z:Nqq鎟t.]KϋK'ҋ~5뭏c}.].]Kuwy|yz.=t ]X:\7.Oޭ}_<wqKg~zfMttsѿv|8tӥ7]sqKK7o.};p9._ɫ.ݼt+tu>/ҍץ[P|utcN<܏[ǥ߾W0Zg:;\z<å0 ><~Eҳ֥O,t;'sWn&]i?^v qtn}[|:ӥO>.< ۥw3]'N.=]K^uҋ}\uv9q_\zQl>t_åKot8Jw=6KGztyo\|x>ԥO\>tP]oKťKyqq]ХgFNt麡kK֧_/-?n9q:8ݗ.  SkѝӟQޭ]p5I>..=]tkgu΍럴omݜB\n}L\m}ǥ{+Kg:/tty_ӥ .K7v99]z}wx_?yt3Oz.ݼrn!\y|ӥ;֥:d\z:jҮC'xuyKåwJ]_.=tDͳKҳm|ǥå.}޻M}>ҥg}'ItGKw|ǥ$t,qDqMN,Nt'ۼt K??>Cg _9_9SKKwof!\~WÕ[G6.YGuqsfvsOuc13_Ku_֥?.< g_m\kg|}i]ҝҧ?5}cLKuNW?wQ|d^5za Ǹtx#^3tJfٯgkxצ#g.ݼBۥ҇n2OM|S^ҍKn^7]2^~\mܿ/u._tĥmIK77<~W ]:ҧ/qe+-tM^q_~;צ;g|ԥgjpK+qopܷyw|%҇G7t.=z\;/|_.x1]ǟUkGdKNp||KE??.zߺG.O˼+6r}.YG謿bxMU_zykv_~/So<]:oN$6.ԩ#G<etSW^so?#[g}gn;k:vXc_N'[5l3|<9{Ef7o.ϗ.M|%]mtz9kԭ7iS\u~_+?tU_aRެo^2Ut}Y{z5$~;58$N??v-Ew:\ްCǥKOW;_xǥw{s] ]z:>"qփ.zNg.K~ҥo9ߙҙ[?&Nұ;~v& ~K=Y6K}3ǥҥܘ.S/=}ߤ=sFb(޷Cg5;d}6НGK>"n8W:󰬟Kz{һqOn\yKimG=]/=w]z^yBɓC΁NzҩW tsj\zw3ZGKwF>^zpvKǑ[0O]:qҭ/K/֗ebt[vzѝyp.T]볺tͻKo^q+_oڸt,b<՝љWuVݺ.ўåjzܭcץ?/å 9yK5WW\rͺҥΤzkOf=q]/]zY|?k:u+y"/MqqI>:y/׶?ߴlȣ6t뱙G>F-'ut5ҥߪKz<Ӹ~~o\^_/9zn^åuxl>z>#??.b\ze=\CK?.M['^踇ǥ?׌ҳ~z=[uy6~Kϼtҋ#]zK^tKtmMQ/fPNχ^ex͇6Mq]ץgLk8q_o-^xw|ա'^wOf~t#2^3s]tX[/qQo{=r~ze}vW]8񚗟/\zu-lyt>ѧK/'!vmևIt\_ҥS?p'.Y:tϯKo쬗./:sݴq&N^lONDn}M]љ/,3SGzͼ/z68X~2uO.xͨOKg?*]U~u_Y?=z问jlzGfѡ?^Yxp|zyӥKӥLyo9qu=>zܴM^['s+znxMt}z׵Oҥ㨗N=#ӥˑ/]z>{Z޼6.}~\Sӥ7ҧ#?~u:ҿu]tқ75K֥%^x~ ]z8<]Nzҗu]9\:8O?]9+tIuwt}]ugSg5\ҭWKw?>]yEtե?e\zxWׇq8wKT|y.}˼sIK>Nk%<tc~.:~ҽKYuK..}x[7ǥ]a0/8ypygz|=?.tGKo^x2M<C0?>e^5m}^ӥ{}z8׮3/Wu_G]'Eͳ+?rtmWׇ|xiלʩ;koxͬD|I<X/zNBѩtqu,}iӥbtK>._GX \җq|rZ҇p}Y_},]zNݺ:uWyk[taKϼI^^]EΙ/ :$1o_-t׽㣳^:Y/}qקK:}N+]+\}>ӥwK7]:uҥu;/xKԥ.ߪϥK.ͥS~D̿uxb8]^|3_o]hcpԏ6뜷qsUwezs~;a?8XLעKϼ=ts]n~Jqo>;8EzMw8ng'̿љ5J7m4ڬ+=N^|hxNYs"pD8҇vYO&ɭc_>Y/sE|g:3g۬s?|u:ȗ.ݼny9ӑ/I|h]HgN\{=v:m9upۥ>pY/ҭpk.K>.͵ӥKg?us6Y?yXg.utѥ~ĭSgsڦ~ЕӟEK/:o:'sG7Ktzs}t^grK߯:籎.>v3.bYs:':9u`GKsgޗӥq:nn?9G.z>up#9yz>'𨗎NޯXM~Kåt:0ys\t]/}/~^ò~:ҫuNe>C7fMaסǺQ/=#n3]e=\~usZop~\zK/۝3{t}nHt~8ήCQ~D68_Y/ҩiߪn}D_7N͛K.Wc=뉋t1HsƥzU>?\:yX,8x6=?w.yet]/~ӱ; w7ѥg}8t踹Kt⺋q6kO'&&Nfm[wN~keW .}֬^t.oSn9_ЙucK'&]zuΪ3'?~?\z'.䨗g>].>Sә}?Y?Bĺz;g|}tAgNl; '\zItt_{ӸG[WN\?3fGK=p_p˶y6tM]zƥ.=qv9".n@]ҍ3}x\uȹΙgscng‰7,st)ҳ>9.]|}oKg_4]z:naĥҍC֥KoEҭKoeKoĥ7қq'f\zӑwh\z֓ǥg=q1]:q u7"]2o2.լsþ2PNws6۬s>ro?.^?.^ۓ\>|qff|t9+!]UtהK8UXEKO=n)>uurȥ+Kp'S\urgʇ7[/pȥ[SOF}ir- .2^Qt9:t&w}g㫗^\T?|srg:}ʇKɥMʥw$\zѿK#E=b~ɡ{pɩ/6u:ppcs'gs\.7>-wNk8" \zr!r3Э;.oN~1_ʥO]/Ӈ҇\W/].=7>ۇ.3C#2==CWoNNx!\}+]˥79Ǻ~p6u:|">.\t1^'><}KO .^k_.N>[ \}09Rw+kx/+ mlk/ߞu:rwiSwgE?tG}S'^(rįɭO]O.rӺyrM7.= m.}|tH&|˥;~^z'[/ȝ+\/c,r|\n+}K'_\zU:E=k_s}\}.lp_9=g8So&~O~ʙ_g<&\P.rp˥g_>Q&u륧~:OF̯pFj/қoipwakæ0Ƨz'՗KG'.|ssMO.=9z[>ȥG.=ɥ͕[/_c5t9:t~S_å?\zå˫MpպWEX[>WɥKtwK|\\;\9 <қzʝWƟǩ;L]9tm.iW׿ʭSwxS/ն˅|vɱ̯s~S/.=9~ɥ/nOr?%?&9"lj{r^+Z^=?\\\\}7\#K?˥>ɥn 'zKt¥UCĥw9sSg+3rs~?\㭗빡~MX=rQ\zN.=ϷD|\&^xcd&ڷup$pɥ_r7 ltm9ϧUҋtInnb}S.>k#59տYO"N}ӣ=c.|\ͥqkxs5Wj~Q.=ij^3\Mt ?^Orћc\_J}fr|KOnzӷkW5͙ߑ}!ʥK8u.g>;_a'x,9rwxԩ׌qv9$8bKO" M}PҋY|cqs,wE<5LJKϘ\7qppצ3'˩#"9;"T96Y35o?lj^|nb~.Kg#[/=rƫrw˥R.}ȥ?mSY/nSqRn.^mZ9H=u\҃vf&zry¥[OzS{Щo^z[>\\Mj˥7l<>pM=zWzM=_S/=8ͥҋϿ.rk6lG*^"\zҧy郳֟WCwʥ'OzrrKgNN.}ig&לԓ$n\9߼SG(Yy#]G9zpk[?\:Vr ȥs!^\}}srU;'?z~HSǿrһz5O.}sp_K3ғkO.pɑ7WެU\߃K_5ƫ\-\kp|q_.]\P>ҋ}0y^>ܜ:z}t髟\}"҉!.~cw?G>'~zsENlu҇~Ƕ|˩_pM.}YW+\:}ŒKO=׼<\D.z?ҫϷeR9rn&!{x/n|>QY/淭^'\Kg\zi>.\\\oQ^pCnRw9sqMz͆p?tSQGpȡ/u9åi+^zUoZ꫷#_r襣_R K}uX_gW}[ :B1^K!G¥_^|M.>9rAK\:rž0rW.PS9'*ZBܫY)~  &_w{[W޴5cóuvChMn0&儢@599_rs}yaZ{_ygu}_p ^sp|7p+`m-7]+som\o4\y=>{V'8[rkh8}=uupQ56ʛ+eaۅ]:z5?9_yu{m??crw]Oᚗ]ew}\kpAq︞{^ˆc^yE|M[Wt~kz|xد~u9z^7ы=bq=5~ʛkmpk<=`_Erg>}SO0k-;r>rW[ys_\{kp{<羮=ÿ_{_Wpso=ʛc^o_y<.lkxz_z^7v ֮/1[Pÿ>xڠZ=}ZgG 둆1MoJ\ >?}}~#3ؿ_ѯrOܟ R}}3#8{ڟx_{pk>؃%~{˭?q_o:~c?/_y~¿ڗ%8ԃg':C85~+]ϿvGN?-855^?5kWxd g }==cWxt=>-+n[Kn_\ֶ^{~Zi?1'x+op3_yk>.}]ֿj_/cg<.q?c>}}<GZʵXqO׋Zzıpj{%|P񯱾 w򯯟cKg~֣_Ͽ9#^H~Mw<{ޟ||e=?{k)⹉=#:ɭX_Ds}}Ks_~~FMp~vW¿x j]Ip]νWN s$Z/z1E79rS8ջ νupso-mkc7v;~s:^1!?c=ȭ߬_[rܯ=#~Hn5}=:WarO[pWį\Dlp+pc?s_{p/s_| ~cU9. Z}Bs/85v%3S.F]Npkuc8E{/_z Zk }K-+8̇¹)>c>Fp~sO6f_Yo0~"8#[S'^_'\cp~hr |pc?o}?r\;k{kp }ͯ7v_zW }*3U8: W {Ox:8uW{8~kIp&?|y>+|({?x =opޟs%?oGԯ1ruipk}'3 x&^ }'g>=85_6lkqb~s=_{ w`|ֽa~|q|,|_C~~D~ҿ185_Չu981ނso8^Uܗ?O9 \m>N.w_6x2_Ϙ列}p?;9_g~ }NZMpg__k_p۟`65 3_ ~8{+6O{?FgGaUO; kcjͧ6<88kr+W~EE_Ы¿/z_唂ss}w['kUѿ?ƯM~:_n^y 9s_\{9*c~}®wrnkOqv;3 -v_asz8=)׾3Up}}w//6$vg==;¿/ } Ͽvܗ?_')r5Wrpv+?ƯMOo`%}os88 =z>8ޭ /6O]p;Dx }kįM.Q=_羮`ysapkwcs_VlWGw#丣`sp8uWn}ϘϪa }=uIR_9ܳ}e s_~8O8Bw68gso_{W/}%WxνWXO_s?ÿ}~9s[Fpk=*'?38O.^crw9|]?85 lIFp{r_ }ݿ=~59u"/~_ƿrfgp?pYˋB_zM_pY734}#z{s쿾#p=ppWk7`{g }W*6j_7=bs_xa[O"E<5[ۜ:>>5k };ܳ=7s= sK}N^pso[؅pîG<yrkaq9+8jx_KÞ}5 ;8s_]]W8j0=މv­Uuaz[{ù~5{8~j8^QًcCTwIԩ'"85<į^515^| Zlq5x=9^.;8_}Np[K9ر{לqzܳ=cܳ=3 1{x(ы֓[/4{{ùoP/yܗ?=8yYYO9_(7*G3 o_~gk{_\S~o_ыzTp^x^3x+\w5~^s֓GZ?|^_p¹'/(>~%: } ocw~'o8rW!8ewl-i{XϾY75sN8Gs(8{.l"^c|%?O/ ZyOuKooyN8ȕSwYtItvҍS \\zrܥݩ|U. s?\zw<) IyϓKu:pyrrrU_rM>CΤʵ}c!>7N,)s?yGrU}tt&N?!y}W\n&WyҭKN"K<¥Kw>K#i#*'f^ Zw\-w^O.ݼ79ttR:*x;3\}6\:y҇}ҋzݾ/¥9ܹ68LnxK|f{aQH.>Npɥ7\q+Mr#­ghvǙyN8k􂿄K+zuҍK'o\.us6lƋuM{rlϏi.\>\zKnaxNQgr} \9ϓyN6ptҳE.]BtLɥw!\urʥg]\uɥ\:vn.].#tp7^;f>krįQgnppٷI}9{~Ϭ Krօ˥i7>үȏtl`E|_I=vqns\ur ˥'\GLuKN];r9"S _x?ȩ3f_5fZpr]|>Yb*\ur].?_S]n~.8\:vtɥʥzwj~8'ov꫷\ҝҭ{K;cG/}'tfg"tߓK7NߣN3)'\zS .sg_.=& ?WǾ/Sg'~:b/qop-\_o_kKirZr~y׬ծGnl8*N>.#!7bKOO.tr鿴}ȥ pMwrKſ\zrr;fɥi_ CupV?2~}< G|[+2?ɥ\zrs(ҍһ'>U.8}^l]/o.=: x_\ \uB]LV="?'.]I.I۷å ontENzW:.w~Eu?3έ'y񯯶}"0Ӿ/]NRǤMz}tʥ>rԓߗKWo^.>rKk\:z޷}KE.\K_m_9sE\z/S=l>MܾO+8ȕ_ѷν_]ɡå^'rp&[ٚ}_SwX|5Mlt֧o)py|<rpOɥ\zvk`/tÙY1Sߞ\rk{憜98­ݣoSWտKO.'~ENp|opɩ#ԴSpה;I.&n>L.=cbÙ~~0>\__:+هN.=9å;_ʥ\zgK?׳!tm.=ӷ 59t9wqX3uFG(ͥM9s׎~lj_9~r\:ީ#4LJSzMGn. 6޵CνC9t+tu9tS3#\zrU=tkȡ5K[}u{GǍ_ppn.p|Kg|9%;" 0$}Y+"?'\zS]*䦣^һ|6ԗ/O.~tK)k\-Gn zo.ͩc&K$۾/6\ᬳ^ysrk]c>KSGwrK"ޗ;56\:ɥ:U.}s> Sٶ;ɥN.}8޺zɥgfS'.[rNN!4w˝SG:yG\z/yK䬣^39NVrzُ3g>K}vxvrW%.dK'~Kw)~ur'&~pį:M1"W~}KÕK\9v\:\zU<<^ANpL_tߗyå9[$6Y\:kc;C͕KKoe뫫!g~KWX.z?v[3%W~G 1ҋwrå'7R<^Y7~MKKrݼ{w}xқ7_:s>rL?Og͡MS?X&H.}ȝ˥˙?'/N^6ʉ^9ZҝOһ|rS$#p93^>8y"wݬ>:rs[wq<~#Ot;p]n]o_ edM?åWǴ?mt-KW\i߁\C}D9s=!p3o!7n}>3}V.=gj"חzSn+cq3o9t3>"}KC=^zC/}ا`o3ɥ?څ:u9?Z"ȁTK./yNae,\o9y<\gˡ_cYҳFt9ͥGѕy"WξMr}^l=rp驏lj;z|9zꥫWt~or].}ȭ쿉z~:rKoC/Ŧ!Ϸ߷m 7Ito3_NY.r6\^L~'z t(K7ugp['NC/=}>twһz[G9wȥ7޷;QSOe='N+8:<\eȡ$n]ם7K_.\raޙ^-w'2Ko[>:ξ'9I.ʉ7\zʥK.=PǀKo ՛p}`gO.wN|"zҳN .=-tͥW/>rMV~wpu>ʥʥOKkotK8\Ե˥[Ǩ^unrr[/x59v?SOtKor}K[\zrp&M}һKpU9멗n]\jK KrI.}-.G^\돃KkK3OtT?>ㅓKcS/tɥO.`M^zK{p70r#b̩@;ÿn"opr艿Z:"׮^ɥ|!. >娫kꥻ\:ϳrɥW9t+}rå [$^|ݺC8ғ[P>\0~ ->:u׋^z}gK-H.=9u0Wr"R?]iåͭӯ;ǿKw<ȥ˹ɥ]ʥ?KO;UK:ʟ/~{[S߽XC/zKO>Vɡz\==c=B.]bsp[/}`c?t7\z=K:u:SN}C/=n>n\z·n_ қ}mG>ѯ|3rEr+[rKP/l~rֱ$\zrUZҝ^:}{sss}KnR.??t׾ׇKO..}xp]..=3K8c}$>'oƯɝ_Lm.m}u'6/K9!R/]!\p^:uɥoKw8L暜9zsExAK֩r pw}yԓnsl[NN>\\\zO.vI®Ưz˭Q׬;{>̏9kS'g^zå r#rE}~8MuIҶՇKtr3}ɥK\zQ{kʩp76}_K/\z/S66up-N}8tn9tM>V^Y9 uveK$tNɥ9$Yz>|t3tp\:kqёKI.],>ԣoCF.>vK,:Kɕq?^w5ٟ=һ:}Ы٨?Zjҫ4\r{2~}sBzkʝڰK/o9\\}_-5__J}; ȥ:zߕ8%rY759t5?\!sɝS?~|;jk9ܟK7 ކ#u}zܿ-/qKwU.=orå>ɥ`P\OSY]æOpS}ҫǭ'pE}r5vK/Q֓ +ގKF.}e'g nS.]=_W=u9B['?|}9v\}JR/}I}txv6x>$^>:kwr|4WC/9t׸K?\#W}ߕ9}˥xkF_SG(\}3zK!8| >䲳^s~It8׾੟Y:$KWG*Zk6lkCǿNψgMSG;6ɱ݈\.[.='åg89s#{ꥧ>zϋǩ'^s<å0q/Oxҍw/n,t^z;]r˿&^Y~y^#|G/ 7WN= {kr~1?y1^^_.懧:'nlrď?.}KY>y?\zp-rrre_'Z;[Om&+\ 6y)wN>\zK٩\xry-tFr76__m֩I~åO9s9v򜗶g|_}DmKw^O.Srÿ檜s^zѦ}=9~9:u:n 6 z6u:_m#B?._ԏr&ΗK~~Enʩ}t}^p&~ o.]>%wxK\:7S<}rmzɥs焃~SN}SoampKO\\/\zih-#é.;:~/ntu[wmn NM#\z/NyrKos_a;uKoYtu_?O3޿\g͡ͺ>tKO9ɭ˥{ܺqeɥW.׏>/63<%Wn:yѳS_]z=Kr\KW.A.ݺ{t9t뮶^pcKOrt9Jt(!޷>:}n9tqzɥ'gom3KrVO.=ʷ\ur~xkS'o+S.\zM=kbsy9KoϗKw\_.}K/k?#}ɥ?zI$nҹ79BDnCo }|pQNG/aWˡP/y7]8Щ.]-t\u~—:Xȥ''>8stcz>\z?tɥQ@.=GpY7rrY$ȩSwXΉ_3ǿV/>&pgҳY.U.e=&nͥ9uKGȡC=ݎoꥧ~k!{'wK/S/>r#tW~{u9^oٷcӰGoo-wNGҳY.37װ3Ng`'jzɥ".'%^\zݜ9ҿK/8~'^\z7rMN=07m;&? XwXЯ+z>\zU.r3ur9l.=~䗒KrU&^:[&׎[IG.e_p9tÙ{s1>髝\\rʥ~KO}]\wrkv%hr]oirr9rwt'n߶ͥ='޵k?6fpg\oDҧ;,ȧ'N>M.}s̩\ ȵ{ʉ_z\zG_SG|)n_vrur<&7WL6襣ލ_ݾ}"=x!zr9K.qw0?x?^6NxS>7uЛrW8K:ԉbիW/]_.=O~K\T_ѿ&w^#^.=ͥ'gN|ԩ'WDs)Zw:K;Ko \zoursȥgٚ+u[3ɥ'ښ}"W;D>(.$n]O!7azrN9"n۰3ܯsc:t~e>N{PٍMl;c|}sw9t+_9vI^KWK8?gO[/Ү\z{—y?ȭå?ǿu_t8דz7[3.N^w+tcȏv98}:6Y[WU.od~X}jKO.> Snnjjʡ_̙ϊ6$q'Kz]o.]Nt[/8?5Co:]å'G:BSک~ɡ۷G3)wn]-ٰDž\zgx˥mߗM_5Wɵc0tQp9uW85]¥Gz͇+tqp7|t rM=*.=9yPCtR/yK/b=m[_zp#tɝ^.=_pޘYukǩ')r7}:6{O.}ʝ?å|k6SGhȡ_ҫܺ:~5˫^zG/VC;yPg_6\z~Z񯯜‡K/^\z/r5E\:><å?*NC/:[N/p9ܹ҇:B[-g"g5;+9v".up6}"l.z>}ժ:ɩF.Kr.mx*gN|k/\zrW^49[ ˩<Τȕe˥'ttתSS+n$C .jiT~%6v9[$g˩/N".!.7^9zpߏz:}69vㅊ6:B.x0tjɥ[?!.|Ρ>[Z{7gfpI!8яO!~ה+'~Pg/^?^_gߗK!SO=Zza9\4?|˩Q.=g,^\:xrS|\r_r˥rǷY]rk69t_:<KC/ܿ?}zpz&w^xᾋcϮהCD?>uR?QO\:oR_S<;">ՏKO=f:>\zuʝ?K/r>6kWty/χ꥓?KoN߀i= wNN,K>tQɥ_u_wurqv9ȥ9[ zKOn5N~8{rwr/=t_sIKb=+w~16}ɥ"ǝ\z7Kkr^s\漣^{zOrWmWå$=ts-/8{ߣ^> rYO.KM9s)^^zkx_.]uҝ7z|0W}/<^F_aFKz^3|k~^xok.Kw$F\}:ҳқ6G\z`w?.?UY־*ߟ{<+Mۿ?7cC$D?______Ͽvsc#ɹסqpAu^r+o;zT&8!iJpur+oZ:Zs}_y:g w>\ʛ^ʛ!g}rY6ʛ>ǽ;_\q=r?[?oM<8:R|Xwc?,g\?~g_rO]Ͼۻpg98:k]o|oEzoʛ1cNXyӟq?WKùZ"]_ǫ|z7m .28xr8߫r3g ^b%^7?r3W[/x_olWt+o>_x꽯zq$~{П_yu?}}緲8oD{1~sܿ٠wE_5p~v.1sk+og^P}M }#3xz|o 'v 0k\])g ]lxO?r=%泾+_87]cܗ?kںQWtbx?9M+_ճ w=p%^+_yDŽsO:)?n+ֱ{<_l1s>z Pνvrkῂs_vc>{{*?b>k[o/ẃs_c_33tsc'`Mn垯k7zِٗ{Y6'?|گoSy+885uW z0M:~s_c/_Os_`wlϟO{<^c+r?:R/wտF_(x?ïzRo}vc\y5{|c=o={Gn| }]_|~|6ԣ_}Fgɩ?b>Oput9uWd?mjw~7Mƃz-k]{g{ 뻂zoWG gHp?. Z#^_:rOW :/v+_c<695m팿s_Qn }4sXp7;??\r˿#8{Gpۿ܏7¿w$8'v X's_][Oܞ?9l zlا==8\%l5צӺ . o{+Ws_.}|=>|b_<8u}W_џZre# xc2?Z? l3֩׎=qNqㅃs_ݎ]~1G1Yqg f0?8/{ǿ^{矛;98>ɵ+W8;gps߿78=y=Op+C¹i{yipkP<;+ܗj3W/ù)?zz{gr28n{Dʵ_wroSGgY~Y;agn ,}q{3__7_/8|{ÿZwrטOs_gܿWN =pkqcs3K587pȟ+?:Kmzc~G}}Ͽ#9^s_8"~U/,8o/g(zrW]|ַMGW>q`/s{psCp¹Jpc'~E}|&{`}3s_M8=yWߎc~+߷Uݩ^%#ۗ%8u??}'ʩ__z؟oW._9y88߂s?F}uϏC.~ ~KK-hp{<Ɵ;]'6]_Sofɭ_c'ś>8/s??6ʵ3 ǿ_1%}E~X,8=b=7}?W~W>߱{sܗ=8=~s08'8wos 8"_c<#ޏgԉ_~_Ůa'/s885߾į;~{pz&8)G^o3 gr+^p }cpk={puw&^fWn~}׾¿'8oʽOJ䕓/9x^Y\ms k>ks}pyxk }͇6M5W"'O{M(8/s+8&kGs_7+uvp?ȵ_c}s_|\rW1'}q,ާO#k«J>νs_g`x_ѫg} :<p;w}_s_rԓ_CGQp p;{S}u^¿^ `&1|$~"8̗ùnG}\ֿv7S~;{rQy]qzGs\;88n~8(_77sz"85}ܳ^=p:6:/85? g38g'%rW_ %8s_h9yWN Np[o1?^|_ Z._t`w~*8xoo ~~qpSg=s_?Eע|Vpk7\{$>8C9vq_|Y vWs18=}6]xע=y5osAfrkigE}]羞.ȧ{ pߌbvkV]5Kw=Ư7v5%rW :5xk?oחUn]Zz*>P35{_>ݾ֓M }5U~O7~}gSϩL=z5Of^7]34?L糡M~5?<>=^W$Nf[.5rkpLm}2+~Q!D~.zͱ9v3_ pkuCmkp'Bpkv9WMp~ù'o8/pY .,8\!u5#ϗz<&rpk|b/8s}gpkaGk_<$:$!z ڞ:Q }3>s_Qط{=¹!wSzkrɏ˧^39rJNUک'Ӧ^7_}r7s_a_=ܓgs_Lr3ߔk_O@3{xpį[Q _cُg|}׬=#WzcE_a= >S~_kdxùg{P|䌩rY9ԝˑsܳ }o羮cCTlzpY羟wp?z_ݎx}'9uy9v#pk9׌Pkǿ^pQi>os3އszS8u\|\_ovs$oxpυs믲5=~WSbw[}gJkswRY>ߴs__Nub&O{¹'sok&tpkMq}J=;Gx!z͘_s^08WR_Q W~:ub.#^tѷH.].ݼ\'ϩ>ҹɥ'~y|]M~V}Dͺ8{P/[RO}"w]Rɹn.\AU>0v$ș\\prE~XQ/>K.fʙå;}p.=+t|ɥ;?ȥ{r׎rp>ɥgA.].rsׇKF.ݺҧ_L.m>/rs҇\\zׁr\9Ip7.=^ɥzaG߱f.}z>pg<'.r@9%g޳ƍ>b|_p$>M0qɥo<}Xҧ< I8/kS!|w |&n'opهK.m}vm\z:ukl{'؇(n_0WbؗKOnA.]"[Kw[.]nD.| v;3g˙7 1ҳ/O.=9u7B.x}x?/ҳ/+%rgUN\o~=ۇKS3{s˥r͗uȱÙ.n.ݼ\Y\uW9Nԡtuٺ{9~Ι_.~aUK׉/]Y>ͳtsUרKN:4\k~.]Kw?ps}p\țK[N\zVK.,q:5\[;ǥ|K1usSK͏åN_C]ߏ~q=u67cř~t_uq,7_.}vr ǎK?;?jn:Ne|wکyv{\SoX׿>.ݺ_]I].=yqc }ތY/$+׺}\zy~j\73:K'uús K~izp>OK7 ׶\z׭^xϚp߇q?t&uӥ|quSǥߎBx\q Yғ=_u8]z\znNg>q駮JcO]yKOKig3\}ҭץ;ғX|uX qƥ{\z].^L~i]ĥkkr8^\S.%*.׾.ttc9twݺƥKޯғ~8}K\\:}=Oz~vu˥'\k]}t.w~y>̯/gKΩ8wK.X`<ѡSQ׺touaѥ>Tt}uOڙ_/.1}ӥ7.g.tzq8rKyO:[q}_z`_]9uu:u?\ԩS{z]8uׯ ˥OҽCť_ű߸0_>zMG?o ?ogpI8K]-o\]>g.}sӗ`W.ݾEt#t^_tϗ.ݾQuLpҽХ߆K.ݾ0t>tԥSgQ~>9Uw>;:vɞuc_ү5ݏ_ҧ\n]_\e-^qyyҭK\z9׿>=ȕKwF>͛_/a>t.On6]w]yͥ7֓L?׳ǾOt \$2.繺t/틴tݹqyD\}#u:;\zpqpܒtҽ?֥{KKݼ|[g2=9oi]tNnV]tq7]n_8\KO7}å4]}hK/Od#T]}!q篸kG3qqԓ:߸CWpŽ28ݏk׌;g>k}~\M]mKqݟoZԭt~嚛3țu1$uKNnG]zʫ^:z]LvwpYϋKO]A֓t?}gCғ>/XשеүKǥKcK^>tK.>f3qk^:t֯kLf.^{uͧWO.g?h2_9^OqӜEĥХ\Z5OMP79Y/ҧ8H\cg:u1]K7Qn.ё^֩Kwp˥ǵL}^>OgN=I7%7u_}}kC~u'zͩ3C'^S\֕!pȩg?89zM]r=ǯrt/tc\:yӗ=p_ҧg].0qK\k't]3.]O׬nsy[];u+%d|}%tyk:nyOpkΓ.XcX}nwݿ]ozw>^ԩ WzMOX%Ok .^ǩo[^ԩz_>NKO<K[_6tO=D^~\.եK.z{/?.\٩+.}r~ĥvrN93'w/u۷/..ݿ.}Wwupү/{{\4V>̛ng#_N2/}Oޜ.}noƬÒp_w2vSw} ?iΫ;vKV\nrt\s9ͫ?.KG~nq'/|E]˥O+M];KV's\kss=Wץ\:ct֛f_`LqypnrVK7Sn~.5Oѡ܆|}еۿ>c=tϝ}NxoV~yr.A: .}{0\i0gx爷_>gK.=˼ǥFN]ƥSG1yHq/@\;gs֩;އC}O93Г~֭;'/s{6^}κ~ҩ;ǥ'w\z楳[>J\z_/u:}k>֥k^} K?-˺PKߚ#yqSl|å}>fg[]kc?ay үKסf_]ܵ~ީ3´]l5HMޯi>n77ɷn'/}ϸtK';.}x;߾7?\uqѥ]Z77qڧ.Ͻ>yssz}|Kw_(.l%o<.c0>yá/@\zAy_pӺҽ{z/썱}6 }·1mp:XssP}$foơ܆]iѥ۷D>{?___O\Wѩzʭם~{zcWwN~|K_ӥ}S1uUK}tg]k&/|!\4_eѩ>%]ǥǝǥ~q&*n-/1q#}NƬ_qSGsG6/\z$u1cҥ/.ҵǥ?~^ ]zҭSԥϿ\u]w20ut~:K7'uô.;5?y۸tV^zgꌩcɛ| ]x|n]X>g=uAu~yuG܌Y/<:οq\=+y:5/ݾ.{rqW\:yӷ7s;O_6oXwH~c]KO>]u=\'c Owz1͡C73ԕg=߈K˥Wݷ..=5\W܏u_/:uiwpK'?o]ui~_ط㱏ynҳӥ~!^c_izgs_Qn~..>.:t .g|tƥHݿnμt@ׯuut>s]yӺtu^u:t8Ù:tԙ_o8?.eteߗSN~tG>.=yu=[ycwny}p'w˥Y.>quKYN]i\ryyǥ;K\:}O.KO]NI.]}K)5o)φμoKuGb7_n[ò>Sw|ouѥgHn?.ݼG՗zAJɘCW^Ř8~yp߮_Ϝz?ׯNKw~NS.U\z|lyKOpugo#gԩKסp۷Tݬ'5wǥѡ5n:uXᆏO=I\}K?s1fzʙ_q֥K:U]ƥO߿aߗGw~nϯ7^.r|K?O?{K'/w3қy'UKy_N{w9q_ť?y鸸ͥO>ߺtgV^zwl.Q]:qqo^}/W^zoүq3ݥ1Kn߈_ _O&y}_ѥ{ХogJsgqq̸tݓ.qKOK]:uqy?+kki.q鏿o|s>^:{>Q7׏Ko~M?ox_ׯ>Oׯӱ녋}z]NGN}HKL&~%_^9wػqSgz9yWOf}Uy1f~M~:+:yn}RO]Op\σV^:<>[y2^sucs_U:cljK...J~->Y׫>tK˝~%\eDwkG^cK?v'~U9]}mpӭKw?N~U0q[9}6p≯k~^ytͥ?srғ?zM|r>tsh5k:[str}3&Go$@g~0_܌K׭8-~_a:s֯ǩ'9?.ݼԖzWWN䡟sեputOBc]O5us~sͧ~SI^}5}޵5}s!ˑү5eK:oݥ/.>_u3~\?ד#qtߺ#KML&qĥ>uq8>]g~泻V:1q5_lyQs\K?.Y̯q_篸+}tw]}|-M:צSg~?֓ݥG0yW\zwLf/+/WA9c9tq3rzKw.֭'.ԓHP]F5OoN>VoY/\z9u֯9Ϻ?\ 2qrǥ>0??.}'/G8޸#&<.8}7/K}Ekg`L?xO;ݺsSסs67c`˭g򺓗._҇ooƭ{R?꿩3g_x9O_һ_+gK KF\^+c^O^zW\˩!773?~a[^'*R~{M*OQ}]\Nvt򤓗><<>tu.ݾ˥:WOk\C}orMlt9n~޿i\9u:NMrթS׏3Gg|sKq1||PÓ}Nqϩ\.yc"S?OǥGK9F\O^tlk'աқ-.:-/Օ>밮cg_)I_ ?.g9编CoԕΩ ~9ǥ?Y}ƥ׿g^:Bgҧ}!KtХWMMһ}NLs_G}qSSqԟZMǺ9:ץy'/=)Grq&'/n9sD]M}}\:_9ou:suأ39bwL!}Nĥtkߏ}NԆ_z K?>.}xL ̯y].>037kť[tq9ޭup爏c#▓:f~}t>_3fo\zҭ3f_.OB~ߺ9ogթ;[g_ѕSO_Ǽu\͹n.}z}Nĥ }Nƥ{=u:8<gytGƥЯc]vjUwӲω{ƥK?ͻNͪ{0/ZΜ/ߒn].eOQwUK4?{(.=ys#ǸZ9ݥǥm:j]+/}|\n >_]{s[KN>yKr_?2v~=Sg}Sw5֩[1v+9\GK:Ɩicw;X.:{9ouK˩s=}N\yҭKեV^:K\:K:$]}pq7tؓ>3v:}k=uC~ǥ(y'u?٨sZyucc2ο҇?.>q鷯ǥwK~Ut<'oM]?>V]gL^u^>Ӻ8;7K6󙒷^ե:f\+/z{wx\z8<\0{}uS7?g@\zթy}ysodzwO^.}_CWNk޿> /N]gq;'¼tuquǥt:`]0.e_]ucNX]z_\u[^q^uz}\;>;ݥm,u/gқN}\zO\9+]}mKOKonݐ.=ymtuqfe\üt$ĥOu:c]zq}y8^g+].>[_.}ѝSwkӡs=_Kn֥{>ғ7K=K7^Kr\tĥ{?l^u׺guXSқ߼tӖK{tڇ}}u_MǬ_357c#k~SK﾿#O^ԭӷ7tݤy:].~?ίu<2.˥ͼt{߯:sp˥f>Lޜǹ_k~φ.0S_K:䥗2/Y\t_έq&qyZy<.]7K>V8:ZK1,3⢯̯K_eҽ?.߻tǥ߾+}D&:؏K70yף#sgrLK~|t3ftrOfz!~_\}6K/..g?`L_K{t8λugR˥}|ׯ[^㋺u:9u=\y釮;]rq㚇CKO-̯[g8y3)ǾK:Sgny鮯K (\:.W9u|uqdL>uסz^8tݥXy霏qy2/ϋ.ݼr]z\<os:cKo^ϚN|?5/=3\z'a] KЙt}urϕNtDnNWn`L]?C77u%o?OҝSw8^K.]\3vԥu'#K=Nq|K>tO҇~9ynݼt~\7.Mf,yuޯ:t[y}p0?;9B'w^+/|䥓~XOsc 8Sg;'OSY.=N>ձ_㴯-}>Х^_z^::>ǥߣ^qM^3 !Ǿ5?q闯g?ҝ?tIG^rw 9BKO5֥?+_zkRy֥_:kOݜ_ٟ/Wrl0$/Øz+^~_]5#D:y.ݺ-/ѡz͓1:?tեZtKO.U] KK㿜_]yc3P雥K~).=ݯ¥gUKo\p:tҳ>1/3pӭ?~.=U.!q<ץGL>/yr֝_}=Ϸ+^|t#9pȧk9K]3ԥo_O_r ;oi']y+/ԱSOR.F~OGg3:u]ǥOqW\Cw?NNf3o9u}'GԽЩ'<\\4!/jW^z%]zԥj^?>~u|~I91oO\ǥtқ#}"7ݹyNc0KoGky:tU+'K}Ww&ou21~Ӈ\懟t]!_;ϻpkK7W}SY#qkЏ:8{\׳~Kӥ'?<9BoϏKg y^]z31'p.65f~%MN_5.>t?OarNw\::yޖz?G[s=ӡ{2z6utp\ztg5ɳN^ҥSopwH~OWSy0y]}!8t~r_mե'D~Nsoǩ[+.KquKn.vx}\ԙS9ĥO?>yzһQ.]cױ3];}K+zi\Coz,.}'_>Vz_OO4t:8o)papt_ӿ}Sgw_/퟿__ÿ>ܫz9kߴMkߴ'߼Mu2::RkߴM]t6 ν7m׹<7m{[y%/M{[giUۭ}uoڹ.u:ϼkߴ%OM8n(ν/sCԹ; ;oA6t-otJ8~|{cAޛM[kߴso{}Ӧ;ŹwEq]yޯ8ο䩟uݹWm־i5Źs}y׾io:7m'ܻ.^z6'νSso'[}6Tqmhp:վi׾iK>v?üR{my훶-?W%νq:N~ν_+_|4Ot8><jߴq}Ӝ86=_j4=;ν%M8FR{>ݱ׳zkߴ?soW5?\z^<οs:L{?V0?My8f{{>?[-M{3p~ʼn׾ip>I8\pu;.8kߴW[s_߯MSƹ7]/ν}n~7νsoCg^m־io νnq},us=}ӟaW?|{3 Csms=Kj {νM7mc}f>4νm}8}ޗu;t?k'8s+{O ν7u\t3Xw~:7m+}v|uצk_{e׾iK^x;f~=׾ic_Smvr}Ĺwܛ}p-yo#й[z?jߴtХ׾i{oZo:lY7Yףkycgpν7ަ} jߴٷ nϷd|q}W۹\{ޝ{νRqν.pܻ p-pZu8R̃~ܻy8?kߴ[soy_zsYGq5㷮87mֽܻSso} jߴY׎s{g~v֯חsoܛCù{׹7pt]Wso[*ԾiNެŹ\{>oU&u8ƹwν,p-yoù{?soS]⨻qUgsotn~EކyۇqCӯ}Ӽ8v-.y7k4#:9͘uν :ν7˹:qq6_}t{Źscx֯q׳䡗so:){7҇zVGνYׅso:{ש[~98wt-n^2~{^swsw}sޛ;zk;qޏey9Pso<ֹ7 Թ?kOx9>{7o¹7yq?ܛy48~sw}soqܛ}Ipm~[ν% Usw}so {_/7պA{{ν\qMs{W8wkuMDžsoAXg~%y=t_~1˹?s?8wu@{>8v˹W9ԟ8޺p~%߽{νs 3:?й7q5so֙ܛν:r{kܟ][ׯ.~>u<͋νѧMνDq/C9so¹g¹ߧsoqy{QssosߺYswP>ߝ{;Ĺ7͟<_p>ӹpZo>qй~羾v[~v{:rùv~7{Ww_˹wS8wt>ֹ7νMνA9w8n/=q{q6?~m=й_sw?G˹7]ν}sr<}</8wܛ}pU^'ν]Źuޟs}O _so&{'{/B{pYƹ[Osom<8Wsu~so/+=}{w{3rOy7ܭѹ_?osr]ν鋭syj:n=νӧ_6= ={{p?zy%Sg~쫅so:W{_岇׺_¹g ίsoG{q?ù[so ^}si{~ν7.]s}z3vޞY^zS> 3~rs}soù8rmsߓwqƿso{}7׺۱\A:6/ͫŹwJuUs{{:rY_ܻ}p<ס{g?ܳsyνM$8rssso8 {﬏p_68p4o{Oq5{K}96<{cùE{oeOzq|>{soq;9:܏۳SOR_s>Jo{νaSyx_kg_P޼Ĺg{uUS?;_q>786;pYT{p_ù7s?s{#KpK:qͼh{{nuP'{pۖ~|_6tW~=8Z7];;vM8v/^{}s~Wq1S|sz죊s~};d=܏#>t5pӵ[=={Oz {[yoIjwܭչg3#{pYoܭչ؟z^8t=S~1z*: Źc5_W]S׿¡^֏ZߗKm,s|ѹ7[5}s_?OkչC%5uOpWwsg~ֽoݹ>s}¹?ίqMso߿5y8wu-}g֯Qkscg?.c5ɛ\~SI1$swZ_'ק^Ե?q~=t윏s{;:^ǹCWzOƹg~ùsy]syν=ަ7|vνsR쫁so[g~M=V{>_8ˀsw_싁soqU۩so'{:a~ǩ顇ׯM;痟~?=g5qלҹ75:w}νNNν_so)¹soN5n#:c֯q̯?ϭ>GMչǿtPHfs|^_ί:p\e:wu۵yƹ[os+9:so׹:7sLޮsyνѧW?pܽ^Տ>_ݥ*p?ҽԥ)һyo˥>yx9f֡Z]c7җK>;$ŝS׏[K|3g?u>guιE]c"ps|o:X8&\q:e]|Y.119;t͑>mw9ovy犷6q鮳kiް.>RtuntmucK?pt-_o1!ez"OK?.L<~վ SvKߏKMsuKn!.ϋ.}ڧ:fͳy0s[.}|\m_ilw|z0vSwK/[֥Ok}t/gRn9Х_"Nai2fvZnқNխOCyxЩ>uqsN]rq_s_?۱˹1.=k|Wĥc[}> .ĥե_}_μUK~l'./@sCw}N>ϩCեaZ[׋һ:등0y}3gvygg33_sD7=ǥn ]}Wt7.=.Rq<Kқ}Q63g;f~\eu?07S+ƥOo]}t+}nĉK;gp֟./.Gn]˥:uq?:}pݺ\z7?F~_t\CN>'8nNқ˥ǵS>_q؇xutk&u'7{?s:빻\/]|[qAߕ~Pw;C.7u?K~0.]ǡK7FҥB.=n=_sDqS1ίc0=<Y}9u'͓ťn7r̯|d}b]ׇ1uc9ώKqsSg3:utpKy?qθt.=Cn.ywgw#N;\zK:e\+> p~:ױqc`K.aN^C\:u~o>rΩt_.᦯_oo^KK7M~~ғ>xNt>tcťqf].n_A]z#.=u˥ϏK7X?3;Icq[tҗ. ֥71.|G\z>EqwKKwcsNT]zs֥AǥǩyF`c֯CwtGҭcץ~K˩ǥ$qq't7멃qKirAҝt?.<]]˥K.~O׶q{9w/ѥ\9:ul$?ktֿn]+tO]nե{?Kw>.WKХtХ~[xܺ×q]_]z'#.q{[c:_us9u"jǥގKEҗǥuw.қF.OХ?˭SwX˥ǩ>:ql[s7\/ K7^̯^N9ڞ7i~r}:|]:}KJ~/K7R3.=}p>?KOxt t~ҭ+ԥ~.wNΡ;??\#\z8V]yt}n>&.縮U=?}0#<DZ~ĥ}ѝp}q燐?.]ǤKw}Kbs1_Uθ\z_˥_שwdכ1uХMn ]qsK.YNgN]qvt?/V:[.ҩ"p׸t }^Kom.=ϫs>on1> } ʥ[KnO~7}tW]z?ƥ(.6/~kcSg~n^.2޺tcp9t}ҥ_i\z1.> ݏ¥>r=˥ϏK7?UnU]}=KǑqtK?U#|tnCtt>ԥO-]}Kϛ.o:ur7_.<7c$|K׉қ}Iq鹾n.ѩSO|vrp3u:ϻk~.]|ҏn=^3Mf_VKoy#D>x\וǪ}\z>8:ة[\,nؾ/x;gԙ_y?}p=܏#=.'8qץ^ե;}"Owݯ8k}^uC'W|'}:crҗIL\zq-}K8q.?9BcݜկrL_5qҷt0sgGn_\z&GȿL髆kzMSt֝ҭψK,.},gީ錙_~T.Wtߺtt+.=.=OK.-ˏK}rй$wLK̛OfƸ'bL= yϪ%ߚVzͩ3w?Ng~nst֥曧^s}2^8oԙtz\:y\;Wcơ;gt}w˥<&.b\:qޯ}>֥{=ӥN=.~2>6~i\:q\:Oqs.7}%>.Yv9U_zͮ+gZ.֙'G曑zͦSg~ׯ"?zM+˥NK?K~Ͽ\-u7N^tݮy闎98s※y|&9u~:CN.;yӿ$y輯pGKtĹ 'T~>0WgN!|1L֍[uqۺgwKjKtGL:/t/WwY'N:wwq;myc[zpn^ŜOߤ)yq9^.2 ?ҧg~%<.V}΃1}6n:;w>'uH[^:n9;EҟY͏Kߜ9mp鿉3Yus~:W_\:NtO'Bץ˙yoq9ǟZǞt\0o8ǥL\ғ}YKw}a^:ãKngn>=Nkoҿ.|{Kn..=.~8鋀K ~ԩI>ԵZW]yaSk^z7}Nq#ť[KYnIKMi?ᶻҽK$o{W M^zׯN~Nk[˾/]w߲yqsUw\zɷ};Nӭfw>'KO^u~\ -.}cU͑7^}=k}nn^.|ɏg]O҇y3g:ҫNm㦻}6RХjV^:nHؾ/o֫u䫳~re^uBίz\gBn]yG֯n>KoY/:ԥj^z7c9b8W ҭץ_߼v?[.ޞ>{ݏutK^q"ǥϏ:cl܎ouq}ҽO^NHn.s=ӥ?Kχ.=no)yهqǧnW~܆ީKť|n-F~rҥwy:?]z\:t[Ƹt6.Kc9t;S.xn_ \ύuW]u+/˥ǥ~_\u>zNC}?ust~]zuSZ.]N~%O{=ysu"<ЙsO:y8GUW{?u&qKtq͗ե?KS]uί<׃1u:=zcOyac[~[Й~?.=?y|gڇ\/]>yl#ϻvs?r36/1]Ki_\:_y鮇K'/ D:ܼ8|KyЩzᛗysgғ~׳C_xs6]ue^z7tǥ&.қz\t'KϏK֙_~V>3'[\q|m\7Ìݹ_:}_^?]øt+t>a~'r~'I~]a\C_/'c\N!&oαϻ^S~.͕.=}tq-y8~=}_ץKtK.s\tZ.=߯LK֥ӥt\E\rgԡ[?_]f^Wm֩'ίWf?|ҭK˩Ssǥ;?GHvlf}}tt.aKO޹.e&u)sk>:.U~^ԥ=\ϿK߃˾{\qP7$kK_O\zunCts\}ukțy̯tťӷ!yytGgn=oS\:ͥsѥ?O c\:n!.U]P~.zM#z[~[2]_>"/8kƵY:^ҩ8]9ϻK!S7_aL_֟q6\zK7^x_N^:t~}txtԓġ^(Kr=}s=_~WݽukOfӭ3&zq0fx:ĥ*.ݼh\}#>C L+_OSץۧg^y=9BWC.'>y>̎K?Ϫ/)׉K<ť˩3:Θk9_]8tԓ$?]7>t}n\ոtsEқ?yNݼt}u̯uѥ;,N>w͑wݬ'qݥ'?Vn#9BqMwׯñ}6jzCwnw~+OzKn=ISu;>4/=nzMtl.>7Ň}ժO.6zk塳~m:ur^[cꇿy^Kw7/}snxgǎK?=طO\4.]}/>C|\ɺt].铗~TW^:K?wnP\:9qqUOrKNǥ:kƕ/ť~頻}Kt7tԷ'/~InyrpЧ$So^cg<ݥ71.Zy>թS9|=}^ݹ}_>.=C$\1W_:y?ǥ?=}nKO|5ݹ.kƳJ˸C8t0'?}^BeʟٿKg'G6=yCgK:urK~p^NX譮owspK?uk<5.zFrNxzKO:sѥWH~ʩ|t$uĥwrS6^O]͘|q?ǥ>uKn/ӡS1ts]\:үyxq#ߞt꿩3ԥSKUgs_NJCĥy]C6=׺1.]j^NC>+_wަoˁn~.~3K'_NDә.:uǥy'9"^o~]:mt>O^yW9\.=yb0U系t^^yԙ3O$?|rww9r9~訏SNݺ'/ tyyx?.Wǝ:qt:tO=KK\\N7W>ЙqKߏKO>ҹKc7kO^zK':.>tKե:|tmwt%/{qr>{ߢ[=:{s:qq&<>j~98ԕ9wynsҗqIƥN~9n}κk{r/]ema/G\:s10ޟǺC_C?n]ظt/>qMwξR]ϙҧK/OXg;GKO]i~wһݥKIҧN>MW~K9Rқևnn|uo:?$_tt9qNS.=\ϙ_Ƙcǥ'N;.:]5_:lzfԩ ƥ[~/Lu?XQu&J}w;E~~~}WgNNԭ׭[݄.]瑼8z!YYlOt:n8~swFOżs^ p~Ł_coNǸSS.>g]tRn^g\tR\}pցĥ^\z7=9ξk׍ߩ?].r'=uY/ܻKMמ}۱ݺԙ7wgu.gt%O9\ys&F~7޽]KoCg!߻g鿩d[>x\U.}g?7/}>r釿z!yO-:\z.=utݙ.0S'ܬI~:n.:Ӟ䍯nХljҽn.ȭu#9бғ~ҙLcs^'/=__tqSK+C/%OgRCt0uχ|aq_.ϣ.?ETr鯯zWN?:KiqOFny{_SmU+0yͼ9˛}_N1ߏGgNߗ1qGyһ .!]z??|Xu̸˥ۧ3.]ǤKOׯOKW.ςKo_?!/|~mzz}\.XW:H\ArKv.]zsu:cg'yC7/}0f?nҫ:aoۧmѼtOw\u8_]xs?u}=乞;S(.OEY^:tWa!n\}:Vnݺ~:|Swå{ť_ǥ_:tO.]z^wa?eK{[z.?'?77ts>.pݼd\{^Μ]JnU}t|\z3OQny y~qrusc/zA\3n~zɟnί_~u&r齯g՝9uƹۯ=\Еt<L~Y\zM}Kmu2?]os;΄WUXHv`380ىq`v۟ެJT_mbZȥWp3/knr&~KK_ҫ:טҭۚ\uҫcݗ)gNȥyty+otrM}gKz֥K.9z\?.=rɥyȥK\zU_Ru}rp&џꥯW?=pwQ6vʡ;=؃M_?\WK߽z驯>O_.}=W`9zzKS."_*Ǯ>S\ߍ{ɐ;缫Kꥻ?KFp;n`8Aѿnɫ6\Gr鮇ҳ.zuK7>^zԵM.|S/=꥓WxpUH[ns~ɝORsz0{=zU\= :u_}K7Wr5l"N>#xr#%qrUS/}ʙ~_.C.]!ntߗzw9N8{t ʥ[gR.\}^˕Ao]5һn.)>/~Kn}Ksrٯ֩chsKw^?_.ׄN.3L&N>IS'?9qpKroS;һܺKOnU.x|M׬K[::BE\.]NpSWmʭ迈ɥWIrqПs?!n]C/}asZu#*6u_כ3RwC0\zqSN}yj/pW^OftZЩc\Mr֡K['_:=^:ҿ9˥~_!{Y}L.^.{s*.7`SɝS*+u9Yr#Kp% rkXȥ[P.ݺ rP/]*n.=gpoҳ.Mҫ:V؏*wZr\kԳG/7t\uK \|mλڇKo>i^|)E~O]~~?8t&߾= |M8׼/~ǡ^rM.d>Lӻ2_nQ:̷ףȑ_'*䰛u"sK䲛59wt å'zyD~[>uy=uKgޑ89sc&.ݺ;5n'Ь\2_3sϛ9$]!!B_U.~˭?1?Ή~:zC|ҩ&n]+WwC.ʱاM.+-rԱ'ܥ\ySn|ͦzrqs>墻ɥ_S%S1>Q%tH҇N_3gZЩ >'qȱO2̯xS=q^\#G?+'>[gQXƇS+[ဓ;K+N.=9жΆ+8ǒ:BpɥOۉǍpɥߗz%k=6\gEkp;Kr|f;a8om_/!SGˡklG/7wI.9+G&Oyɥwꥣo?>ɥsz釾pLB[9tλܺpȝ߱~|ͬ@fS/ֵ;t$S.ݺ\zor驿\zzupyԡK.].=9ҋ˥{=ҭs~߬ҫzkr盼!z_'n.e:B?ɥW9s$gN]_b;a}oxM*N|xɡ>|#^wԛƇɥL.ÃKGo=KNѫ^..ްS.{?pꭷ7_åח;K?K.K.zKO=򝯹ŇK_gfgoʥJ.ݺBpY'efԝQ/#ON_r/-uK9%΁:~|߿j;_DBLa_׿wC {O}ɹr;=-=A!;}G/{MG~qSҋȹvN/\gIK+rcm{S?ɹ!W_0ȹoMvp;n~wp;n\_ϯ߇Kwusop~?? ~/=t-}wB-Cp;S{krWx ν~yNc[68jW;nǿo>]pN=|V広s/M}?;nӁڙwtGl_1x3a;s[}ufg:;nڊb`߂ }j;[py <[/?b+3_[p?n~M28֯xso]#{S}7/gMwO_s߿U98|ַ-<7nqa=պG}aq=㱪;/8wȹYi1_sLqlvt?sۿe J}˱_ }ώ8 ;9W_W_Ko_1Yw!8na}_}cozz}*8=vkrw\z Z?tsܷ¿~|G=!_z:=kpa?wE|듁ϊqp{=?c>M_nŽ)/ܔK}8 -Wb> };6WW0؋-q룞'>z%~57牽b}_ɳs߿g`߲}$up{[W{px\鏜 ?[W/sz[~$8 |b>kr#kFp?ʭ7#[{g0νp }}L7޿w|#8w~߃S¿w߂o{g3son#{_#38z*swr%Wc'C }k_ۇso#[rO?¿g Ikǿscv<ʭ_1һW{nxlrOWo?9<1-[`|&  >sg~ 898=tCUn2 x[/1gؿ&~5O:8>O7C~Y#nwx=\s ]b~Op?1s~!~u ,;#g<}ko1ރs:78r=<3r5ӿvpހs#{^]OoU~2U}b/o|kW~|V_x{9wpτszIE.w@}xCxvr5[g/8mw_sKkrxNuă_ùg9~{"¿뽞{oG| }ޱ 7vxcoyvk/s%c]xɹo}cO,*^/3Ϫ\-:xfgq{WrćWgog_ps3&=ד!^vshs~ =px]__~_;8ù ~ß-8wފ\DpLs߇3AԻ =pK"tϻ";8w|相'ƣu_s4;h8w~ νP矅c.[y\Mp{==♷zksyO{쿊zna_1Mؿ6KZm]ć\'8;8w={+νs%tkrkׇ38=s6Wbp_G}?/{M0uzWJ^6>,u;^s~>snB\s"^s_9܏__sϖߊ̺,TpWwɱWp= x\r5vkr?qUG%8?5kj_/:~/87^Or{ù91}vk_ܿʽOOR}WpuyOs0.|&nn~.9'lKogb_~_v_O<se_~]®o>>Epyǿz~"ypsUxvu 7]ÿ{kWk'GEn:8w~q>XD>SG 6yQ}ok'wȽsޕ zɭ񾞜 }羷qxamp{vpF~}߉aO+y<~{YɩO=ﺰrpXosc{`?r*^$_{/¹y*^OL:wp3t?^ȱkZgdo؋BuI|W_\_;:0z8}{rizU֙yk?hXL59WȭW淆c~^?K M牋|M5p|{nUn;蕓0grwės}̇xUKn<8>lk&> oӿGf_!gw6_'ʽM|[c> }xܽ~/2S/\u_S|3$7o^#_ g| =/pOs덉M|ʱE<5ù{*'y{/3] {zۿq^O/lk=8܏7pkpR3oBO~|I3 =ss߿b3't~hpO 8kb[/gf3yGfmriXM-W]oZrǹDZ~x3e'<=c|n5\>ņs냆ϳMn<_nb;$_\sb7MrO׍=cGf^=K }W'#٬\/,IR?xc[wK{qwGZuɽ߲|g_9{?VUG_jW淊M#~|~wӿQG!_wc{Z/,xx.o%O+nI.< Ω>#\7wɝ_N\+t98u6پbރK/3q&G\c't2ȥW/tKppƙKOs}taK.}\zr2O9C.]rpɵqN9or>ߗKOv9ϻyå-w;D_<>,lԟ') ѓq%"N>'~ɡw6yS}ye;g>KnGnχ8gl>s_̋r< 7ȡuE2/8\zr;;Ƀ-rWm =&}Dҗ6W4cJ.'ho_[K/r8K7R.=ktɥSO+KS.}>K}uG}G_.yҳ?gȭrwO.ۇKoe^S'y: _EaG$WMhǿqN;녍'g\zrSM3/{.\uv˒KO${ɥ_u\zG^.._9gCp΄׬rɱ#/ҋz0|9뻙q׫~M|ѣI.ݺp}Ht=ҫzrN.}/.NN+z:v`'9̯w9t꾤9"uq!\qk^.Y_͓K$t+t~K7O+yrգK7\zsϞq[_Krռ~?qNwtɥ|9Kr: z˥g\8zENɃ]rꍺ^7xM.2jx?ᲓK_.zr&'^Kr9uo.y*r8gr]m:K/'^8gW9tЉs#\n#VݼȃKn\gc<.z.}a?GǸsȋKn\zOKϼ;tw҇ɥSWa{wr˥Gyrr'rm˥\˽KN}I,lpzp>KT.:p<҇tɼٟrɉ'K?/$\utKOyӁ#o#6mtnrMNrUkrWq^:\=. [)ux -r- #O-# '^ԯ-3q\DKO<ҳ.ҿsi{K.=?<ɕ_˥:5\u6Sκ/ZN.xLrK?rᚋpGKw!^C:Vz{ND..& ntҗ?\:uKO.μ?gk#n]M]Ks|^\|pouЍɝ_cK/K_tEҳN \zUoM.^|rEΜx\zrqrة^\ ̫KK>XOW ksKO=;'^z_kå[wA.]A.].K.=*7r}ԉLΜ<~OK_%W>yɥOE=t8sx3uc~K\z`S缫ɵE~X99[cgٿ|[.{f6:ɥ_rpS.=2Ҧ8\7\r˥wr]kr7K/9%~sp?[Ν,9rrsrp\u]/ɥw^}_\Cǿ}-0{='+9t$~SU.=0\uҭ^cd<K~0>\>\r3+r|K˩?ҧ6:?ktrҝ/һzW:v?Kw='nEtɥ[W.m^κrցK\zrEZS[w׬ .n^79Nӛlo'7,^/͋K.:p?'r1ȥ_\G{rS'Dʕߑg^o\ꭏӟʥxYasޕ}~fʩ3gzɭ_rꜿ|r/-g.n:r䓠}Y}:s"^ԃ渿"grkG9=og~Sr}\m;WjݗX_ʥ~ߵc\zw[jSåK>׉M<._v'`O.=9E|d>Iv<~x\3'ߓ\z;ni_Hn~3\zy.`_ȥ?..(n&t|?^wk69uåW_}gt.ݼv/˥[dpJ>S.c57pYwyלrćS_B~y3̉w+7C _c~{X¥O қuᢍP`yλS0=4ȭ}kq˥/ rú|%N^%NgYyK\z?ҭ+yɥˡ.\z5+~pW.|K/.z%uʭ[ׄ'_Ӻ r\zå':Bɭ͝o .=\ rϑK/ǎAZɕ__Ua^759sdݗ-n;M7{n@k"_3¥^+\x/9ﺵG/+ə3ݓK2_3uS_)g&z߷58 zvr}.gN~\{z9rM 9s kF4qC|͉xsE+k._׿\:8ɥOutrU`*g\:ixrU.=9/t9E$^S}~9gҿrEۺ.}YG`Co}9åɥ Vr7t-gM=;N!8®/[:^#g΁޿W_\zUׇK'(҇zkWrQ@.y#\>Wg^:rGmϻ:6p#ϻ!Co_pSN~:K\:VrćKȡH.Nx:u.W1\:\~a}F:B]/M\*^gåw9k.Ƈ+_KK_Gf\:u.}ȡr!wb=x|=?uk&kSn~Ӄ5폺. 'O.=ߒiqɩCd;篩>I>\端.L*~!2+~_kv9tuqpp霷&ȍGf-p|ZݰٿK:x/~ɡ_'|a|>KQ_;5 \zU߼6'Ntrߛ1ҋukK&\eɥ[H.SgYҋ;5G.9vK\zҭ{,rraKor: _.}srUr?jUMOg>K^2hW؉K__ֱzЉw~C|Mt^K3_3~\:ҭrKb҉$Krޙy|6#0%WNfӏ|Zp_'}3)Kp&NYr{~\z}?}pIȥ?r םq҇07֭iK.͕.n=C/ɵ=.zɥ>x5\x9#‘ԏЮǾ,tK8y9>\zW\\eFN}sDf|C':t"rSKrևK_/qN9W/}|zպ襫*o'Ή\/Ϋ r%^zʥW/1ҧrSG6lԳL.]8'r9SG!t੗n]W/λn n .^zpuy9zKN9ɥ~}rUN?KSH._] ~/cGn.97$ǼK7\"\K.]ۇKg'˥9u9\:qG;g}~d\9"ݷyɥ߻=Gl#KrEnw]NÞ]w$Ao&7=[sʕ\zΧrA7aهq}+>Էə\{zU<ҋ.cSOn|X KeG'/"Տg _+v?i>^O 'q^oə|fp/_.=֎KG:"gNKN}Xꩫ!ι;/GXrAoS8^9lrrr\z~5.P.=99k;vt_K~*>K,}r9y^n)ҝr#္a}0lkpާyKU/=rVɋrbSg#{totarmt^EtNj\-|g^ĆK=&zɥ76qΘҋ6qqNFɥ^|1޿K?\#o6u_' s3M[ĉ}K\:q҉^!'w8_s?wә~}G?tiݗxҭ2̉s>u2 woW.<+o9tM^ƿAE\yr橽zw\z.G\\\yrA4O.8ÍgMf^W/]K'Ω9s[gm~SKKsKrr֑xxҧ;zw^*6G/ݼһsp鯾|v˩ '\zknKK7W.}:[N=ױ>It9Jt{å_# y%үKNrrYrr1rǽ\zS?%N|@Uƿ58?wp? g:&~ėK?ЯT9R1Cn)Ϭ[ڱp_y1{p̟pK.]$S?DO;tK/}zn-gԱ'jr9^ot\҇zEnȩ?GfҭC^-_8cg~utՏKW?N.5`KCx硗w7>ܴgzɝ'r..#z%&ns< S]=Õmj^\u^{=\z=>zʥ*,3*ʡ.~Dr)ʥ[Htp&^c|QN.=9G KOb^DSpgCUW/ntzv0/9s:yY:u"z8ryr嬣 xAѿ~裗8ρU\p$å_}ҭ&n]AtVȥ'9y/l0Vw}& ɥˡʥWO:χKoe'\N.˭.Nr9ɥ;_ɥxZʯӟʥ~x3xp鵪^t3.\zpR/ī.=g\zҭC!^^x^g]59s%>FіK'^''ni+Kr霏&>7t0\z3'}:x?ҭC.x\uҍ7>KO;\˥?zs ׈ȥ6\r篶3׿j_ɥV.] nO.ݺr]}yp\kg.^c,M|'99;/ɥG1tOtLkrw\=K&^r%yқg5XU/Xɥ˵\z\u^.=v߾sm37m38lrw5>5/n\:KS'$;pYH.ҧɥ'ǎ!Sξ4?\:u.ҶNɥiffS㱿:u/mq^9K\u^.>.KC/XלO;p#4s;GS ?\z)rʙ }}|r㽞Bt3^g;G=KorNf.$N&\;:B\-ގn3ЭMf6_SNjuK^:m&nXҝ?}?ҫ9}xқ:5Y7G.ݺr:O0_'n~oOKkM^?}kRW!5܇Krr=S// C^\s~5Љ_rȵzpsEN'I.]=\Cn.絩[ ]cl:}MΜpO\z9uI3\zUraѱ9zpuޣ.\cGr¥WV뫟>̓K}Ot^zׯ^z?pskʥ55=,81tާK䰓Kr Pr3spk&|_KoֱzQ.t9C[Jje>\rSߙ﫩zr^:7[x?һ|s;-n]p9tDKӅKܦ\zLǕK/׎}>\OQmkprU}״er驇>Skv޲cYKz+0K۾9HϗI.r'>z^z9u%y9t9~_ݍX*~pkvuꖢw^/\r7ppͺjN%>?/+Or9$O?oͧ^:_9rs\=\zupKW.]ғ+:hJ|:zSN:h.דOw{e9uI{K7>zC}KOstz=線|>S?3_3Gr W|Wk'_\zE#)_=k)Nf9bW/).3{ݺjp멗k7%yzCzNt>\zK\.80>#.tSz=y:å;һ/t^:ᩗ/Ao}wx9"?ttG?9GJ.]ng7CS^Y_?WE^XpWrsuK=G^\zUU.]n8g{^zp0r˭`{(>ləmy;ҧuS?.97o#}߼S/=3<\9fș7 n;ҭ czrpZ`O\r7:yrWXK%åg"^/9Gn\:uқ|99sm;'Oy=6Un}33bW }Q/sKrE3Ul`9\+J.]_.۽'9G|Щ^ww۩om7O'>&.ܹr#vo\z~:z]N=ҧ47˫ǟzp-9N\:NKw>Kå%&ιK|lȱ.ꥧ:Irpɥ9x✗q9sXwNsǞ\z+o߼}_tK/>כ\#8'sD/ɱ{߭׏^x9FM*W^zCÎ8`>o+L:å7qqNٿ½^z\:9o9jqΪ>իhS%rpd}'WN!qΪ\ܦzy榜ΚM^X7oK]=ҫ˥'W~GՓK?5?LpM.]KO=uoM^䅽z錟K2C܆\zM\:zԗzsə[S=ׯ^~sDsȫKWoU.]nA.SGsD8n)t+/~'ЭKk_ol8KBf>w3˥aGO.{b?\W>:S'lG?bə_1i>z8p5å'*.W3ަ6ß&NDrD/羬oyrqn\[KWO[2|.=FN/E\96p9~kW.]N.=ҫ%S?R.ʉL=MwKM|.=3oW.]Ld/E˥?GO9uKM.S'}9bpet2ϺٿR7aZg#?\zQ.qryp\#|˙_CgW ι`rP/]KsLϾ͋zr[D.ݺ)rr¥[1W/=m|&.nQ.^cW/cدI8v9ɥ~K_n7o9Et9dtK_'yrrr iy "br關9y5wM<:3r?^.&/"?p?T/}u_WK~O.ݺrU}Ftɥ;Cֿ/n䐓KOΜK?zg{=u_v0^?\uRҝݟ˥;ȥȥKҍ'K>\:i^zꝓ .= ʥ ^/z+@.uo9P:Or驷zS&\ɥȥCqyu6s &qL..c.}InkC"tK/>\\uZ^otXқwӿAwϻn9r_'nMt r~^.}91kt8ʥ7KG}8‡a|MҖҋW˥꣣\rKor>2>ȵ{%~^]}}\-wrEn9sz_rֱCgz˭{~KsKw.n t/뫗^"<"Nåf!Lb,N\zor䟤^:-r૗Щ5t𧻓Nܿ>؜W>?.=z76$?KGo)ҋaҋ$rROJu߾R9A.!>;SG~rzѻ|MϛKҍ¥g[tШ}_rK;kһv3>yӿ|). ^ҳ|f{?8ҭ%zyə/c}^)?r59뷕:B].=g+\ΗK\חKKwɩkuys8x5=K竗~ˡE>ҫܺ\9\z_뛯)uk{9vt6ay<ut[\zf>C}esDs_ɥ].}M ~_?K7L.=0SW.\zp?WU'y~N> %y=:B.xEr)ʥON:5K.}kȥ?{g楽rݿU S.=W/ϫ#uKé.-}Cɡ^?"^\4r鵾.=W/hkrWoȥ7WsɥO??KM#n|Xc\:]ɥ/#_|C/=Rt9Z;Kpr^:6H.|?w^|ͨ^uo׼+v'_].ؓKy^:׿6uu&N.^rʥ!ʥO,~M.ݺ2N +.}^:3s<ʩ\zw|,n] I.i9ؙn?O/|'N[n/-ʥ[B>-\kʩ[w3wpSμ>\T~ߗ:B_.K.|Ko=~)t$ntK~_3 Λ|ҋug_n>Ko?QY;q3_I"E7ìc7: H>9s0|Xiu\rwG'_ZgaY'2دʥ^M.|&N[>Ǜ\z^.cC Ω[M.{~tg0 loτ[Ƈw7'_׫uɕ_!~yM۩RlǿRw._:\zpr$>G/\z4ux~oꥷKϺpz'\d-g^|'KK3Kғ[/y=רn]o*/n# .O.}ʽkr7U9u+zWu_] S˩_H<&Ko׼?\zUYֺ˽>M׿_Ͽ~ ~=C  O}ɹ׶swאkF ;u97װ~ajr;n>87}zr׿{ʽ׹۫\ wېS9_r{ ]@-·}cwtU{DV_O!^sq= Oywts__r-D7'^ʶ;n\sooX?<~>b|-ܟ/rw\}ߏ9Op;n_s٩cn+ձk{G.~E`supx >㱾x7[W~M6刺vtgr{>s>w=u|sss߿#8=kGp~`;W-~c> x!>>[{3=?? w}pݱ淃se\㦵9_ߟsx_/gwt].Y]ÿ/uUsuE.xr-^M_z=T% ν6 ~պ#G}|u4s٩,vpoXWؗ&K1 ~yp{q|Vg__7 \Ϭ|W=V,8MznX 7¿r 7;_8;c>s{m+3Fc~W_[g~}o'o>t?r'}|6_y`)_w>G^\pKps~/_k =׃p[GOz 7qZ ν5U48}?rWߨ c<_rXrsO굯\Ǯ1 r#E}1ɭ]̼s^Ӯ1ѿS:@._z~ߥ-rOx?kg g||˾¿G_k1 x\~?#+8+_Sr%羟o=/4uk7 8pٿ/8sO o'@e<} c˽k osKŮ;¿~EFO}rX~;ÿV9Sp;"zSn:8{> }s߿w瓃s@9Frÿ@龾ao*}_ 2p+_Rsa< x_"!hr7 ru԰"|ɵy. 1#[{Ew1~sr+j^kp{>{3c>So+8Fwh8=_l1竊EϻȽop-{Upx};axd$8W.8/U3rYE݀Cv< ~yoor=粝}^_LN:8?rհpڗ^sȹϿίϪռ{Ky\Ͽs( xƿv9v-Wp5+p{+;o7.XEp{>;8ùc ppb&io1c! }߯}nùo>gψwU9uggrW?e|e<}.pWgUr_o9yl89}? Ņ~* _+ߜN;x+ua/Tw_!8w^;W܃]Ono_[W9[p \vZX/g˩?_OsrO!?;!m6!lI'y}_7v?\Nh7&w˽Op]8=w3> s?ExsߟLN(8k>89¹_>}~|+ _:ƿ¿}g'6|8r-Ð}Mxx.Bp}{o{ƋJpyof|t ܷ+lp{>'?#]p;yp_8sg;W }l __ks5gėпc>[_sG3*~+1cgڽ^rwOg{m2c۟{U_~opo7}p{#=3 oL5o$_|<'ƣIxX3ɵs|I87~&: Sޟ'O_\+Iz:g&gk[Ю[UN~*kpo|e_wλ3_85{ˎ|n3=K"_3L׬rk^ӿ=Oqa?ϛ p |MD? ׷羟nUl6W|k׍=}-~~c|Į,lλٕUnaI^8>ulI6[n’kǿIࢋM|v5> םOn/58~!9v_6C=s3=ܷ?>?Ά]M]kʡ 8ù=#{}?_9x {ݯ?sx%{w23Wp ^b~G=~}s9|Mq~p9ùg>_??|u8mOWsQ8\¹q~8'}k\I\;S)~=y8\Og|}WsgzP~=kW:{?O|8k'_˵3=r#z+I<%8=ٿmGfss8_yC?qz8?|z39uҿlǿ/^'n[ۉÅI]L8os|g8>>8؋{דs~6a;W>?¿ZǤy~|M8Oakf+%~a{ùg<}6$bwhk6$rg1'_I888/s-o8?j5IOrù1{#p{ȱ?ݛM17^~z+_'/ Kcå?ѯɥu9;:?"nw˝Qkɩͅ~^8e;y3;!OD.WaCܼ]y0tɥEwt9Jt/n+t/m.=կ/'ΙuK'tyҋ.]rtҍk$>$t90t9 ^9իK%.%>̉sN#鹢\z΃\zU.V?=✝?N.S,^vrvms y_.=9q✷3q|/'Ι5qp}zGO.}h' .g(RoݼÆNy <ҭ N^kr鏿oS̉s.|#˭#$wp:1?$^sD܇ɡ7qNIK/~8u_r .}\z'o0tKK\Ძy:å<қuB҉'>է8ɥWƷ\z39YE.}s~>0t93Yԉ+/Oȥ׷n.Fe;q_.] Ø/3O.]R.ݺ1pm8ޖ59tl^垉sr\zr9KW.,]'~˩Otr>O/+\7\z\T͝{=O.}`[c/89Tҋp7?yɥz#pɹʥO}җ#9\:p'>'/"ۺ3/lܺ:qμ~F$~ۏ8g?8vցK^yr8!_3Ι:uȱr}'rLκ\znROgow'[?^ErM8rya~npYw8gSƿL.ݺ"rS{+;ҭ { .~Nz9um>\u\8gmZdrwuS'i\z'/mp9+29உs \\qywɥ7~e=seLrW9CKCgNw?\u{;1tɥo 폌sppu6Rn=~!_.}}t_.k3\6\z٨rsh'YcKYɥKoQɥw#գK\9qrpsy✑GO.f|ɥ'\z}ʥS;tGt5K7/\.=s.>\,/>?\\PZW }s>rr\zOr;_R~y¥76טSW-_Wrkr˥OчN=YW-ڇx+cK\ylɥ88m_Xrb;YpryKˑK˥7mλb}$BrMK #>"\\\zCN.=G.]NL..國uO.=柗K_^3Hrݿ\zCKgK3'l,r.I=uS7\zn]|ݽ֞|>J2;1 X t^qߣ吝`-=۳b5] kƥwxutϟե7 LKo. \vO}9]vq9tUw~}rt/ׯş|6>..}ҡN5os|qxǟ.>Pt߯s$?/]:j_5y8[Kϼf_p5.fqoK: gCg`/xkҥ/߯i<.=럜_u5UϬg?[<<ӥԓ~.OǙ;~Wv KwVv~M3]sǥ;?ݟ.8}_ݜzt:H]}\tcK|y\ǥ{Bޖ/..n}st]zn{}9]z:ӡίE]}tW+ǺtWҭI;ĥe_uK_]vӇ`Y.=~O]zμ~nҙdy/:q8us>N]=]zOt鏿?spQߺ|U%]Ǐ..}갳^k'Yv;^uz~el!0yþ҇n;5}}>Wi8ҭ/LKқ}u9¥fL߷'5c.=tӥ.ǿ]Μ]߳]z_f~3?.tک,:l5'-uk_O.=v3¥w׺t ug\zW'oؾ1ksu|עC'w LS~ǥ.8ftׯ8׌]zx;MO= :>>rOa^X>x׻ [+cl髖Ǒ}ه8~`^Ǒ_Lt:I]c\a3stk>s\:.XOuO;3Efzԥ7yÓ.}"uaz˾Kw}.nj5o]w7ן.=\.|R]TpO0z=.=.=]c.Zӡ$`qқ~9ncҥq56~KwKSgPיs@uӥ?ҥgBn9Bُ;׳I NIեwk\yt$Y8]:;gz|=_1Kºt.={_}vq|u7\֏Kz1]Mux֥gt?Ǿ/0ubkK7Z>=ҥj>̻r36O.qs8[zcwWӥ״6]z5_|k&;59$yɺtr ҥ;g~-:vט/K]z|^3Df|KW/כ8r\n[]zҫڸ~ӥ?;>kf^c._.Y^^ҽ(#u1}Kw]֝gCnzMzxY5sNpѥ{=Kw~Ƹ]5.}{avkR.=ZgP9]z]۝!pK:p}5u7ʩ׼|?ҥӇ`s0|_u9.å'^O.}-y=+Dkv3LNtKKKWcK%]z.tQ¥ҥ{ץ/_O1w72G֝1}3q~.=:Mg@n]z7xҥ>~.%.}o}Ywu+O~:,ܠ.שKys.Nc[}NuL .yYy=K/gϼu\=;/=u|uyݹωSf3oՙKw_7u?ۥ?:zIcť[ե 9D>ߗ.=>yۥ떯KonNR]}|>.Wq|җ}2/=}NGy"˿K: Ko q>ҥy8}ԥg}X;.{G{]]YK??ؗqamt\>}!t~u:.ȳ&=9q8gsv:.=/tKyҽK~o^O0q"?:5vқuŘ}ԥ]zt|\z>g]ۙ{f0u^>åw,tҝ31þ|\zs_ϺһvMw9];Os+/[;]zեW^]z/9k>.=jo>o\יף$]:{u>?f>y3_X нXuե#ϼsӥO]nҩ=һO7.ݾK鿙[SO}ĩ+|緜_|Ko` ]:;ɗ' }N.uҽ8\dL?t3G_ǺUn>Xttꞎ۱:;3ǾSߓy鼞:v^S7/t9_Cpt9y+t\uC'_åW 'I>S7u%[gz\}tz̩{oC_ǾjK>tQ.Yg7ϵwH^4:]usWsf>[K's>;QwK}qmu;ӥWrsj>w拎tUlj]>һysZҗq_l0ұW-{+/YNMu:][ۥGv>gqrL>n]vqnN_\z1O}NbpHnϕC~UKn~yȌFw߼s>:uo6G}eޜ>Ҏ|]NAn.]ׯK7Bts1]/ӥ9}_p˹?.ݺҋc`q񙗞NpL:Sgnu1.ҩS1y[7`Kax1}#/=ݹmtO?]/cGtq}ҥ>bSwX|>u|~;1u۾:v<:tIӝ^Sq13O KyһnQgs~ӥKΩ~t-v=޿|.}nna<>2o2.g]uztϿG>usǥ83̾/>ҝ_֥ts:tut>'Xߓ.;c\ϣLǷ.}QKoy1?ӥ?:;\c\>`ҝtu0/ݾ'^+եK7Lӥg^|.qcs.}Bygd.=ݒy 5/lN]ҙGtOt^o߯~s>֥߾ks+ut݂.o>OGK//~}\N}y&|8q:f?~[wd^߼tuK'b]n.sKN.]}Ctaһιԩ~Y7֥_ۥ_>~}5.|KglŸuK_Ϻt陿>\ U;u8K'=|p:6\>.}1Ù~}]z7>.7.~ӥE^zчK֭ҽ?.=eȘq鿧݌p]ۥ?:_җnp9.κ?]bҝtC]\n.)WסS_ѥƥ}8tñ}_Uo^Lk<X_qٙ|.}ʯ|r:]M^u<1/݇K2K/%{.q8Μ5gtoIUN]N̗|0v~u<1'!_v:f?nﳏ.\z-.]p8j=Iot+֥{֥^֥ۇLK/.=W^o7oqǝ.uЩ;t-\X^upLC'p9g^:;ykts>u絝KO.. {1ut]nu.x]Ǘ.>Gn9sgCw^ҩ*_t?t¥[g.]ǨK.ޫq1ug;tׯ>nk3/qץ{˟4IsKf^gۥg:}_Kwg^yǿgX]/C~.'?]];}6:w߿]?/W>e>5|ե{?ü߃KwONAá3?\zi7Uǝ.}\uUs_]z[_oܟӥ^^3Kt8^Ok~.p~e_KYGfUХ;3/<5ө3]ǘzqΏOk];k棻?<֯tKߗy̭ 0f~ea]y1f:uj[COOoze?{o...o]z|>}՚nzK%g^z/Wkf>:}6S[G^rW:^OǮ֓o^u1GX>9Byof\G^C/~.}ln^bʯx3}<q?ץKtt\ۨK?]ҽҧcl<:t֯^]y1x{pB\u~\ XuW9:n|<$q{KOpә[9~cſyUN+nڷt˱^M^wsK13:ks5o\u[եw]|7k~?I5\S~yҗ3 һɗO^tݎzt75/]7K߼vkǥ_tøtqK^tg~Mt;GHu}7.tJt}]>͓O|^u>Οzͩv'֥p㨻Kxѥ?GfY[oqr}$yU9KK9]3/ѩ3Ghfg.<[]zzMkuAkb߆7OS~>8KE!oqC|{>+:yQ˼t].>}3G(Kv\O~mt%spMI99Bm!.܆å?:trmҫ.gΘ}YoJ#a]5nߎ.@u߸~ҹ?K;1t;һ}#p];+'y`][>}2G!ǥϮKϼltc~Хwpy;֧utzCCT糮c^3lsWȩ״..pDZSyЙ_c>¥ݏطKסS?]/ϯXv]M߾¸G?쫆{'/Kst9}tCtڷ8>tץׇ>M3.OO{tХ{1Ez_tO_5]9ҋzϥ?a~?r\{]p OutuS]t҇`1yVMKL.~$~گѩ:K/:z9?7g0uq|ҥ?p{w#f8:p|`8ǥn\:u4oեq߼[ťoKwp8G77u錏K>WYqs|˺æS7)\sO5KKuU'q;9 yDq>l~;&;ɭ[~ӯ9>Koy>Sw3f+n>ofN7牡+f: xԩ{>.]үӥ[g?r_3}tיkIy鎙'p҇n}$]O~}8ۥwag#}Nޯ1K_۩x?hucaKב.ǩ˾?LWN]?}uX;]n$]4}ι:0ëuH]fЩs1];k39o]9y8wՅ3/]שKx5/1}8KϼuoK֥S.zc.}tcK:Kx8~w.=ٗNv|>uXӡqK:R/0 Zn8G>Osⴋ+s::֡Ν|8s}\z1}3t:|KgQ/?oaۥYeҋZ3f:uԝ77o]tC73.q~x>:C]z_ۥaSw:,ۥu:r`q>Vq;ӥҥ_nxqA1/y'K.aY3~Х;ϼt竕7y}ydf}]z9pQNv˼qsvNg8c\3KowΜGN]ϙy.p>Cg~ŹK.}l.}z|O._Rh<9\y"sK;]:ҫ/kvgǥ['s>t>qu;uYҭ4/ts6u7ҧnq_W1uMw\>s1qtE_sǥwky陯>'ytͼ]z擳|y:W\zoەqױuyһy!n .wK?=Dq}1_vzW:8z9/Ptg`7o:tC]utO]kKg?*]4wߌ}ΦSg?.t~^{;+懢Sg3zv^zsL6T]z3O;o>:s3Vݺu1鿉fSoN߬әs\7/]KGtKKt}wG~nyNqSg~|{;ls֯t:;]: ԩ[٠r~m>nߗpSNΥS|F^m\8amq_Y⨫׻]ltwoCKY'K.|D]ǺtGK_qsq<~å#0_ܼXgcg׫G^EKѥKWut?;/q/:֡SuhSg\zM{eacc\ҥgD>t޷]:vKǕK]DRn.K]:ҥ}m^u̯pKw}Kw}KnKu_/:p;/S~uau@ B:NN'Kն~\ѝ\N!߰OB8.=:n.ɛ?}:x}u|K=?v_ХFpMK.]KO|?\yܣ+wfqN26IǾ‘tuøv\e^v1_֭sKoK?.K]^5]9u7s8}"u̯қOϾjcǥ';]ݝNݺu\zt_n~YKϼiȸեuyO7I]؏?S}~ǥ'N~.I]z≯t陇ޏ:']zaC'|w<ֵ];}x=+'ϕo?oO^z W>i}S|?ty^.cK:6|tpdۇ˼tB~.W~\ѕ1KN7]}qݾJtһ.$ίtOtb^:uˠK׭oyͺ~:N:}_n}D+ycvq?\z7tNj.d]K>O~wz8}_ǥKg<:Oo)xy\י.>}tYӥOx|ҥߎ'i<ǥK][K_]ϧ\z|kN9S?掼v̯UnǥϝJvKқgץw%Ͻy+9_եu&:i^ϺtׇWbԕ_LSُ֥.\zťwꠏG>T~.mÉ?ίqKpѕNJ<Z:t kzԥW.2.=/צSpKǁsҥ{}KO8/_OpL}_b~.}~\KwZzn3v탱җΜ/CgN\su9 n;]:ok}t֥Wpcҝ?\u̯MNߗ]z qQ=ҋOӥ7Ǻ99+ƭcoi棛CGqQ-ҋg^:y%]#t̯8 ]C W\܏{|>ُKW~}ҥuһ?̿\/[^}||WӅ빲^8ԥ4 ǣK7?oʩ\KtLpӜtz1WLꘜGWzd΁nzYӝswùYk3|j9ᠶKO>s}gН#D^m_K3/.zH]#/}Ω5gҩ!p]Mw^c3?]zn]#k^t:<]zϟᾖ3GptӼ'1KnN}y8ߕ.}8zGwh>YK~Btӥ͟'ѭ~m:ulw sQ9תc7/}1е〻>Wt[zDZy>+Qy+K_z\h:tI}ҥЩ'>QCw g{^tm硗~4/1;s)ydP|?w^ҡӇ߽nYNp+Mzcr}\?{\;K7Dn߽KO}tgy>.:]K<f5_;/=ﳏ./wҟ?\zѡ~R&G"];G^:n~9SI}Q˼tͳ^s~\YKϿff:v\:ǥoKsz~Z^sYO Kԥߺt3o}W ǟ.=2o?׏K2/=/4>>q:sߙ>uN}tۤKw.Y>:K)]zgtrxҥ7@nv1u^Ol^t-?ǥK^tg^덝~.O]z1h#4u5zGe<^֩9ޟt陟N=IutGO~_gߎ~~oHwo?w??_G ^q?vԹQ;{Y~Mhi7~peqC/MK75{yùν#_y7n|K zpg :!7}wv8ߘW~S i+wy e\۵ߘv82} }2ӡ`{M[?!xM~=[~w:*[g1_{=NϻoùZ¹oo{nW^Խg_{}so?k?{8q{-t=޿x;^W|o?:_Ɇs/|pM+:6r\G{p-s}~}|w}\~ νw>'{>{}9~g~z>!{>msŸt<9^N{>νU; \8?[?W|_Ésp17ԯ+mэ8sq~ ^F:w=L-/>'Wskͯ>@3~^GYщ_1Not#޿+}J_}sӹx+ӵטͯ}|_b~5/8{~խ?k1Ͻ: ;;c÷_ƹ];kսr|˸Wq<:s3_=^4| w~u~ }җ~>Rxc> ^F/U=}ϷW~g̾;oq{K\s_d\^F3Y37}ߟp0~:v~3N]+>p ^/{<:|>ӱym^9=wϘ[2?_}7z#p<}{p 羿o/{squϢSz,;[|?4c~^/O̯ {|W=g?b|ͫ_1^+gϊu3C8xӽט/ߌsb%⿯_^[\oׯ85\D8ҭ?7ֳNj~W8燫~Az7_c~;t_uss/6hx82=G`ù0,{>:~_o?b3 ?*W2DZ糇s/pyùqs>yb~Asq+?|f^L8!t¹/p;ʸ|#|Vt{3];=xN"{^o)s9{:{j|cwtK,ҹ)ߌgx?G-Nùsw+|FռpzGp|7pϛ;{>G;pysחq9|Vtz'Ƨs߿ùǿg{~{܏߱5·s^/{GpFztysú;g|w~ս|qѱ>ߌ[䓷_N~u`_]>8t̯#WùùVK8w~c7O`sO8/Ĺk?U]>{'b:˰|fd8zL?Wqe=cz~tϺn.'{:pN>cu׵p=Oǥ{#6Kؙ_8P8z ^_p/{}g8?~ѾVb.~\=׫8߿qqC^c\u5]tr~8Y}t#Gx+W`wK^{tmc 9G¹z ~.ƍ%{><;Kg\\/ :} kpù?_cZt5G蹾ǹq~}=>byuZ>yùaec2w {> <|>Wew)[S?Ooskj1ņ1+[v㼟sϟqKԭ_}|>֛KܖK羏p#.^s/> usM^~~|>b{=g~]s7u~n=OϟoX_sqYc:1~s7qts3ߟ? py?x8w?@)s|d>W|+7w~WӽXo>ֵs>[8wg[8sz^ōG};z$Ÿ?_>:sq=t97:E\črc:Ky8u8wҹ>[b={8w4? ϧK? ^,ƅ]{1>=W_$8p5v̯Y:x_z1fұw cuùŸt_[b+5'5ɯz͑N>5G:~}_qGOǿuڷ1xqc֯{^=xt>{pyG;p{Pi.-_9_szG'5<g?Xኣ^3rz'qwzMs/#׬Ox񅛦^6;5~>z!>8z<]sgXu׬'p{=}/Wke8}>[5];E>pkV?ǣ¹pP3ùg{pz=¹gݯs\c?}_sOY/^3+zM [_s?q?k8'ĹsxPk'^<^g{q~uk:~t_sz:tOL]:p5WsyŘv8¹y]߿ǹE_5K~=O8s=oxp~Wk6z=w.a^/=gqǿG&;8/qex.5?~=C8MfF~'=}ϳw=]pYs=לqP~~w|­gީ[n^ӼpŹg} =?ſ\^Q{cq~w]_=}~k櫳~w;Ï7>\Dȼi0} |{0c~:z5} _u7ݾQ|sM~s8ù?~?>/Wפ=q]p_u5G |p5yYY|Yxֱ3޺wƘ5KQu#޿g?n}_?spz#45s8:8}}=ةo"<5{טo¹Øzp ;"ڮԱ3=o]sO?s?^kzQI]o#oqK4] .}o \4~|Q'89ҳ>åk|>p/ts]z:\j]ĭ[3[wu Μ}N q9}=O7Х3ӥ]ptXҥ߾3]q扥S:J]׾xOKàK7S:e]tsr.o>>K%tt\K:tg.ѩ/}ήեcsY>o>"y|"bܭNQwS:"]ycXwXu ‘ҭ9\zו3Op|KnBޗ?.ub};$}Ko:uܧNN.=ԥ.6|ƥ7os/`ͭ3b]c8..1t:}tpqy|ҭץPY~ϙG>b8Z]e=2}쮛u KOut]zϟԥڹ+.}Fם+>R'[_:taSwKY~o:l|\7 9g~Kg|>ggӾW _Y;g~%<9K.]5xrrL\t+ңuQW/Yw|NߏjqK>}t\һ}tt]:u鿿b\҇Ow~%<]zӡ>tsr\}θХdtG8\z[{1fuT9.g?o.w>'.p8:,7ag}.}zK\H.qW9n}Z]z_K.>f>wkgsBvs>'u`K|$uc;uu:^/ cW><]z_Kusz~ץ_۵sfʩ?w]z|Ks}qͼǾjg3l۩~ՕԥۗKx<9쳁_Μ}طt׋қn}NvQq>S'KKҥK7_L~sv}D9uW:]Qu?uMϩsѥ3.<眗y>.=tο{q髖NkeL/9OsåХեs_/]uWsFݖ.1O~Z{ѥgK%`>2FwKә~v\zqL]ĥCǙD].:6]z|vtoǥ*]:xtӥ?۱Svǥq/tK|)gR7Kؙ_q:G>'993:\s~đwWq.}\~>1 qy.q\uۥ7KYׯ[ҡ[q\~n1?ֹo3u̯_ҧWn..#."]0_En^.]WK)҇vt;҇s\.}߮?ǥftyF].׍K:k\yRt]-.K7_PkѥqYKϺa]O^|}KzIХwG\/.}__qԗxqǥ>nv]VǜϪ?OҭťoХg]?.=?].]gK7Z~T=:s 8}t̯7g9]z) i]znqׯu:tLCLC7% ͧ}"<..}tvqYK>pӥOϺ.=ݪ.>:tot<>q&Cm]zol[꘾/l\zba:tߥKSKסo]va~.ݾ ZS|:zVn^.@\z[_9.}KϾ tt.ݺM]tݾ[NåW~>sK7zqOto9}tt#$,}qn]MNǟSKSw>pL>u߷_n:؇1s\?3x5֭xw\͘>V1u:8u13o\tӥ۷at}|vgq]7.}۳`NGKU̯ǥgK:z1qaߗ+ZםNtXq2~< nmWک'3Otԓҧr?.?t2ӥ{LM\z'F'.};￞.=]..=.=Ϸ$KWnߗɸُ[:uIѩsҙ_f̯8Ϲ?KpֵҽK.='KOgKw~ѥEH7iߗt>ɘ;.p帹Seqzұ~.}t_\uº\ҭեDqy}KJ7ş~.}ҙ~Et8k?t҇Ntsi\v 7̫}9nYOμ}1[~0.=83<\z~p֥G_2|x<ҷ \|CK}åwҽѥK:I]}op=.=g\zQ\z~uo{qyKn]ttu_[gҽ¥T~]9X-Kg^g\^:sᦫ}_pkz}KI~Oޜ_#qycC?Q'rgztWNtzts?H{]7\ҧIt{\z¥OίcҭN|dСNJ|9:t0L,/ts=K__^19B|>gR?.o[y3XT}zM\v5zйؙ_oԝ^xtOy޸['ݲ&}t?Gҽ?]:NzM3֓tUsl_Ky5t~VNqs0.5?.~|2^8ҧ}3qzxRxQ|I~<\z+spYuN~op]q9 y3GG5;c\zӡ_uT\4e+^S][^+.LwnŘp7̟7CvC?OR>i_SJn.|V]9:qptݝ.]wK//ʜ93>:sg~~t}]9}_N>9vx2?wfc8]:o5g֥rGg^x*c4.<5Μp;oίß_1_K}}kBnzͦzͥ+gz.}tv|9^tlaLP/t?ׯKϣ.}uþ7ץ.ޗ$˱*s?psKםnNn.mHq))Y! GKv:}K~`l_p}=|ߕn}#t7=e1_3k׼t^K֓3ť[.tҧ} ptmS?uї.]}gtڋ}6.fȏK:~mj^z˾/q틠K/yХЩoIgq5xYW\o.}\:^sq֥>ҥfP\?sƥ֥.g.Ofnz͢S_}_.Gf/tߺtҷAN7]ߓKO^2fld}D->gA]W[㔫>gstH~>'<99gJgN\ѡSwKω>/.]wKwKt8uoKϣ GԳfY.<'uút.:t|$:/9.`CN~7qa:.3^׾M[ԥwy鍱.1ә0xǥCuҧ.[S:]uF/R޶SVy 9uҿyKtiKǍKߟWs6;xfا˼>:|[Nk:t"t5q},/]nѥOb<}եWn.}oKϼ3wt..=ÿ7ӥ:st.ˁKw^KһΜ:qfuw9:?Xҗ|XwK+O:u1u|><;gȷK}>밮SuCty]K|+|`qܗy8Knb܎`o^:ӥs߮þ.5]y/7N8dM0{ss.=׏ϼ:;ǥO]3yGެIw=7Lps^:t^ly#.}Ltju]w>Xkra|>ҭKOK/>;]|'׏K?gsXyv9u|3w^s a^[_J>3s>gtS.=_:;׋10^OsNh=us/rqpԹKnD%qݜ/y7#țufߗt鸙K.å>';_ӥWy;Nt3KY?.=_>b}}ttRt^ߣocNQZ}{s WSwH>K3.]nkgLߗ3g+?.: ]uHaKfͨ3Х7qžjQa^z36:NC~_s:u>~1.r<>/vGם.w\:v`}8]} t陟K7̼tKϾsKnڼtmӥtc99:]Wt ..ƥ[K\zeltһyfsy}O8ppK9]ǠH_sf>ľ'}N̝W#>;o]9WޛLEnac}QKoU҇yۥ4/}mǎKu:tugץ{KߴNg9 } p n] .wqsUwNk鷝y:Kv.ݏkD\zμt\2.:h\zpK7_P^uuKwN]Щτ;Ƭ_ǥ['KIμ~O^;Ϻa]n_Ƙɏ(޼̃ǥ7sҋ{<⨻nq֯cݎן.=q֥gK|sg?.=]. uw%ҽKKo>?{=K?g_y8۱O;4/^ྯ;txKg.q}K''/]Kϼ+uaË}ctb~֥]sZo3/ԩ_oUñ7̏Ks7qӥ;A~.pu]z˼CЩ>e<t~¥KKZf~FϺt/?tc0g~:k;/w7_-cCqռ5ҽ>yQWK7}˱W;y8Na<^rq?Ϲ:oT%:ާK8w^}t3ӥ.ݲЩL>.:O_GD楷=e:#{d:?w;.kt: LW\c\:t>C1]zُܾ]UK/\z~t:>|7ҏqsM-upۥ_:tg:upۥw}!O:K|pҧy?汧K>N>o_qEN}u:qn_\z:]_t݃.]z_I|?KqK<]Kϼt~|Kx lKZ]./ͷztUgl_72/=O<^q>#ťtһy>1ҹyi9qa4.]7y麟yg^z>\0_S{d^бSNútrKץͿťk;sXe~:$8i^2~ٷ4\vϧ8y8]gnkelKwcKm;Ǚ<>>`.tU6:}p׸tKg?]>Ktsq.tKwLn+_5/}.}89]nKA^zٓyҺteuG>:n.{=:Xȧu8zCOd̗t/pz]܏եqϧ>tlt9e_p/0>3ytqP9]zGl7.?:}g&>yևKop<[J|k>Nߗ3:楛Wd&okzͼKo:לoqŘ>|tҥY.~dOȢ3'֡3>2o#K2/S~.}ryUw~~HtOKK_>N=IuqB.֝Gf+5ɷNuG>8Kw>y~XYs/'۷T.럕Wk^}Wqty陏N= n;sc wҥle'|嘾j!ίɫ<\z\[[N3f:u?cIxS9Bӟ_?{>.|5^39B__.K?K>085:.'^0f~=gҩ#tίV:sXᶫ]Nߗ n=v{!yH^q/K'<]x}8spp}t׸Za3It8W>5'ɼt.}?KǫK_:aeSKtԥ Kݺswuo}bLf$za8$tnjGwp|tE_]/̏K7wt֛שSs_KYI_#G{U|zΙ_9ȼz[תC`ҩ7ѥof:}_G4dǥ{$]S_]tǥKɼtr3/ӗt^9^uk;yoۥW]99Bjk-SmzM=ґ^t}yyטC'G^]/9Bq>ĥGj_q҇3^v׮#^u|kk~y-åg9}ҭ[0kg k;urp_ONK.םN_ҩӇy|3^u_^7sn:b>¥\~mN=Iթ stn^._uL߯Kg$]|K> mVt©W=DqǠeSg\z.}??snn}.K~oW_ӥ䥯?]zab8&\`ɼteK<c$]TN}Φ#z1ߺÕy/o޺ua1QW.t9oy WmSbLx楓>'.GS}瓇Μɧ.}.uPtVK7UoX']}Bty<>NáS_GDt>v|?.pG^zqtǥ} 7\yӥ.e>gۥ:¥[K.+ҩ3ե{BvE46;u:88gvG\>N>xt>a?50]z\ާKo_>b?\zt/<.=]usKƥйoCMM:1ťO3/}N'o9c7o3Cξo\:yߙο҇N:j:>_.餳f3.801'9zV^w:yq~եӏ/]Ko_\z\tݫ.}y7/t 3/ݾ4W]~ҝu󛗞K]zq9;KzKå_vIqz3|]>ʥ{_-]:n!]:.YKo䅧Ko:_xNz>bӡs2_Kw_%]:u n ]:қ.[wHzw_ _tGeVa#=9μ}˼n_tt.#/|s[?o^Μ9t3K/|uw9:t|Ko?>Vq_q' q޷N7w;f~%;ovp޹ω[.Y['ҭ3/aWע;N'bS] o:Nyǩy>.]wq>ԝ32K|z]z1[utþ/w:b\80\| ĥlߏtşy=}xӷ*ҭԥ[7Kw?K'O=}ӥA.}[QcHv97]ٯ?]z潧Ku;/:]}2/=Wӥs]z̯g_N쫖.}1_^v[K.:6̯ҧ^5.ujwN'Gwtpݾ/QwK?ѱ[oXGlKvS3uq2/}W |KSҭS5/]]q#~\N\./K{uűys1qe^z:˾/˼S2o`^ӷkӱϯOpq&NQ7tѿK|Kw}.]b^N`祓ts99]zS^yy3 틂KA?r}D^p~:CKϺ}\z:g\9^]z_SyùM_KOLJKO]:yܗ}6pǗku8.q҇tK[/]r1['^̛:3?"u?tҥ[Kvqԥg^w>uCgN]D߲.0ƥ~GTG8xۼ.}^y8q&N!ǰOoN#/?s%~^NT];Nqt?~ye^zpKhy\:sgtϷ3vp3N瓗.Μxt鮟Kkч#us:㬋}>.=].=?uSsTn]/mYCqa\5.֥m^zί3.y8 :u{UwK_K]Ett]yKy}|]:Kk8f~ t7.tҥot}_pθå|Kw/]:8tb+㙗>N?.b]zO_.>߾jxt3/8.nt鹟8v^zal}bl=wvCy鏯ttt~_8l\z:\O^ut?ӕ;NƸ}|׿K?7<c3/y鷯.yKХGVyvNgNAӭ[O2yN_cY9,KqKvԓĿ]z2Lp_cỴzym~zMuS3_8⪋_3?zx<5G,K'/>]:n}ׯ#O~3/;f!_]>^S>>%t].v䯧Ko:t|dfǺtuҭCץ[yԥS_K]zϧ$k^7p]z:tyu˜eksl㺹1qtMwKo:޾ϟxK]'btҩ/ĥ-.=כt楻>1/~o\Oʮ+S70I"ځLpf'Ɓہ_NH %{^j(2o=?[G7WNޭK \zK_n]]Ÿq/}Yv9Y:u_C@u`K<}"NOK2>ϯX?<R.L:}pԙo_O> ³_zՙ.=.å7^Μ8?Gtÿ/]:n|g#;_1£3o||MkӥOm]p_KQ9(gx5~c]q鬇ҥOyq&>s>q>N|ӡ^(:t?:t.OyJnh]N{K:v wqץssեf.]7K~W{p͙Yu>tǥKo:tIn_Otl>M!vq}үO.|5?'i/ԩ$o~Kt%<ԝ#.It^K_8./M>7]듣_zwL[3cKtzk.p٠_|k_:`..醳УSgGWvǥ['EDCեԩѥK禇h'$tqK]/|KҧgZtOn_]tEGQ~հ_:}ҥKK?׸t>BUgNtcINu,tȧ1/:ҭK7$gw\g&|t˾hK.x.}.lNݗw~W|ۥktϧ.<5 鋒.=7aѩѱ[1^#d](\NӹG/ݺ1tv1?;xwS?o_G?7Z˿__w;йtuv7s_^t\ׇ ^&ù^-{UMmstu8߸3 ^Dz_7n8~xqez?'M?wk87MkU.%{p}յco#^_^^لs}^Mb';X77S' ];x/zu8.׊Щ3ù7c?W|uq?7n;28:/3pT7tz-T8|L=7|/u޸_ތ~39V7n{?E^U]U8~~Vte߇pߧpx1~{~oܴN~8>q._po=_q[ѽ1?,On<Х8_ xo{ 'b0^1N^&kGĻk8pupS_qz|8K߸_qÍ v_:*q3]b|3?8~|U=c/qb~Es_u¹Q7${mcg}_~w]c~zk4oL~u%oί} ?px|s'[~w݌k>sW{?Wqot¹?r3νM#o<^Ϻ'?co;^t̯o돺=WeWuܮ}z5Οׯ3؄s/=G>w~{\oϯ3^qNG~z\q?Z.;kѱ_-1V]vm|{-ùY>/k<s3*]+/~-۳'87?ޏ:{o]ùח_٧Ǯk:#7z}߱^5sgo~]~_¹} y{]Ysx;{]k<4sKq?~+uFXڿ'ֵ?qKߊx~:ףyO|t{ p4s=7~t#W?~f݇pO8zaLνFXoot#x?+֯p_ƹzx>uU}¹s} Lgggy8} ~u=8?>Z}MN<9&cqqsx W|_ss#p1uj¹3];_|k93Řux|W-W|ùpq}ùw8wϖ.8{.ί.Ƈpq2ztd~:u5 . }p-Ww8߯pW̯¹dLo3.Ͽ }|׸~¹G|#{?[:ׇ{$lw1~8nr~xL8w|8ws|#kù3ν.׿];$_q=WT~8>דz?=#8'f'Wifs?:wjpϛ1گ9epzf=;p|q y0Y 83똄s_ {>|;W׸Y' ^sv֯7h¹׃cqo~S8}8z<_w0{?_Kt~sg]6Wߨ#p{ >87=~:N)5|y^:l忟1^9]gKYR'`x=ùpίp1fk.~빟?^.5r~z|I>7=98oW;{ͯcqj5z?Փ{,|g5:+#_x2=Gqǹ^9̯79sp1^~3t7=:8}5u|/ƃqs%{{58Jk_8ǘ+01"_{ޟqscY`kƬ_yz: KX?ùKS;+.ӯ|M]n-Us~ĵ#&_s;5kXWө$}0/!_ r+_#_s|ONf׵8yp+7o}|ͩ"_8uw ЩE:u8~bϋ|M[{錉q׼>dƹo~,'/2>|z<߿_~z?2s/<_ >s]8y3~6tć:tܯs[spse7#wC'Gfx\?¹zmkz<0O?ί֙_txps? /ćsx8q1f~:uWtP_u#u5[kN;8~qϹ>>3\q1> s;x~we88zq3&_ϖ}GtXs >|Mzweuqs|U{gӓ3sSq}߅|͜o5~a8<~75/|h\z q4{9NӼ]z_zՙd?unyǍKo_;$.]wKtͼ\{9g'OIw~s^v+)ҧnGYҍACg7u}?[gWqNu鮋uuBq+up˸tEҥ_83\z.q{JNFtҋ/]rb~|Nn.}R/O>oK ҳ_x9-W p9qK!Gt餛nnUvp8˼[%yeotǥۯug<]~~¥.;֙#Ι<tc1n.t1oKoۭyҭ]åAsҥ{"uKׁ> d3UCu?צKtE7w.8.<]Ϲs|ӥ nLny<y<~9ǥs80EL:qΩ3g6?嘟pK:"X'Cc?{t;:1<7Kw_V\zuѥY^vti\:qtӥts.ɃIԥg qNangKq2ҥg.۟.}PZ.]WKOqeh\;̋Ns'N3~>q[~븉s6q:S'ii]zå[gq7ϣۥs<ӥ'9һƉscs.nһλz?=W`nu$tCGKw~Х^z n\R1.}}5.8qβXҍ ҷsts1.\:yҫNc<.=tu?\]>Y/LL;6w'i]z8'4t6x.}XJ>\ ..~|t.}fgץg?p\:tCKN&1O_>bl~\tӥs.]'K7_nqN~qN_җys+- ۄ֥w K_wť;̋5‘܌;LN3pKWKcr~#.K,:st.:6җyt+utڤK7>ι~-5_q}2|=u8?y:ʙ_c'o]E]X{|tGK~q:y:qg^.=.}ӥwn7>.]KK_:f\:_]2oLn]tu.޶SgƥO n.ǥga[هuL<.?a\).=k\yu|t"uYWK:u:I^b8bݗ>ퟦK7on4]z#w<$.}t%t ҇KѥSwQn|0]яq:qtuٿNgq֯ۺp:t}ǥ+ЍNKwKt q?zi]\uuusK.=쿾lt}Iwu۱.w׈/?.:bttԥ|Ko:c't>Yg#~ߴtvӹsK_>]J~d曱KzѥVcӥKϺCts}K7pԉǥ;')\HKn.=ׇ\_ӍKO]zK'>5O꺜.}ds58]uSqKw2]zƥg]q΋n.tq5On::uU_~:״nvo[g3v]y=u Kw9]5\Xǥ[X.vkq&t鿏ҋκ~/O\z>ҍwu쇎~>ҟ}t:O]z:}\:NL:cqtҧuqYNNw>;k]z:b|qqoҍoo.ZWU7}iGf]uWk⒛תk']v♯>u'q7sqrySNJ=Wy;Dtsa|ee&c^ҝs=]['xt^ť҇uzq[Ǚs__ҭ۪KyDnN$^_~}|/җK^׍K:j\zx17KtKt3/G.!]tWuj%5q䙯yέSp1k8\~~upw.}d[wNݗpYt.=ݒ.%P8ӲY>KK.}_oťj?a~u]'_sZ 5Eq.ݺ҇.|é~zOgKΜ>7'_8.}ї!]zaI~ubs5K.xO_љ҇7O~㎶KC'%_g!ukAե[Auuժn::s_y}7G?y\qt?}K}<~..P~x#5..ҹҥ/ Wq-]:u|c}k[YWMNGK^Kt­Cg77>.>KKvSyutח̛u".=x3_OߥK.]]>o_q] nݗCg#_Ñ߬KױnO~.=q#כq;sҥ؟c={q;K_z'}Rӥvqgҋu~\/KNAok΋$q>pKj]tkӥt>t?t鮧uK'>.ݺHtGuy~u.oaי36ć/[NJkӝOJwuS\~}bs2><72ҳ.}ӥy Gί:2NCtiZթOrpҍϥK/.}X>ӥ:s~K#]u~t֕ҥSYwkK C8n/qt3gM7m\c^N8'nq]V{tG5g3ݓ7~g}0]y!^3OӥOeҍSK_g'Ik;y٥[wйcPKOwNrL\ѵ'q~ԩ'<<>Nit+K/{|E:]YXYgC:Lw^}] pݱ\u3/q9I?~ܒ7ѥg]WzKz/zZҽҭWK__z5smØty:әg~w70O#o޺uצSuC\y/{oףҳ{tCK[E^WNz,^?i~>it]:[߼=z֩Qc].ҝtХ;Dzu9N}^u~sOn9]Sg~_w9yͺ/8ftsΘ@ѭk:tN}|KN8KouǸ?ҍkftҧݺ/:.}n]qΥ[k~sCgN^??;J~Yg \qtǩo}헮S~.ݼ엞uy1{aLt>sN9y:}_:yu-K_.~O_zӡSszuw~ՍnYN:n}sԥ]q8<~c<ҷ:u[?\:#ҏn?ߟӥ|.:c{xytGt].}Y ]yԡӥ/ҳ?.}gz3/}K:scz}-~'׋x_qͼ~eԥ?ۭ8/Ƭ_:CTćӡ[ץΉUΤ3f1;]XԩR>.::һ;\z[WCctyp7K/~K_^|qg֥ft靼/=LrzӥةA?~Y/ct3z;Nd>ЭS>ӥ7s_::V?g2uԱ*gZ?.nNN^:vRgañ/ :nzĥK?;ć.g]̃W]y Kkav3:>҇G\-Х{ե5:oe|8qoGLݺ/Ƹoݼ:.ݳ^eLK׾ks}ԥwK~ۥye{MЩc]mtUN|xO\z:/=엞~c`< ];an~ԥ;Mn]LNS~B|?tEӥ[o޳_z8yҽoN˺/E~QGB֡/]_o.~љ~-u3qp\K7藞cts>.Klt.[tatחۥ~_;'0}^ǥ>Х[jC7DbҥsL^<].\7.Oɋa\xu~GxKonZ[>K~8fy_/8:Vדt3^Kc\sIpMCN^?q.?\.=D/?|\..Y\׈mN|z֯88~niscǥ:ӕO:t~8ҥK7"]cҥe?botպjt¥/+u9_m'_3utok2_~etB7w]+_G~aKw?~.~w!=].IGJ^g<.֩7 c_ҫZ<ܓy~ϳPS3 ]:~rZuם}}[W '̯9~åsԥۍ-N|NaݧKJ~q#_33R Cѥ^>>"]Gwt8.}y0ⳏ./qytaukgԍtuN~Ǯ_c<̫\/\?.]K7;]e/1&>tpt]OnSKե:{Y۫Gqפy 79u'.cG+unұ~-:u|1S'W>_ǥ['DӬY<><3_1K~ҥFu3_볟_3Kҗכҫk8֫G[Н3޺sϱ?Wg.]:K:zētkҥ_A _/pKס_t>g:=~kf~N>BC~Wѡ'W]9wǥS'*]uv1}pG.=,ҩNgt\mq?v~1uK_.=_c~:t֯UN~Sӡ>]zoUׯ9c/gd]p;Wӟ׼~ԥ~}pӥOĜuK>BǥK.zῧsљXwK:t5ԥ[gdK>.=Gcf;'>Nҫ>5c]9$׸o>t}yG.}sf~QK_\5#_u99Μd?t✸uXե&yG~~Ent]p>.~ۥS7 =o~X)vǥOvǥ{}so~\3'n_3:r"ǍƘy/qL͡cg v2:A=xZu59yK>.~t\ӥ엾t/=\/=~ ХgL~MgNҫ3A9N{߻\q1ܣ.{q܏nnz9қ'.pJ:)]I~Yw`S\p|/z✸~ҝ7tbҥ;.y藞/oφg?ﺺ~N>baynK7.ݺ 'K>ci8߸I=tίs~1u.}lNN׵o"dzfסs=:Oz:1ǥuKq꘼?sV:yqӡ_>..=*ѩy]zflu|E^}8Gǎ3-_ֱzNn^.}:]1{W5qǥ|K.wKKsK~39?.=[K'ι?G:u~_:v~uvt9~68]A.뾋u_Kt93I['9Х?jݗq<:2|DžKO>t}9qΡSgpؙ_.g}_s3;Ϻ!ҩk.sB;-?oE{KK_‰s^۩اiGs׎K_Cqsֱ2oKoWμ.|\y]`ZW:Bәu.B>ɓСSWm.}~y֌sp1ί8l\zg͡c ӱ׏3n:Ϊ+o8Ƙk/]׶㼛yqsgK/֡SW-=yEw^]Gt͋ЙW x֥OY'utχ~鬇zy_9ü~5u3OߋK|tOҥפK/UϾYUtiuDix\.:8\]?v1.7.{:Vq>un9\z/eK3yt﫮\uӥG_.=m]엞.~uguU:ɾXåg.*c'NәSjG|p1k{m.]yygs=G|c_[K^o0u pE~һyK߮XW]ӥo^uKu}ӥKϼGtK_:uY/|KOgҋc:.|\zcnG<:u.k_:q#_z~N}^Out^ ҳ:y:ǥ"tu)\`?A>&׻'Kn.=~;_Ա_N:]]N \2حqץp8t]ǎn+]uvtSK}=\z_Zӥ[@^t:u֯Ͼ[w+v헮;'/ԩ.>Lp0κ;~]y޻_:GdtGcgu}\3|y忟78.}K/=ҽ_uŸK..9.<_z:tln.=]xeuԫuK:;KcG7K'p1mN~鏯gkuL￾\z]S\z>ҭK:g[7 ]up#w~u?g|~B]dKt/:cKzƇos ƇMlaOq<ؼKҳAt'.=O?W]zn1ԩc:]utEKo8d:̯:]u_pt/ׯ0f.=/u1.}֙_c>ҥu:yV#_y#:¥K^Ot/.=.}XGQy^./=;KK5KtӼs5]u]p-y{t:uq./'v8~fRե3'>N ۖ|[ҽ^p~^ҳe?5~kѕn}~u-uLa<ҧSgS3]9uK3KNn~x=ntvt^uwſί1ҳt~wӥc\ԱSz ֩!NuJ 7K:#t8=T]zׅgpu_<ޭ;wS?0Kߨ//ҳ_kաӧ8]yj׌3s@ҥoǟ..tg/xkљSǪ׼.yq~Vׯ1֝<=Rućӡ5ućqG(c`L㙯[컱tt#æ o'yå_:q_:twyb|ts~s8u"/:p30t8}Fݴ[g~W7>B:uӱ#=]:wGtt95]':i8{]q[Ƈ?.:#ۥ:u t֥JN엮sե_?_:vI}Ytq|os|y~KNf|tMw몍K'K7=KhRә}p_zY6~r녢['_;8=.ҭcAåるps7S.wݹ]c\['$sGKۡGHgN>Iϯפuk|͢3>u_:S]z?KqefԹХgt}KN>I\KuetŕEԡ^=3~~ޯtֽХg?aݗK~;^K7_3ӥ뗲_ft~FѭEW쿾nǥ/.,׌Cnd:GCԝҭK_֙ҥyқ|q5ǥ /^u֯QnƮ_grkKN.>st___,#߾7_׿IϿ%${{OW?~Md m^l s/۷kی1^ iU˵Yc*[4 [i ܫ~N%yz se?ǃ5ϋimv0ʶ̽& iaE^zM)aJ̽خ^,=¦U sv6-̽6^Hj{`nv~bv^&l^#lZio's/2>{aa"[k]}Mcw2";d0J̽ wMkciܑ̽-s/{2 s/>>¦ղ0d6Ea}6-ɬ#lZ#lZ;¦U s/ÿ?¦"l~{=.zMi=̽v|M v{l'ar⃹s샹ױ_Y4{Viu+*r{rTQNy8#jZ W^U(bwX~}DMkADMݫ#jZ;ٝ`$Vab+8wfxijffC{=Z_l)Fbk;{-ϸ]Z$!N^%"7[@܋)L#dZ yKܫ)%jk{mX;w* ⾨p_;{ɂj}{1?^#o׷#^Zj~7Bkۋ^j( ^ͯ÷Ҫ·;~\@Vۭo <,nK^oxK/OJǿ W.,5GxqۋbD|{xi}]k߯t_qso_ K }KKϋp+5'oy{1=nP^:¥t xO#t{# }ZBZFvBvE=t{5^/f6إ*n/vEW=0N^bn/vGɨۋZ,tn_Hö/m_TRR%ݐ=/ de{8-! a+ۋΐe;d{c}梕!xCׇo2j&/ _j/d{5Sz-!ۋq ^3"+;SBת^DG+ )+ۋE9lߟbd{LhlvDR*z+]*Kv^}j%d{QN!kv^.MvCbG%d{+J :zkE~^(l{xkG&xUޙ=|`{Z^-$l/<`{Ab&`{i߆ l&`{)nDh%_2vCYJ^@SK(|S+bN|#wW,y̓ƳPݐ͸Sn ۋvU a{=\BBbCY`{!.ذ 9M ׺/µ/}*[P]bGGeP{H@դkP{1)^KwJQnQ{9{+u&Z@դwP{݂ȝ5BګԞb3?P{^-:jBP{b]{e@E j/E ,"^AŢDũ5@5Qqb2P{MګpAtEul*fkj/6WDբTj6P{.@u{ZElo2 \Lj/Gs+uqG|=U]6:V_bs@P{fګ2ލsm"}kfa+9BxM{/=i 4}M{^41Ǵð8]X&`ô57`ڗ%/#ֶpL kp_ehz37x!e@W+ +9CEF^z%T^nh/N!ګpZ^|S]Nο/D{"杢=u|@&6?5n~Eκz"BZuXQ!D{F4Z! ўVD{>H!KSh/D{!hϛXan]槢T$E{-=`)ڋARHh/VpB:^# ўw/DY ڋ/h!Kvў#=cXmnN^CWC^-h/@@/Zs1<{,S}\2^3@{`=oBB^6BnnUAz9r!wy-OSG X` n>^V@r ^,Gff5hoEKf&P^l4 h{nЫW)07og̬3lh/<Wƫ*#ݖ_d#3Ӹ&`' #3 vS+ēNjg}> [̑q+xԂyًsoꆳW !=V&j ފ73^,g g˫L'[8{u5-28{'G^kG^fZ^^m#/tbiP^j ^n>/8{6ޑYlSg7R^XLۢG^f3ZnΞAt8{5}SDZj|@^f ʴ̥noq_V>%cLDWsAg^yV@chu {<#-f/>n^[^,^f]LZMd)K`8>2+w/1{ÀMs쵉1a}e%>B1fbM#-zwe)T]^IdcYI`JXOnLZ^oq{ex%f6(f/݊{qLz"揼Lρ .5~_WY/fZ:1a݌?2M"Ef7L^* ^8=2 .ueD:^'fwOR:1{Sٽ T%y-.yQ쵉I$#fw)'f7*ftqp|Ybzo>E fKI$f/mcsbJ>1{m/^m f/bd0{o~ fID٫x^(.fy){vՃw?kmҎݧ11[bv@ד?ڤ^(&f/jH̬~Ŧ`qv7եuZM^&-{2kak,M̗h{ΎxR ~;3~ewDJsy$fGֲg sG<m"$.H̬Y`guI̼YX2 IURJ){Y,'/ز̤evڕA٫ [&dwCY^|dY Ǐ!wyx|c.\@:H̜3Ma& Mdž$f#d׬] ݃3@q3- d-d %rBru\ݑ q"dBDRyz6V?A-y.Aw|x~6H;S^Z)w%7$4Zx^~腬Ř","مK>qϵB:κl'<7/B> p3x|7>y/-a8sx2UHNjN\J09 ϵew˟NwmjN!),oaf6x!d"4w߱ |L3~vx3J Vr|a."!%p0!W>yϳ43g W|="oj[y3gܹYJt]LS9;s<]{8 FlvWJƘrԌOw^ތ;μ;ϳLRs@ϛ65y x3`n!Y=^xN@$94mKx^x(vs~ްNuΗeݟ63$/5 ~Se'i2[1-!;Jy+|M2MkkTMr;$mNԫ2韌{L }Tt2_a緭axPfbdbym[ymd Kv^擝7Yy@23Ɨv~2)"@pәXuQu~on"j9\͏:8R*Ƀp>ԹZy9ʸ:Pux:"YJ>.TY uZ&cJTŽu^#Y9syہ:"_, ؼǝjl: Q@Cx2]8GtPRΪ TyoJ2 8:Gts+nMo BvRc]PgD񒑷c`ya3g1qq~Ǭ8?<&+guL[e,\ "0w:GYAts|dt3n?L} ;ԋ`F^C'S:/6BWo΋PƠ[Gf 꼚W:Q꜏[un9չT6zFlt~I5SP@n<V~[M+XmpFM4V/o57O֜;_U)ը.Zy%od0fj*b:< Nu~mU ]GĈ0G]PRΩ:w#Xu^ZjRy*|9":k]fsb1UbM7*U>*:7 u^nY8M7<=꼊P/']Ջ]aݲ󴱲s(Ϋ]eDd癳 ;UMpsW;Ϝh Ow_!y o]9[5g7Wy^o}VJw^u.DFow_&Vw^Cu{^V61϶LM~=/Zg]a=OӁ=O=iDK=_^s9=d}Kί,2_8sܯ7,tqK]\*OM߬&oLO}^G)]i<͇ܖs-G0fӍ K-5$`Ϸ|sjSN\}3N$>bi!>$>&}))V5v*>=,FJh^A4T- ~>_:4x ץ&GǣQoW4bb5oEAϷ~}[/yWHN}C=ܴuGgz~̍sS>/P&J}^-[>ϰ<%dsPrJyrpn7}^헽y}3>WHϻ) :c ǩ#m}nE}n)+_u`Gnv^iQurLw7ebLX{HTGc}7"}+ye2UC~ERw⾧>/ݷ wep@?us[+M]z>} Cр2d4IB$C{ϨB2׳VfFFyͻ8.ڈ#5y?~^L̿~npƇ~޽:7,+n~xyGIyac|4UDN\/?(}9 ϛ]q9Jp*Ϝ>r}yu?|t*H? Ty씽Nyw^_9?t퓯̽ 9SY7s+p潟9wN]Ep_+gi 'q~[_&@ovߜߟ<N~.~a}f_Oyf~"?loV.fs/#ȅAy5}ğܹJ?N83MCՍn)teO>3ǟ?/>6=۹J>xŸT3M(NIq%Qn~ԙ>>Ns^O3^vviJJ(^Gn_@y{:)6uR qթmU0@~Vtۑ˯gwxe+ OO/x,a9ՙk=]G6*X#J"oҸ~8V-P#hG PFS _@.q3s?y^9somJq H:aWb2^wVB[|Z\M>_j.v+}~- ss&MWgK`^ OqfWi;JO05Ɯɂ=+E>]۞_u9Ad xs4Uu~i.y3Q G|NVތ=_kti ^RtTL[qGV9귪O#Vib<ތ{U볊^[VÒ+9m \|[T*7m|FUvÿ>7@|n`9Y-Z팙LQls/nm tkiMyf*-8&I(E##=o@~y'6Ř vz9kSu6=7gz)4uE U#ٛ=KOUy~ @痲|؍LӀx* Aݧ!ß'<Ly޶,Q\fך"K}z~|j'ui[xX|,''MLt<.tv]Aߗ9aߛ$qТY^:Ra(kE,7 mrc7CYs0ccu7ۡ6iiY5/>oËksq%>WoϏ?\_|0>"Ͷ;s}Zkv1:G#,o7G|ny#2ϽQ'םy>̪:sY5۪.'cZngM1:48ޙ*|-{7{gqSPŭOv&czÖ{]Wj =i7/i'ϡݵ;7YCgq+<'pSe/z~H[i!ERQx15 $?[jRtv+ 7fqݧf߁t?蹝/V-n^>Jg8Y=g5meK2gvyuA|DŽ$ D;5tV7kyPs;4'8]S0}G*3J2qnэ~q1ε mvCBϗPyROUwnt(2(-RJIrlAH`㕓oy4' ۄ˒vߢxp4'f(iKynt\ <#&WE8(MS7<yަoլb<lܮ?%KNyly~;ff禁)ύ@۾#ϻrNrs,)]$su<ly>,YfLTj_y^mZkK3^orQN8T˞iϏ<7Iyn}\e9u znAN=⚿yR_cĩLs3R})ǥ^zCϑ6(UA?U4Ƥiayq,zA@7Wޯs *wy dX9IO6\++=g]RO6??=5)zQzn}Lc6ƞ Fzn^=Ġ)|DTLw=g42q]:#XI\:Xۨ)'q)7ƞ{2\O&=c칾 zh^|I㧝4 4ZAe:+ĞM&Ugp[D{vM;}b{8 ?Qױ'c+ $- 㞛LMU圓{~37̵+qKINs+֤w2=?5?칓My#j+gҖ]\{k`m1YܕA~nF>wm>׷͜ܞ@6>}M|n_!3}n4|6UX}Fۦe@|NQp">1A|Ͳ\&>߿{}n1 yqڦbs9x;u_vysl|>voy^TU>م볋SxX^_Yn6>~g6.|dX|rG_.Nm'>*WYFS>'|n'Ϗ=,}.>*3v4.FczЖ5 HʢK?{n.4{֞bZm\ʼy^AWzn*=6zNW.5ꚥM/J*C)(zd?9|bL ߗ+Šm/26=~Wwp q kRk.FJu6] rWׯ/=(ϳϖ~]VUgJsǦ$')cAltJt ϧ躕tMCOrx+o?Tg#[X?}zUg^{wWǞWY݇-Tg>W M>^}nZp[]N I\kNyWe7t9sS>]jr *,^@s>׳ϭUՕoکN_[t]+{2ܚ RJ돧61x~1Gjή)]'zN|j3e՟o].>RV2PP#>:ck+X3|~uYZUg.hǚ,Kɱ52tz3-Mz~cu  =?9??I|yŜ|5㟌=YG~yeW0P8wy2Xjno)=|J~X¿R?6z?Y[\R^i:ɬ/Yx*H%߅9rv))Δ"_2;ř@y2\թl1fuJ-o,O# ҔKZNo`p .߿sg*՟+Uj:ҊS)=ﶡNRz,0|-I=yQ{4\(z^VIY{>>>>R2MRһrT*=fy可ܣ-޳|BǗ;9e*üܢ緔si9̿z~=oRsfqK;c!zNâ鹩sۢצJ9?oIѡd)8m&c.i%?rOW’ŘCϗk~^u<"-MKs/y䄞'6 n|q >?Bi_rI.$'G?4X ?^fSc82yƚKh~b1 s[%)tSfy5+ɏl|?\|>.' O_BY4[x>6D 緇5o-+ y,=..z>}O6=oRFw=wqyQ彸sq.wKY\p7SEU{G=7{^:ӳ9~󆞷tdrϗ9YuH gES߮ +Wᗞ7/盞ś|>#nϧ9Ϳry˅?s姧ñ|^Bϧ+5!jO[ZS]>͠ > }^s">TV9mՠ>#2hIJGv1[NGR|_ZwOH>Upl8A7Ǐ>s>9[=,pxq|ʫ&Hx֬PΘ͚!g0ǷocC}}ӹ+>z{{?꽂ϝZ?5=`ٷ{Dxa8+p0jf*Cϭ=G굒έ2loMgL ׽&r o??Iʟ[ջ7paN$_\3?oViXПGޜ^/k;k+nz*0ކn[\zsfǯTivMTGoN:›kÑ;yi$* @?X-n*V5^iu|8 nn,:KL!< @9i1Aĺ!t4H>$֬qZ.AYak!݈- uQ~> c/NeaH*w Dto_zUC/}>$GrnčgDغ!v)n(}}[AgM^$ ?nZt Ao\? ])A?%k?t# ͼQϙoA;<}qAsɦ~%B! 2 ?OCι^sZWo#\ r-AoFI=~n,nEЭ O=Vcp<69os~s}篴_n'ތ) AoFIЛK=nK :WŏV%)'%KЛz T $%s/M~ DU󸽾^_IyK+!YկFP*At[0HA/r-ϏM̿$A=Ɵ>,9ߡCЛMЋɣAibnv7|]1שIB]PCzW%BP?M!CzY|̙V`;BeNy*tO(f BWیa5Wc0zOk"+*u߿e!Ps|,9X^!\N~ѠA7|S^wgzoVDL9Sc4M{բY;c׏A$VZʷsZSrնRO^oeSrS(}aqsoNvyslx^ɢ畎A_~ůvϧ-?r /A/ 1xB~?O?q˓ِOAStݼU sHнٕ^ɡs#Zbn {E!!5)ytt!!2""F i7)vA}?%.@)Af{Kk|YɟE lAoE!1{Bi;}JkKW|S+gLt ޽VځTM5D?]u/1 GO tJ?Ƈֿ ɽsǛs:}ޤcKIu׆y!Ы}Bzhtj, u=?K;UoyqͭNzҧ`0dZw&?w'swn KZ&Oyx<`۟gw2ܣ_Nb]ZQ2Kj ?oCW9zzs&@Nz0];jW?hfoWfysօ/=:u$cZ O+Ȭϝ}:\*PJwG,"ܺ 越xi-p= ~xkωH~4CSD>D^O_>@wl=hݗ@xeW6:}lÙ7Uu65i}kNɕetb].?O!&>~2w|s- ),Q}Zt Ϭ:8^Q@:}+|[>s+ۚ);>~~m~*-@w*@w@xnzuRWog-iP@|4ݕ "[5XXBK:@,X.6uF*ЍUW6)SVy7]ֻLSN> t=*ޝ*JF"obM;!>sZ-1}x}-dN9Ӈu$SNDcE膰7[-7Q:%?X7. O.t7+1~x}A1D_>@621.-[l]s2 ׻_U5_g"01}QFyqBeΦOyuTv5Q^?/|њy+CL:㯁[qok]54\Z4sVʠ1nW1^4L-*S'mS_\k[gJ  hSنih' zDӎ dkWmsc޶i7U#gzi=>MO_ϴ-є??z.}h),>%2 CgUW sC'_)`ǭ~;dҙx0܎!2ayْ*^)/CwSQ%0a ih}5"0cO{5;%M9{I u/ݖNf}0a^yzCwsW~UhvW>i43Ku~}vUw? Y6q_ }QczUд+VG/[M4'B7sVBPZmSO!fzhVz*dN)bxeb$B_}>&Nv!tL!t6"tBF.]l]u?Ǚ{ۻ oSǿ_? LOr_}㿎?WI{oJKw3DZ}Q7.3s@w&ckW'{dK.!t~WH;-AaCYuQ>Kwqާ]MPNjƐϿZG}Ӯo ^m-RUѾE.vN;Zk#/*Ќˡ]>ѻ:Imaq/'߅ЮV7ƪ}H~{9?w t(W$2JK>w֬_{W?.~vn6v_xz_R}zcGjk؈Llg7{w!*~W;s&}ѻٯ~R0]jhNOp0zgm\ލDSpvcJa_~7-~g.bSx6Ͼ=Y_?ZF7U] NA9i{G+vewQtQАnry&ۿ+yg7[^tSПU!=]i/;6D{]F?̼Т̻/ȼ8%d?¼wr;qu .k}Cͻ}1"03]ze'V^#* ޻tbHyF+P9>tW:rhq-߻Jw)_I^ף@:!Ǒw`/TTC^w#! kǏ6|C=>>9W9v|t)n̥-ۈw=/IE|w1ֈAxG!zݟ}#'Wpnhnku vcg#]K?R㰇Hxwh"f!^.ƇU#]PxMG{wkuڌT ;Lؗ1+]TƆ}UwAw}c;!Î|W$ŕXqHuQθ|rP!y%&{ QP 6~؇Yf6D x8ߵƾK}ֽ_dw'1Se$aԨ! z"m4=Gt nbaw&!Zi󝧀ߕQ](훃¦TbttḻDaQ1K Nj w~4w7>{qݚO k0]`nYS3e,8 ]V ϟpoAۣBϮKHR=N{n]Pv_pNv'(v~rD+]b-Z{ͲNAݔw {3v+F{tWhfvS9jltb+ɇ90wݯӱ-FIe1ò, ws"x{''5hndU0P;b- ;MX$0&¬W{oXVz|tcLa^  |şqQ|] }ݗ] AG{Hm\71[ xݗ{v݇|q]ȺgDe^ 3`Hڼ9:;Wロ]Z{ i=N2|YI5̺*WY{b>9kXHjJ<лr4q[[ڭьV+Nꮜ doA4_]E4k`2{2u=NAĩ[JoߺWR}!u(ɜwet(. 舡TP(C4[ǚ&ֿ|=m<v[2:K;0mw2q$Ajzxy~ra;=b/{v]=?=wkcP%y#yx/ߍW;;CX:|wꗫ?B箦sʇ9-U˹ҁ_*ƹ _B'¹?w7o欅7Et[ankln`\s,aͮ Q〚]4n^ \)G ffv ܗq/ =h1ׄ(y&%1xn4Z({O v2NQܽ3UwiH9i(.u iGmy ,BaNA:Mo{Oj@q\'~*fߢZvEqo:?ڨ XaGe{Eq`o]ǭ}ÕްߎzCFoMB~T̾wt xߚ{ovoC}06  .YIQ ⛥h|8{G3`~Gs :?:d3k`ovU`Ս 2;b-F.J(%G4b0kxɜ q3}|-;cO*R.n$7W0JQEΏNZợ)ME )33t⠳z }3$P2U)_~]bZtZ.ΈNwhN1XW^;ҡ#!u fB* #t]@Z 8Eq@t{!.7Eq'( _x\4I 6M=h5E!Mu#rE:vzrݛ庣uuMu:S4߻0LQ\=z3gq(W(Nk n_(\@Ű\aJC4}+o{W(sKm}V/v*v;HvmeeCnaoJWvۺ:?:Afm-5 P[$C|Kpv*rOw.Mj[[nRkfWbқegu>ֻd?ќ!Z|T PMtMA6W:f۟]wmi{w-}|w/+BB6E$ߦZR{27ʹΓY⋠Dhώf Eq:?Ukh{QN@n!"g{WN+Rl(Eq 11Af;GY8e0\ZֽcXY%X;PVqݨ0I&Jv/zHF5.~(>T`)fWxm/c:)>?:&8]Kll/y['Xq^z k(._غ) LY,zUrza ;l ;nm[7.1I: 0X- +[Y *XKu@Z}徘ֳʫ^_jZyTԗW-9Djcr9\Rj_{ ҥ⫙ZW].񪹣j1`1g}RW.e{U ëJƫg]ƫJUmujݸل>LXNjy4V« 5Ks@xUq:r&i4KsX5؄}4_*: sU-īWF^lxU#/=aַY[\Z׵7VU-\emǫjjW}$\k+|ѢxrU1[:yīJ,iU;:x:DUWe}?^u\ ܚ99UUO&z{9!xPcEY;By'(^VUƭQ</ jK}|2^ٶWMhj]񪞮BZeU=ū:3ҫ>xUfxթe^\H=Rf*CQEzzնEjUWL}p8۫;W kmm^ճ ^T)WuWW/^u\Ksƺ4Y.ӫޛƫ^ūmHVЛM׫"CovOnxUj񪽂uziW}Y^Ոx'׫N?xCPSƙ՜߻=6EK(x:U~rP47Lǫzj c^rJHPS<ҁUQ^(]Y&0bb47zGnW5r=^%RUuƫ PM{`ч|u@j]D޺īW^uqW[xU^&bJU7"~௚?z*p'z47vQ$ߥiUqzաԫ j:3*t'gOLVūV)^4w/ǫVWū&ti.۵(;&W-Nr4w+RUIW*KsV}īdIzgdi@x;>M5^lxnfn-ìgjGxrKWͷ|5zUxW˃90J6~:.ƫbW5/xUβRNxU 9^UڻƫWH>^utxQ/=WBUYsӫ*Wj!4^ c/t?^Փ[j#WM"^uz}lޢ&޺Ho(^U!R^576xU xUoNU?QmZM =Q1u: ë zgފ{FUǫzW-:jo:?WƫWӏWuwW٧zUoU07^8gxU?xhgD*tatݟMg9mP2ə=>yEЫmWhx{\UYUӫ= ǫňW9^uܒۛz@^WtiNmoW{Vz;tf?A^4"{N }lh.wQ$),$9^g ?zURo~>^ս'jL=AT6F^:fN~%Pm8NӃ{/͜.sj׫V!_Eΰ_{4'Jķx|FxU:U^W2ǫ/l(|[Ϧ3-n]!^ UW:EzyLNANZ[/R> JUj8^FXxեzf>Ų&P ?OYڍ;X4s)_N^#gl 4=HVzUgWj^>^^*j^:RjO69]:.dz&TZ}s.V/|5^\|Nb9oͲRtxϦ(HxRU1W:H񪕍]34Eq>+^>ɜbj/6PEjNA"zyscAo<(Ӂ=JP=J$BwƏ s}{5fUkjYW"5n*sWG+]s+zU5Uǡ\rWӫV4J(것ŰJ}t?jE}k«vU:ӈBWHiU5o^ltCj^v zϦ([x2>xUKԫVt!Cܚ =^U xX䫹nH}ASEq;,#rnTfN7}rJxU{/l"x>7PxUVնWfκW}| '%^o[(RH>6c<WT9([s{t9Uǡիf%/Т[٧ëZnjXVj!*'d%]f"? 7!Z.qz)+Z^iͬnD|q!AMVol9a(UzӃ *iϷ^՜EqW%8Eq]1K%xn?x~kQ\WTpWv|0ZW ի;SWRJn>ݒfYpzU+%q .ٺ'RajU0[wkUOU$xW&cI-#%UWԓ]vSfNxU(Uz{tf;5WS9K&+d9: U@5(8T,g'f]o^ǫN6h. (x@ONQ\Ԝ*uNxպU+?W>^u)HJQOwT ^aCԔ 7a*Rr0UOLq.-Sy՜TUtfU׫1~z7U ƫ>ZwJPsԬ̰&ġ}*Lz8\>zރxպ5WH^~U4zUvdʫBj}xw8UBqOZ84j*RqUوcy{zwS`{UJ5Z%^^'_:xm?aON)YY*|G]U|5KMG u:La!4ܢVǞlzWUAżzv܂Pԋ;!yr~-U Wux{ՔU>sV^~v&3Er $'~4kUùǫn4]KsCOcZЫ| Ks6_*7WGU~6-E- 3a!yfiNzvCnw4wiN 7&'Ƨ*s0a9䫹[(s|Ui*_ yPPل~V"^J0wUy7n ;Ü#_k+IΏWuEzr ^ÚϮ]ԄW,u_zU!ܩHM-A y^l+[Vry}l%whR xUEj 5Ksfig:47TԹLjELE\ AKGUs0n-JxU^uFjP:7~6vjwYӫ>rݛ+&)Pk0L"boL9}h:~#PW^5KsZU+Aub*[czնj*G=FUG$ΰ_UƣWTW^u(' 0O׫[`'NХ!_MxUo,WEy&A(vz+CU+tp櫺"jW:U/o7U@}$`F^\kJ.g$#"~htf[>uEjNA5͡.GU?D9~o/?9xKsJ9{JJX5T$䫲ƋW>>g`Fa#_z^j:hjէkʪVrԶUo_G3/y=_E^XjJ7zQB_"|[1tj:3 %n^D5|Ɛ]@xU˫WfU/ȇS6x'_b9V2$W-9əU6kI<؄%ei䫶/4^ղU=W_ë^TU$_xxl:?@5琠~tzk'1at's 7L]^4%:UHHgU-Zq]U7Ƚ6hfU-WQjJʫ/ǫ΍[̡2$YVʩZG^zUw5JZjVZj|*r깁j fxpWeʳ*9Ji@5W:cJ+ԫjt5^/]5_JGgUMb*zW'zxѤW×2oƫŕtKrN/6xc/+uzS{nx0LBpi&P@|_Rg|ˬ҇ӟ%'ǫV =^ ^m^p=Z@5}O%I|2|1m\`W]m&`2xJ2m\-RsQWf2şxU3R_jH|ř?^uH,szt׫pdj&h!_%YT67 _6_Wm Wn{>_gUK>F< S9'^IjNV/96(!>HX ifWhUyEzզuxUc^5xU^@x:AWͻWV-^TUzUK^RW"_UW&_UUFS^zUU|2!Jj:ҝ_G 7]^u0zӃhIPGzZ s0VtZ׵+TW5UfW9] 3+z<mUjx{5RW@5}96h>/j&5WEfūK?^5( D |57yUaP͕fNW),7&_Ք[Uz7^JoSxU Cz U4)8}UY^ OUퟀW܂l֛ì>櫪U0kլ^ūg:Ts ⟊WUxU=eW~܋"2fMa0(] *_QU3"_MU5MFS=zEM9&W=43(%PM =6h:Ɯ^ xUWÖ&xU6AV"U]+W欕W&^Փjj{ǫVo .īĉW-P^x̀W=wkYjV^3-|jTg׻x0ҡ'_}j*U+5BUx ^tf>S%Amy ^6V/.Wp^F CdwVÔ}Wz+RxeWiYJӁ[WǯWTU')GNE&c}KxU Uǫ WZxfE[n{񪶝W[z9|9]s:ɇwxHիڐ*^)xU:0U-:^&Y^uhxn5kZ[c2mzw-WuY8^8Ӣ8.->^uW4iQ-s[j$njqiCӢ8ȁ3Jim}ji֓+ݔz r=V/񪶍"_ūZqWu)|U[U \H|U}' ,~UPTU^N|g>9ͼuM)mգfͲzUWʫ֓{iE=x8JSwql,C+_5/!^u4>2UQC WNSn7_>~QV/s ]87}e9prp{@Yī:gǫ=M/^վ#MG]jwjtKzOf5W~ NjtUI}XVZWX)p9z'8ivMUЫWSǁd,:!ĮUOŕeyP*%Y,͚TkW0( 9«vf9L3aM𪷩U]ƫZof||ۗ0P<1UuP=J<Sr9<ī˿Qf&|1#2I(WYtEqmGY_xbU6hhX䫞2RU?UE=䫖8NQ;_ $,9]^0^UAy«>LCNYs 4_fYTSWqٮat 34_ѱkV^HTjnOqk׫W-'{҃(Z|բ'7ۼ-C`/Z[Ojtwk=>5_t^UԬbGs_ZofM^;_5fQuz's˟@ī \C86 q>9׫.F-W|SKb0Ô_zr'_դi*;zUzղoi۞"mdW UիN!Cߢ0Eq׫>UUMadJu ^"5WxSǫ3|wW6^jg׫>Ϧ5/HV@5(!H@!U:լWzhtpEw-4ā#5͚7ƨaڠ={jm"Moxť|c0s铹dU:82xպ!aiSEWe5Bʫī>|U'!ũ˫WEqc$_{׫NZ^UQW;^իiQ\zUU%_UO |xؓ9]zzON*ywo꿧ojxUW5WhʑU R|1W@4yq 474*?LXRa~4G¦^Azsnq4d"ju~j,).[]Dvj6bUMr:,qox m4ل"4^usx?"x~/U"5mx /sU+lwfR? K0^5=WW,3a%FzUUexUzUe :/0_~fi2a3Ksfv3U샇(:^u';[T뜵>W5 jzUv6@Y{$,͙lM:ɭ2ƞM0KsmVrU=Vꐯ>;:*5_Z)JarxU/W}$TCS7KsO0^՛1*zHPC+n5WxU˫b'PyJPJxqYkWSΟ9W5|ն}v ^xUgzUj_k? #nMzUuVr!AjIW-MCc#^uT*hZɑU"r05}ONaa>|:70չW^j=|UC˫-zJP yYEE }f9%0^f"U/DǫUѫWjY5vI9^u0iMS!\yW=IP nmnBMj]{\cP5_rxU;_Μ`+SJjg/>5^*9}}WU>^?[xnz^xU~Eaaݬx|S?^վs۫:̏MSƫj֤qlīVijNxS^)W0v4cebl.,iN3#`w4kt@BjW%34Ks4"kqɤeinP:*Sn1ŭYV*:݅4*lB9h 2Ҝ ͥGȧ[VrKJbI׫Z?S"5MS1}s\ūzu֫W6.Z~_<9^PxU'&;_zUT8 6ի^8݇݁LU5 +p'J|FuRU> *rWPPޟ9^ƫīZZxīV[u퐯j P8x'U f«u^Tj}9?TJGtx0WI*,wUG7"|%_={o^ɜ?|U>ȧ[GzU/jrz)߇W5%4*^)yI).2#RMm{Wwà,(u-HZդEʁA 7:!*=mƂWxUMs鐛!MSuMOʘ;WUmWC^1tطd8~ׯWUIU鍣W&^n{;_RJw}pZ)W=^]ǫ@[Uz Wfo\M|q𪧌BsTu0ZaQzgdHsitCs!\麚yo/Wel9핯|2I#/."5W:T|)RUKf9^UtIXU/ j*_ʟp "QU׫V?7ەk+^`5w2xUW)'_hxPnq8LsAOūL5ktCzHfOwëꐯ&uJ嫴A^OjM';AWh<^uS'ǫ=pjݸU]WoJy.PMSxNwPUzDu«PWed{xUs'?Hū:>DW%lv^Q<ǫWZa֗&u.7cxUjGxUR|JGҥ^P< LxUG!v y(z4tNmpë3WW'^ѺF\_ij76jŞ(%9JSȧU02_i0UmW=H嫖f͕覵u? ^CEJb]͎+|Uc*_jNA'Cj 5UmG;^u4.;_׫“Os96p҃C SܚSszGNw)_M%nQ*+^5W$l$qUgQUA=9n ^~#ëWu9m^jWyҬ@UtٛDǫU@5X,gW_ W%_eYaI=FӾy(ZxպeW-WۍWcc:>^ڃ},^|x{k(Y"D Ŵ(nONQ\=>|U_~같v+:ĭDV/KLC"5W:ZOEɝU'(2|%Wuo]4lZ"t:yī"z*a97aN$^w*^)|B}'(NR4(.pz]ꦾ֝aj^`unz{Ixպ߈WcU"5Eq0RUojO^ҙ`H"jWu*hXB0̲R]逓)W=4zJ_MnƫnE)6!_%eQ\Y*jɄN^~U«NwR_2.rLT Eq 9gY|?^@3/xU{-.@6h>Q R2[[Ys *z|Wl{UƫޚӜ׫Vk9L(Tʦ^UYWZ7^zU5^ Vkm;W5sjbxU&We]fH'zՖ:Gmˈ{Sիz \-fz(5a;;`NYPJA%<\ ^WU9C}BJV_UzU9Ы"0zU^v[mCq^5Q n(UCJdar{ʪ"1 /k-;}/_o?͊_g//?𿷿ܝ鏫QFw/F#+n7!{o} &|G]8Hǽ`aq/G}E}.V c}Ër |pð?߾wGq?(u+Q !9Kdۇۇg+QȊy.VYE9낯zG=0ϻZFΜzs=p7>$TQ++QcPo~w) TcczV=yPvݺKǫ1z`%2 ~.2ͮ _wAz/;Dx{I f1?n(JW:,oA-ܛi ARkauu~]uv"x_%]yl%<lT| r0'?:Q5s=;jqns/vs9Oi-3ފ *56LPφI/!]iNӯkuv4]ykasutp>w !ܻ]C ~N$#7xF$-֔=m{0a#h !َ'C :5)kHRװpI<<Ob/¹{)&(1mCt'f;E ALGNَF!htZx2ʩJsOܽ'^w≻?O$+ -x'޻mMmf;Byچ/ a#})j~ʝ_wu_wu`w 3ނ'C/{) ^lG(/A!vO:e- ̮I\Ó½'{ O 'IR9h plG]  O;e-,w}X8pI^Ó½'sdT<QO GvxaBy؎/ A@(/SV{W\ݫ^2{[Fwzʓc\}|I4,,z%,;k" έh%$uCH+1HD %A^B:"u@09mSHru+> endobj 4 0 obj << /ProcSet [/PDF /Text] /Font <> /ExtGState << >> /ColorSpace << /sRGB 5 0 R >> >> endobj 5 0 obj [/ICCBased 6 0 R] endobj 6 0 obj << /Alternate /DeviceRGB /N 3 /Length 2596 /Filter /FlateDecode >> stream xwTSϽ7PkhRH H.*1 J"6DTpDQ2(C"QDqpId߼y͛~kg}ֺLX Xňg` lpBF|،l *?Y"1P\8=W%Oɘ4M0J"Y2Vs,[|e92<se'9`2&ctI@o|N6(.sSdl-c(2-yH_/XZ.$&\SM07#1ؙYrfYym";8980m-m(]v^DW~ emi]P`/u}q|^R,g+\Kk)/C_|Rax8t1C^7nfzDp 柇u$/ED˦L L[B@ٹЖX!@~(* {d+} G͋љς}WL$cGD2QZ4 E@@A(q`1D `'u46ptc48.`R0) @Rt CXCP%CBH@Rf[(t CQhz#0 Zl`O828.p|O×X ?:0FBx$ !i@ڐH[EE1PL ⢖V6QP>U(j MFkt,:.FW8c1L&ӎ9ƌaX: rbl1 {{{;}#tp8_\8"Ey.,X%%Gщ1-9ҀKl.oo/O$&'=JvMޞxǥ{=Vs\x ‰N柜>ucKz=s/ol|ϝ?y ^d]ps~:;/;]7|WpQoH!ɻVsnYs}ҽ~4] =>=:`;cܱ'?e~!ańD#G&}'/?^xI֓?+\wx20;5\ӯ_etWf^Qs-mw3+?~O~endstream endobj 9 0 obj << /Type /Encoding /BaseEncoding /WinAnsiEncoding /Differences [ 45/minus ] >> endobj 10 0 obj << /Type /Font /Subtype /Type1 /Name /F7 /BaseFont /Times-Roman /Encoding 9 0 R >> endobj xref 0 11 0000000000 65535 f 0000000021 00000 n 0000000163 00000 n 0000256043 00000 n 0000256126 00000 n 0000256238 00000 n 0000256271 00000 n 0000000212 00000 n 0000000292 00000 n 0000258966 00000 n 0000259060 00000 n trailer << /Size 11 /Info 1 0 R /Root 2 0 R >> startxref 259159 %%EOF brms/vignettes/me_loss1_year.pdf0000644000176200001440000005236413155225620016475 0ustar liggesusers%PDF-1.4 %ρ\r 1 0 obj << /CreationDate (D:20170910140950) /ModDate (D:20170910140950) /Title (R Graphics Output) /Producer (R 3.4.1) /Creator (R) >> endobj 2 0 obj << /Type /Catalog /Pages 3 0 R >> endobj 7 0 obj << /Type /Page /Parent 3 0 R /Contents 8 0 R /Resources 4 0 R >> endobj 8 0 obj << /Length 17605 /Filter /FlateDecode >> stream x}Kq}~EɃ~\)X؀ DI6]QU=Zvfs{TeeD>*+>~?<Gx?joWӿG}l[{ά/~?صpE'>?#[_Lsz~G~a<>9giBN|v{xuIe=S7]?MӔL1?~P3%gɏ?~LLP.rhbz6sV%rq)9͵<abz`b{65L36Z}81,qF98?4_igW&f +ޙ؞A\Q&g/WQLs2g\c53jkٞɿp͖ u.e<)!. {&'\ڍM&>Sq))ߢ)R]G>M3;\r KM1!l*TA2\ژ '| ?2)d.K_ӥfsn}_2ޏa b&+_i}^k=&k@)%'o[kߴK^a`Od&5hɹsĐ1[PFSƼ]pnh& <Ècb# M82k2h\z fM$A&&H1lph͊UhP@ǖ0 5m]C5.l gmQn,`߸zSxP#2> FsҡF\EUIk:؝OZ'YCL$ ZE  /Ыڠu _}bH{Bqd=uME#}Mv3 z tr=\%4وVƂDuiX-Hn )<6A^q&}^6$_E׿!1_ش}y:2jIY!_K{eGȱ=`-Y^i=Ҳ<؋) yΑL~J!1=CzشB#* _%Qfr"3ЄmK_)\ң9@C+!a RCiw W+iw߾>=i<@(2I!ʙ|yHX>yH<$yH0" i~Dv9KCMY^XAslgQ\`GE3^dޜ;|9>L!gaɮ}T1UC ØOEW E>ʺ\sf&_oXm -{3j5.\^ APp0a%z 8o@67^&jnLB"` P`'it37!mL7kL-@v0=.#FG3ycze LᙁbKqcz)EhQq`zؘn(c)؎ XXY(L7`z\  L$1rZ 0ܯD\ =]nrѼr0qaz4cܮ`\!σ&'ax0`ɭL7 L7@X9J&+drӣq`E wa\tsLw9L7y MW@d'0=Ā'0z]s@\u? @y,Y]qϒЌx>`4% Ѣ^5Zrh|[K4+o}2y\~@LN }]F%KdsX=^Zofڵknl2]84K{5ߴ'YM{ F/xӘ%:!4;yӸvP0Mljt`y^V1މn1ME]1j,BJdƀc٫vhi8+W~,@"ȰA22O]ROkq v@w!CafQ<ğS9šE_+`"kܛMY2O,pMv!g?iHP5$RGRi8ӭ5.ȱ:[/>NL!(z1+л΀'zvm^R}ʡvn :9}5xS8ho-@7P⅝D[88X>s &Bu_} |oxEA #Pz8TRKx|>*|^LcB{(A&KfA0`DR)}ˌ]H' 3#73n ā/pjL?>X^ PJyTPA[F?P%c1S+͸Bp7&:Zɔ3=%C?U<p'̴]'4'YNLJ\":#N%Ǔ YK%ƿn>Pb K%oŬGJR gdwL>d{KnJZf)+g|tekE jeG3~K7/O2TB?@eQ%/18%Vg!m2~>|z*8I|&sll{tȑ7 #y0^]DS82 PNg<-q%ubө\}ϭeݽ[Ml\8ܑmDaQ4<mIJ$5i7u/x wW,T4-i.*\(ʼnE(b4 {a֋Yg_͒Z , $Y@tnv/=,f87bBe\)9k,p1Җ<92*z2(k dH,~A` Cϋ,c9{ϒHWg@B s>?3"#[ktT$D1D5V 2dHw bQ!V (oxXxXY]ߟr,\e (f=+7w(:8=8Fs/5y.:lهHqK͜8n1[ˬc>'yrgwZ )AIBV0ْldg^C.*I]ȼ̜PM{JˤL8K^h2"{&g$׎,_;*tb,ݯ*Jcz=1| `}k` n~G>ܣ0li2/'| }qB?aߗES_եQ9Kңtn. خKfq9_)h&\iM#(T u 5uIz>(uQUFR*iiuQlEv%M2U}hiu!خ r]躄mA{NH5ʘ)5ɔNFg. hMLaڮM`lJ'uQZrr]2]arW]M7 7@ Vl(Qf2/%Uut]Duj AeBPnflqCvR/.Lel%yȕ:TTT֢:UԄT*&*F*հ7Q1jJ "zL l*M\.AԓKդH亰Xx.خ z$=tc}v+K*޸NT}zj opl-d @D+rj*W ȒtU,ae( )d8#|7!On O=?[+(gJKݦ\n2~p7¸t 5, M&9ppdؙ"̸ɳ^&Cgq+.irc~oeƣj9^5voKtk>jP\U^YYؠ,Ȗ>,r=ASf#hBzB{=XEMNY66ڵJ~r=Z&](\z_O{`*=8q[٣gS,k=ewCujrhO-x%(XdMe3 e|ăxTKC9 zgu U+Z˓z ȉ`MIs:2ą'×_WwY'e @Gt ib\< x"*'%E_Ěfyy" EGCAdjIMOHd j2/ 2N۹2ؔi{!B/$(O/*ǽ*;TVn0DUKV!j 1FT Jd+muF^kj$9zI[Nij&ֹo: h^Z_# e T)]!Em7(MTRP˶\6CyUGjXPY/E!9na?̃P >zBU~$dV:, VrB`-#UvkM`U%uծ냕Uy%dm #.J\N/YceXeSvKXi >Xk/!Fm܊"Vܘ}kn)*Vߟ{p{!{X}cO_o ,$yUG|W;o-dɡ_H9iNUbMW{;}ϧO!^. nkijOQ1޹AO ݧBgmm[)HTZ~ZϰlF$)VDh?$o5׃"`6߆+ؓnlZUgA~qW BߟzPp1y+͉Q|(D$)nx#nд G + iPoDt{PK\Ѥ3V58 h6z0F7{GBÚ>XhzEL&ozN2n%ӹՃzRΒF9qcHhbtT}%=ݯ$=k{ $=3>l%=G ;΢q}Єyg䦘 r}ՃbS _Qc}+nzPGfS&7|1/ccc Ϟ7ד+vzP7v{h3_|V6%|W>("}G }U*u}k|P+ H+BEJo^x2z-z.]σ^4w ˞MacK٣VʲWEg%^֟d/M eO@6a챩uf3sۯ/{Mxx3$Jx}£7E{»ļP]*X%m|^߲ l}EPysiޒ|vYI!~F>9)]|sl~ >_]||ˍ6ŧ2K&~F+3ژ?PUC*CoͿ &K.>Vu!mE)cPyՔAׅg4]NR=UܛrriuIr CNUMUI\mݑB葪N7ʓ[}N%0"ׅ(u V9ZS]m]´LAd?}۔lSASua'D}N%%d6%PkqzL0=rJ0===7m=K=@[M#,zf<m5-ZM@Z!@[ #dЖlo]3sjPL׼M1N/eЖ]lWlћ#j{LכmAЖ @[ڲy/wg߮nHlZ?@{rڳY/kE0h3e$0V'Pآ(VP$Oȳj&Fr^>6%XKh1h+MWË(M"ڊ"6@G @X M%ZOӅ&yVtإɘ_xڋh+B ;@[ ϡh/RMnWlъ>h&3f΋h{B@@[Cb5u^~:{6Js5GWivlYyZ8Gݱb̗pܮآۋqCmOKe V]jtZX:D롲Ke/2ʚK*{c\5*w\\eO؃rjޙ=)oڛsG{dk[KfvR^$(6N{[ثAR:sՔgn8d:^*xٔQx x?JgI*]$j2qtM6)vFr;A:C!wR`zpѭ9t66ٙd \˹ '̸.O2ba P,rDcvF%ڕ ~ {Ip C/nkn2N}"θP`xm** .oį\aY~4J/ ZM|xp?c v0Lވ4cӪ"~܏.FQEDǃjxzsፐP6a@SKT*@oD}E 'wItEpEBf ]6>tÊ]B[^zQ%4c~uEbĥgG1iH2 ^k/M h(U@@ ZJIkvzASaCU-TЦ>>m4֬muuC7Ymە"P퐢}E-ZhI %46MPHqMLN5j]KPO Q+P& i椆=sPڑZv]TԴ+J[@Զ0VԷ*wQEREA{F{&5~Q^^wVt l|ס3'עXbfvv^ulOt{?6̻QXBqN?1*7~>J$u^{ge=,3.{farEacxsGuyi1Dl3hqyL22y[UL|nl`vNV:4 NǺ4yOx?vVJnG79\׫Up"}U>VZ\͐0k=ԬbGkқe*}zjZ =jdOT *{cz٣ŽWƔeJ` ˲B㲷Dž!WI>{η^d&k}!Fx̶ ;; #21(wlG=O F Z|ʶ:_߲ *ǒkK/g!doRvh|!$CJ⫝!%ħw{"ܕ"VgiV邓7e׭'?S _~tJ`fOe7 KU|<ˮtңpv]H}*VSWm$t}4Tm{*5*nۮKkB%Tp\R%(ZBUz?T[ʶ"*[wgKTXEBCڍE5;a4^:5\HyCm4_Y ΧJ %>mʢ>f5Pݺ=r=d^rzzI߯jz,\z,z쬯=82N"=I/ڛ=J,ВJ Ҟ%KE06N2e;3eoId_dS{Cmd#C /Tx(EnEƠ/l O 1 {CxB{y.>`Bxtcl[:YEiF2Hu&z M>&QC@v;X $i#HB׻١;;YĴI'+ݕ7ଭ) .| BW̰IW&Ϯ WWѫO OU#!  ~f_gu =tDE: *cz? 6Uܮ¸ 9;>c'L`{cuaߗ,ew-jE*NUW@gVuJ2fSoe3(cR 8Π;XYm%dce݇">^ ]tdFϝxӥ{C-q8P!&iopĐ-%3y'ĪGU?yY7L Rx2۷iր> 'lW)SrL&PHV|^Чyf{@+7Te+]o7Mh&phc5[E;9WEKa Ԇ@?ka^m<|SraO/WWCy S"z2zfBz4JkJxxnP|,R EYi|ҧro%J)*y>gyX^Irke|zlj!}ԅI^Յƒ# OPbx%ׄWi ,N]dSxoUxyxٗPxDx3 :O<|_ Ol~C_|$JfaSO[rD=W%+O>U\]|,)Mff;~>7G&?!_\xD>ًF|3->ڹ!V|@vUv8ɇw.O@|)EK>w5:Q+7 *N A|.s] (ʮua(9jr=0>Pv.Q2]TumT*ۣVa\߮ #RkRc*RA\ȥ*%#0k¥"Do.AKKCD亄Zu ܻMTpv]%ޮ _2UQ)u~ئu r]L]$SXH-SdBy^]Ԇ &ATuQ{uua,*r9Aax*sJ-P+NPP>_zA\oEP)ׅ6^"EFR]) S互 *TYT0;.U+l)-f*Wۮ צLkm*M5&Uȵlv]\.fޮ\ .G*^yȘzMr@+*5`p5Þը/tE]J{p/ޫg$lV'5+c&hVmf*@N#b60ΎK\ZZ)[cPP9ؑr(/b:89y/araJPs!F~+HK #b1^0SxFZ ki Y+02Fa`nI0ҏ#-vc؈Q<UڜEȘ!"ceE81[E;EhȸUHo-&y2u;~1R< yx02 b;9FFm!FIg`/ #B\>`[x0*aC3rW#Ud:O^WF~]GH?Z^xF\pBC၂~&D4+<8n$ݿb$F#p0za#]#wkHbGF_` #u䅑~~NV`_`F`l#M&f Awi20r$FZ+HpV`}wիi2p_z$HI|ݿx$GW /=5ޑh>>`=O+8Ѯ`>DSK SΠ>FVpJ_A}]8&Cu%{=Y{p=B{jā'+g2 \Ǟl|tGhcuUdJ3;^_.CV l=8.{ oc;iճw@84}1zƒp6"p$dR#^isژ]x7Kkr?rnpw0Lk'0g}Ajk;7Op~#5i KE1XJ1(SPFSPMoUI\>_}Gz1Y1q< ҃@PelTK1VEs}ir p@@0!$bmX )!,˃%eQB`n/V \o#OA4 8O]q&e8, `-3 U=`8a7P"JNRa#QQ%2gQ咀BIPXL[Dΰ©Z9Q@ .(b . bx* 'OZE*.3)neŖ( E@B۸(ve(x-/bWA8)~ Ve .Ul.D8t1*3WXðWu3*|tn#2RNOUۺkЛEݾ(}K_#tv__){#E/}e=_?b=}K_q%ox__Xo^_?G>o^ G>o^G}b=}K_@ & m_CWF >Dɦa}~?qVwҹص>t>/Iv 9IHO浱bZ7Fzfg; H~>-Ϗ Fhϥ .X*.xt~|__S7" H;M5>d3F9<^zx}3/<.[j4FXp/oj[xiÇҼjne[}CX=όS>9}KFFƨRpÇo3]NdžP>GtRo< ӻaף꿯H]1/ǚ5wHِ~2֏.}(vww~ާb>5hA9>hj(Uf~F~>Cή?x}>y|wZ6orꬿq÷pmßBJWuM6zӧ,L*s+sIپI~x{OLhb\Ûy_WwuVzD Sgч]endstream endobj 3 0 obj << /Type /Pages /Kids [ 7 0 R ] /Count 1 /MediaBox [0 0 576 432] >> endobj 4 0 obj << /ProcSet [/PDF /Text] /Font << /F1 10 0 R /F7 11 0 R >> /ExtGState << /GS1 12 0 R /GS257 13 0 R /GS258 14 0 R >> /ColorSpace << /sRGB 5 0 R >> >> endobj 5 0 obj [/ICCBased 6 0 R] endobj 6 0 obj << /Alternate /DeviceRGB /N 3 /Length 2596 /Filter /FlateDecode >> stream xwTSϽ7PkhRH H.*1 J"6DTpDQ2(C"QDqpId߼y͛~kg}ֺLX Xňg` lpBF|،l *?Y"1P\8=W%Oɘ4M0J"Y2Vs,[|e92<se'9`2&ctI@o|N6(.sSdl-c(2-yH_/XZ.$&\SM07#1ؙYrfYym";8980m-m(]v^DW~ emi]P`/u}q|^R,g+\Kk)/C_|Rax8t1C^7nfzDp 柇u$/ED˦L L[B@ٹЖX!@~(* {d+} G͋љς}WL$cGD2QZ4 E@@A(q`1D `'u46ptc48.`R0) @Rt CXCP%CBH@Rf[(t CQhz#0 Zl`O828.p|O×X ?:0FBx$ !i@ڐH[EE1PL ⢖V6QP>U(j MFkt,:.FW8c1L&ӎ9ƌaX: rbl1 {{{;}#tp8_\8"Ey.,X%%Gщ1-9ҀKl.oo/O$&'=JvMޞxǥ{=Vs\x ‰N柜>ucKz=s/ol|ϝ?y ^d]ps~:;/;]7|WpQoH!ɻVsnYs}ҽ~4] =>=:`;cܱ'?e~!ańD#G&}'/?^xI֓?+\wx20;5\ӯ_etWf^Qs-mw3+?~O~endstream endobj 9 0 obj << /Type /Encoding /BaseEncoding /WinAnsiEncoding /Differences [ 45/minus ] >> endobj 10 0 obj << /Type /Font /Subtype /Type1 /Name /F1 /BaseFont /ZapfDingbats >> endobj 11 0 obj << /Type /Font /Subtype /Type1 /Name /F7 /BaseFont /Times-Roman /Encoding 9 0 R >> endobj 12 0 obj << /Type /ExtGState /CA 1.000 >> endobj 13 0 obj << /Type /ExtGState /ca 0.400 >> endobj 14 0 obj << /Type /ExtGState /ca 1.000 >> endobj xref 0 15 0000000000 65535 f 0000000021 00000 n 0000000163 00000 n 0000017970 00000 n 0000018053 00000 n 0000018217 00000 n 0000018250 00000 n 0000000212 00000 n 0000000292 00000 n 0000020945 00000 n 0000021039 00000 n 0000021123 00000 n 0000021222 00000 n 0000021271 00000 n 0000021320 00000 n trailer << /Size 15 /Info 1 0 R /Root 2 0 R >> startxref 21369 %%EOF brms/vignettes/inhaler_plot.pdf0000644000176200001440000071630213202254050016402 0ustar liggesusers%PDF-1.4 %ρ\r 1 0 obj << /CreationDate (D:20170125184259) /ModDate (D:20170125184259) /Title (R Graphics Output) /Producer (R 3.3.2) /Creator (R) >> endobj 2 0 obj << /Type /Catalog /Pages 3 0 R >> endobj 7 0 obj << /Type /Page /Parent 3 0 R /Contents 8 0 R /Resources 4 0 R >> endobj 8 0 obj << /Length 232956 /Filter /FlateDecode >> stream x콽.MGqe @10ḧlIc7^SUW?e?a]Ws_{ꟲ<]W?7??O߿gd?]O?Շÿ<cjMO o< ۟~'|fgOypi=]?JןG^x 5>ZKx={a9 ,oQ=8;X q\vfZO)VO Bϟq|ȂSjrTx̀Q-GeGuGeO;ʰQ5;> Uj>}0v' {^8۵O)q ~y?GwN°1nб/°1aq\61|0?LjO]v'¨`*ƨcu\Zom0@9 eWc7 "9^/?u^=@/.EP:=@u<*Fv_|::n*P/>@PyUn!. ^P^EDžQ 5(^5j107~ku1f>?Owu-rCS-v<0/姓-|=.B`=ڍ-=Ekz}x Dˮ2*M<odtusMn&mdS@/ W_i^}?|R4`2ϫ6-=󲅳q>޴xA?/[@{cG'~,Lwwy= ^v S;t˸jzكq^/@2!MOU^le<4]<UiC8ㅿ77,eq_~C1+D e챫J}}0^3\pR1c\z̸]SƮȌ"pM|kx`rgDM8C^b1UA}itNW~=|~yz#^O? כ5߿F~/U2͟B^fP379!^Fji?̸_l*}U"zn?`5!2eSR>R_o3Q}U;%cwTl}u;g/߈'r'x۳ˈ'۳|]o/]Ɍw8,,>"^p?ǻߴ;|d.7y֭Q޺\5ىCoИz )^ӄ@u\vޛE=L_!\LC}7{wࡾC}7twK+wm}!扺_][wW)yګwMoݜ, :x{Њ%}1^/wX7;[x~ջlRsV4ջ+דB߽<nVn>^< }w1{|*nB]⃱/V]."}2*r/-#q?^:]XH+xbQ%/b^ ]d{!?X|﵆ߟ:r^ 7 ),ݵ0Dx˽Ezջ=Bv#~/W!/ջk`| ;rwJ/&Eq<ݥ:|'q!31rxT28~![l_8뼐/k慄Y{`گ%jCژI}W2e?_˼>J^M}_muq_Vn~~%3&3a-% ?Ѻn1_[I~#~>OJpJ %x쒥8,g*Zgx//ɷ t>J~?R{{<9^>%y_ͼ}7~\]>C!f;?暎%yϧG<3on||9z`sIzƷwwy=5% y=fΧdswһb)IONNzesN5SS'pwm^9)ߴyx|f'|ik[.91wwrc|]wGߕ+}|᏾c>7r[GzKQo)}xx|Gwʧ))e}|T/|g}zCT+-CϤTO1cS='rMSSS(rw7EN1ީu8;g}zT;ܓRpKzK=OIzKͬWFNWw^)ީz8;kg}zoƗɇS=pwgGzKQo8-X|]wGߕ+32*#2*=Ҳ*-Rs+5;FJJɺɲɪɢɚɒMkXlFqF1 ` lj`.)q^%ܝܝܝ۝۝۝ەەL+ )+(3(##0*v—cT[Y,Vi+˴U"meDi`L2rIfaMbIFaIJ&!,DcHx(%0k%̊lfA6Yͬfc3k1KF@&τQ0cza8R:f;`Ojd5:&?`^#뮑eWϪgճ:Eб< 9vIaT?j)4-c=XR:Rǖ5VeղjY_,ZVWm~}.\9prݰaUÒ ;箼[y5b>R꣤>B꣣>2꣢>"ꫡdat͝dFAOD|O_wă%9PF/FW7SkЃ¾)8ssAǵCBWuwk^f}}DZǹ' ǵ~xL6"Ni,⅃U)0x&׈ qIݱ) \pt# GZ+Gu$D{ !b}.q@ːGK>]x9d{] ѭ.i83A,vHI'n6C:^?Tz$#-h5>@G֎OПgrG'%)i1`X*8 Cm"d=4>cTư!?K6V, 'C2Aod0ѝ쾜3ŞKX,{#4%7,P `jCٗq`bl^bQ܆8 =cnyCy P&X()~>)CH@-Cz8 AkA?ޓOHz4CCe$k3"cݱH2X$ =P j 9e%/[n@cb,z8VHV:T|y1o9*'+ߖQE} ;tJ*ٿJ*1V|_~䘷 ZBt\QŹrqtXr]񮔶㿣b^fUQ7BWYU+c\q4C"=䩍+(GG?;R/vLT9QQv\Te ؑa&/#;:~wGG=?lzwGIf~^ّbϳu-uqIU:Xww=,; xÎâeߣmO}GGpS ,3vT"*;2KAou:YdgZ Au9Qj? G<:NM/QRfǪ:Z x/`<-'-:j :A܅˶;v]_ z*<8^ ;~ayag B_8bǴ1ٶü`5In_Q^\t$#WrpiÊzAǹ ]U%*!|ѹ~פ|ɊVpt`to<:}:kv%HǀK_P`!#a'XXp4qǃ*ח c:֗r4q)I~﻾3 J^Hz벮O8rx(te3t,.}aƥ/" G}S_r_pT:t?pO%8>wiP<1Ϝ?o8J{ʒxHe:VwV/J*t >CGq EtbEG.h_tûxFGq U/v)hޕ;:#p$fMͪW.XU]ȪY.Z׮ZW:R9;o7P-)h}'̿Gl.}=zm$뽙go~68'5ůgf|NxxKxsO|sKAJ=|yjsǟnsM_**G<ǁ[<k<%S%!lq|;Kf=Oz,p㓞 \C֏=fΧdswԻ#xG=9;)Q9q=pxx#[w\D{-SK<_J{Sz1rw\o9qzxˇKw\oGN-~䚎_!O5l|Sc>p%;c63_9;{"x|MgwWF>+r[̇nYo1vf|y |x|a+;Gߕ+}W>|]wG!8-G|r⨷Rc>;L#;Oc?pwc!qwW$n!g[$z1ޱ)ޱ^8;֛xzUX ec-pwIo%zaΧ$za+xzg+;KXo 뵁c7qOY߱8;ֳGzx⨷XOOgw9ޡ p[w3;+Gw-x7V?c%~Qo_$pOz&[[W \sCKex~)8;%Ng}~Y߱_)pKzNk[JG~)ޡ+bgw7 g}~)޵O8;O?Nz~/x%~3-+&NSCdo8;k.}W>|]wGߕVYoVYoViYoV9ޕy#xvwvl%xXdidedad]dYdUdQdMdIǦ5 ,6t來;66 g kl~8RPc,,,,ޮݮ,h2x%!Eƕd gQ4Fl)T002E3Gh,VVj+ 5P6fJ[YVh2IQ.ɬ#I,#,)T$D`S d]fM6$Y,fc3˱blf-6;&0`IȄQ0c\uLo1G Pl)@F^#+ȺkdճYtmx%t,¨]RϱZ 96M`KX<5cԱeղjYa,ZW-˫U'wK=W{.\7llXsհ}>)+/V^ͭh(訏j+Y$]s'Yu#qrЃxq!`\Āv7l)mĭ h7~# rx6 f@*MLV,;h4*7U<=0U1ySXb![L{pVlK{Cw=!-9W΀jr V#>*Vўh|kOzEaȊXdT1{ח5S/*nȱ\C^=*zwůW:>ړ~!Dǒr4)=)Ǔe/'FbOǔ>ߡ ($UQ#tl!Lݎ.Nӕ#L_cLa9ʔ0Ld9Ҕnc t~L2倇#N_cL:h~#ϸo&ǣ>}#P1L^â/~БD_2 !tDO4Qi,Gpdb!Ǧ rt!G>*QJȑZ x~hUHWUUIYգUJ[UK]= Gr#㣣zȪW.XU]f h ^j)^kW:VAqQIqFÈx{=/y撎czmwޛy?Ɲgo~68枎`sKx9Ļ-ωk߉C_8yVƷƷ5o'~#OU|/G"MGqGyGz pIk W5lni|EmkN'z*p \tPocs#j;ٜXz8pwӁSGwZOl9i=xL/)ZO.||jswZNN)ixֻkwZ/o.9i8;tp%;c63_9;{"x|MgwWF>+r[̇nYo1vf|y;|x|+;Gߕ+}W>|]wG19-#G|r䨷>RS>LN#;SpwlS!rwWDn!g[DzK1ީ)ީ^9;՛"xzUT:eSpwIow%zaΧ$zf+#xz+;KTo=굇GwFi|Yߩ|8;գg}zv䨷T鑣R=LN#;9ޱpnf}~YߩaNSEدg[9n{w|]wefUf[edUF[gUZ[eUjwx~1ޱx㝢[7^)=Y=Y=Y=Y=Yֱ9zcuOtOtlXbCw( 0+6MMc`SpwHAM,,,,ޮݮ,d2^IHɠ \IF ID!)Tq002%3d!,VVj+ u2meH[Y,d9 7\YGXXGXRI( d?^)Jɺ$̚lfI6"Yͬfc3Zlf)&$a$(LE1 c:7L#cF^#Kkd5Yu,z\Ƕ:Ga?.)X-Q&u,ԱK PZزjYbZX-뫖Ueq'wK=W{.\7llXsհ}>)+/V^ͭh(訏j+Y$]s'Yq榳;AOD|O\w 1{ 87ڈ7~,">#?Ru?p cۏF<}%q8G~OPx (/ss~6¨㠏x?=4;OD\A?5}*8>EyЧOgOBE2&fǺmdzS܂I.8r1ay'!2՜b1nw3r<{ƾf)!. :z# 7..gޞ)i؈d -7T (Zn!|džq.gٸd_grC$ᠡTri1`DBC:cD{#cc1ŏ?X)`x![f$s3a)hw )s [Pl԰ryP7WCڱ5t8q7QblxS ܆S`3oż_g, q@ZOH@L3.o C "aŦvEp7a|iO _$@G_|z?{hH1^vC {t :ܸ=$ܸ<4ܠbG?=>o=x2 ty/ܣBoqOqvܹ>;[؃޸=]o={ EGq z;wP]ݥA}辰rv~]p#rl zCCoM%:֤ IGj[85=觾ŽUc:佣xIo2~_lHc{ 8w=-?|@tzx;<v O}ž {7˶؁;k#;gמxbF#= VU^p"ٴ1:ƍ|KԞ<]8EG-g߇kN;}q7yBǾIpݎ= `rlIP 9EG9ac# / ?"ع:&'HǏ MO9E:<w{{2A̛|!-=lY7wp{48=2x~Ep<e _ zgރY(s{{x/i3gh3 GO1猿7ܿ'=py2"3G23p߻gVCNy8 ƝY{W:}W=转Je::_wPg !:J1;B~0>|Չ4_9Zy=k*|=;Ƈ [РlXE8vw}]w޵$:w!]xHu;:O P"|TP#'>K8OS#TQ>5W8,~˽t^ZbǷkx||[W\s7~\Mw- h>\H.i|MF- as \6SOq|ck\'s#j;ٜXz8pwӁSGwZOl9i=xL/ah=zl)i8;x֫[wZn9ixv^\x 63xQ>"pwgNN5;S6ZN))8;o:pz5-|;; _91xxxW>|]wGߕ+}W>Qo)9-#G|هgwʇ))~x||ƗS` cS"rKǯT9%-#7^9;;_)ީ^zxxzT=꽑{_w'NYߩ9-#Gzz䨷T?|]wGߕ+32*#2*=Ҳ*-Rs+5;FJJɺɲɪɢɚɒNMšFyfQ\` mjB?؅355 G jjf wgwgwgvgf1]Y]Yd AAA81B8R` `2dKf1xB\YVj+봕e*meF[Y4s0 &nF$&$P%Q1N~$RuI5̒lfE6 Y,fVc3RL&0aIHQ|v0"%ӛp%Üp%5YzF^#뮑eWϪgճ:Eб< 9vIaT?j)4-c=XR:Rǖ5VeղjY_,ZVWm~}.\9prݰaUÒ ;箼[y5b>R꣤>B꣣>2꣢>"ꫡdat͝dA?P|8G=X'd>Uǹ/Dě}}ٷ}~sxǾ DZǹ;|sx>x7D?C,A_!w<zǵ_΃:^v<8A!)㠏xqG|J@dAqՀ"O=ձ;Ԇ|q;@NS㳧Cdx"Ǿ'*DZ1dzSكI1}:Axw<{;= )\ptۻ Gec!D 2ű$b}.q7*A98~Vt'Yf8tnw7dx@,:=_P:"uj k؎ȧI:= q !vtc{CG S;a1xrW`!՗q;(Y8>?-oiAW"NAo/,]Ao8CS, /(c)8FB',# =bi} j 9g , =^alwjC}m'/hX7!<0oÂS;{/;qz[%Rc5ća;{rlG:ư2oj̸w#3W>{Џ#B2 &C~;!9eh5Ab}O{A!v؎TdԌ'3rOpЏČ1ڎSd/>ˏ"xqa zc|1 kx=%Ǽ)Du*gdGpsvc1qמǺgoIokA[r|#c=lEFۘx=̘{1cn $2p "nc.9=co<Ŧ~&TeLYTDK(aD '  c8Q="b=}سc<器%2*2pbc<V ?NĊx'YIesBҞҨH X -c!iF ٱ[8vv |(jR~p yrł$>G;qKGuL8>8/;p_#50f8Zx.ǻw#;ʆꆁ׈ss=z=?c~<{_x-/<y=//7qI;➎?@'K<'^{<-eǧx8pOc<8i|O6lq|x5r3#-5@G=z#pK^ \w8>S{X'=7S/|7t>ԫSKNNz:pwS#rẇ91rx|fk"x|O/:rcgENz--׬;\rc>o3}/<|x|]wGߕ+}W>|];s#G|p䨷OчWwg))~xx|{_wNww7DN-R=LzKQo9;s"t>5;Ջ"xzST]WwNYߩ^w'zꅑ{:ꑛYꝇT/=RSpwN=/;Փg}zTώᑣR==r[)ީxx~=;n9ͬԯp8;;lYߩ_pw귈5"tLzK G['Q"x~)ޱf3e"x~)s8;ENg}~Yߩ_pKzKNk[ꗊ"G~)ޱbgw7;g}~)޵Ow8;mf;-R Ϥԯ9;;FNScԯ|]wG߱4rwW]#'~%NzSc?oNю,힬,재,랬,Ɡ,ؔ&ņQ^<`Wl$C356o)q~cpwVpwpwowowVowoWnWn4lAaJ2憍3(#6d8 c` ^2Wj++:meJ[YVh2IQ.ɬ#I,#,)T$D`S d]fM6$Y,fc3˱blf-6 LX0`E2HƵ1@&)@0')@l')@F^#+ȺkdճYtd[^IP_I.y0Y-F#%%{%k)eղjYa,ZW-˫U'wK=W{.\7llXsհ}>)+/V^ͭh(訏j+Y$]s'YqKރ'=Ug_C29}nK p8u7gzǺǾ)9Vy>8x/:pnxú!Ǟ=a88kq{*r<{;>{3^>LrCS =}vcr5 ާ^iDZmǵ'ukO]>C].8Oprx A8HS.|O'ie]y^48;Żhs|~t/rpP.<ב7 F#E!NAZˆ8i@:Sam8zN! AG '00&SD MmK,`Xyo|bid狅e=Xts%Ys 6C?#, qz@R:zC/#y|9̎[%hS TCr|5G[Coҷ/3!vle_v, vc‚\;da1os(0Ȁ4J#7F#00{zУqG_2{Zİ-@-MT E!OtL_>wOt318D7# CRH`2tO}ч8zC[}i/ClXI1Clv)3C8Qf܌DF{:#c/:,3A ~12pX!h-VvXOKBd<=d5S+Ao\ό1$2pH#5az)ǼK]dÁq{1~cNx"#nog̍o9oCwc쑎1cfdŏ0o7s1Ê1~(T8Q0c%1j[NT<8*"t{**Ƹ71꺛]/Ñ1/TG==]YQwח.=׭5 *VXke '*^+bazc|1{E7c~+r8?9=^3AEٟOT $xߣ"nyƃ3dw#l*~sa|"5\/Tl+^=a?azgd\·{{t. +sa|C+}!e-ޙ }`Ǥ1`[pء#4b[nArE7Qj\9H5C~aը=tji݈t:b[+G86QU_XsbM䨿w_bG/ߡl=}7PFDZƃ ˾xz_q{{f@yOuiwtTy %G/:= !ǼEGg-hHxpO`ץ=;r^rp*pCMhv{2 }7Wr{*hG8*:=top>_8bݦ(v1 c\H47.9c"+ F}W{$:<'GX Iy_ȅ1GEt~}7:>Q傾SnzĹ@@oȊ ~A} 1)1;JQ.$džc#ӱtt3t7Cp%hHꐭXLEV"ו GTbrQ%w>^SyoUwǘ$OV 1Bd1P0Y|c|x?x;U8NQ9gc&+ty΅|}7[t &X,cZw]M1pU{7 ܑӾ#1HG.ѱx"qF.t&VUwﲤW]$>*]Tk$MzV ]eCPp3 -8t؂>"_w?ɉW pD'f\U$7+7^I*XnN1.J_[t |-2c:'flxgsIAk3'y_ͼ}6t>~is;wg~78lnq|}\J枎`sKx9 x9rs;ƷƷ5o'=lq|gg\{_'s-ϙ7x>Gl.i|[OT}^[+k;KK䭧68686tF|M EWw7m9)_Io)e|qKwmf󅇯o|]w̧wύR>9r[G^))}xx|{wGi|Y)8; 6Yߩ9;+"tJzK3-S"GzLTω\T/McS*rwwNYߩv8;T;ܒR0rOSR=r3땑cSꥇWwNYߩe}zT>ّR=|]wz̬zJzJzJcc;;E;oR{{{{{{{{{cSƚFyfQ\<` mlB7qYYYYYYY]Y]YdJB+(6$dd8 c` ^2Wj++:meJ[YVh2IQ.ɬ#I,#,)T$D`S d]fM6$Y,fc3˱blf-6 LX0`E2HƵ1@&)@0')@l')@ɨ'kd5Yw,zV]=5l+) YF#~d<l–,š’Ė5VeղjY_,ZVWm~}.\9prݰaUÒ ;箼[y5b>R꣤>B꣣>2꣢>"ꫡdat͝dAbAo{l=I'=Ճ~!"`K|oA=ߛwom"GA85Q=Qc/A~9~uϧ1~ 6C4yq;9dAx>#vxaTޘ~zhvwJ@'O6}*8>E#+O{\#N™ i۱Iݱ)߱oA8 Mw]jxBI'A28;!~ȑQ=GZY3vw~eGVߟlH$Kك)iqz8{Ew!@u|~Z¹[C/} aXB7G:{EKnÇx)t4c7b޻{$u? AoQ3E°qy P?ZGΦ.#ibxqy PD#kC c-=cwi oe~uكeބΎ޺@ʛO-CF2st @-I=qF68!%GIá10ZC߮(ᇊ7 c8PS:ڽaLW< UJvs;VTHGx=bFٿukOcT7zkc)c:޽bn ViT"f3c:`"_d@EnTf$9)RZ Z !)@jiz{3p?]jѷhDfFzZwc6{2w0Df(o`(Q<=6{2"y0`c1y1wܤ?n+ĈM|vU{4==oD&zc=YDA`DO"yPO #7)ADzoD$"b^PQ?=R{TmqSS}PWC/H8[^d,<&q)BfTȸBtnFظoF?xI16BE"))3V.)G$%GDG})W;淜BGd\7* #`d B#Oo('P=בt02 X/ʈ {Qu"嵘uןwˌzoW7dB}?X;S=8}]pom}[}f]{o{מ_{9_d]{~-keNA0 7ă,Ȍk;fI $Ș<=jQy')yOPߌ̓'ZXF(;1zpq zwػD42R{}w z{*܌؃DP":-C:ߩgs&SL~7wƌ+$J?,=^b f, #2/|75w[,좊Eؾ36͌K?8K1ݩS~XP-d_z7Fƻ/PR{w̤S wK7Ph#c"3*03e(~k ݯ_.w(~i]!%s.ax&Ttͷza_;y׃x2Tˁ5*xA<*b:G ^(n}"z^:fq6iE&3EgES$EuV":pe)7|f RqfF*HuO.$,{,}댾P*.v ?T]܉g=旝T^uOAƃ =h(3iRy=҃~3(*/NO)c>]bߥ׿CY㿪'==PCk1*fo)/ě *iI 4;OKEb'P[셊Q!:ZnfĈS_\'DHv7b׃b(̳P\[ r=-EEŻKbqT[ԒsN,Ċ'b~KESxV(-8ˍn}xx{k>9_b)oaOb߆q#8r;R? W=p=Yi'#5L>qw{G>qwhxE{5;G.q?q 'a.z8~iU~?{wO>ܢ~`︟8;=io{p>pP qW"毇?`y8G{G);c _qwxEhozG{GgyaȷO{8GE); ‡gw7>5;<\)_`E~|#S1_o)I<|K({|c>axm<F~|#S>opwWz|s[ʗ-[y<^h/pfG~|#SޕOpw3|W[{x|G[7||Ec1_`opw4]wߥ/~]wߥVoVjoV*oVޥy=WvL%68ۑv$v;iݎnGR#ۑ1)` 6w LwГ+&;M {0kL~7؂QcHVdp+ۊmE"yH(208@4=( # `(p0 2bDpD6"SFi#IڈmDFь0Qp㠧Ḱ,Qc0SE %Dz;EK#'둒z$d=XlG2#둊=` =-z3AOpM'z@=` k0P-rW̫E"jvȺj$]5r'[=ɣ?O.)ϓZ zd%'@=y(` IK/|SHJdX%UDvUwC5Fk 7,1lc0E}a}n ݊s#F}q/*ŤQ_,D}sK^Rg\]? xpMsj{>Z?,<ܜU%]pΪbprVc21׃§?&^;W@ }rQp'@5o$%i\q+s})"1C (΅Ёѣ zْ~EuM-+i@5 pY ޗy=Oj 9m@IKsۛ ρ7O0PLbö*/auz 7[2۹f/o/b+~FƬm#Mךa z^cNkWC[ n,^^o.67ƻ nt=b p"a&<$]xb랸E?j7L7na;2\* ꏁJsDEdsc@BPDFD`:gNxpN@t ׁz^G`(B;MxFhxN99 DC"Yl ^AG;IFwDv"y~<{Imb4xG?M?#I1␶~ER#qv Njx|0"b ،DE#.g1<ș ɴd[E2+(bÞ\d))9ۓL|3>qޜeUo'"bYBF2be![L|`(M}};XLM5dkcFN.!̪P2A9KᏌLE22A8)d,}0 3"`Fӡh/Q.%S#zL^"oSF.cҐ$3R2,u^/3R =fIEd%*і*#3>x|?axd%}?Q7̸ஞC/ї3]ȔS`ba4e>ߙ~y0cV?|_b>ߝ2&.M?, 3]L~pq ; w3>4HCFhVEfwgFiVfލA efU<`Fݒ.t!wca̸[2rcO63~. DlȌbB2vHPị,Rl#GЃ`(812f$3U@@U=P"jY-8?M/>)i uH8}흂/\( <d_3Wyf_O$8 ئP1pplG}l'}l=L:u9u9a gjTd\3.XQq=~P'xĦz'&P\$9H_RWT\1U`FStq#(̕MEP7M1Og>c]|7(̏NV)NŮ} !P]z˩wbS[LrT] ~kC4 &~}T"AL>C~(r{ʼnN~*근P\H |b(3"Pi*&/b@'"Nb1EQABXPTT $7(R_4 {x}<(b_ #76<;<;4D3` {~bEJãx\BpS0c]AK⡨Ο':< Ex#HLż]èx' m>9_b)oaOb߆ps89䃆z7zN {'+,>pw{'>pw{wni?aF{3p~RG) OWN=~`4\~pN]9; hv8;.|| ßqCџqw{Г" J7 s-(k0P-rW̫E"jvȺj$]5r.g`@<>z#僞H)XzO ԓ`9VDU"*_HJdW9|1tXcaqÆ9F Stڧ/֗ +VЭq;7nnR_LH}/ŢH7[M5+Кo}EAn)q1I\݈TtA~2Rak.<{x}umY$ifhD+%2Ktx5Qȥ,ȅ%P|M&ɗSWW[^7FA&C7%&TҐ%KTR4 ؞iNlMÝK r2iLp}0\&)r/Kɏ ?.\M< > > > {;2aTgjAq^><)Z%-&ib R!B"2#Y""& &IMlD {རm)$u>kzIeHeUH[8Kn4 7N:n3s&@O L*>q{C@?+{O2PMi l2Pj:Ou3ܹa;mK gLT'qD$7v=ӄciυ :z^?^DsAT1iqU=8E,LQʈQ s拈aI ZnI||q9A|lQ| PL"ByPȈQFcjǴe)8`n T(z#YFT xGD-SQw?6.#vE/+(F {)"xBİ2"E/q,침dbˢ #Eb=A g?FT?3#%?.;) q.̈qˆrB"8#XfDHˈwQ FTwDƖ’O*/T)b_ieIVCE=gQPgE92 {&+cB 3^PCz3#:3&*n02.jRUDddT)zQRUU!U#U%5KaV䭖?vз*73^|̈$ʘ9=AjzbM% WF;y#*G 3*w5(ɬ*63jBKUKt'xQC3U5SQΌ|1HO)ftU?f|"]?`XaHeDX8|*1#dE`[?̈;E|Vu~l{B2*0ctwT#4GF`Qf DF|2 {+#3Kh}1#h0c|_+ˌ˒eFfQOoH{^FgIv1㳨+3Bz2c4(3JG)_F*hXce}2^32b󤂏yQem"H$~Y Wf(W_dSJuΟǪܨhdHCFsMϠ/#:7fLQ 2sefdiC-2OE#Q}.+sBP8t\)#=g'ˬ vlC^{VifgVP|6E?z,3>G236HeFVaf'w*T $ĕ my88/(ԡHP)ҢxHz?8Abxa1)7+Hp*:ζKyO{}2:*H b%IMER$)IR S1ॢ&I!KMIEDgCs=Cx E7AH1:cH;>I<́"Ըh:n(g/hPԸިYW:k>]qPu|Q%ge g55CE*+Iі* oI89ᤘ;>:?O/C~/ZR8ME=xTi.E\R!/ERʻ/EbR {U UA^ɭa zVNbL8V++ J}0zWNs)=.B1:)QT *Ⅵ+;8a0Klc8~'oyr86pzri=: s;\8\9p 8\''=Gizd.zd/~~ia~0?~a~Nʅ#a}.|}|~/ {pף_g=0? 0?O|0O|'>p &_tt8!_u8;]aav8;q7ܣ~pN 5;G hﴟqr~G1ܯ9{{iiF{sw/Nqqwܯ{\{< _{GpSw`8;p8-.oџp|Swho|xD{]wߥ/~]wߥ/~{%Ǟoɟ[G?a=R3- ><R=-+z={|KÑYpwߥ/~]wߥ/~|URÁo)_p|Ksw)G{|^S: NĂ3غݎnGb#ۑv$u;r)s XJ~+%?ɕMIzæv̚[0jJnE"SޜV$o3rD #둍Hzb=R1S F=igzR$ڃ@I&؃`N%` E"jyHZ]-ҮYWF%٢ H=\A~$|s4K0Px `$L@IZJX"*bȰJ$X%U/>k8,1nXb0ǨaNra݊s3nF͍R_TI}/EXT$C-\&hͷ~n^>-~~kXErg[ `e ݚD,`VK b)&΂RQ ̥܆TЮM!04C,pah3YCmGP7C)V(AĊ滃ah'{A};KP HR"HWTJY Y{V3aww:A꠰; aPTn*H&VR0 Ti*邤x{AJ aJbN22HRb Ti\*] LEob y\ɳRThYi*уbA tqB2j!NhjCH["Hz"H"8QC)c3-ҾmۉkIJ"H5ٲ< IR^ viRI!!1yRo3풐2^L_9z&\8>6O Bcp:O^Msؑn̰ *~H-.*cz۲w)҆'z&aX5d@0 S ,,2i;?-c[paPlO J="uY ac^﾿0JQN(pw8C^ I(~㽅}<#69_[Av\}9N*tbsC=;R Б"3 v4|8pשк%UL}V;~?d=@}iJTSϵw/֭2nd4VtbL3ͣi,4Fp> $4op_"_  y<Ӌ#@RUi 6UnT$$/{!2NZڶߤ,,"gʚ!` jpڹmVVcZU)U*m Hyr2UxfU'> UJvW5a_@ (I7}J S bÚ}&S˦ eX誐YSfd!`VeQi$]nPXNf)Edt@> ?"UywF6a{K}67 EZy i)E[Iܢ&H- ޳;?,8첺om־*V%sZTt&*zgͥI}ԡ8z0kA4\I:}*H^ EzK{~c:xEC$iёk^$C**0S KV^d7 ^fd&pMϏC }y6_u %)qTIT CPRkvj Jkq Bxw:mP~ .t^Aq`%Eh*$\l *26ll|ؔROjڙ,c7shIkf^DLB)eq9 Y%J*6HJKfݧg887!P)'gS=JeP6{MTJZfN.$nR?%CfcP7EV6V]G.))zWKSzu<3RCT/Upn|jʗ]Z@ʕ:yuzF|5'Omde]MhԣZW[.5z]q)VV\.$uJwi՛L{UwTwXeVNgvSUb6UOb AD@!XjiC~&,~jAD _gb~pY2l6z~pT&9-^dM`QlK- [J7ŷJjÇs {?8l Pl*{ xrCC5NIx 5^`_ͩxck5>Y4Y"XܬlLnVD V7+[89V40W`'u6X23#223P3nFBMJ&`񳒹6d곾 {ܬ#bd0"ԧ`s`E]}R fw 96)'ԇ`I0ݬ`LnV.V7+ 0Yiɟ̖(`u~f Yy@W8JW0P.8Rp z? :? ? `7\0)m. 1]ڂ Nzzz~5(u,@`JS0P7P`'Gٟl`szz߂9(5L@7~? T^@ :~ `[n߂l'6j-XQo| `P=W0P-8Ro T *E"JAȠRdP)2T JMtZz?舍5~k-8fނ(k-ؼFނ(k` zx e W`PֿAg{ş<<݂k#6ֶAgi_B:v? ~(3P֫[00(- ʺt VOlG`:t?X%$Ol=7s? @Ygn  ʺr e=~VAYCn``P֌AGlX#6܂(k-؂R n p `z`P}[00(MۂAYR?{bc-'6pAGl@@6:m? l? T ʚl e-eڂ-=:bc}tƺj? zj `Q[~ڂAY7m@``PF0`7zh NOlg vOl{@w@s@o``P50E"JAȠRdP)2TؤMjؤMؤM*ؤ T@I@E6I 7N;iqځ7@v`M;&u&ʞɨ'!cېc1m"u6,zauoj 6Q I+p( i?Zf G~M4=cQk:_uVy׆QkCި!gmh24 F B#h,h.׆3QkC5QD-n ֆaQkk͊[@yz`<=Nt1e P -BFȱS9b-)v(ޢnZ 7-pM ̦bSjL4=0U#r4T\Bd xb1-̀(OvP ,S)”`J 0%ң8ChS bM%r40N1aVg 9#ls"[d%rHU"SD%HSXJܤ @ m/,93?|rV|>;L~OZ{\uZ׍";'ك8;;l'_I;OK?jHz>uR~8onñ:xa;ܗ5󦣜Gy'{<2/Ⱦz췟Y%z_ X) 'Y5߽>L(>ĽL>ŸXg?_mco}[/N^Br'3n;;D;CW-ʸO}!mg,̾B6?:oLt ӐPl]dmL~O9`owqd_]^dWI'N_FzƬ> ܟDxk]c' ?yd|?tzs'3ƭ ~gl5Vnݦ`k*?%r ?~ן?w o qFb~dmwwIgW0@;CW?f'PA'xޤD? 7xTO^Gc?Qu:b~$2w\Ў?nv}雄.Λu<>k3O+wSy}Sv? 'I[9nܿ9bSv;‘!Kk,}Ϭ~ggb7--m^YI ?+ j7?gmϚK57O>*dS+,z.&^(Tn,WzL~ϐg9_$~>'rdN,7-~8yX .8 7^mh<h8Um7Q{|?J(:Ϸ_篎q:s=<~5RW%8tYշF!MT:Dz{9?t7g้ ƿ;^AQxլ^舀 y$n^o0Q8~o{%x / VOW/zz;*E} KWzg%.os}#?]/xу s~2o'߁~ob*ƛ:bru7}בH8t/:!gXOG_9%p>rx&0{1^GŃ+~/x|6e~9ٰ; t]O#ω=|Rtzj!91^'0x 񖭷Ó߈xg=x8ݺ^ϭ6*K#a?=tGyBpux ~J[; xW|xb+/XC ~.E1_ޏzqJQw|L\OwE߳?[W~yoZOI΅N\ys~wJŇkk˟*lX_xo¾A|$u#_'p|im'1zߘTs}W>ssobs|·oqq:>_r}0_>WkuߏaXOEW`^-♝=Q<^8p%_^'.x-%w)<dzgvWG`7`1w]|8빆~o:q%w-ߟx~fn~*q! ?΃փxl=Lԥrj<ޏr&^,uni |]% ~ p |f_;xI;~Y;zA.|1x_'14\p~g~sxvy?rf'x~ ֽ:TE|b/ Ɨ_;^7׸^sx,uONsx/fmgtfּ?fˍ Z <8ο?D]A+w<Ճv> nJ?]e ;c+/c~2.čx_yy5ڋR| 4%O6Qlhya5S]LxJ_Ws{JnLLq}}K;0cgՃ/M:( {Z_ĭ=x0+x []g7ghƤ^6c "n<>l nװo_{vs{Se(ÞԽߋ8{]w?z~ {\c|ONN1x?kxWx|60^V횆3qS?_6Mލxdh}o Bx%n]/}Cm:5k=H鏆.Kؿ-̏.S|{w/m dL\aZ?MwX-ɿ]3/c0K-yU߆}hx6/ Ϙŏ›;oN&uv /}k|5T |_:kϵ<{Uhڐxx'z&K|u0\OSrm_)Eqp:7ٍi[۝!ܗ{gm˿'>\叞/=190s<^TZ/FB|Y|/#m?zylxx'ލ_BGxo$zzʿyVAo=b'&?8&Ɠ?[S&<^ic`{;\lv0v|x}lnwr,?6~ #x^$93axD˼3k~^Em;gXY0w G1;1sV{v}N<p_NDgOs60$mW%lT^k7q^c򗃯6wm-'Gu7F|`-GB;DmӟttIm^~]r,=w։os+;c<=ߝ1'`A|^<$boo1~ z{UwاMx6ʯi:gu}&œvxG4.'co'1ޢCȉ-v kb<}6n{|]:Kr/{9%9Ͻ0i![ͿO_~)a< :9x ||*\,,v'w^ċyq]fX >/3za*yosO0|)_[!f>sG~wG|Չ9^]/ܿ\+1;o770Mzą_ΐ}Rzj/g~.=mx8_O?t1EaL7s~<3ω_|ۅxoG!.仕N|. ʿ1P1^Ug'|`gx`'Wg?_$;>3ggyqE~v-(˻s<ޔ?+ϛ|>;ߗ0ƣ`ߗΟ|f.\g&x 3ߺ$; 2ϒ,w b8~u/YU?^/'_t ˱>Jļ&$L4c1/ǫGWuӿta<;0oT/uo+|xGLq.](q?*n=_{U3O 4lÝ|Os%ĕIܑ/_/{OAwly=K[q~MG7?Ϸ&} lEܩlGW|ĎjNxgy'Ooěz3"oO߻ooIh^Svq~pc=׮0G!9ޟl:>xۃG{^53|.̏} u=߅ׂ?:z׷5זgO9c|J9?<ߖ4?ܿ?.̷z` 0_3"a[y"gL9VoJ+ߦ0>m&9Ck^ޟ&9e+ZW^t֝.% Kgҙ'tӗ.=IgN]zGN݄tʋ.~eҕgdtKI1]<}a5.=Kwu>$>ӥCw#]tҥ9Hn:wxҥK@]N{4]@tK_9g 7]zN5.kPW\o x.$^.}OꢨK:]t^^_/]vV:v!tCda!t-ΩK'tItC:rw.}7ħKCoΎ.}SW#]:Kҥ+nn:ХoL.#t 71]Z/ХQtLTg`[r LgN?ҥ' tKI:KN!|V^!C>7u.]:Yҥ}tjK7{U7u4ԥOϧK.qFӥovKg^t:4]zL]\ON}Wtԥ? ]69tkAnuK_+uΜQ]ey{Խ.'ҕa:uפCo/緤ұˏ-o/ӝ3 Ott3Q.tkpR.ҷ(PtY.yҥ8~$Bӥo͇tK߅럺t~ytCUׄtřKWҹwtK#]:Kyw5t~z=.]:;}.ߠ{]҅O5җ.=8xK_ԥo_6s~CnunKW\tMtMK7ҥ=_S.8z1⨛Nk]yqԥNtSf~SnuwK.]uK߅[)t8.ު.]ҷtߖ:*y&]zt{^ҥKtLθқouJ>ÕrKW\t.h>STҹ.]yަKZt.=_I5җtԥwKG:/OtR6tUc+ooKWPBt.]yҥ.}uI&ߡ.}7oKW]0ҳtԥ鐩Kgқttҭ3ϮH~ƛۚ.]ucKO]W+N]y{C1;tM7ܻtqU>j)]:.]:u.~ӥgK=.yK/ɼEJХ9tSyԉO9yHK7>ucһHw:u%ҹqt겋3z!qҋtċ:K_[iҗS7uylC8꾛`_KW^t鬻t3tyAԥvbtӑQ<wHgN>uCyKtUy{Sxԙ+9t=tey>QTwEEHtХoKK,]zQ݂)w 9g:t˷t笓Z.}g<@a^Μ:|>)J=Kҝ3o:buau>7[uWީKґP>t&?CY'T'|M.vs<;uhONҡO 3oJgԥo).]uѤKtMI>TW*Х'~oK7tPn7ҷӥ t9ءK[wk.]Wt ]7K߅қ]KWҕ?dtߦK7zԑf76L߻t۫:K~Rt).]/寓.}Jo)KK%K>Kg wtL^ȿKgt]:{,]z%?~tꞳQg]ҵoOVKg^On]:w9^_KgN4ϧ.])ҙetGҷzR٧tғΟx| Ui8v>u߼]uMtԥ7Y'1]zn]m֩s'o\u\71[ҭs<ԥt:9?+UX{w']zNޢG]'uƧ.Dӥu.} ēv_w{]jԥ~{ХS'gt_.]u~K.=}.tnwҭt6uS#]zK]+KWwt:t|_/̥~LiK7]:uC.I+XJ>>H}.=KgNҡ_4H>/~-?:.}}.]ͧK~FCn|Vt}.]uSKH:ҥ҇tХ/#K:ҥI^txҥ3t<]:uK|܇ƫB]zes5Wԥo[o["Kn?dWTt'tsS+t̷7]t{tҩӟOuQ5өtC3?KJ&]:ҫtMyK:ҥ7› ]:IL:.ҥO>w~:tG>t?.JmuHy}J,]:LKߺS,m}8KuW0Ks .}ק3g_-y|ީKg0ӥ gҙL{ /ML]ҷGn]։|p؋%]:K|Ko-܇tTtg))]:F.HgM]:K_IߔMx 3|^Rxt=*9˩[ҹ ufKW]'tJӝ`uH~Jg>` @]H.{']{z2]zNԽWb9.gK^eoK߉t.<ҥoQt݈6]>Q|*ҥ/1]:KO {/]:aL>iϨK_(]bCmR.;ӥcJxѥ}t;tuqҥKE]ҥ˯ltE.qW3]:s/]FKr_Wg^tUԥoUt'.}tYw\J/[u50ץNQ~/J}SǩsG?uG#]kIo>tҩӯ3[L.tM͋ԑS {&,kv' $h }qg/XKjyƏxjꨫ9o/\ySϼt~GԥӤ3^#\zөӷu ȫ:uš>;a>ͥ3Ap~Zɓ:u3ǑS'..} ]~NIk/:}{M>k:sitWuIk˵[wuq}\z#}fΜ<gt]μ=K:s['/霁 Kw{{ؖk!_dLcM]#:uɋuvμF'/:qo}ҝ{`^:ut9[ץ@O^zsm>6:}vI3|q˼nv~Х\uwKQ'ѥ?/]z5=qz;o9}lqҥgԑ7ĕ߬kaY7hӝ߱St]t,'3Ƀqץ;'?}{pKwKKo*]st/u.w}x~Нqt]}ҫn 9|\:yپ_ɟ?}{9u;.WtG>5T6ySʼtMI_懷K}^tq|>@ޟ>@l7N}ҥ?ouxҙ?.9t\@楧cƥS7Nﰺt\ҥߺme`f~_ӭyKWny5#edv9gJ߿.}ҧ..}ǥD2]:wYg^:n~8o0Gto_#>x\S`N.}x3ǛO%o'.1]z;YrUN|s[n/.GKwtW\'_| 5/ݼZ\e^2>E˥C#שYp2p*/5}qwCӐ?.=y-&kť׎K7̼t^t-Mӧh_.}Kwdt%/C}3`dL}5uMo?Yu93Ϝtq默w}onҝx k?.m\zMK|!]Mqk\zp3B7.]KoNѥ(uO9s|~ץoKwn.=>>.eӥ }u<ޟ.}̯^߭s_:uwv85sp٧¡7ǭO6|>['O&]9>~\/MN҇-\j͏ť\sGpӥ{;7O<ϼtO^zq}}\9y.}뮫mq5.}&Ͻ&&>t ;(]z;۩ku¹tsRt5y07Ig~E}9Iy:b\t}d^zK_҇]_]tof^ǥyKpYMoD >󙗞>>Μ;.ܛ{^{W:sWqQ>n]zh/>K_K~]K:s&/h^:3/=3.ytҗnZƅWdK1tts)n&.=.9X楯K.M=97Kn}ǥ7ӥ߮ |o\:Kܞ}߼t].ݼҿy~u5XS?]z /Z^yu u/}F]]=/y{vo8}ySo1ǔ|bv~ϑҥ;K 7Kw.}{WmV湻oӺf~w{k_p>;o楓?ޭw4Kew76g~qOKy-:y<3Oo^>t.=_iЙr/֭.tr\7kdnNԕ{|7~<ǥc'߼}S\틋.ݹt3;8y}ջ_.}95K\̼f <\ܺǥs{wӡt!ޞqK:Kǡ|Kw.ypۼW\zӥK:a n}I.4LO=K}q|ХK.: \?ҧ?]M]wҧN޸>ԥopz͚{<ҧ8뽷/FItӗqSW2/ۛǗ7/bM<9t_|Х{}\0ƥo$.=uХ/0qQѥo_]wKwq}|\zO\OZ~wRvNjӡqn/o|bdϹtĸtҥuC7K>K.}o.}Y/ӥKFsEp'=\v.˥ʭG߬GO:3/ut:o\?v:792Gg>:sM0uU׾b}.ov:Κ~9ǥ;']ctut O^zsԡ+FuKO;ĥ/{K_:j4.2Wq9GqwQg^zsM^֡s|8y\PNᕗ^?.gEwU_֥z9y\yt:u:09߿\zݿ.둗Kt\z8]X}̇יa{{ǥ3,]z泇KOxҗ~5Ν|#x?yE7K߻9N=t{ծC~tG/5/K7?ؼnҝ۠K/'Kwn.}毓7_ӡ\bK鮣W^:spɼtTqIt#۱K_t95Νm^K_:'>/׽~+tKױ=҇y1Xߞ~^tCNz}wy<[7\̺rw58״}ާ.}yj?xq黙w.=?tץoOKZ]߿<>xz~SqulM-_qӸw{tϗ'KoѥKϼuׯ<ҷNK'Ow;KKOKw.}˗.=,qnݹHK8y]yKzD>}ǜ/\=ҋyKgn˥Kg|oַǥ/ޛn>>Konz JK_u\K~G>.t?qI.֧ p\z8I>cϼ[N_^k_Х"K7/K䯧Kau/'/֭S'wÝե7_?Gz}W曻&%y gC.:uf>^v\z8] ХWKKǵS'rn.:7tFa>z{~8]}Eź|}å/Gq|h\y"ҥ4q^Kǝg7p8fҕ֥30]ҝpd^sp2o!/=C.<\g^zѕ?uitn؝vx|+uiҥSKn~.ҥK?󧷟QG=y8y25uw9;~ӥ=WoK=:t|柳KN_at߿]\7 |]68f ]zxuGQޞ=m"ǥ+,ɻY^'KO]gC1O̼XX/USԥxu]Yv~ߥ;mwzv\vӥ7uo?{uM[3OuG]\ut[O<_]qǗK>^tqK'Y׸t;GANW t<}q3OFS֥-u8p9tҥ<8ϹtOw3/}]MI\v΄.}z,yқs ¥ǟ.9bt~G~79uԥ3Nus|8jҙۻN[v\Sǥo~Y7H>u$q~~t:ҭҽ=uK׼{>]s856_e'׻w\OqK.ݼW^z|^t֧}y7[^kz/oקy~qgҫ~]_ߙXt/,t8ӥNzu=.輫4_E>.=k=uKnwiGKO on>/ uӱ_ݤko/nKo:spݷ}Cn>|g#x}q\z{þ8Kok/'/=4KOt烦KWnޚ.]gf^xO۾BGIwŹ&e#o:+wv}q:CNt;}tYg^:|/N^zסvGv9.׎KK7Pny>ߺKuC>}}tys?t^u|Mk\O7]yGzgz.}K:Kw..}f>}m.}ۧg^}׺t;>p:tӥ;YҝKKq]%Wt KwnnK7t8w9皾B}{u9uSn_\?yrm]ԏ3_v\n߷.=Ku̅m+Cd9N#\z3NK>۾[\{{ͫkΜzvm[~ե2?gbs;cX˹SwN_\p|c ]zw{ӹK եe^za.3/ҙ?]N^mt5\PK/s.y噗^ϺG=;os/\za/ӥu.ﲾM>=^]yE.=KEѥsMI>.8n>'8vw}\I˥~nSg;˼tq;_a횾tqUn[^t'һs}qk]ze}^:k]n3wfb=>}):1]z揗o~ӱCtyt5ۅS/ ]st˼</dnG\Nvu]թwϼCo/ג.=̻Kqٙ.=.6/_pKoo\Qn.z.zo?G{ @|K߹t7}ȇkq1/K~å2/}qҫn=ӥoN8^ug+:u`}o2Y[ԗ17/}Wu[/swN*;Ա;ҽ:ySy~?.}[:qh^:90ҋ/.ݹ&|ttKw~^ ^]#/8ҧsZӥg6r;S>hW\߇yz8O|oO?..}/'~Xyåҥ;H>tvM}^/䩯7;_vՏK4].~{y89 'K'G)]:sFӥ:pxpUqqߗNm#g_]o.}K_N9#96qougĥ zoSnoQގ3_{ǥKOw?ronnHӥ3`x~å|>8i̙ 'Kߗgsw}ӥ7qu}.|v]&\oqNv]9[ToҽNys;sRzv#ץKoǭלt^x}ty-s܎#ϼuo.:+[NNt2ҷ.<3z~~t듺tPwժCXGuwkԏK֣u쏹35sRs+VY?onqӥo|SKg6g~̿ooo8ru3׹֙ԣǥ3G%]v{oS/gd͚9z9G^.9㙗>uޗ]w^_ן oq陏ޜK/:]G~~9қGtz9_tf^z=y0ԩow홧N=w\ǥ[<)+ޟ~kå[q8uԥ{at~tC_NSzo|~qs.ץ\қ'M^:ﯼt/:ܳxҙC.}[ַN= /XG^t{+/]ǥ;A^twҋm.}ڇ}{{=Ν|Oo//{NݼΚz4n}C]o{Kżvҋ.y>w]]^7K6߻د}]:9/w5+?tͫ7/}/Ugz~ǹһyMG[OnNŚ̼Kߗ[o￿Z{^±+~gǿ?_~FO?_oӹ3+νT޸{?O:{сù$νtqEgs/E{1?^\Թpԟ}8>tt%u8r}{5^t~8({i܋N^>{5^2>{1^2={Y܋}8n>{OS^u8Zt܋^2=xq%]x8Bνpys/_Gs/f{Oc|A{>pEs?^8 ¹e|8s/:a{ZS^s ¹ν>q:nW(s¹b܋^.νù8pùt܋. 婿ӹX8O8*{1^{Ĺ&νs8qgcC==vEs/{i ^n]8Z}ksU7ν?sNs9`- s/9㛺.s{|ys/Ecͼ{,pcw_8R}>{?νǪs/|8Ź }:Ĺa^xspEs/8۟9^#{W}?ġ;ùޏ9>j:Bν^tesEgν8W^νTtŇs/oҹq^2>{q ν8^+O8(=??ps>νOs/~W( {}z^.y8sҹνs/Kes/tù8+o~{q νGs/ùby82w^ny8uɺy׵qu3ks/ue{濇s/X}: KGcw1{qν_s/7{w2{tKs/Sg4D^/?{YOpEs/9G!{?{Y\?Kqs^/ uw\㞣 v8s/O܋spy}s/ K^nv8ù܋s.p>{=pKw@8+>s/yXkҹtb.ν4pùKTto{9^o?Gopù%{>wqyĹ nY^rNB8|@y=¹^s kn3-p~zq}νp?t^ܽҹK=n:)pż":N^ }Gy3uW~vҷs/}\dXq^܋^O8ùys/܋8r5t%n}Q8bνpEs/m{桇s/]K~y;{1^[ŕg<8wϧ:w܋n^¹p5]tuνq~?ѹas=pz܋}hG sӭ_qy}۹3:3sXvEs~s/e܋8܋}8yXWs/7}8wt?s^ν7s/{}܋^^u8¹ys/s/ˠ^7ss/ҹW8bνw=??_Szk{aֹܽ܋s)p瞟o8rg'멋_ԃuԏqO︶ziw-{t^vH8g=qe|{o^YGߣ?uy~¹qs/楅s>νm~!νPҹ[ӹ[_ҹ'ν7{Rtzyשs|w~;b6zνԓ^u}%y{ӹXtչB8b=z^ܫ^okp5}8Z=e}{ީG/Cty~ǹ[?ѹs/9!{¹7{O:<܋8w ?Kx&źеS?n'<{νsq|ַoouu޿8w8ɚwKǢ;^sL{n=߭oνs/p[l]{q;G0 kԭo/'ks/ùO=B^_bs}cY3?ν^s/܋4x&ko47]pǛy~]܋spSm:j=:{uq5ùf~x8ZuqXS&;{8q目Ա[/'uĹ νoOWs/^йνpy=sD:ƹ[~gqsz=pEs7{qν8g8w?йsνsGnν8G ^^Ĺs8sGc~?ùνpqY¹=78s?wYS'8pY/ sLֳ?ܟϫx~溽ܟIIgMԩzof{If{8œ~ yh:Ĺiy8=܋sFpK#~Yw_/:H{ѝϬ6];{Q_8yu{\O㖋Sn= 9:܋s|pxqŹf8w/չrueù=ν8^y-ޞm]{zs\_Kѥs/ù'{~Kg>{:).ݿ{љ?ѹ[չs~s@^S-Y gs߿^+Oq=_ܭ܋U^tH8wueSv܋82ͳxEN_֣yWo{{/#ss/sS^3s/頋S'ѱ[/׽}qjz:+Sh{lփƚ1nzs#pOt{i6Wnos6u~[o9xqt5t@n?νs׳ܭs/w^yA:ZN^Թ8׹[Թ[ҹtŹ.8>{g;m/qWG^/[YSǝ?N4{q :}>6ܟ:;n?9Sù|s-*S:wԹ[׹^2>{)̙qԏzyѽ܀pGw߱;1{--;7>ùE:W $:N<{un:[ukpcݬO8veg K=qǹ%{|pG?t=]9]z in.K׭+Ko\^pNҳ-]Iҥ7W 6yۿut[u=(<\ץK..|^׽O>tꑿNљ_6u ۭT֫}\:t>~]L^:TKg.txkЭW56kuut].}y\:Aҧ{X' GK!]:N ]z$ǥw3`ZX>sOOmqw\zүK/qI:u8?Enޮ.I]:ӥXu|bҝӷwpK>/PgMn^.}q͓R>t>@ěuSq/uCyХ֕S'i: |Dz1_VsI;ǥ]nu:_\5>gdztwMzwoOݥfKu۾n ¥Rҟ:skȷƥ]rJ.gjuN\.Rgץע3OqN6?{=.=\q|ҝKY:utӥҫ=#ۥ9>CL.]רK9:.]K{ץKwKǥ_?suܾK䯧~7/kY>6\6.N]w;}vUg^7\CqϜq^/'\zwKo:uI,ɇ1ܺf=WI.{n`\։]#]z#_>K/:}.qrҥ_a]#>u]z_橧KǍ/ҝK<\zo_m}?wܛ­k߯GK[_<^]z¥jx)\]ۺtպA\3)0>uQym[q̻ť?SLk8x?Kҟgo~?Oåֹʟ:ĭӾnp7+ܩpcy=.yn7b=gK:nөt;kl_qm_`=c_:>ҥ_>m_ҥm`ә?:u}t].ϯt1uM%ӱե3o=]z:˾=e[qҫ}` ~\;.#Gn|Kե{w\G߃.ݼf]q_ѵ,{ vdzrM]1;}dt.6]kҏ֥Ky-.ΝqE>zy\zוGx֥/qťguKǥ_wBA__/}}g˥{E_~Nr;K Ouo8zo?z; nY_85˼i8tq!d]eԑO]zqy=v8pK/m=?묩ӥIܡKONӕ֋5[g~ץڙ7KOW'Itmst.|Pqz}_0=Ngs=ӥKv\֭no߯.ݾpC^t#n.>?]}Ϻt~åue[/׏z/׋yҟY3w]:r#>=.#ZXѱWngԥ~\ҕzN.ݹǥ u۷KE]ϧ.}o.=K:~>¥tҧWN>E\6}'kG7f9ַǥIԥK[ԥK=spӥyK/扆K{N}ҕp55saV^uz~å v}ux/zɸz8_қ8K7Cs_޿KNsӥwe_arS?Mߛ8ۧ/ҋNG^^.=~pǥp9kCzD>N^yno7KM3~8'ұO~iM}3ֱS.:}~U^tӥ;(\KO}ŭ:w_:vǷҿ3ohp>ǑJt΅Х;C^>@8pӺtҫҹv.v=_t:M]NP ^N_\יS-DZK/ .8/]yֺt.ꚯO~ߏKrgN.9tu~ӥؙ ǥ[ť:]}:}q1Dwlo~wξھz.=K.΅]䯗b7}p鏋ףR/yt3'}o]sWpS~^=<䯗cַo9Ofo/.G.=^ϙ^[~K/ۼޏK?uҝ3K|Kw˥wܞ3]:.]GKw..7]ҧصsMIGqu#4>tUG^r]ϟ.tҝ;KtX.}q[K'KF]tq>'=~#t??u^^uztCw};vz{Og}Jt?3/~{<3yѥַǥ\ǥKwq\7\zޢK'2]sp鵞#_W\u_/˼tzC^g=@z^^3Lz):+uqߗ ׳Kd焑~s7<\SХw]|w+?]zә_~RqUwNX|ҥ;wJ꜃җz>ul58r?oE=/u\o<\z:ts998m};uz`KwKޞvtүKOKtYuGK?:..뚛[:tw9:sMwm k<їOz1^y]`pXt:\z8]ytK߮e:ugǥ׫K7Uuue̋:rGĥߺνֹ͓W.=z;.}ȫg_|5[~owOΙz}\4=]ұ_ַ?.=LJ]\]:Wƥ'}ynǥ7ågN]t9C\t:5sR4ߏ_.=>>N9~eNǥ36]z|~O~>.Puҟz]ݒsMkW]ӿ=t3krKqչ~'=?_׷n?{qzſ]zK_[q8fr;7sʦ^uIMwN}.:]z[sNbݨwzZK/WǵKON=:>/Sum͚~;7қ{ۅַ۟sr}ҥuM{ƥO.KqYO^su[wNvON>w|եSM>?O3OG]; smӥg^e?xusfu kb͜x=_.ݹ33ǥ>n}}G/ԭo]ϘK޺r<}Sz<'~^iΩv:[Κ1n>\tΕХ;7Eߥs3Lg^t^.}}Q~|ҙjz~Хs{wqY:trpܮcǥ]:oooe=:*//++s.}̛saSN.˥nq\z?~?ңҙ.KYSwYnoo8utc$M5/]Kykխҷq.|\]}tKu]:ם;I^t~<.낋}{|]V^NCpttҥ/y\zסGst߸+KyMgN^r'[~[IIn.tyE ۾3{>^z~w{Ƈu3^?^.}{{W]S'.=Эk!܂S}e~Щ׼tһK/nǑy5}vμӥO^:yE7W]NPuut.mW~wX_:Kg~Qgh4#~W37mIyv8tSO|םNuIΜF{߭^uߋ.NWKۥ9K/p|zGw~O>.>Nzsݓ.]Gvқ8{söo/=k ɿ&/ҩ҇N}n.Ky|ƺ1ٹ=?.}3Bu5on/|q\:䕗m7]z9>/$߼Ч.}ݲP<8_+K|}{5oKI]z:[g>^}K7_YJ#]zig^:y|>up|qo9nuɚ:DթSHn^˥?c_KzON.=Cƥgat来Ko\o/}~?y7׷gw̙]y pɗuIp홗ΜСWk[q37wK3]z>sq~1/ݹ WoZk=#_t2/tuk׼t~̼܂K=Wtp)[K<җn^|?q.y/ҹ~NnH_ԭs|p4]^پX[wN N8]q:]]yǥG.=u鮛y5}8r\7iw?Kp_tJ4w[3F5/ptywq链2c#nH~.ݼA]4_>ypy.}\_Y[g}Ⱥt~uWK!3/} >o]`m>M8y-8ut_5νk^vtc>xҋn濐#oμK|twҝ_q=Cw׽?}t^]:֥͗7e^:e^Vc"/=k!ݮ.},;stgqco׸Kӥ_g<r)']2~fCL/r_ht.}^./]:g^6^tuyMK?q[n:x^q8yۯ .=缥Kו~ury}Kߺsi{ַk\z8 ]z晓1/.p5.w:եgKt~ԩ/9}\N}{_]+>Sgy{ܟ0/ݾ_]yҟ9V~K7]nbMG^싋_ҋyq/gKo3ގG~kxGUe>ץg{t3/rM};O]}:N~:k[qב=>n]3ɓ!N~9un~tԏ2/.}~.>W^zޞ;v/s2/==N]9^q|wks0]ogz~Kw.C};]zg.ݾt~uw)>zoq~n}kss }y-?RX35>N^֩~Nkt᲋[w9KOKM^trqKǝp3ґ_~ȼthҧKҭҫϼ/~˫;]z:˼tJ^30ۋϗNz)..=/^Y]z:q\zKGYC^OǥKױNޑ.åe]zQץ_'[gn˥?.=U..뜯t: EcttuӥW»G7.}s|ݼǷuu6.6v)vt[]u3YR]sK>G^ￓ^^XK=>]^;ҟҟVӥ7b9t=IZҝ#a^Kwn.}:rq楏Kt9_ƥ߫K/\O8/Cky8^]z7(қ;wu֙Jx[ⓗǥg~:}](]z oԏLϼt̬ԯqyw^s}:X_w\n}üǗn3wj^Μmt:trK7]:d/uI=׬o&<\Kw..K]st#O^zvS^z~\zSG\z=]W]Stct8uѺrWtԷz4<̧o\ [g^]s}QGKO׏KϹ{KwNy|uuԷ.=97~q%o~].2<]:4ޏ[i='N^zK.~_:r윻:Y[v;gܿyÄK?ytoKe^:ϺE:tn'W,tqk5rk=/ԷqYm6tx\}o\3o7S߾?._.}ʩoxo:s\.r@!mz?.әo/楛.}O /7ҥg>ґw:/mogNOu5Sp;ץO+7,.2~eNYaMtu;8sWu/:y.=J߿.2ϻx|KOg.9uNZ#O/]zå}ҝKϥK.y~K핗ǥo_8sOn{^>uԷ7~.}/ӟwK.|L\z5Zμt7>:y2ҋ]n85=>oOg^^ҥSGI>̃ϼpaKKA?yg7u '\Cܺ+Ϋܺ3̼t捽\7/pʚy{FpռA\z-:N^x¥?/ss>^u}qvM_a Х7]5y{|?y~2/Wu>.#:m\Z >K}\yútK7f3/֩W;ynKݎ#\A.6q|Nͧ뼘y.蒋 [NB_=.hK.^&//|ǝ_G;/nv~_g|t[!6NμtK/t 8wu楓['UnU?>/җǏK'ᕗ^tռf^;y?\[K__.9^:}{¥?y?ud"måz;}ҥY߱k'楧pt]+/K/7μ\'vqם.yoқ.N~|Ͼ=9/UnߞٟW\z)]sjt8..yRqՇh^z|Kot=:&\zͦKǩS7ϼ+'|_Oӵ//KW+:t;N~':敗.ѥOqu>ޭ3g]ӭve}:u ҥy7KNy{k?oq8>\2=]:/u鷎G']zݯM]:߫ҥOKg^[3ӥ:y2_¥?ǥ{.=벺J_+/}|\ߺtϧ̟_cn²nWKӥ/d^kƥO0yS\S.}ko&ߜ<u.k]z7?N:]z=GN>7Kƺ9o&/=OKqҧW >1ҝӶuu7O\ǥK|K<K_:xGpԝ7#tMw~Q>.8!]]뽣/;?Qμr\7CǑtܸwy~>.O~܎Ktqw֓9Pq.3//n{K>tฟ μ+sdN:'/͗ѥ SʼKD!&KSn˥:#x:t].ݼm]zgbå_:vd׷~vnבo-oOL:sp̸t¥.=畦K7_'\zA¥|]O~x./Kx߇ӥK䥛q\zu\K.uw͓Yk>5.8]z1/|k[~t)fqǥi_\ӡy'/.G{EnMvsu[>ǥ۷j^V[åתső'KouרGS~㘫}Kw.Kt u楛l^}ҟߍ>OnqKgzvG\K/:tz֡}ׇ|7X0uҟ7_ݮs>.ݹǥg:}v鋋ӑ/y|yKK6ߜ{|q~֥K-Kҫzԝxk~rEΜK';\z^tx8\z+Og>.zEix^?.=q΅Wt]pҧG^un,.KwΒ.ڇ񞳤K ҧǥ;GGCvt.]gK7ڼt~IC]aBt?k.=:~ӥSg^S7=oՑyuCOqyqҥyKC+\zg͜TqEd^n\tνҥ{=`^z>=7k58{\K0\s3ߵg7\Gz6EwND^ǥ{.Wt7sV;k3ɗ_y}+.s}S.=*dbq;9[N~~C'~UҥKO^uq}Koǝu΅յ[g^:s?.fs祟_|?.}\;.oեߣCХ.tҭKwN.=3/[O=z}]z\Sii̭[=_.=ҥ4O^;^~~_~vљS:u{:uKtSN^pOҝKjy;D^\:s8+7kd8pzy3qCw^߿t 9hӥ/\S싻XS/#]s'tuҝru΅ձqM?ԩ}?)]N>yҝK8t~<]zjqo}(\q[o0/oTyoUnl#xg{ӡ׸.8sҝb^zKGNw}Ι:^.yw;Νm׭ҷzTvy{[qqfM87uҥ[ҥ\otu۹ǥ9>7]:dz2ƥtC\|{k搲K'O~o޽=8_Wq]:91ҝK;ǥOK7oX.~tN|t?t]ߧK.{3/9tҟb=K_Kwn.+/ݵǧC'KOw.KO>>ӥ7Gԏ֥StZ?돓#q~v./]k_Uӥq8m};:K:u']ɓq.}˛nztS;E/.vev\l^}ܹ:uqX3'_][/q|[:t..cdw;k,OnN8+gqI^åq鵘'y镹jywgNYgMyӕ㴗9߼-KOW]uUwNuq;sWsǑ}xKWȏ ҝsK#\z^ϦKSKw3@tz4緛+ƥom5wg~]NN+/=<ҧs uU>==sHn}s}_X3t粘>|+stӥߟr.z7.}lXK9bvsMvCnt˥OK'"]:ӥ{~ѥgsRo/~ >-}g^z|k=n} [￿ZJny~P:=?/׿B_D?WoQox}\哿>ҵsvQqW{W>ù?ٟ!o~9qo [ u|U&/~k¹?~KW/#N^>.~ǹ6ߺ8s?\=pX=NqLJb8Q3/=ׯ ~_st"_ku_G]DZ?өsmp\֙Tzù~q>¹?;:}}qM]#us=cb{p pߥ_q|a~uopNܟ׳I.7ù8ǹߥZ_Aze>9>^ù??{]_7x.w>X+ָ{9'bpěÉ^v r]Ź8n@B D B npZ+볿_lӵrppers q]o羯g{g Tڻq}?/hS|_Kr\yG8F׽!ꣃ^q?y{eY};}N=spxh|W>wc^_R8u?sߏWr{,ߩNrg}/?_֗}wz?K~Qks/֛^ql_{zڏν8/ν:ν8=_8B={^/pes/sùpgbP,^/s?w8}n羯ׅvkx_zby9>\b{x?r{<^?ʧӭ=ܫs]b<o;s~ƧIx^1νq`kn1>o:ѯI8=^t}?~{{ H'b|n0[l̷scgsUgs/KߣFZ|__\¹p|;\-΃/{ܯ?~pe9tEù?t\l$}9ov~hq\ xB^.5hG(ν7sY #~=yWN}o<=|hDJv};z·G/xL~W}}8{lp5Gjf$`nS}}g/LxM;~ùg'/۹˱h.'7N}Y;>l{s7sǏw慆s+y8>#7~soB:åzd$ 쿧S7}c&~Ys=ҹWqs9]/ 3߁w^yW8}~֟y_pxh{S3Ĺ)8F޿/Oۋ#Ǫc 7[^Sx6]{n!@\ùg}N2M<:ۻ?;su_ν6rs~o7z'^N9㽯c|Kďs~Q~mn?.:`A._7>{z1ϖeZ/s/:5=olq?޲?=_#so|>{ywxJߗ8|߀sy8s= }qw^ұy_7_>}pO<_:K{}s+ƥE^Y_c&k=FW}OWO_gu_ڍkx ~xryr?q>];߷޿^=8}|=6G/׵rWpOgmfly8}~W/E6ƷW\8}|޿vǟF|"mx8>sΝtg}?/.w|ݣ߄sx}6['~\tՈW¹IN۞tt\z<ùufOߺm~}ɳֹDn|X?#[Ĺ?Ź3>?S={^¹o8rd8}=yi/s:<_܋.;y羏׏`N%-ƣu#>p{<^1L8/~?mùy%¹S8j|8=޺QF^x_s?A5>/~O%˴yx4yl:z9帞sK{G|羟l<}7g8|{u|sb|?AvOgހ^q{[q_G<úwپs8|Ҟ<,ڋpOlߣ+?i8>7SOx/~;}^>N{k@u&pos]{!~ko^R=_B8|}:鬷>pٮ{8|d8~sН;H8=յ+_=6Qs؞ۧ['GO<%ޛ,Dw8"m=px+sާp~ 羏w۳޿w8s/m/G8|s&[Kķ?O<u9=^G[~D|yڞ1ގkw{[ď >^;{ ~{8^wꩳ}S>k mY?k<6.?>#y ވ[_7s㕇W0nю?4¹xP|1>>u#x1{{Z:|^~xZ˫b훺vѽ1^[8߬{Qlw;t=Kg39¹9K8.qi%OEùM:xYoUwKg㺾s/:J~K^|DKùzpy¹n|k'?:/|۶R3>ux&{zu!'Du puxx=/۞=,Cs9k?;8¹=/_q~W⽯5ߚy f[W]4^{g|џ.7{Gn>}/Wʡ[/L->2u3̷=g8|?sI8}uu_qƹE8}hߴyǹx3s~\ױq|KݷؾW"ޫoԹ#~zďǻۏ7{֛џqyu3ökW7.-:vX83z֧"y¹{_z\¹g>=϶zup| GNùH3S^wWw>3>~o:8}m֫{O'O<2]h/M>8N[8{ډ/]/Qpl^6W?t~_'Nrt] .=.v .=.Z]z?oΟX?܍.]wZߙ9a]}*N]z^7.puM<ҽϥKw?CK/y _Νx5n-]]:qt.9\z:6\z:S]:tǥ/?N\z\=GzyZҽҫPu/peYNõҥrԳǥO!\Gfwt9~>{o[qsK^qzqҏ}C|:t.q'K>^[7AK.ҥźjb\G^N}Q^.w^!NyzzKx֥ۥztӥԥfqfqܸ7~/yu>GkK7K7O']7]:ytǎ^[/7s]%]zΫgԉk|:ѵ_oqƁҥt쪟'Ϯʉ|:tx^u%+qKƥW^..=ҥ;/.t3o>yq^{7n ptޫK=.ݸ.Xnxjo!d".~}/^ݞpYk\:!>.]Kt_'] ^åxn^Atkt\z=ǥå;_.ԥ#]:6]z~\+[]O7c&/n.=iå׾̋G\zK/gХtꃧK>SptJCѥ7sBPD^Nn .8z\:5;ҙ7G^:p K uǥåI^qnKN`M +\z3^dbӱc¥ҭ߁KOעKz_.u9E6.X? n9]zgާCChG}ϼȓ֥w\:,7?\z.ݼ@\z?űlSnK/.XU^uҝ'QS[եK7/OZ?<\zqg..=#.=]ytqoH^KOGKI]y\tҋp@t:.=/l8t̓J=r\yt[ǥj.̳+'ѝwcwK7D.=7ǥW:7~?\zl8t!]{/t77 \zQҽ>3ul_ߏK_spa3^Ʃ^7K/cypҽѥitpK7.}1ǥS,0n8wm]t.tҗ8*\tt.Nm\:yK׌S0.=?ƙTp*}=twp9.z tиzc'M}/x6M]yw.XY.w^=t;<:toq.qϼať{~}߫KہK'][w^X}\z.]KOKy ޗyqs{m3O]WqY<]zsh \:ytws^]zۥťҭ;.yItqhx˥OW7=u˩/ߝwzyam/\pK^x{ޡ.qߏ6k< ѥn[7?hK\|ۋK/:O<:ttģa%9שn_.qyaxytďiy!u\:N)]zӹK_pup9o .txZN˥S}^nNNUN˿{͏H<Xe]1̻n?֭ffu\ҩ3go>~ץBt9.z쯎տ~7.Ήlx͟H}ñ͇ץK7~.zút}.WCgn~Gԉ?:u򭧮x4oK/#¥W*Kg<.ϞNz:s8ccǏK:p_uvt~\z|p=a//پ+g~ŷӥ?.yҥw2^~t ҝR.Ɵ>:n>lqåWҫ?qOtOr\]=29~uҳ:pZuҋ'^N=n>ԙ+<]KWu\zg@q:CwRrJ\z-1եK/{qߺ\C/1.K7rqKoփSNyfAvgz9)#!6mȳ>;uΜxys9.=ƃitqҭ{qc.=<.n9]zܗӥ/]zҭ_KԃХ7Z/=i⩗ۓ ҭK8tKY}':t$ q^:ܼF6y8yls0t韮9\/ftC\z\NnzU޲ˢۥgD4pNpt.ޞy{:s7ki:N^ߢz׸FӝXK7.҇u3W]tgl.=JpzƺG7ϕwiu2te-K7.K^c}.텃;.K:|;^mbsS^#΀z1qS׎#osɼpHKw^]9.=_ҏ:t 8.>+s\zEftw]:I=q޷ӥO>.=ki>?/.=]:u.]KХOgyKss.Xgk]җ. ^z?֧r{t-8}_>KAsat^zәӁҽ? s]zawq=å0]ҽK'ҳ|)z8.륿nKgez鱿ҏcm72Zt!^Sҩߐ.guypy>ҋge{K~.yqu˥{ѥWgWwKt_﮿ʩOdz.9N+n_tq)WѥO9.z8㬟?\z^Ot֋M<ӥSﻘgzǮV:q҃WSkw> wKw}q=ӥ;ҥ:=~ƥia"~o\y4HZԩOmt߇nr.vS_7z]GYzKY/=oǾtMwN^ҩn4MwN#ҥ;_>.>tKގ.=aKgqs}_.}K|Kn=>/뽇K֛;?9yvy .=Ӂw|Yz'KzKו^)v:y{5gy.t.0lK7͋:tKO?n^yK.zK<[WwN=Y_i[<1ҭgKo֯$qNС?`x%߿\z:uo^uYO^\N+'/'.}7ysǩK//q۷hSO&Fu7z.%G.kӹ>^oC+yqY?['ώ?<1]yx<K;z:sɤ['p..ӥۥ>yl{4]fFzƥuiC>^]׌o'KϞ.=~o\z^z3pq/ẻK/8֡WiNj.]K~ns nrYOҫҥܟp_/r|K_ynKN^/^z\慺\:~ЩMn8tAc^tKu#{yR.åG讻yY/<]:uE~)Kg~~]ʫ^:Z~yW'K.pq˳:=\zҭ?kt]ХuқOt8['/GOp˥ot~s\Сg]:n]hS6PwۏKKϼS/ձߎ.[ޏS9/.Vg̋KK-s|Kw9w}ۺ}K7ҭK7~K\:yY/tY/= H ]z/|.'<^cޫ;M=/<9GK:.=tOҝ@޸>қ9j笗a??.it7tC7K_֧O<>r.'Nc{_q[/ih|`ӥ;/.]/]~דI^yq H}Oe]z~/y\K~K=.>c+7^>i+&]:9Щ?\z:b&^v^B=>.Ӷ^ե[V?ҫҫqu?z~_]O&Oy{pc:˙^sOw.'һ_tnt /]c]S/}K{yv:uw.Mzse`8xݢMKu_וnn|?]<.=WpCozԥweS/x .Sskg<8tq}^ҍKOߝg6];<.x.Y/zd8穇μ1ĥe}7x]zAS7!]zq܏.n} KzKyH3ctI9q;\zu\tsY;o.yUtΓbt/.=ǟKyn.x~׌םvx©Nmꥧ3ǥbt>uxy\zw_Ki;Νy^o?t7]:{R/}gN}3:.=/\p9+$:tg=u/Wbݺm!}uBxtO<.=ӥ.y)qOKo]t1^?ҽ?ҝz!J8 oO󸾴Kߎ;s]C'K/_7סk׹΍W5Ewugv2tKׅY/=]cuKM5qYyWΜayRõo)]a :5Z/]KzK/ēzm_.=KIeK/]K>ҝG뮗&^^ul_Љoۥk^:tGƥWU\zӶxەqEХ[g骗\o~S/]љo=tmI}hM⼫q5:u{mӡ?n:ty:vꔥ['n[KtZ/N|+\.Kӥw={to~:ƼW6e̻dz.~k0~꥓?닟zy\:tuK?ӝ9nrqK/9}/:tďN!\+]БK]X,ηҩ_K'R^BY_SNq7x/;yHq}t;?Y/.ݺtwExK|tnYnܗ7֙5\..teRK~8']Еot[^uʘ˺bvҥ/K}.=t^z~e=OǾ"~K=3N1ϒGx©C'~<\yzzq%kgvsKwଗ.:bߌ[nߠͼ8f<\;mvQ[+~\BKnyRu8rq|븾μtY?뵿g}xfY&=tGz.xTKw ]w:c'~֩o ㅶ7:v+|8's/]c=p.x|t=/.[Sg^S꣇K/#`tL^t uxҥW]k/:su:qvѭ}әgtwe}yc;OK__.}Kw~]ftt֫ѥ^:gtgW.sy8ХS^:qӥS"]7u֋^z=m8ɣ;Ǒ^zur}k:s;;utҭz\z_]vq~_]euC]'Nt,^s׸N?;𪗞տ~{:;tG7.җ0/8?\t: ]˅ηߛn_8N]?KK/>:νr'֥[ozN=tY/}t f^lOKqK^WY:s{/{,ۋK:xA^us|råj|vppѥ7'\z)'!ҙ+΢K/锫qK>Xt-ХK7!]+]zӱK+.tE7ލkۥ<tCҍK#\N^a/^ ]w3)FOR;'N ]G>]۳^zM^ԭנ}s|KzKqrz+Kg^KUg grt9?S.xq0X/ҙ8]ǯ.å?K:k;o.tsxveoSt!\r8a^sX,_ף.Vk\|0M`[ǹ>K=iK|^u?ںySK:yq,OM]<˼ҭjt,t: \z$]:qz]zGKzs ]tKWNvϠK7O+ƣMW^飍#gt}KwtvSѥKϼ9]yZ܇npy^r\r~Kwv6?yqmå;ץg.8ҩg>ͳKW{O|tt^:gϡӡS< u'K׉z8>;+:ux\:g7mۭu>|rMScn34ӥO9iyA=?t֟¥a算>o^K=.ybz/j_sɷts{uW~ӥ[/n|2gVKhOљ'5qy3չ?o֥g1..X.|~yaނS/]gn=z;tt^ytt..]wbt.:O..tH9/}꥿k.zqye<;^zwhq:~\w8~t8t]}oқ]zӕҫm5O{XߜqfyW5ҫ/=.b{ΜyagYϝ3^ԙߕצKYyHn..u^^å=z:>]Y/Kuӕ=Kz3Oqus\:ӥg}u._ZpvK]ϣҭG.=/?aryv]N=}^SK:q!ۥCƥ.zǥq8u6..]z.zǸ2Nt[~yaS/}fWetK73]zv1nХ7o]qdpγ^zpK%S/orwzOmwZ/]K|ץ/rNqOKO'ߜ'u_֥W{xy|_O?x{*H꽿/t/ڙwuʟ{&\uW֥{?^ۥӥt>OOt?~e>o<Ϻt/t)zu龟ӥstx^.=K^z>}8_ķG>5둳h_K5wǝ.}>Ȼn;^zƣq|pxg.=땇K/s/>g~xs<=+!.|9Oj]cr8>l%KgK_ٮ]tCӥ[OUn]]q .M~4tDszM#t ǪK_ǩ.D^GҭokGG߲>|8h\zփ^Ot4.;@79?8z|p.}龇:ҳ>:/~OڶY?K$.2C7K}atҩ=u[7!:pKU/=˥/=Y|pKҳuqp:eEN<_]uKtov鯎=\zS/='ߚzzƥgm;/.y]^.}qU׎o\:ωۥ<.}ԙw5S+қ~7qәgt].IY/sԡ}Ý=qtu拦KtK.q_K?zY>o^=ۦ^37_Mz]WỦo~3lo['njK7?Gc?tCNʙ5룷Wi}u~#k~gWt.=n=h먭~[ǹgsSG?ұozå7R/zǥrMg~on|9]륿tUg^b6V7ҥ?ǵS,O]z~{5qY_gKb^:NҋLX/yQķG:rxr7߿[WlrKK7.yupzt_םҙ76ܳՙG|_.uq鼏H>3o̳d{c륧;XƷ?l_7tg^ķKINxԵxԉۥ&S/ӱgY/Q]z}N}uK/\uKK /qY?ҩҹ>?~1@qBiꇲ?v({EO??tV>y:}x;}:/Ү<\b8}8}Mrù\=kںpāp3,vN*sOp?r?p"_8}NGloo87ڗF{{pw:phr9w.t?Co}c/N8}թn_ӵu9}9yhEѹs{svop;s׈{8ù7r{tcs÷B6{8ùpη8^ùo. ۗ;@o7Zc^-\K8}p/r?wD/C8ss߷˹Fp}ߏKK~}~>C3 }_71O@8w7t{8ThhZb8/Or}8¹s9A{_}m{I{s=@fxG\¹8¹6w`Xktp;OEb#A_שs翎lϊgTc]php{@<W8wt p(sD,gOOg9=:/I,t?խs9>ۿGh֧ ۗsS>]\NGG羏_~9~M/L{{^s5zc/ngu49OEy c6 ùr?NE:pM?}C}WVן1t+ƻgq9}?|hKיw&s?p9N8=>W=o_ _`<Ҟ]}X[_q^8t5>;t{kyꙏOG=>x='JW>=b<g¹Q^bI=~_N}x^sᲇvchם'$9¹nx;K~1~Nձ|xW{_-?z7N|;}=bt389R8wt<ѹK{Ǿb sqs?p?~{s}4;}|}[_9¹sG];ǵOۺ}=N\_'`և6ڍ jksCj}p?s=}?O,6wW^Oq{|S/ٟ8|w}}_1yȃ )_}ЭWuo|~v;|[by2~o\v?׿~s}t?{s'+_g=p"~¹ttwo^qTGsS_U8?ùՠ]?;u/ˑ}{{5+g7=8|Ѯ1:y9}˹[/M?uo8uu}_toN+';Ir=ƹ끮!">۹q9}}{cpzΝׇthW#5q~'O lTh_2ֽ?ftxt׵vcEB>b]v<#!`/w\_=ԩ?1s߯_˹o{ p_ț{~G~^?EOGǼ8w^ѹ:!yՑq= /{{c`Q [N7~i1~~u_wq+y VsIv/s&Νt݈r+m?v#ƃG'qk,~_3ފs(ؿ¹񽎝xtw87Ɵ8¹nx4ۻOG?:\xozv݆sEå_wڵx.}/_?|s?xpؿ/l1^/]{+c~?]g8v=߷x#xs:xwsĹQ=br+֧>v{<[o?}Ѷ??ѱa8}=ӱ_=cs?TޢphO>9}|џp{^Aw8}<43ƻ?Əy7~^-鏿׌o?għ:tķcs?Ϗx6y>{S'ۻ;⽝;ޞ~Bszď}txC6wF|{Z}}qs9N$y¹F8=~hO[lu6c[?y3ߗsk{x8\=wAkq{}q5s}w.pu9=ދϷ;^~p?}JG<G~?O<}3߅sQ##cȟѭfOi8}ѱ/w9Q~߰M<{1|}?O8s g}8~CO|ڟO۸'s?pT8}h/\?84ow|<9~¹U_8Wx~8|Fs}{[O<0>^b{Yx;I{˝w<>{<_s?p'}/y|.Y>u#{8&?ztƣew}?lkxupsF'8wu8{wp}i羯WἫhf˹Zs>ytz0i+_?o euX?w_,=ߧ/n!m?c1fewotģ}s?[8<q{<{'_f}vz5Y?F~4:9¢#߃Ϸ¹X/hA¹Wg C0:F~5ƹc'~#?OsG/?Go]uķx_m{'pyknGy?нsN|f|F{0u_oëqO7tO7tO7}¹x4K?[lo:v͗g'^W_/xrp?:ow~qN(}oGvO¹xh^^i_p|s?8oۋvvk>kW~3}\}oKoMi<:ηpUi7X7[,ƹo3羯Ǔ*{g~678wߋ$cvU߮q5:j~9 t3ܢt-xϯ+̃u}| $|!fG{DS>.'^חuy3\61sDg7O/M|gxî_/Ĺoon|']>c}E8b2Qp;=iz¹營7Z/kӥ.ՕMn=˥֍]gw~_.]m/h{:]zpFɳk\z׵Ks|e^ogpqS??I;yq>K.FҗnF\zG\".ݸ.[oҿS=..W]7yY<]:}ۧű?ӥKsp\:n{נ;}K>.qn_|?\;'nBs.}8]<t.}:#g{ť7eܠ>={˥Ga]q؏7tO\w>u呧X#O3?LtDt惺\z8,]Ņѥu֧ץ[utХ.nԥSo']5q?菶.Ns>~=ӥ3k^å+ĥoql4]Ƒ㾧q˩^#r_zٸtC|3O1K'/]Hҽ^3Jԟ>yq/\zv﬏oWlܿtWKo勺["//]'.=mtEһ.|p5~8usե<^qN^as8.SO^t:tvuӥ?.}n3ӥG.{O{t腼@z7wB^NUN\q˼ ǥ/} [\qЏyl6q~t:ӑХҥ2]:yҭ_K'n.sҽ҉pҭK'Sިw>~m8k\7]8Ĥ#/:u .cyv8O>yt\:_Mw|0w}>n>]9yv0KN;//tҥ?ǩwylq/t%KXy,*..YMn0\qޏyvK_?Mn.˥7#M~Wol8N]o__u%ǵǩťWpݼ\ze>p]z>$.\uC.=&qWKout]ҭKǎKq韟byGt3W?.]r\ҿ+.c+ǥ3Vt*.{)vK;ť̳t].]K7B{=]˥G.]GKg~t.}qyIn.\_8~ESХ;.=뻿kʼSGyǺt.=O5e\.=^KOGK7q;:AtH92rԥWv)vݿtա҇u~/]wX漫sq<N=jGw\:ξ9*[]{}KCХ_ٙהOw8/@CǑ㤇mꧏG^2]u{t_\ҫp]KuĥW?ҫxU_k^].XnL\z:0]tބe^\_ֵ7~vy8{u˿gSԉ;hK.\?\FK.}åӥ܏tUތot쏖ܶ_..n>uY<Ţ&ޫå?ǥ7KOK6\wFqӥ<ҝJމ7{uOu9ӭ/.utMn}K]An}8]us\:7.ֺtt5t;?.8Х{Х.uxҥSONҭKw,\yUKҿKA7c{:y{t鲻m [WǥKe|r\zE\zҝފåw.Zoq>]][K;.=u56Gt韎yf/{ťѥ[g\zHƣxԭOҭ:p鑞tuzü®Sgצ3'u6tqu9|ЉG@^?ttStcҽtԋtYOJ֙5Ϻtt.zϺt]ӥg'^.Kx.˥{ԥwptwn=Q\qtxtq"?EgNzy\:CqSW/Kqx.=wüeyWu ީvһTқ6Q=\/ҍO.=IJ.ݼW]gtyu?ե{ƥ¥bpUKx.ytKGxr+mo]N\zctyf{|ߥ.s5mqK.޺åty>sKx..˥=8/uCWN.]G.}Nr/>t׸tҫq߱ux .=Ǔ_yR?rtzzƥ{ӥ|K7:]ҳ|{{>:.M.y*t鞟tXr{?K.Giq<ҿʙgKw|K5.=2Onn#G}pqoSϏ.y9t.9Kw<2;u83nGs.x2.=ǫtK~K7t\:qt||ץ_xyMw~[n|.\z|<ӭɷ1.=ƥuΣ.]{tKOK'.~xX8҇҇˫᪫hq5to٩ n>Jt:e|_\Su=\zt{ueKTo ƣ۲^qխSWlԙǵuԷ󻎝x[wǥWoK҇#\ƥK/8']7rpnå;o.t#֥.zZuq{c'WKwқnީsKKx[n~.=w\z^.=wWޭO>\n2}sԋƷ}.鮇N{Ki]zױѺtۯmz1?)"<cӥW'.ѕwӥ_.]ǨK=vm؟zݸ}tq8]9upҗmymKK֝uӥ/qХS1]Эwy\qqYN=g]:ĥK#:v{u};:sSN<:5+XҧL>4]uKO}A;.y,t?ӥW/.TuY~:Nz9i]zk'?Ʒ/å;xj}b>5.ݺ$^tSnK_Non~pttn~.wt=.~7åχKwG]z'D~k}O~-NYש}q~ѥ urĥ[G4]:GJNtg>xѩҭ.Z]z;yao<һ.qU?o:uytaŵKydp|]zt Z^|҉OKtM7G=_ӥS+]?\z~p-χKx]s\z[?.}Kץ˥.zmtqKҙo']zП^>q鯎M}t\҉>Gut&.=K.ʝvҭwK1}oKևԥ@tԥG>u}}{a]#?濏K>~þ8a'X7x>.zz}.ݹE7Ky1/\StGԥ\OW^z5o/:եOy2kEwNLu|OL^qW9(ެpҭKn.;vt_uѥ7|tp2zqKw..yv䛓]t䙏Nyt?oKm^z5Oڷ:u+k]~НKo|o7/=?Op9btG^.]Ko7>y-Ϯ~o:4'}\n:t,^U]st{}Kߏgg~q8˾])]5_߾=\zγץߺpg]z;]z}}M.GKAgttEn_>K[nɥKo۝y=֏okqӹSwN['&] ]z]_qn'?<=]z34/=c=ӧX}qӼ_yם/KUԥls;/e\Kt@ץ91N|祻Kx}K5-K7/^t_̫եs֣_ n}"]st.}op<9.Tt].ݹ ˣOXoO|ԥLtGd^z?km^K&]fLO{9~Ec֥9+ǓuԩG㜯t5Ko:&\zq.ҽХ;p5wkAj:uؚ}}\:}ztOt+]v{3/}oz_XөϏSǥ7{k׼=8ҋ9#'~oX?nK']ԣs+qyKwj:s\ɇ}K.6<]:y9qߙ^~Xw\dPֱ8ti\:sӥI>/qק.9_;/=tn~]oޛS]zCב߬o;}>]B\tOpMe^C]stG>:t3z[3]sv^z\^͗k=I\#қ.7.};>;ǥ9h?uvۥ|Ko.z.ķKY~)5t䇓w6/w~3e͜o^:Kq~n]z7箩4u~\7.]j^.ݹO!oݼt2,]z橇KK:v׼ .rAttyK'"]ҋZ=c{3.|\zN=~y_o~ k8oҝKt陷K7Y ]]\zHnɺÙoz[wK/o:q9gPNOt_ߺGs..}ӥg~;.=G`WΜTKgnpj/w^ԡW=9"{Ko.{.tyK=޺ g.ܟKwyU'?G\z^K/~=x?m~}\st>{Kƥ; ^/q>>'/+p5Gz|s\,ҝK9`:tۏN~q]zѝqKӹK/¥\.Yn?STykzvNj<#/vN׿WKo^Oҋ/O{]#^2;\z@QުysWs;U>=]pəǥquq Gg^k7.]gKtOuagy3,:N;.%n^uIK tp0]gšv8\t:7]z:sW=_{-z¥Nu:O]']s$t>tus tK7xϏK]]z._tz[5;ezKsKo:tnqsp͹$oַ_ݺ:t֣c.=q{|ǥǥӥ_.G:K/wt@uɸV.Lå<Ν9sWK?;WWKt=c.<~K:i͏֥~g>.]N:å¥\ҋK]k~y֩C^~{{yԣܹ5|C?յ3Ǖ|ɚv nߚҿ.}et1ptEKq b0O&.]gKy{gh^E..ǾҧΜq^.1|tΜ.=\z_uxۇo^%OԥK7/=G^qܷ}lŵuGgNޭ[KKz\kwn:`=1Aҫ{O^y虗ڙucuq{Ku3g~_8H˾uFՙs|8p魚wy5K|ttvKu5<\.]K/gZ:uZy5u/u:nnΝx.QW!>Eq酾+]z+c᪋}vvN.yɣȼt 2/Kj^G\zk>>:DӝG]"]_{/.];u /]zӷK ._杇K/Ӂ?!K;_:D8Iuy+,:t7/=oZ:u'?Wi/n}Sեe_I2?>;9u m]}\zq~ sFt:\]:uӥ_nәYv|SǥsuwK;gԝ[xXS<׹)nq/sPtOʼtݴ. ['O&yvrSinѧ>.?.=.:a̧ǥ{}K9DWԑy;]s0t{f]CWauϙkv=nN>.9$;/uͼOn~.c]uۥ]dn..}:y|3/y\z>wtӥWwtGkd:uo^~k<O6{ȫΜ}h?]z>}v7iNn]-3=_5s¥ܑ^tIrM>ͣkC>v_:u;tY0/tһξȻ.}ث8u5ܿf8]ztj;n_wt碘ޝ k]speO>g7z9CgNqԥ\t>ZY&'?Nۧ+qҝO.=/d]z5 Хo{ lnk;7tԁuQnsދ}v䕧K9ҋңp鮟:u_p?7nr7>t6{|чKם}ҩ[>~n\\nCǹ7:֝7~g{]dp{A|ɤS_4ͼy;ӥq鬷K>a]:ҧmq޸k;AZN8o:}{䏓>to{=]z5ϼ˼tustt|?IK[KҝK/ۼt]yB̓¥#2/=q\\zxҫѧX楗mtw!sOF@{ϼp/9֩Gy][ ]z:i`s=NǣK:'k/.zѥׯKiۥۻN]?]}[ť7]KgQSMܖ/nn]9yyKO7KϾb]s[t.=KݺsMkEg|ХשKPx}һK91K:p}w楿uۺѥ;Cnycn_.}xo9k8btM=:åBH^؞/楗.ӥ_K9]zuc[ۇKoyn=ݟN98K9.}:K=x縦Sq* Sҥu~֥}ütKץw3?>uN¡SιPK}7tϟ;gּtݷ}v:tT.똋;㐋]縎KO.NNsX㾫n}hb{/ҙx]Sz=Χtҝ3K#/=џ_\-}.ҽ~0/]k^K/tGwNyn~-ۋyMd^zK.`ե\]sUtcG~ԿӥHuq/?]zz7oOޥSԫ{u+䋵sR]?š?t8r\x'}6t9Qs\qtmߺu\:9\5tnӥOt]\qp麖K]z:u}tKsɃo֏ooO?8?]z桗~|~۳:տog0=᝗_M>:r^OsWoץ7w^͚~G8:sW]ud^sqt:&].̼tW9a^xf^:E[1/}9\7ut\}±ԕKp8>w鏾O..I6/̝^t怹5uy~kC\XcY桗z;]ںtݑy_:v^zCɍKNQ^kեٿ&8r/5sW/z[n^n*.܊t̥/g~{}>ǥs\zeWr9?ݺtya=_K7ԼfwwgֱSԷߏKO'>osG֣uӥ~p'Kޑ.=yS~?.ݼY]s3Kw..K?|祇KԥWt1.K7KtHK.=һN8ҋk۹twt2/}꼋C~3K[\g2/~txKo3۔.9gǥ ޜkKK=ν:9wUt鯏cxq]wnŚ1|59ex=sovpOg\XS_֏q{yۙt/_:b績ͼqҥ`qەҟ/;Uګx}1WvՕԧ]=\SyҩKcK7?Z~8u;Ngnz9t?jz<>:mׇrw;wko:/>uַo[K/4Kw}C^֥Щo7:ySgN9ޗ?tחsW޼t9?7MzXS? ^E]yKtc.}^Y׭Sr:ҙKK3d^:hh(q?_??o??~{2U ~*??vNA:w~so}\X3_'5;? l+ܬ|Zsۮ; ~Y?\T8]n¹tu¹~(n׿?+g^f8s}e_psmp Ǽpu50@㯋_Us_8z {¹n?~/=;G?y˹~m:7'Rȯ_?pvy~̓ oz 羞Oy<8s'o^Ǘ'/?]8~QY{`wsVq #tc_{p5/y3ws_珗5':kS|̫O}t[t9[n_ }ks_5~_8?k2_w9uq߳8sis_>z?ֿt| G}=~qE_{[s{=}}<|?s_O9z*+ѯjsùϯºs__ep}t?:՞ﱎ/z~O8u~o<pdz?fs_Ǘu홷=z=zOۗs_?]>9~yY?o<}kSgթ߱ǿ]۵gs_?Y?W>s[W{^ȭKo}is_rm.z\kΝ?:sŒ@ùvz?ߟC~nq }-/Ǐ_>q˹롛5{'ϼ%w8{pf?O3 ڏχp|w}Tt3q}?k?q8}xs_s_:^ǻνun8>XXXs_맭ףp@a]:׿ڟ νuùw8nǿ뵿߭[p˹vW{S4Wp{umon\oNO=_uaښsx¹pgwq=z<k9?/s_ù}}]/w_Ե?q3O}=?ubzw~zkqօ_˹tw=}}¹_:;ywO=8<os_z8~ 7CqѹWe73_}>-gD8UOS~<=Kx;׷¹ͺpX܏{]pG{OϾpxu/:u|v%n?tu~gǹ5}_]ucoo\=?pV~k/>z 羏/z=_s_7 oe=z;ù{^[7*{ sѹ|Yg=8U\uϧp ׫s>ù.}oc{w}9 G^Oqs_pp?:x_˱=|zysu#o}.%gS ^os_S}tz߿q;tWԓFCuσA|_Էù͚{u~ùףkõ?o¹źgqѨvb]E8u=ퟨ/ֱqʜ'Zx' P8Ab}8yuw\3ao=A8}Q-<>q=;^?Tuܳ>υ:+''>{|:;nO{tԷ9Czڼ%z..=9yqw=#7ׯ8̻o?s_;7߻zb=^o넢F;][߮g\އs_5mcĄs_O؟yw}"|{ԩSW8uùAa]nq= ^z _]ԏ%:pO\73羯ùg}=_:ùG}<:jP=Oԋo<ӹGt׽pmz6|< >F&^W8UԽs|S~3N'wd|Z?~美WO9 oԣsc}Zi}9^m-[8}~ ޺s¹g8] h{s߿qٿs_Gl/֏cND8 羿sS _k쯙]_?; t Nk/sU¹ޞu8ù?ipp }.5)z^?olu]??pkU~G? z|Ix]g.^sߟϴ 羯ùvq}>s_W]hs|;y[C>N^=^Yw{zۏx|_꽯FkԏC}>p8{7Go?et5otrù}{ùc<^#.<꽽Nzl8u3zs¹˚qŏ߿qpnoԣ~}=qU];t0SߎϻInN}}ןù˺;xs}]^w8=bM8\yxsߟgaM?}8}=} 8OSX5c7p-ڰ[sǹ#q{}uoxhq<羾Vԯv|8}/:?ߨgo5t_gxӹg羮wN?x_8?e~8w2tps_uǯkq}s=pg;T8^{t5Wwoq|M߬S _`M6Gk^z1H8|?ZQ~t7ν9 v>oܳ8zӽ8Ĺͺ6k};\W8 =pz]X>tԣܳsݿpbM=:wY>{z{'ܳs_~e]?bt歏k^s_g}νuùg0=ZO'=/8ƹg羞e޾gpZ7Ϗ܏=Ĺ!:K>kWp̣[N4_tO>^`o_q?lXS|721W+{Śz*=} =7pn^]<_wަ3Oe/[on3=}}9^jNztamN~{dǾzK~G?cw/ǙI8ut݆s~ 羞o?Ν2{s2~z&1sp߈sz=Kq}ùg.=}}xԭWMnoW?O`z|t=-_{Dp.]{Wk羾Է3=ߎg8s=Qppp[| ~ߞG${ނs =ܳ^8˛+o9Y*9',>_sz+=ZW/?J;ut?t::.=]ud]f9.1];֥9KR.M>p tjqq^צKΗ.>k¥֥s]Ko]ל.7|?S:+ ?.=O]#]:}ۺź%ںkҝ.Μ=}Iҥp]Ko0]:}htץKG{ץ>^>qmC\:tu%tK.]K<^\ǥW.7.MS;p<^۽?gҥӥ{֥g~=}̿ӥqۿQg:sƥKҥӥWy6ts޻>\zoǾq̣ť۷.WߞۥwoF݃oÕһ}Z׸N>nnP{1^S'yKĥGKuw]:nw]kܺ:{\zߟS,~F_c#_<];89ҥO[:r9ۧK7.åӥvq;\};>ҥOБg;']+]ågyh]k>=.|i\zo;_GXX?]7_XKwx[׎Ky_iq;y%oq};Nbm_\cn]Kos;tߺtK/pzԥ_:jdzSXcݬcN\$]sVt鏮[׈׳.]zΉ\ \3w:; gӺt?pqy]:3ɇKKo#ե;ht/33{M"Vӥ;K^׾u^A^{\z¥;;uW>wéCr].z7g/]:}׺֥Wpӥ7qI7otӥ\zwn۩C3.=ҝkK7K?ҭKgntһst.MKo+ԥ;_q:e}եyKo\tnޏååxK7I^[ҥg^y3եDžK> ]o_:>zŭs;}/}otWKב҇_¥{~Хg.\z-.=>ta~.]Kgny}Eb҇n}Zp-e^ө79.qݎ%u=qJS}~v: ]zөҥg|xu鍾!]:st~K7J͛Z~ΜE]z֥? K׭mcһ}¸KϾf]_+.=q~Ln^".9]3tt qݼV]z7z{/ԏΜǥtutoע;Ǒӥ n(]zpΣKϾx]zag"Nz|8|ݹއu іʳ~\yct|v6]ytq9)һK7]z?voO}ҝ_\~\:suzuMK7nR{uw.'|eߧk8>@7}_~ǖ!zotquӥiwqxj<8ҽå7s.͇KǣWHwsԭr\?KDӥ;WS}ĸt縥KKtϰ]NǏKySt..nݹ5}l ݺs>:NKpt\IK\z^oҧnrgv@KKtޞt靹t>rygۋۇK]׋SI:3?In.8 ]znKѥԥS9\zcùlYv{g`M^|=-]FĥVtt9' \}f.=})]܀u=OӡzϺ n.ݹto/.G~+]J\\z{]o‹}yKy]9tRu鷮Z?Wq tcNmթS.޷SǑ_\oҩץKyܳO1+.=ҝSKKQ^KΩ:'cqޜKKw.]7Klv|]v5%_ǍKK'׺s#N{\?^ =ow:}Mnߞkoz~:uyK.p9wQ޷3M|.K[/=Yϸi[g^?+ĵGbΙk¥dt Kwn.>K]z~;S\zέĥ]u/Un|; ةt>w眫K|Uե;7\p]zcλ.=?tk8/nḛqy=Ki<ҥOKwN.ݹ*^7:w͇rMn1թқsqFKw-.=oҝcKG3pkoǵv9gs\#Rr]zq}o/.%n[&o<];7e=_&]svtyܸtC.nSѯK;]:sulntfv\һyǥ;sp9GEN`a|w\z^KwzBިԙtty>ƥvtBKoO~K-ץ߾côƥvtq/<n".=.ݹyttӥWs}.=.tåG~|ѭS<kӥsp^N^t[Koۙ_1G;'_.Wn~.]KO=r.zts p:1\z{ XgK1]\C:sHk\zաS?:s;tAxMpA_ַs;mqåK7VN(]z S`A94K?D ]z}]:tv߸~~N1]z޿fY_\}Ϝ2ݹwԗuԏǥo_L:ty~zҥ7ۥ_n/.t|J=KۿY֡S_ſ~L~|ti=9]ptyҫJG~f+2KNC޺N7?Y?k8'Kw.kKt9]z{u5/5mn̍ҕoz=EҥƛΜT\~k1*]Ѕwod}}ΙةoԥO5ùKۯ.~']z^k\oK/>_s_.=өo3^q~Ϝ..9|>q[қsktطsc~]sӥw{~\.8p~H^uѸt_w=.ѡ't|.\z3_Y&/ۿ׫tsҥ;H\#e\qӇK;4]s8t|c}?sv;]uy>.һrs.z.܅tgKKtԃu9w ̓ץ7t;]z̭7枦Kr䊦K/KǥťwHqåOu7\yM.pӥw/.Cg^.-p^γOKO^Mμ ]3/}ꞋkNg^z槿߫uΚ:Dq̫}.OnwIN#]]:SKo{|uݵ[wN"KQݺ}yvW]}<>_ҝz?+qoWǛKOe^:}Nuf>y yPNuknq%_GWμ/^K|[' .=]vKѭ\.=>;\Kס;oON\o94/=rd=5}6g/Kw.龫}l/^N$^tқn9ώ'ҧk$Mg=y:.=+"ާuG~:u < zJ^;_:s_.ѿ/q!_թV>f~_1Oq]zǼK|o<\Cǥ:u7t/.};tl\:ߋt\s<5u٤KowWǥ{]c{~\l^t敵NݺNa=Ng~vn߳nptt3/=^ۥ?9>쳛g~c N]I!s^_toUO=yuGN]#וuoyv?:Qn^.t5pקo/]w]:}86y~pytХK{8];U>CӥKzޘ.G]z海ͻu[μ̳<ޟ6#]/0]tܫΜ5v Kne\sWv^:s^y\sN.Mw꾋k=yK7/Un.ݼ>\zқƺt]yv 5/ǎKms.ӥOg}楷]oqt7tuno~ԡ>u{n.p5c}GN.ݼZ] 2/ݼ0]p} xoon\փL~9֥3'/ocӴ3\z{g}/t _]x/ț}{{7yw:ryv\8]z{pt,l}{t~gKn^4.ϻt|/w*ҏۛRYq=߭3/.ɓ'/ .KufyIҳspy>1/W#ϼG'_o/uK>ңo˼tfq¥5ҙ\iL7/=t麧#/fM~N<`]s>v^:./.zܬq=K>35/]a^zNݼt:y2ӿC&/å;w/]zӧh~b>Ţ3W9MN=u;5sMo]y:u\:>;}yg\n:sa_oO=G9=ۥw;NW11/]׽ǥ֙o?sǥ3)_̜ztKwn.g~e|z{/qEWn=aMu{;ҝ;Kossk~u=\\K7ms>{2/}ַ:}qK/:u^q-:s8.<ꝗ;uMCowK'|ΙN^tԷ{Ǹj+s^KvԷץgKϹ_Ϳđkԥ|ӥɻg^z:s.9}lUϼt^q4fNj|0//]:y0'sy{Xw9򘓢Kq3#2_׋KT]zKotžХWߺbv{s..95KE~ʷK׭3wr;[wN=ǓtvKϼs\>@^K:SJuя.y:ӥ Oۥ_ۯn8tԷ/:}/owַ_97zBi\z~_¥7u?u鯮5:Kҥ;Ƽi^vϼt\<..=u5DsH]3by7+EΜt2/ݹKzμtousΜz9yOַ8>\OE{c.B{qۣku:w]}v/kyt ԥ{Koӥ{ӥ{}K̯>š3o'|p>.iҝKO\}qx{{Kzқk7_t?K/>-u_^u-{?.=iwӥKԥ[ĥg sK]spȼo\y^?ҏ5 \zѥ.ﯺ{ǥ\yֻw^z?u˹/ssRnqpwO?tu0/ݹE6/gNԝ_l/kImlҥ{.]78s:qΑ¥KKoC^ЉKK nN{ogNj^K9 [2/tqCmIХ܁W7~7љҙ0=Wwb<~e~y:tѷNz4ݸtӺtpCU96tطsao.ҝCKK۵7S]:yxҝ9;{搒ޜktGg:^'uwCwsg@楓G=9'5s@tIӥOyCd^7.=uq>¥.n¼fku˥3U^b_`]s u|K7_to_K;sכΜz40^N եӟKypLt-Ɯ[]sҥt ]]|7[2~pۥsҥ_nֵ-եuv:sW\ޫyoSvo~\zׅ?_yg^qG' +.GgjG]zq.tK7(]zEGKW抝.t#.].}q:S\z1lq3/#w{̅ʼtv}շ^vUWN};.#t.G6qsйUg^KvC>3#O/a?csM~ؿۿyOåߺ|\:ĺt=N+O\-ҥGO^:t΅ХNzy]:stεN>{һ^?]yc]\StcINntG^:ҭK84]z/eǥ['MNq?ۭ^Yg 7. GK?up"t?3/mҭg^ө<:sS_ƚFӭs'֙_Q:t| tt2/]3/⼽qKn^\[С_8u9t;t.?ޜGz\:)5ȃy5u\S7KwG]z'ҭ3ҭy鯷1Or]Kμ3/=nO~󝎼Koü7_ GuۻtGNt8˺F]z_I;uxK.=0.wWq\p}kL:|bl\z6Ngw1O:uVwXt8q. ?g^:>3?W~!t]K7ov_kq1'1աSKXs˼y]gNy陯nY';oҭ;bMbיq 0߼^cb|\m>.Onp ӥ;FҩåK|޴o֙p2dcgnLauߗ}lg^z'u;/bnȼtze_Ŀo^z{ۛsy~m۾#Oқ%$ \zK>.=}Ց?:'Ľ҇kituKt=+k\ԝ;o0OO9ҝc^zag^ԩ?H<3/=_Kw.=?tOo]~d>z?@ܘß:r\stoKzQ[ԥs=Kϼ\uK7ټkKowre~)>3?'ttGm~>C0/]7i^:sҥg~<.]'KONԥK/En_5.=.<*WѥKO.q<]yC;/}_‘?Ņť7Huɘn.*q~In.]KOK|Ozy<]_ݹkpq×}qn.}ȣjon9Fnߛy҇yǥGKNE>u"]$;/ѩӷ7t䯓O}ڼoO]ՙ_Rxw^zgMyn3ѥdžKoЭguud\^X3\.ϨK7oW.=}uoM>wU}uԸS<ҝyKy֣q_y7k䋎q[oK/֫hk߸/:y=ҝKKouNj̣֣qݾ8?ymg_..=/pԙ{G3ga^z>_O<~}{~3/ΙeN.ݹK5߼tjzoա3'5_tҽ~ץWKzve;s_nonpQG['7]z{hx2/ѡK;\qaå;YI~?q7߇qy}KӥU]Kťv^s0Kg'/O׋Su8u8t98}S]3?ttαå]yӺt u?.z.מsG?Htxm\a_[_?.ݹttqҥ]k^ޞ;߿Oqs ҥ7]ҙ.Se|;kΏK8\;]CimK:vzӥ+&ҭ7ĥۗ.nN_a:ŭ¥g=adqu}֏ӥ鳋ׯ.}tO^?9\:Gts/KO76OO!Su.9>6]}uO/tkqp[][/}ez~to|\^u䇓M5NS1}ҝCK_pݜ.};𦛏Y]zy˛TYΜ<3[Tԏ3_~;>뽟#\z{78?%oӥ.9/ܿ.]K,]zUKϹ!ַ%皼tt陟N~6Fat9zrӥ+{;uCN}|o\sq9gļ{}S?os]9Ktۥ?^8_vԷөo~Kw.=?Kw4.yd^:/.=Yǥɼҥg{ӯ;.]N}[߾t%߇NE}.yK.:ޜKo銋ν&lίp5ۍzD9g~u]x[G?Ǽw\z :~Dҭ#/.j2/׿y~zԝwfw秿ַ_::Kw.9XK>sN۩?ncu9>e67Vݹ{9v;ޞ3/=.~t3/}ߨOӥ7uD\stѕNy~<ƚ|եSH +溕}>ѥU?fNXt-uͼx\z枍\z8Y\z>tKͭH+]+]s{~oiu/.t:&]:twTץwuu#/ڼgS|ٝy-K]KorqԸtT~k_k_Ko_t4.|u۝ =[^a]Hҹ>ҥ_qxns1v^p{?źts2/_]z3Zu8{qKםS/ss.յO;ߟ3G.92uf>.=sK\Sn.tM.=㐋k9EN=ޛysms\f^yƺt..ݹ9.?/YOʼtq.ݹt3O}{/aX/K>o^y׸s t:u xnn~yW]0ǹS7K3)]_ 9'~eXѡy?+?.=vǭ>q7_t9~>Yq˸td^cƥ;wft/ҥS?M^?MGN>8.=]u}gq~ƥw|>̏<ԩo:tc95m\q&+M?FcM=v{WttOK,]ח;/=]'Weԡ?qӡsNja\׿'/̩G:t;ϼq!}?ùn?]po#{M؟yܫuu`c ΟqN卼>s_w{z]Fqܦco v^{ͣbԭpxߣ ds؟sI¹j[?^Oӽq.9z>u>G={?\zbE8w?:޾g^t80k=ss_/pI_57seG޶^ﺿq~X?sas_뢃-p㳜ڟs ¹}ƚ<?_G 3 ^Gįu1}t{yA>}(/ 8q`Nͺ"_@ZuU|9rz}]5q/׌ؿ|K}&bj4똄s_-ޯ,y-g2~e*r5tSb;/1qϺ6ѹ`^/ѹV=?XOs_¸s}:'1ùO8_W8u{=߯y {c&'sqkkc}k>Ȅs_cK8~ӽO|?8wn[tz8ܹѹdzѽXߺB|ӱq_k>W3'wkf'櫻o^޾uk|¹?87n ˹`ձWSכ3s_w?cOg[}__¹eqؙv\c}_}_>Y{}>8ss:y8{_ps3~X_;~Wx>O/xi|3z}?1ӹ?WFN[Oq}}m>|}ݿ/Xo3s_1[ ޏʘx}}~f-}>7%E׾ù}}GGPc>rs]~}}ub-}ngb>1s_;]o!>p8}},{#uIen۳#8cfď}Onop33:Ν:>1y%=8}|7LJs;}_cǗ|x¹?ٿ9:^n'k/*Z߲8yu<3Kxog8/[n8>s_3x~\¹?e8u}׵{8}?Wq:7 ֧::r3~c=}}#q{wL|7~E<{}?>O7A8u9:sqRw֣7籾 羾ďqOC;a?:=/3{މsߧ¹8ٿr8x?KW= 8zN]c38~}˜x4םѱ߬/+?}|֥ ww%{JB຾G_:'֯?ǹ>/+泮V$7cǷNc_C$>}?Խ?/2W.~ |ӱ?Xs_8+ߍG sx&:S3~s_볗sQw`߾u_gw[g`n͗*{^sg?:5ֽ?]_pksө?}_?ùg<K1S3ΝA}'ùKh2}ùg }ù~:X=^QOK_#~\W^c>D`fg¹8u?ൾ*pp+^2fK^#3`<2}]?g[W,G~G Wq:g|֩^s_SߎOwoY.Ƽީ~׉>۩#\G%7/Η&pk:5u¹&GWZPcx+u<|Gƣ>}|jģ]?s4sߟp{ }6οpk : ~_#e=}mď։Wu.6Wz8}pM-Ӿ?߱ޯùg}}_1:qù{8yp;7z='8u\X{pkk_8i0n1?_j5{t5竌W|U:|?^?_#㽷ۉG߼E/GغJ3^ci݂Y"u%¹=S;iitt8/ֵ??G{~?Ig7Οp:XgA~NB>Øo_=N|;g8~K;^o8 羯pχs_'[M8}38¹9UģWeӱόo;}!EeL=Ĺg|P;itzqPo%.gO}t|ùnz|ԟu}9&]uGn'= c/gNZ;its_uoùG7}c w<3>sp?:?R#~O3iǹ3&ߚgoG_:ۗ9sΝ?:^={'^~cs__3#k<4]o8uԭt[zۗg[~ 8>{s_pg^.衛_G7{~?G>:?'յ1v=?=>b7tk>h8WON5u;nwԍ;~i{s_ǫ0˾#Չo{xs%=8u=yv83Dwu>ؿ];௏}#q+^cbqqcu3׼왿.Og<?"ݷ{'ߚ{?~q Wz~382ͷ\3}?^xϿ3}3^co8\ܟѹ[+:/3~???Mn0>]\k|ͷgv8'ltk}{pi?ތ]{=q8&psx};X^:'18}瞾޿ʘx{8ؿO/9~XWp+Y>#;tď/]kG/sߟpk=|;/?nOù/xtu<{:vD|4;_?1Wwpzۿˏ==}N=t}+μ;׎Kw.]wKwNb߸.S'q؍kx=?.};a^ǥåny\zljmmp-tݰ._z~q#OѸ}wvǥW[ԥO2.}?;\z/^/.Itһ4qC]:1N2tuvI‘K^]z)fW{ǥM3ѥݏݼ8H݀p_^Ќ4׸gwzåwGYwKvv%Ӝt.}?>]ut{ҟqtԥƥ_:pt:N]zK+oڿ62n`ay<&Oϻ7r~K{.KOKo۝w;9tKwåyvDuҩ yooIbK7W{N\c{uw x?q~ӥo8CGSz޲<.qԹsn׏K?p?.=iGqågv?Kwt{ץCӥK. .S-]Uwu\v.8sA?q=tӥS^n^.ӥ7k^\=;ܫyqk.8u=pǟW^HgL^Kt]g~G8Dӱ`yqCg~~v#.:+q3gtu7['n}+cWz~Ըt듷.E8]:.=ÙKw}K}Kå{ԩO~ԡ:'QAݿÑқqO5xu|Ϗ.ݟpәo|\\zh]ytJ0]KtWt탺H+~Wbn<:7Kҍ7K['8w :?<;޿pmlstq}zө?֩_ֻ:sǸpuK.ݼw\zһlqY7މgK//..\zǫKN._'Oyn^}|{zt|\z{/]:7vp\z.4w\ҥϧi]םW/tvp0}v)Vҥ_w4;yvcΜC/;.KGK. ..S^?]?ҫuUp-~7^7\Ř:q+]zz88^!+.ѩSw쿾5ƃx/8pқt֥ҥp:t9åB>XdƘv;|ng\tuīӥ=&}__yZF~yӥP ފ;\z^KQߙgw1&^]zm}8]3k:t{׭3_>~y\u ӥ#]~t䏮k.ٯ=\։GntcK.~\oOzk)⶛< ҫn[״u:u8¥7KϿ7zq/tO^?. u^tSס}ա3_ܟtҥ{CcKD:]zIK7K.:%tNK:w/0͘<8tU'zo9&}}ylO\zҭKK.=tKf<on.lq:H̻y]yt.ݺ6v?uэ18*#.|\ޮW|.c2v{ŵqٿ}zΩ.ƥW'\x~\xju鮋q;ᔋuR|g+\zgt鹿ۥx]~mǎ:v^;.Sb.gN_:.;ۥ5ӥg|Qzަ[wu?·n<:v\ut:օ}t#ȭ+'M:e\z/|tӺgNKno];C;.=o|SW~z:.ޏ.]'zN[~Qga\"X^>zqg]z\vӯ|oBuU]åo.v7~|aK߲/u pqݺ1uan:y\vW|8Xǥ?{niKGՉUu1t]~qηvtեgn_)]#n<.;.=AtuިKo֑Yҋ~vq> \zzK.:wۥqaťwi:GW~[N~4뾩 .=K:aɷ>73梁t:ѥS*]CҥԥOKo[iաx/׃tI:\zn'ߺ\V81<\.}K:K﷮ث['ݟ}!ҧ.5^^>.t>xo9]t׻tۥw?b{oƷ9MN?f|;+.ԥo޳ŸD~uz.N9Ot7J>/~ό)uҥOoKN2Kg.>ҭKG?v9e?uo+݃1w_ҳcv֥[n֥S7Xޣ?uMw1я6?]:N|߮:u>F|~C\zIХ_tM}\:G\3.˥/WtKpJtݤ.t:]\z_ogԕSoK\f#uںSKҩ.]K!.=ҥ{֥ԥG[_kt?~ǹ|>in..=9uHtK/<4]zp5sq>s>8r?Y3> N\c\~n>㺟.~{? q]zיKxT7ic7uZW]}Kef<_鼻inSޞޟ.q;'KХWץӥOntuttҷn};_Gpt/.Wi:t}}ǥK~tuCӥ{̋cK>kåw.]'Ky{:txtNN҇c]zeL[z>gwC7oONpL޷_K]qupĥ7ҭKN.}XGť.]zi_5sԣN>uK:8ɥ;; N6uC]:&]c?Nd8&.;yԥ#ޟԩw̉k輷Kסss\:kI cة|S^}Z:ӥw;u7|Ͽtj~q]cc\߼̭8 G˥OН/.gi%ҕ׈ .]ǐ]KCWKطy{E|:]s'qL}t8x=:yvcߏKO'K|y?KNӟ-7>~-nUu!{?_!.ݺ tD~_zҥC;{u|:tsåw;suO..}~CgN^g7áKN]/=_3nAw߿|:+W܋gS_4c\op KO.}o۫۟:X/ץXѥ_Wx3&o/VtvO .KS.QGJ7]z[׾K.~tsK'O~;ut_C'o8֥+V_8Wg?r:Wχf?k|]GM޻/>=~tpt};r/=]|ڶkg?^uXå:yqUW~uߕ{v]nCIuз_]z>O?b/=^Ku :tW]<#ޫ+W~؍kƏ߿\qiХ{3~:]uW엮ӥ{֥[gKg[~yҽ/xM0K?['1~K7o!]z+|9&p[/]KyҭtKסۯE~>.]Kq8K'^..׫K7o^Ϙ~Nfʸzu;.{gKONyl엞n1gsu\C'o}KOK/]~MwNsf1&k%_<]ytm;3.oK?m<:tۥz[g[Dcե[91_)үg1/'tet/~ǥgUOχ>>/Cn<:tN]Kwq~Nw3uzeq:U]gWuOtwnN] ߟOd=tե^u)ѥ{~u\Ƹ!;K~ԥ']zt֭Хg#|m/}:&~xy:u<ν[5_wo ']:ʇyvNt}\.JH޶[_͸t>_ҫrߣuarz)~]m|qLOwҗuR߸tuKxKt?3^KKn$.=lNtօХIԏKǥ77q~ҍK\Qn\zua?z0Na]z~ZwҭGY]N޴.].}_]-ҭËK/=y!_fKn>tYU޷SKo~q8>}}ȇN}Ptjq:t~KҭK~_p63]t8t2~q_u~s)['3_յ['5ǥ[藮S_c/K{]uYn]:]uIz\Jn?\z5K).ҥ{o/K7]zs<>ҍ7/=]r~u<åz\KK~됾:tN//tWuh|=m\e6//.VnWS#]q~ow!Su/}қQ4]zGG>uG]:ѹԥ:엞NKn5wڧ,>ߺ[w]ҩ?q*+vǥW5ҭ`isuco K'p~u^t7^.fL[7S'M⽗wKƷӡ#$] ~CN|֩xxF]WgN/:ۺqN].}8f<~nx4SX:'֫qt_:>KgKN엎J~Uҫm|5ݿ6#xo_K't>~;7vy问_tuR?:uWN>`8|n|ҭ~tt=]h]zWtgtKa> Ktsu?{t/q[K'/]zuG8_>Dtg췽۷1uM/9uRǥ{.9XxwK[\z?c<]z^t.+S\N]+ҽ>.~K6?֙K8|\uMtѥ{~ҳN.|tUgX'u.:\t҉s+/ ?rO^W:ҋqԋLp~/yt*sץSXnGtet.ӥХ=~;T:w:鷐қ~.uen˸F:uw26헮ץ۩u#K&t:=\Kwty~ťWd?w8wx]]zk{L^[7- ..=.: af=;}3nqC'o~:s[@~鹿t.̯Tެ+K?Lɳ?y\z~^t3?M8\Ft靺ۥN*]NI^~gEwN}z]2/Ngn=1yv.eA4Ǧ_ƥ[Fut鞏ۥ_;.M7xډkЯZo/{O\zĥ'M+.}:~cץS6]zҳ:qtǻ|gtgJ=_z[Ǒs|{֟ә?^қSKOҿ_ҭ+KpΣKwp7?q}>4[/4_]:ңN.K?.~/K/uq/ҽI/y5npЉn=/K.\:ӥ~2}tN{fN]rqq}/ű~t3>}9y{t^ץ7ץw.ߝtE.}ЉLO"o\#r}Ƌ .}bܠ'k~'CǸKn\z~_:y/8ꗞ:c}3KuUGu=~gn'n\z9y{엎ӧ_o[WDų_z\Nt铺Xi'qW?{OFW#N4nKw3 v5;`toY9SN^'yUWi:twSi܋yq_1/ѕۯe|rO#qѥ۟F^uݯyvǥ(pcNnޝ.yۥ[ n9-nŸ}\x9ػdnzŹxM4:tڷK:tK~Gct3/uSys;?noGӕ3_?/=#O|KN/пrKҭK?ǵ;\zO}<>oKxǥ7^:uytϓuWu_q鷏g>я=]z_)t/n]]uv~w~_G>utxwc|CMngua~ҳz|?ͳc[wn]g|ӥ@tcCG^6.=w/=9oӯxEޱ.]it~~q?|ԥ>҇~2ХgK'$]yKOwZwuWӓuHӡﻚ7}>{̉:u_ͼ[nxyuvqխ/q?&/Kһ9\zm҇o~/ҥ{.=ֿK.[v:/c<|;?e.=Ywҳxչ_?>S/]]zqY/.ݎ'.=O\zԥ_[O>u]rA[KzP~m?ӑW\SI>ýC7PN|;_O[ÿtq~׷N{8_.YIt%=Su?uWq-5.ҭKog엞_?ױ^YWNz5ܺ:⩺tv~7K .$K']:ީ3K֥¥g\zKwХji:uw՝_=_:å~uXu>ҽҫu\q~ۉhz{usqxc{/[WQn3?:['?_z5uso>']:@_zЉⰛCo~.ݺ#uݺ1G|XҭK7?!]unԹu}Տ<:7øtut[/+\/|t>7ҳ..Ћ܇μ>K}vSn/GXoҭKN߈wO#ov^on'_֭/՝I։w^Ñ.ա3ԩSwko=n<~oN?*u_:KOwN.}[)ҋco׹o>^ψKcG_.{o%3˸PfLv:up :e߳8>b|keԙW..ݾutY4.]qKՇK7*ww1?Kptҥ#G㖟̷ȫND<֝w/w~\z˥{}ӥw]q~҉K'0[|hƣ9Kԥc+Gpe?_R^t):q~7`K.]WKPg?oW<~ӥǑƣqwӡ8Kyijӥ{ҧË]unһ;⽽yĥ{8wk~tu:tХ+7Sw7]ENO|1}Ϫn)]z:+͘|[vOvul|;\.t]M8C'^']:toutҭKtҽ_ҳ.pKϳ:ao??~g({__?u_+ѹs/Cν ]n82W[;ƹ3{k^Fms/ຂs/c|-H~sGluܰ1s=>\I8cs/}8b?"z5߽]?m8Ýs/~+_t+tg8-: ]k/?ڿo=^O82^wN~%>|Sb>9s&{?ێ;o5_х?1_u7A8uux1Bpk~cz 7Cߞu~S'`]~/dz|N4{[z<[7qQ|~=نs_ù7k8ѱ&mo[Y3o8?t%k]oy}|p:7uq]_1߳_17:7||#~W8u^^u[3\O8ߘ}wLx͗ߘ|C?7|~gVq] I^x>~ͧ{ _\J^7߼ܟuwqWc0bx[?Pu8X? ru }oQtW=u36|w̗c>oy=羯gW\ù?f_<~9u؟0ga]{K's_Oycԙ/wד7߼>z~2ν d8uys |st~|ù1 |xgp~}/X{|#}˹>u3#s_]o85o.O?q˹{W| 羮'WvO}|ؿ{9vr.%cw8pOur¹>W㺟}¹^z9u=ұ?u=˹޹speT/?/7qùg;<ck>qk}Sc'?{szggyPn9ףq_ø{_M ̘ٯ~|c;5c>o8:OOGpS8yҩ߱ڟXνt+>_gg韽o;|n{X鿾g:z;_ k}6āpM?'k:'羿߄s/nG^p{}p@apԽr/0^ʼn/ɷٯ|/|֥ 7۝v7˺W\Z|{̧ 美x/s_߇oe3}| 美^]{]6XWp˹k/ G}b=}8W|pŹggz7c:~^O˰^8N~~˹:)[Gq˹nޘO}}{W?xnѭX/O;֏'o֯~m1}+B|Y^u;G'?"93b}>< -q=>?ħu`<";:p+0~-Għ^u$¹7Mo9z]{{=s_ɘ{Msx} X'7??b}o8u}׽Xߺ|˴V8>b>Z8н7='8:O|sq\:pq%ԁùo帞s_ؾo}ߦ51{~ƹ1~Q!'^{߫ƷN~Ո~xXons8}}߸뺏p{_.B77"]Qoo?_E77^3^s_6ùϟ|7~?s_θ>7ugpk=cgŹK:73~sדpx7upo|s_e{ǿspC8&cztoo{.KS8ѽ^?xN}ͧ# |4]{t¹+X?:u¹kn_ ;ӌ{oc=Z>Z/܌og_Wtp7:_t'd8/{wO8ޕxoKx!}]o󸿆s?ٿƣhgLֱ3_#sx}}?ǹΟ߅sp^8s_n^YW'{{2&ޙF<gp+PcScj|8v~5Oi|!:n5z!u¹woùe83b>Ow&>s>os~u}ާ#ᰌ<~3森6}uƷuc;f>!~>c7v];c4گXV]{,߻p+^G0oߺc׈z1&ԉoz{ķùqg<ڱ}-ۭÇs|R_FM~s߿q{=q1n8>ӵMY&=P|g~㺟V8ӵƭk8 >?ng|o x=|k^osqs_/~o}={p?s?G{ٍ{'ޛn0&: ON|#3~}}~;zf8}/{Kp} CZL-^pk}.6;⽳o67ùs_گ߼dp!3{/\N8oss_>||~q}N|_#~kďuFZޙ/t}ǥc'ߚbǕw3c|;㙏|t%Cn>ses_8O?cƣ93M|ߦ_e5r?{WWsƷqw7uw8uϿ.Ʒq||s|:7cމG_s_z/W|fL_>^uFqτs_W'c^on"Ntvď-s_׻!ENx{į+~݌Nn>8nG<| :t_˧/׵khï#;pkt3=Z]v۸u8ѱ3_8pĹAG]p%^o.zOt|O;c?Ʒ/W71_=:r87S_ٿw}}&cf<֟v|kg7OG߾羮ws_͆s_*]{w8p,o=;:.ķ/wƝ 瞾 羾}O|G}oM;WqeZ {t+<<&}?o{ùQW&>¹zs8xWb\Oɷ/'s/:8%^ɷ\}Oq1|mI>>Up+^P?|~ƹg%=}}/|<ףps/[oqŭg{I:]eқ=\ҥ7\.Ct.u ҥۯ\{եӼǏ/ セ9].Y/N%]zn>ÅҟΥ?K8_W\>K?\z0.Ung]W^uң?._ .}$]zԌ.}wKpǥO\&uO30u8ۉkC~oǾ.o>gDbo۝Zؿq5kT%҇u ytJ:\(:KNj\ԙoK҇ӥot#qĸ /N\#.Oot,gĥohnǹK|#Mt߸w;u~㳿U7U7S.Gw2/au֑Х[BN.=ݪ.Kť.}6>.ƣcoa\u뭺\qx\y/;]zc'Nƥ_tנ|>Kq8̫C_qc'OQK=\z_\z:K]_\(c`ɋk:qŇK7/-]uKncռSǑz >y}u.13~͸åtyץ׿\z:C҇urt鯮>]: n]tt^0r;q\<.~׺z3槟e%/tѸtootҥ{ǥҥZtoKn:\q']t=Kn]i]up?q\:_WשNupѺtѦK׵ҽ>ҳy50ۥKn{ť;yyץ{=ťҥׯKϺ 3]:0ώ:WcԥO@鷠Kxy~ץ{a|1&rԉuۤK|1O/g I>w'Ӹx\zhq|pcS7NR?~K:Sҥ:S~_ĥ3]:}q>}#>_K>K:{\z_ktJҍKEg8.]ץKϿGy.tU]>. yby\z{OKt׋t_>\z폭K7WnP]K^ڕygԑ3<;O^<]LgK ӥHnY\~ w;z)]åitqBaKu{t qbt/ytSWKOyUt?t`qMҥ7_әK.}p.]wKҩk.̋ӥǪKpt}vΜ<;oXה:ü#ӥq]ǣK?ӑctOK﾿t] ޳wһp~Ku:$\p]vҍKeҋn7r8Ǽ;Ǒ1+>;/nO]u[tuO!.Ku㩓yqqҥGKOGK?._;.].ϟ.]KY/%)]ќ/5.=4^NХo|}_EWN|źq}ե8tӥw9qKn9.tIuҍ7ҭӭKYn]\.=i,\#0u_խuHqyq8h\+]:ҥXNuta[]{u\stt.[nޛ.ݼt)ѥ{ĥGgדүӥϲ}],:vޭK=6:][ij;c\zӡ3ߥCjѭSwQ ]:[w~=yo8n|v;r\׳o5q=Х[Fn]2]ztmKqt8Wg|S|þN?CI|Oٝ?\z..>i \z.t<.:6éSթ#pٟ}/t޿u_n:yq:j^t.}ǥO?y{]:KOߌGsʉӥNNҋw?v8CG>u5|>yqq!\`.x.]z..܎N`>~~?]z۩oď҇NW>~ҭKwK?m:;?1t܏Iϫ.=|i6\ۭGpYUnq~K9G_|Ցw}qK٤KMGǥ>ԥ[ >]?ҳ..ݺIt*n~k[NuOcZgWv:c^_tҧT]K\vG|ҳ,.=ۥֹg?~_tq~c']t{q;}ҥyƥ|=u\ěct:t|ƥ/>cI~'։q޿q}ӹn(\,f|;+iG\o1Ʒ#;|Xu8.uo{{uLҭ<i_q¥Hҥ?SK.9mn'>uN>~ҭ+KN1ˑ.).}~;c\GnNs\z[Oǫu\tөm~֩ZN'nҧu uWK7.}TǧKt}ԕWҍѥ/]ry>]sDuok¥ԥ:fꐦ 3?1`L~}cEgN>8ۋu:ǥ]z_ߎD>uSwϟK_͘|f^?^7ҭۧKQS6K|եeO}}حc'<_Ŀu_>>.=c\z+S'N߮-t|p?tGKK>}ҥyK7>Kҙ~<\Qq҉7.҇^>.qå].~tKoK1.sIåÕ_W뮦cğMGN?f<}NzNsnTnTGxp~q gK..}گ>GKݺn8t;[']uďK{=ֻtPKqҭK.vqn.uǥ&E>CɇnXåb|p~8޺[K/ڿ7/'./_s|uZpҥ['F}N~Cבu7u=ֿ8|n\w].|t5WGxo}~{N~tcoץS'k>on~.|tKەğӥO|ҧu]w.}oK?py=ƥ+]up K.۸>tոYTN<:XG:hO3MNxkx.l\tԱեOҥ_?]:uӥ{ҥۡ?NN|9]k0o?3.=|ҍGK}tө7\|KvCǮ#¥[.]ut['^ty?/?ߞ{Vt^k:59֥socytһ|q֛qt.Pt: ƥGtgCo1~>NiNJ^ώKׁ_t1ƥLcχ.nKuø ߫S{~]zw9rLS7nPxNҡ:tx҉qcp½ut␺tEt&unj^}>yq^t5.}=nG^#sq9]._N~ǥӥ[J>ǿڏ<:7߲ygL ;|.=].}+_uQpS']z\_u]7^wv~olwm !"-!=]Yv_7XKz}|Q1S7o5y\Kסo-Й}YHNK:+X3o/O]z9Kq$_>8utҥ_:p_7'/}6>Kf^m6.}/y_t<+_toNnpl\zOeKKs'['Y:sAwKkrO9.]z..q@楳?\satM7?3O&NSu[QXX/:8p/.}8Fեguƥ_Y[qtyK/:uu:I|һyu[q0>t]5.ϣҗn}w_85}np;u8?uQ.#/N/Ottt#ӥ?tߝKNGc_ϧyC~E߲݃:]Kd^c^xN3.I_y|StBӥ<;k$v|t[ {IwN]םyu鸤tˑ^Xӧ?.>t~ӥ7^ۥK/2/9Iۥsҝ.#ۥ:uԱu_t.|XX:q8Kwn.s8SwޙX\/\7t鏯ezѭg']"tJ^C︛-\_H5}WoK;>\G>>.}b^}W]uХ۷K7rWrޟ<ӥ?e^} |K7SۧOޞ|.<ҙ×.]Kw.=xtåO>.|O\z҇s¥.}קK{;9Cwo:s~1W)c> v:u9n>K/rǥKg~著N>z楓GK7 κt(.}q=.=3/=uG/Un֥ù߹?:뷷7Kҙ[.ݾ;]y#t7KԚ}~qzoҪS֡q܃ay7g.ùg^zաOo>@d^zH]{9ǕײϷ.}tkxt9>uQo{NKK<;/}s7kץGKҩ} ӥ/زK.ZXS?tCǥqcmW^b{uo/gt.ݾf\zb]W]圃y7u|sڣk-]zͼk^N}[ltq~år䥓.}ؗK_mto9saK7zo:t슮<3/f{o֣N1¥oq˵4y2nǥWt|5]P^pַQ>ץNLuG x2Of&O&u.}eWO}и1x}җsp{y2Kå?:m..}W.|pb׍Kc^zutTݹs\+k殒'^͇OWU]yE~ҝSK_G~Kw.}9_֏]~wۋǥӧy鞟t~t.;sr}sC.'>.9jp7G?sϼtpre^z_wm^q:]z#/V\zNK]z#Ϝt?K/۩3.}W]z:vpүӥ].}ru\|t陏Wutv^zuMLWu̅m:ust{=^w#ӱL+֥[/ѥz5/}=?ҝÅK_z.Ϻb>.o|\9x͗եt;KqW5ҥ2K|c^n֣3ݹ:uׯKe^z|3ǥĶKrW]o^X2?.lNys➏Kw.yyn=u/^?ou㏿g.,{W85}õ}5sM?{̙3 vp?>.K>ԥKzF]z}__ust3OG~Mv˹k.?;yS\Ӫ+gǥ/guF\W\y׋.ON^zE.=ߧ\,]z3<]:\ou]}t+N:srǢn^/qkk/Wַuԣ{\z/IkJ>9.åL\;'/ٷ^^tK7XN~y7\z^W<ퟸ>a7K#\۩x{GO^s;uv|;ۉw69LJ=ʾ;uϓsW;k~.<ӥ wU.]WK7]O;ԑw>_|ѥ;S=]sKu~>)뽟ܚsHkǏN6:ӥ;NC^y|tk湇μu;>m^to㢛|گ=En=n9p[>KwNy8-]*p.註.pe^sWv^v屿KCGG]ǥg~=yumS?ޞ9q}K^ץ?:e]z5?N.}C.=7:N[u:t.ÁԥO.}tCַu/u|Q\zɥJ~w.}y.#/fM4yc5/^qt޸k;tsK>]z:\]z.=oK'}֏?to?]zӡ?9'sSuԷ;apĸb9yݼsONyO]0Z]g'';]ԡ3wfXױSVtbM5yoEn.~]z:❗~>]:ur ߇N|\1:bǥ{.}2g]>ɚ|t>K rp8sZc:v'tt~I8Wzm3G`Y?䥛sKХ;O}П鷮rҷ ַK_nu<ɚ[gq鏾u589>;֥#쏎.~š9LK.=3/å{>ǥK3tK_>>Y K>?Qu.ktK_.2o=\zb\^zCқ|\iY_>u]ҝ;KO]|K_\ʼ.溦K＿p֋ҥwtU.}ꔫx=.9N^Coܳ;]Yۿ]X?׃I=sRq޷Kwqޞݮk^攥Sߓ~̭[܎ǥSӥ_tE{=K=]/:k:uy{\st#K_e֡8ӥ3/ѝ_q~ҥ.ütϗtץ?ۡ;'u^#o:sCtҽӥ{EtҝK/ǥŜ]:K<_ϥ>pn`8$\sҥ/cdz{ͻѕS DžKssCNr=L^owty{u}F]b_թ8ѷKvttCKo1]a]Ss['y{yҽJ>}u*,c_ ұSx{KgpKױ͏֥7yNSOuU}}s.B)[ObxKwN]/\ptҥs.KG̿.Kg#׻.1<\(jzqƸt߿#s"~祧c&/w}9nίoM>yxuk{T]p.c]7\6]μ3WwԙwݟKN]w:o/\.W.ݹ:N}utK9Mg~=wt5y}t3ϼZ׈ѥ.o#t5q]:ytu:Y]s-tyΝҥ]eyܙ^u|ǝK/:ut7˼tZs..>too&t\ӷwΙ?G^{_׷MKow\z_I<өSwNtE7NnPbuչWyץ/ƫ;W^xq9wK>ooۋc]ߏp;Nt#cҫy|AoW{.=åϏt:ө/tۋ9'AESK<>3ǹw:x>}1gBμtAK~K.=^ot|;ۥvμ~;3_¢k_} ]9nGKIy)^W{W ?.]WKKG쳻uE.}KқJG~^ep~\3Хg7.>]cwҩ۷Y7tDKi?Stp<g߽.ݼ ̣ϼCOK=SA]}%zK7? t&tK:}wqk^zVyӡguw\?ngKuҫ>;'y{=vEwnǥo.}xǥgKoy2߼̷_Y.} _˾t>u\ώ> ]9kpչ}KOi^.}їKwtyzt|of=:u>tg2?z>y䙗t>jq>0]۵~ʚ6ngx{>@ӽ}ӥ}{Ko>S,>ѧy3/0.t.cKoۙOC:yΜt>_ߒ4{ե_:j\:ӥ[W|qMY>J\z:]y[tȷKtqKO}̭7g^tK敓p6/a}sޕy{K۱ߓo7]zyui ݺ}KO,]?.>ygn.2~G33ώggwةvƥ֥{~7/Kו3}ov9nxt陿}K{}v:uU}ǺG)]:˧K_g\t5y2]N^?uqy/]XwCK׷.wW֥wt.'/}钶K'_~ֹ<_Q]M2?<.^K7OQn^.9ۥ7.yOnߞåKwΈy̼ty\\0?Vx/Ƿ$y:uq㹭Gu;/=&u3W6үʙ]xxn83~yWå?>3tH>u[Y5y2}ȼ̧__әS̒g9SNycõWgWљN 9]:NG.}NVK3.ҋk}\_һ{vq|sMkxK7^S>t]]Kw^:O^\?\:ytӥ;GNw.]gN}GKKwn.ݾt-]ݯϜ#/}ԩ}CΜԥ;ώa^v]zqAv~:¥ԥ/Ct8r^9ҹtn[0/׿y֗u阫xt~}v_K_u;sƥ_<>.ݹrtrG?]#EKou\zש?ӥ.ݹƸtGz~f8^;ۼtrҥr;{>.}C/\w-ftqya\6nzǃK>W?.91t{tM>̫.yKW^XwָSq.:u۹Gg^>{9W}eXe'}Y?.:sqKwKK6ݝ:uq%U:̅-:ǃ.}9\Lt 3/~d&/}\һ3uoQ>.~t]ojtKukK<]z1o<]z3]:9]tuv\tE7ݬ:srk\}ttGK_ַqe?p;t䞑/N^:/K7~k\|w*gbM=_ױۥ+^>u-Mn7sK_ޟEJ/å[_ѥ9ܳ\e^zϜqrjiӍ_ЩϘJwq.lסS:uq癗3.ݹK_5]zׅWӥҥ3W6]zk\҅7}R֕qmF~;.}/~+F^7y:9\ZҝKw.NwߚUvK]z?Kץo<ԣq~q|K^|>pc积ܧsay|gdݏzzk^+i?\:ϲ~p\ӥϼtӥ]uIХ?:jvbst䞑s'O<]z:sKC'.=7楯&lΩG\G_#/{vn99Փ>~+tG/o:9[֩Gw:|.}^>~̟ٿ}>|\sBK{;C|K#.G^Сҭe^zfw~Nߓ>uvS?st;.=җs@t7߼t?ۥO?BnQt"һn:oǥ} ]st}w㾗>tԣ{y:u;yN^\;ǵ1a߮WܞgC}?:3;czM/ָ¥w79GNXө?\z5<]zu͜١C',lg珼Vw]3w5;ۥuԷ/cק.ݹ;/==O77XS~?_?__Vrk:z_o_G?OvB7"ߎ_*?_¿O^޺vp_pO8C ^n^?Ĺ }:%s/U\rms/MޟW7(M˵5Nu s/<~ν.u|pν:F^yKӍq||ν޿{,|¹ץ .>{{܋%uR/büW8tOo/s/u˼pzq<s'pE's/AKν;<ν{ w:R ν\z:w{5ʭ^_s/e'acŹWtAi:pùS^{s/Eνs/t+G>P][ν>=u=x=O{cb{ݿ}=gyk/8L5?{;ν s/̯-νLK{,܋.4{ u4{uJ8^%{yܣ|}}C^2={uK8qȯs^~ؿҭGcs/΍s>^7_]_=]M^K^t8RWw{ ^v۱޿| ?źx#/~>X_q/ﱘs/Eg}Wνsùt/{Źbu8.:rù|Kб_On/s/وcW8ﱝ kzq={8zfz4swץ{_kӹǫt8r_ׇs/]gν8'({={?~q|q¹w8w7ϸwûbC }8}/^s/M'νdr( sp.ν{1>{_q}g¹~pi8Q8ppW\.]{z:܆p58K3<{+98Wol^@_=?|ZW\:LǿνT]w^q\' ν۽cݮ/o:ю;A\WwB=5{]^2?={̏^<ףޯz>?Kzs;t5O^-}'=>Эنs.=?w:b={:pEwsν0t|pչh: 8ν<:;g~ νss/Q-[w-ùùe+^t8w  :':?[ƹn {,:pzzgq}Zu%Oӽ?끋}/WνTv*y_=KyO|?Q؟}u8?{qnν4-O?z<׹^Gsν~g]8|܋y8bT838θp>U{i>}8۽/s/]GzG{/qž^{s~sKwҽ8¹ Q8}'}F;K\={ַts/E {qK8G֣>֗߈~Xf.B8w98?svo=vKk} {o-Wo[(x.ַkWuwamkczpꬫoqE'=8s~vW\ws|>f:zYy^WyB^ >׳uSu%s{\O%s/ۅsUx܋. ~Fمs_sK׀s/[zνd>s νt>oqys~s9 ^no2p|e=u5y<¹g8?Ks/;ν`¹O8޸-{qX_+usx>s^O8-}t9!ܫ}:S3N^u8玾Gѹg}py~羯¹Y:¹s/ν4pszU8}}s/~p{3Ozs^s7{~?ù_ܳD8\{|<Nqp܋sùgνng}qCp{='ܳ_ܾ)[??w kǹpSYS/W8}!;rmùMpu9g.~<¹Gޯ~~\/ >އstԏqW6p53u5;{ֳ¹88{{i曇s/ǹ+[?v Whg~/a=zν.q%b{qn$ν9{7w^<ߎe=:/"{^o,ν8)<w瞟8<܋Oe6:R[oqz^n=뽷quXSƥ_?m8b{q97{Úc.@8\pNz~|~N^_ͬmR}|¹Y{|ps/pnν874{ ܳP^N~E}s8~ ͚~*~f{y=)sv\ss/sۇ~8˽9k/q{7ک㢛psEnν¹?s=8ܫWs˹ߵnĿ\ӿ~ϸ]8YSx?GG~<{^js߯_{>s{CN}㟱?d܋spŹm8Wֹ_Q>O~ùs/76{^oח~|묫֩oùs>s/\`8E^.>V{z{}ܳG׹Fn?= u:֣ND=ѽ7G:~ʚmvsqM?x死?דFߥ3s`m<ߌsz@^s^s/9 {aN.=u9:wo 3O__N~Ǐsӹ[ѹ/sI{i>{۽跾t w8=q۩o_:~<> s9pK3_~98ߣ~3У9tgzk5K:'On=9{16{unq{O]Wƹƚ1s GN}{~d{5~ 'OܳR^t85ۮ/S&k AHg~ur8sIǹg]ssqKpʚzc~þ^{ls/΅ s/M'νkN~kz5ίzo?po=BNuq}еq)t].2>;}..Ka[}sMq|_/'};*׋ttg_rѥ?.[rmwN:Iܿp}Oť^җ>8\|4yѩ77;;Ntҷѥwt/z)>:uǥNdKg^]n8sS׈|MOsǢK7OWӥ[b;_;/|t:W]e[g8鳻uzy*ԩC-n6:uqץ9ۥg;Õ|_O7Kg$.^YXS'ytouoo{N ҳΒ.ݼl]Kt<~tW\҇rpvi_ν3S^sw5uܙ+0t䳇K[~.WqD] ~Ys|5{t) uON^un;kƥש==t{M7}K=WE>tM7O6}}a?uo|Ksltwåc_QAt@toex=.ye_Z_Ϲ x|\z|p3ӥW܂||қNro}\:]3ޅKϺB?voF`?L!zN9]:,]z/MO3.ݹ%yt]9}kKu9O^WGz!tݸk;^aK?~K7ߛuӥ_/.zܬ[Kϧn^.}}vs;.>*׋yٸ9#'a_/9åoJue\zֹ_//xb.ݼp9guwe\?Xύb>.8p-t:_ϾA]z/RGoٷwK'ϛtve:}v֟~nni}{v\z5.} EsAqn֥7c`͑^̏ t_Ϭ2w`u`t_ϾpPnpaMݭcǥ?ng_ָyK>O 2+d#Og:FkMHn.ݼå_]D ^֙zvdm<]Ú>8߇KϹK3Wҏ=ѕ[?6OR^{֥߭KCS/I] G]:\z#p9t3.f\46kҥqm;O ^-8w\wѹnz uK/Z&OZKҫN5:qs\oww\avk*;N9;/\oVMԷǥ?Fztޏ[o.1޹#8uo^.9So?v:j]s)_ Kz_޾ѦK7?Xx3D=z_.'sVяkyKw΅.GqzYtMgݲvv/9snݹx>_OFz:L]q3=>qeu:[>t.^cxqOc}/ݹㇵ}v5\S/oK_oOo5sWϝҶkO|wDzo{E9GzupKԷ:˳z?ҥrё㊫msuvK>NCz^ss8mu5eޛy}qyԥ틫uK‰{˙K9=@ΜM\~.5sWy<o|tnqN*z3сo;J|%:8ߒ^~tɚ©C.}_&=ϿSOLwuͻ$ݾ\z..}kOK'O~{qM7O{ӹW~Yno///]sE;tlNئN9#.}:w`Y߾ޣ>K4\z#KzkW~.=9Ny{ǸjKv֙k:\]ҹ_q|<˹k\y䯧ӥ/~]3?zQY\7:vV:/\zڤKϼs.[_MtL #tַkҶSǥ֣qwԣK:z3wqCwc~#]åةstӡS?uwmݺ7Y?q},\z]|ܳ{8f]z՝NnW9\z悤K6wkw}׳zd}q50GusVҥ3*]z̖?\:3/:;]z:Swjriם;p9*]z/e}N\Gk K'߼ZϏgg. s*k琺ݹ59`{98+w\K/ߎ\|oԡO<[ЙS?tԷK.~ny=&_0X#]z7>|K7?U^s0J>0W Koҧn?"<>^9wR'wk;uёKzu;ҥۍuoItᔫms\3_~59eҡ_?.趛st:s:sovCեs=KSKש_G?Ho#umao^+΅ׇ.ۯϿdNŚ<9[ף:u[K :qGԏץS7=>6֥u5輽bƥ_OgNnDza.^t/ҳ.pt])GKϼ#ONy|ӵu?_/v陯N};η3Y| /\{Щkw5.=9`<0^tm^O+s*EΜv¥_KN.MtHtrDĥߧ+k{\KOO.ݹ tp];p魐pt>tt꣸~KKw.ҟKϥt.ݣNbyҥ.k;y<]F橓o{υեsyҷԥnu?9Gy陟s'}Y'ӝߜWu1/]?͓ԥiu楷^<\z~yݖ.]f^znClkқy=kyn|һۭ|t麕p>.};q#QG.~XK.O2_8\p9Nh].Zu櫇Kϱ#/}o]qy{:t|߭C7/鞛}lv^kn~>K>'\zAye_gz]#/=\PCKU^+Oҏu OvUWnbMKågZt;um;t>+nǹw;o܋y>.=uܺΜ-vs{'B~-;}q<]sSK`^vӥ㪫n~.=]Ot5ON^ם_34/=3/=O]ytӥԩkۻ]d^s`tΡХ_>~y2kݹݵy7:t^twf"sgӎ7]z͗5/=gtwn# Б?ztso1tIuK|}mS>>tv! .ϼtͥKNN^yu5=¥7k]7C{gܑkO}EuSs_\3wK?ۛKם4G^:o)ɓ:t]͚:ſA:}й߮#_:vZnI}}=KW O>u!NCaM N]۝_ɺhp8ϹtsL]:ҥ{~ӥ?=y鏎r͓ѭoKg^|H\zϼtȇ'/Kw\z:t~ޚg.҇k]zaMɓ:u?!2u_̼Ku/ҧ?ye[}2?'yxy2.ܟɓyåζ:Kt9Iӥ/.ͧYܾ֙>uɸKG\N.C.% ]'k/;}.}+ԥg{߮~g8+'?|&O&9}{piKWn߸.=t']z׵:u楧#'s6O.}/nOܼx}~o7tԏދ+3OFg^NեO>.|p۱KG5y5}{W.}py}yү}{ܧ}N9%C׭[~Xw.}tg^qvy\pɻϼ-v>:sK˹tKoޞzҡfy:t#oQ?ŅK7]koϵyVOsK¥ןuny6}^Y%/zףۥXuӹ{#yntP;G:t'Sťg_ӑדtЩ;'w}.};Nҩ'N\Xy}쎼vq'OtԣKougm=濤co}܇2odI^9H楛.鳋ۥ?>/G}{G8񑷎Kg..pw.Ot=~K7msKϹ^3̧!>E2/zܼt?t_K7_9kv|^K߮Vt].ݹmҳ0l^u5SgN=.??ۭu W?n.oXSNN=֩oWӱr-{t= -NhhoOwK'^^>.楛ַmtߥ[_qK^yo~\yGg38xKﮩGtϷsjtt~u)>]z\_ti=:/tny5}{~4/9JX]/_x.ݹtҥ&_?R}|sHN2?!]:sn鷞g?_yU|7ҩ3/NNyK|3K<.]]sV楷K.}K|XS}\:.']h|#/.K!ݹ:s|<ɼtiGoWV[5^4f\WN}_hݹ}xrM^zѡG~̜~peۥ_:su8r|?\zg=6].Y~҇|fw޳yU9M~K:mrU1/ҥz3/9 VåN0Y/t׏K/:N3\åWvwn?xeMҩo]>.o|ՙS_:t=g^zޞya72\^ve:Ωo_s/ԣxHo#oNp돼atҧ__tם}n'g+#-ȼtϟ냋:|b5eg^#'/9 3G"]s#t]7<>f?xѝS98^u?Im~̍J>tӥC;wBV}l^zus_:+;i~X&o|:mgDx#\S|6k?{^J:r~ӥ_zYCҩӯ6]׾tOt~/ϼt_{=K/;Xo.p{Ύyu^WǜU\z?K_;u7琾_?>O3/=.#/=8.t]]2/NR=upG^ QxSgҩVu腺͚޴֩s;uvw]Yn"\zJ^p]tN3X':u_qҙ~Н[M=ң+g>^ѡ'SXknvҳ/+]:22~ ]&\[Y[XNxv^:?/3.۟㼙.tްo9䥛wh^Zc0s^cotOǨ:}wқy޸tae^:uK>yYw9qMN>{sCc{ӭs|8f~8>tqҗu /߼t}qkҟys\zoK<@nst/qߙ>p~2/=܇<ΏҳΙ.Q|w}Zt;Z':v.EwN]|me<@:9D>?ҙO.G^vݿn@vuݥ3בOۏõKwNyk]z:νqkw_IkoO1l_ttm"^Ow;k?^ݹY7D$]}vy|N^uOI>.}O?;ߺŚ_>}q;}u~ףkyWt>nt|sw楳tїS$wu\:uåg]1]:tηץ׏KyҳK;]u'~.m9wR]s|_]s3O=o/teF!"Y}qak>-\z5?ltq5K)\z~?ƥҭf^zunԹ:t'SS9)QO/ؖn>;qtCL^^yW>.}]u8jK8Bҗy۸ttn^NmvkK?.Kť?:[۫:t_.]'a^3/=9>\vwMy6.ݾ^?.6>E0pOJԥw]/._twt:]z>~3d}ӱ~~~4/ݾp??gKr/m)V]ޞzo3'5pYȼtO;/=9+ӥKz9.>ԩ'.=NxC7O_=Х ~?kwtuüw\:snpoN|åo7.}߿kɚvZdsIz/N?\p;.GC7O.֣μCTft*K^m|\}W~|Wɓ!~}\{ӱS/Ǎ_Q~3o\1/2|9saTn>.=w۷W{=^9Mgyчl^¥g=(]sgt㝗q|yu$ϼKN}N<^t<z;枦Kw.}~HΜ1.gw&/=^͓5/r}Kotgtѥ'{w9t5mksNuԷqWԏ./yѩϼ7]pkoM^wp٧}bιNtoS3/>p{.]1`dx}o֑9ɼ:p>E(Kt)Kt䱯tႋxKw.9o[qnvyKqQM^w9yottS>.>t闷9]N}gGe9c7O^y;/=w7uqc_wKyݚ~mn^Gn.~SXS:qKHS>u;ǥ0Ķi:tV_usםS//:u>:~Mܫg!u5_%ݹ.]wN};lx gܜkZ]_qo:C?nҥʩoKO=Q3\{Y.ā9'׽Õ3'ǧg`M y>c3{5Х;eבː.}¼tߟHscq#ǙN^sir;cGnAt_3]S']z]_sz9y%d:kӵ~+~뮫GsHz{4U7o//]ҧƥ0\ۇkבӭ_ѭS߮S$_sϷŚq"/4[?.].>\S]zKǍK/K|tsFcq|8Yqko!e~N#J~|֩㜋rsMq|Cgjѱ?tvw͚zCiԩ⠛sWKK˼tpL>}(\skǥмt;wӼyd^p{...K'4]zD=ZGK>.|)7:sR3_GzZq<9I;Qn=An}G^|~LJ_S'C~|:v'/}ϭ2/ݹzbt;.}_tq<}>..mKm3O2+5Kסo=蚗A]5/}:_=.|t#}֩=y|K|?S}Cg)?tߏ}hxsWgKgNY3kedM=+lK\rq]Xkq\;7/;O^zF#Pt銛sWùҗ߬.=]9Ux.Z_8җF.{zƜRtp?.+yt9NҭܙoN:.G[gޘ;<>CKt+ۧ¥O#/Z?.=#2C}]N=ϜK]c.96=WͿ5/]KwDzop-.6/[]z /]psR[7pqKsM:ksʼtKk^z_\:·K>ٿSgN*<ҧ>K:Ksy:uRgtgys|O2w!뽙N}{9.ѝu']fM=Ku\ȇN7/9 n'޲fMY<_楓cr䥓yy\:~Kw.yo#/]>zֵtҗspǧ7y鏮ܳS^x?ҧcy:sx yu91yCyp{vKNNY=\zΑ;åGq~ҥWo?~.}K.9$[kWt/r9n^Gwn:NKKo;o}1Iw^Õg~:<~G^:ޙ^>.yK;ѯǥSLy^GnBttK>߾K<KKK/ַɷ:tԷ3~p,’go_7kΜ~[Ϲt~ʼ9α e^zw\s¥"q<͹ҩgK~kqҧk1ļev.==E6ly{??~u]ѹW2- _e/| ?ވX/G?^7_oωk%Hަy؎+}!Aspݟo<^͛'5soUν6*qUscwܑ^u8v}ݺp毷fy8KW]ν^c ޾5*yp:j~'ν.3νQW<[s￮so۫_G~>ù78q|Q{cN:7o_5pM]k;oun^bMkM뭘~a|¹Col~sp1νv^9+}:Ź̛^uo/չk]Gzw[۟p=ùTֿ:DsD8cIu{+;o.{ù>soż_k ^u}8%]|8?O¹n\pŹn{8z|{itu_{~so퓿p^k8ƺ^y5cg׹vيgpg   t VW1y}nuߗgyxܿ}sg6<}r_W`Lcq<每KgF5sO_ǹ=]\qޯ8k[}=x>w_`71?ynn]_>\pڹO6}ǹtG}u#k{?n]:7}:=0}?o}n:88}\t܇W/'}sQ<>Ǯ./g8qU%}㧏+Jsw9̟o 8>os_7sSsw>Gqu=sg: q'}>>Ź#}u p >݌73>S8Y_:qqk.a~Ge8Odvm|{|׿p[_8/Ís_׹^ 0o׹NЕƹ[qþi׭'|'c>40"ν_:qo:=O?Gכ>׵yu̓¹;7_0 >u?9_׾eo^ǾV>}!O}F܇yo8c#}s>81܇q_8aNN|Pss30_~ܽ~1}DzraC{qݟ| wU? Љ_G{~lV{3uþH #'mùun@>~Ź7o{8w:w8zzoSne}Տh2^eu/ptqCLJs_槑>~߻OnSǑq槧ϟ8aϤNzo鰩}vs{8a3Γ>$O{'_LJsw~mwySouԷq_ԇ;8u7܇y>q~3S7u͛ܽĹdL}9^| >Mw7q4O>}LcS=}գv3KN=Kw'뽗zе_w]/GoI}sC3Ge^ƻNc[6}sup]vקn} u>~܇N-ν1:!ϯ8"}L?NU܇WwکGzCt_yq7}z>&}ygE_>:ù[oùϏ}׹{Kn^#}t~8ΣNx^d{8^+78aԭ?:{X/oP;o}\:pc'1>کoOLxЍܧ또>SĹsGzĹo棒><܇y8>:xS>2Ow͘{/}\p~qsen}S>.Xߞ:xܾGMs_ !=:Lin qv1~֏q_햧CN=ǹ{羮Gs6}ukt{q ƹCsq8989OsnX Csk׽ezq瘿>?ޛ'}n'}}n{7gẄqUo:z͘Sp[o_~eޟOuWܻ~muu.꽮pu7'׹Isq_?l>ϐOl=b8zt|S?ǹw'}u7ܧŹKdN}t9{ܻމs~ŹG|קyq1fc}{ӵ7pO{SҹM;LJs>u'>'}qzp>8?֣?Ozqw?s75q ~ t{__s_oc|ϭo/KO?νAq81.m=zs;ָ8:2q_s_ǻ3v>s_͸8׽emk^>ߟ-o[S~W gøatN>!}q_w'<{S_Y>Yuatǹ'ԏ;oy}>~p^/_G;zy糳ͱ㩗n}??8h5Hws_Gq/ܽs_s_1SǾ}6?:5?9ܭO>G 7ێzuƹAxǹs_b<3ߍ͍4y_]}ܽ1}߭?8?s|s7߇qG{soqٟ'ey{?_wٿ}ޯǹw=8oŹ{xqҽَ?_]>:~ܻ~swsy=;_{mǹ0}r?Mwhg@p8?c ׭d `Y/ѱӿup}ܹŹ.zq}美b|Posrug_:qzue[ޛn=~>p_~N{"z!}ͧN?siԭԷqҩӿ=8ߧs_8~|}sǹ^=ùD]`.=Nҋ1.}q|]\7$䅧OyfSYw߷Ku!J#鳋^>S'_oKߴK7.tYwNЕo_tS}cKg1q##ĥO+.}.i^gമq;ǹ_n >._tuüP]:} v|ttou'.ױХtq:\u"],f҇x1t!r~{ҟ複};3iڥvgܺŘ:vq޸v}{5Ot\KuS~rP~~\z.yA>7Kg}v\wK/>Ϻ/~t]:J;uǥ_~n qNc`W #ڡ_KqͺSnc_{]歏8q}IW>qާեO.]Kt>._ّ.t||K:O]7K|~}vGGa.>ĥz|ۏ\qE2.ݾF]NeݭCqЯl>qu5ۥN:(/7K|klu {.=nws]i:.3i79yq=ťĥ/8~>wwt\=.ک˺us3ϻ+~\K~]M^n`sEAVto/ۥ_9ǥS7ӥkť"ڥ:ɦ3Nu/qy~ώK|\:/NW#/Iu/.}n?uv7y|_.)Kt{Ku:wXx|?}ıqKKw}O]..}uqo~|\yʸ.}|KJg>Et[;up[ҷ+.} Kߨ+7q.(]z!.}u ҷW\>.}_yKӧ:Ia{\z޺ ҥK/BХptݸץ.uҥ[wj#¥w".2pK;ƕutҭ\;?ucsۻu=s\:n_;.}KoKut\Oyqe{\.}KoK\o||]rnOKs]/n>.'/} XN}ɫK+qKӥzooו>XG;?.}q:N]}xt].ЁOv\4En_.?t.>A\]W֥tKӥw}\}p)o]{wȟ?_ ..}ط1ԡYנ]uΟۥ]z.uOt݇K>F]҇U^_v}Yԩϸ֩K$\,cǥߩK7]yX|v8i<7]}q͓ӥ__qss ]wF>ͫ.]K7OJ?\zǥ[>.=7{|C{Kt]>̃ӥ~9>3ukS~\zx\K~gvt]Q:4KK7S毷KХ[? ۥםOw<S[K^:tyqХϓ;..}wlj硳>\w_ҥSԥ7K7.}tq~KOD>|\] .v2a-.>]8\GOS\z;&\z;^]e~u[֍u]JFn.3p+.}:ϝ+]|:Nf|e[uM3ĥХߜ?uďK+/>y{Oҧy{َ:}|N\zãKwץCCLi3ťSѥߏKOI>K".}?O|KoKS?߮C^>|gCC\z{>Kyݸayҙ[֡?^~MǸa~8.ҧڹڟs>֥Smu:ҧyΜuWKһ^Ko'KK\8}=OwMW:K|t^sqzt]zߎK8ץn_.}nu`tҿ>uk׭玻O]:=t}xn:9<:9]u^t'^7J:tAvKWN:.|?;.ҝoyЙOKSﵞKVϧoӥpoե!K?.}vytG/9{KoKO/ץ^:uC\zKґGyGw~NСK.?Ϗ|^tts{_o5t[ƙo>[wԓ1[ѧcy^?]"]z{KѥOױԥ{=KCtץt|tХߜt|ۥuR90O\zKzq׸t?dtҝҭ/e?C?-:kǥ?ԥ{K{Z\9*ҽKבOե}եӟK7oS}Mp]1a7<ߞ:v+߾FK..~|]z;*]:5]]4uwۥkwҼҩ_KuqץCtOYA. .}g|ϯKCǝzv.;.}ǥzt\][>;}wحG}S6t].ҹեvu{|\: \:෎m=owv_n?LҝGq>ĥ{F>;{~1.}ӡqθެsqCtۇrp=өקKEtaѥK]*'9Y_å_;/\^1_zX|g]v_p1]ҽ_qYg>?‘O]ͺ t׽ѥ;ԥv陏҇ymݺ]~}:ug֥ҏҭ+KgKuOc$88cN:|~'ۥK暑l_>.Kǭ?!N:urLԭMtKיlS|0ƥ۩lq麆ץKvKu> nR>.wٵK_/$8ͯK/~x,\dp~9skn"yӺuK?u;t[γ>q1y2<:pL݅vN~w9w^:z{|t5K^7I..(.].|v.:{oxxyz>7_nץg}_>:4|KߗwK?#1u o\KǵKש];.tK7_>!x|z}A9}q䝷KP~qNuKg=v~_Kt:]㸨LߦC|}]z;_uwWy8o\:uK}}vN~\:F>o֥?y>ԭ8>[g=j~~^2_=Y'>{\zu·pko/\o?]7K?t9cǷKW>Erå{_]:uU]zK'nX>[K#ҧyίKS\}睗NN\zK7;¥n}>曻ơcKtq;_0나}>q6/}u~oc̯K?9~>t{~\.C^o>.\zA5/x]9}#KUwopͺ^'>u:?y=}_3֥[Gnn_/.<ߛo;tKw?oy2-EOt;}8者i^k/_Wǥ..uuե>K7?Kgqn9ݎ'ng0?R57>@Su):}ץgo:sS3:u{;yK싻ӷ;|oǥ?:i}.}8=>\q_Ky.p:8]G>uq|}l[NƏK?o~|~{~Kq靏N]K]]zpg|.vۼ~t]..}y¥;_Х{\}S~3>uuDt*qGKםҽt\{v䫔>Ko]N_\.uA.}'^:u8rӛy߭SwU89^{_]uC0.쾸1}{_{gwt#.}o.aL߻kt^yd.ut:]:}u[.ZJgчC_gt;/q;hg~K׍[jNPtuqi]s]GNKґ>?.<.]e<.uf^٭wyKc^Jκ͝'q}{MN_C6]9>:t5O=]On^.]WKc^K>t^Ǽp{G~\wԡS%{/:>~cȳ:o^z>楛ϋKrv|t.spz9N>E:/uFpa]y=p K_ԟ+pT?.} ?:d|}}ҥw:y?޼'C]zޛWt]..]WK7X1o:~?_ǣK y驗||:FNw˥g?}K7RN.}.}<]pzZ߮e_awKו]GM:MqwZ.Ga~\.9y-G:&r|;/]Ko?OiK_.>E>O{¥w=MM#1}v|>.O9.}ǥ?Go] һǥcOb^W)>:u]7K9O7y}?ڥ[ХO?]w7_^S曏Kǿ\z׾[:sN[tǬJ~ẫ0Ou]_ҥ?qct|yzzuu^c?._|ͺLy6ף~S>.y:tN';/|.}k^:!K H]zu^t?wCηu;ב;>q)u۹5/z .o߼vKo~y8[:u{uO}}z.߫ץSǥ:;?tmեyCK>xׅuoOƘuR:Ը9tߙϼ.vۥ?=o:9`ҭיt楻N/.{ 2?Kwݍץ?^g>KwݛK'.fcgtѥҝ}֥_oϯKu.t7+\z_^>uvqVy鮫K_].ҡo3]_t/_?\늾.}=owzS_t.}\v8S?:.nQoOsK;6l2v׍</:tO9LJo>g>.xv9~꽻Sn?swo]:sIeY~x|ץ4l8#tqd3tyy;ǥ'O /-]wui:򸢏KwL}'/~v:<]2/ݼJ9t^>tøtrڥK7uWuoO=q+ߌGsww.}:{twOK7_un?v;ޡcǥoo~Zү߼tlnީ.q_uޏץqtݱ.z'/=w]zq'v>o}[>7cXKv酋9ܸuۥ߯c<9ХÎK/].5ҹ.utӿGwQS|twǬkzt]ynu:l߯cgy鷮Щ+.a}ts\u#]?'Kکo:zq黮ޏ>v/iޟ=y#:G|dWǥvʛя_#Kg^8y=o=۝N>>N.}n.ݼhҷ߼9ҽyy|.=ץ?sIe۱;?oCG?:dzN[~\|˱.]:toN~]`Kw]G]g:rNS~u?og~c^qTۥov۷u\Μrf|73\Kutڥw>|sL|q)g?.}0.O;_ĥy]{Ϻ.ϙ ϥ?UqqDG׍Kw_zt>yۭkΩkāY߱]_5n^:K]vuߛ_x~~]zܠyץ?:ulm:uu1{NJKz~W_upӼ8\xn>tu~:4q˿W]ڡ~NK>u<ñy7c-Kl~N^nPХ:v6ƸC~[mХߏ˾yZKGy=·;ԥSҩv^ɓ~qn>vN}w]y͸7Eǥץyp߼~˥ѥ?:z{Ssy}tG.]m|>y:t_pһW.=?.Ϻ>E{c|۾s+ǥ/Kwtyu ;}v9x۷|y9]gK߿.}K..?]?.ϛ׆KA|ҏK/םWC~ץ]z~p|]h>_Ϻo^[>KKo7K>D祻N.|O^zr}],}ǯ=vK7>''\_?:'/G^ÎKi]Kt}w^:z>[ />@q0/^~>c]KO?_SܞO0_w^z·u\Fݥ]: t]Uҝtm>6y雎8.}Ko>k>{Cyr}_os|C7#/oq8ݺA·K?.uIuw^tU1/ǥB~}]zu1y靧ӷǥO_>CN_ܩSg9o!/ߟK??oǥ^ǥ[By_?]+'/tnǸvӾᘺӺA'ǥ;¥+.:.}{sKu^>ͺ<ǥ]YnqKt欷äKե}Y'1Ωĥ[Wեץn*~5/yt=uwts_uM楛Wd^}>tvny>s7b^}+6/ݾ2]u+¥wߋ.޼~/.xKތ}v) Wԥ{K:s\Й|C}sw:tS_C׹/.ؼ2ov.߭c'&}KO盗'/}]:῿3?.]7LK?u̸uҭK7Nn~.qwusԥ}t].ݾKte].?.1<}x3_qһXWKgvu;}vw]kåǥҩlwN]S3cޭs:?:wpӛӱ.d:uRqܬCZo9hN}/og|җS>9?{]:ucqյ?+\ ͷz]z~t_.|d]:yx]:y}vq鬓yɤ׼t?Oq:k\}bnyS>tS_ף]vǝN}AO]<|ps]/\ʏK9{݀|>/?޼;^.?/Ϻt>ywr:N;.[n=C>zK¼vqiѥ{K]6...]Ko.wץ|@ ..>vt.W}ο>~]:YwKץb~u~N;uӟO=ҷ7?uHw/۾SN _e\z;K\zK_KۨKw/_NM֣.wmt]9ҭ^o~qS֥|t鮓ǥb^L~Ziw7'] ҏיS?n>.ԥn.v]zSg]ءS^.ԩ]gv:ڥ:tq?.Qo75:uǝN}GY?1n|t|2^~u\ukK.9it:qe]ͼtɺus=KwKЭooߺs/n2+\SԥwR]1׭ۿw^S.:ut3cn?.]ťM<;;ļt]y?>o>uŸtۥǥ嘗~ۥץ.|c]{]X:]gKס+s?~r>y8z4.]Cw:uǹus]瓗>t|utÿKlǥҩү7]>yҧ߼z\D]vqC;\wmng1u~3~ƥGy8K.}o>}<ǥn}ѝq/:w|]K /uڥ?tڷq8ΘOїz\֣yqەo.߽ά.FKե?]+:\n_qK/йKK7y&|\t;r;?ys{K>zo緟JixKXW|8O:t'ºby?=.cu']0.}ҥpCzvqҥ{KF Kǽ KK;|v7>n/|ɼtK]:>=i~wqx\z߼toַs]:vc\8p/AM{j gW;4#ל%| l/K\{K^4cv2u|oc 맧KձԋVh}yi7v>eFu8؋aez_{q^߮ND]^^պ PDn@4|V'x;MVz^SNTidw߮-ˉK=^.^ڽXbxzlϮ8ոX:8e_mիi4ue&2<׭ OE0}޼^5^%^ZE)^}|zW^zgWůŠQ"tkRyK}^j˥#B0Q~ݢۇ.;/ ;M?AfQ25|^Fů{BVbo>_u_ԑ捉gŰŭ'ym° kc]8t#3]6\{]=kĘ v85*˭,|e&llyREˋАō(`y>bWχQET^{^::|}avPgxriG L]]nwvWKOKđ3Z*WYjC^:^Q]5Ϯ6~U*2enxO??tˍ3ln2jDAuQt&2^!]`\/(^kANu]ZXɥǭt:=/H1K!5Eb;xۯ I~lw筯"x`wS׽; 2}4G%ܓ5U0$=/=v㞇i뽛vs wB]Swk>֔~*UjF`ݽ۵IW+_)#-,˼w]Q^Zۘ2Z4d+Ķ|v^p- .S'Vv!]F4j!R $Ԟ:8i]QeO vmFS|&)/]S@$]ݯ>מ1NZ&6.#WL.|`vQeCF]tQS4k1S=xȞdί^= ƞ6y}S0:`|uȔ}i.VBaMĩVYK1eSv&j` u#ɛZ[7>Oezs٪ƺү]hެÈ{.ž.rы0[œ`Ϯ`65^.2ih y~s\ңP%K\z9g/aλ]Q{auMv0xK2Q> oym>7k WArRcD6φpW>濳ZΙ!Zyw5!͓!rL̵.!y^֓H2`5tq}F c8Z^IϠbK" s:0g#zy ^+yKORd[|$3U [Ώ?e9Y: Y'IM3/\)7GuۄU.Z}TcqVa*(*ÇSt ]7B\ @y<.<:/=ߣZ6/iC든m΁0VG^ԁs\XHoJ@r sƗG3\\׋c[D"ש^-"W6j. (BWKZ!L= @./.9r%QRˤ2']UqvukTj{rܵ8\|c5q%ez$dRqjSHck@c82>≮O}QVt|IY%x޼5 ^$|q_҆EWc:Tg| Rukrݘ⮜F*.} *7eJ&kS&FU&'60w0c˥Ck* ^.dH<#0⚦:||Cc=xA\ }PaÇB;z\#x6uup&Pa8<# R.U^phApJb2\sp_x okJ ^}=JTWZ W탣Qh@ OauK>_ 1%KpME[`6>kjw%ImFԁ7pvu8< C&PqcT-s ~_$ˤU h7Z@/̜pg]CK:][#PlGi3x'140E{l6&!ӢSpׂg 1DNK5N DvY`Ac*wG3F/ԯ_[0}/H@W#\&޷\-ܷ6w 滿 fE hS;<%}˅}ݏI=5U {w€|7Ʒ\b+ķoCŵmv^w{U`S|tG``x\wae\To[<)B4'*Z˓ykuovkxkzok" k;.[Jz)^ϓ ޚMc3W-{Rq3X=/rNw‚w^ݵkw4rXX[/;OoIT\9$_ɛfHZnot*pOs0=ގ-CHu-E?@HQ8]M-ߣ 2{6FJnIukxu~x[ܚZu?YJl&ɺx\ `VQ5D)?1V!uȝzkO 1ܚ]m[y!U5E_n>zzFu~­C ߴGr{<} n)H,vvw v?4>gFg(ivtxn0wEj5}.tɒ>[L/\=58fRG_-#yI.wmM)b>٢CM^HStd[dF`l# T\y9{tF^(6akMǧ&xWk_4vYB&ǵ$cKa[ܞw-css7y]vCi˕)S>ZWz1-RQh=_mj3Yw Zohg-gE%Y Y/}&L6%n.ہ))w^q&lv[ױfv޾8Ye_߂>׿hY{lvu][HHR>}SN;o?L9Q"ZW%NA,rYQ/R&=Xcc}X:t~b'hXͭ9ǭ)HfEbn@>c \Zݭ|?}g [B uq2 aE Vb-yok.Nms}%f?Һ+IevVWxW{Jju4/6^bWS:]80O?ts՜.*WUz)5\W-3Gxu^Yb2ëZozZʭ1j7y~RwzՒsHe"ӝ!}ۃ.'ehdW8ǫ^+RU1rT9xԫBPU}xƫx7jt=n= O{K'jxMxUkzU^4|6_WE _`,@Ma(R=Ͻ>ߴ<9}9Ukꜯ,ëF^~ӒuūݎW5*5«W5G{۔auDūk.gz)ë?Uw5m>fxzBϮS)StOקz~SUK{L >xK{r-)Rsռꖯë|S4BU-Uk@W / }xUk]^u-W}?SƫNx';zSG23z%l?xF,HpX0r2ǫjpfUWM?U T\մ<]xtyIb^xU~jC>iC:iԫ TWXWSoh{9?x ƫëƫ6^)~7y#^uӍ2fpaFTg >^2xUϓxU)Onj.Kz/W_$)!S{ܚK]n׫vU!P:xCT{@_WF$[:UKW}iǫ~cO{Ua֫jUU)'^:%LM/at y=ujxU}WW~[Wu}Pƫ5u3MU'e.H:˫NWWU+īNKWU&ѫ0V;ūJxxC7xZU=Qī<]xUޅ]|op73v*{S:rxWuīNW`nځϧūjnUi:z>}U]UI:aZpҾǫsU5xv?WES~uA}@5j]^aiĺc_x{W7#^u>Ky=OZNvU9Uߋ'/v;<3%OǥW7^'(ī 6:^UbW5Qj)^ū*Dq bxՍwڪtyս~47ONqk*{W/id^u*RJUY^Wj ^Uī ī:«v1F{S5$twyUXǫu#`JU]SKu^u/⓯OC_7v ~xU:^U W1ۺU4|UMë^5Eӂ+ 9>ݍj1Oav5Y!׃x:ց^] aU"ƫMW58 wz[SۜPХ^5L&2tVM W)r*U]xUsd9ur&xUra]{[ī>>U5\xU1 ^uezU۫rS,΢eAzUaګSq%|v]Og1L)neǫzf^5xUzՓ^j I2uUݴWQƫJBګnx+_}<*Nj[Loxݕ7Uwn{XHnMAwSDѦ 9|Nƫ6W5=^u+W50^Xs2,zxUsWVƫK}C_ƫeUW)HB]ij$ڠzوW/;^UzZ@'8A"5u`hU5G UU7iЫ]W~H >^{UU;L~rndh~pU1tOz|FWݧZ;L|j #ݨ^SqԬG"xUV/2%jZq+᳿ B+xUDC;)b?'G-ǫ·*^u:Wua*~ί^yUUW~ī';׎kfljI{wvn-QxUτa$^tOn}Ҷ$Pk\UmU;yሞūW }}SK!UxUS>!^^YP7Ut)5UsՆW:Z|#3F2iYB bX$*PQEhu`vSq%P7^u2=ߦ {UѾ$s=Wum jƫz1:WRqu}geW5Q*ǫ3ҫ*ǫ^FU^$)H~|%zUU]'xy52t~ ("47*?OxAͲ~E{W-U̻WxUOAUS*-*`RWS=Y!GB 7^3j׾U][IPڃUyUUëگW}Ly=y|5勃W-#U;{׫N嫡}UjīW4Kaī>燒2)~ULx/AkG򪍵tՍ-Dqy2Ѣ-ɣ},YīzZ7UIU?W/^Y_j/ZEcjמxծUY9WdlnūfxXqfYM& y@_iīv *,q빊U7|+RjUSYlTٚtxfzfϮgʻxTëzrë)pc@V7WTgLA^xꞡ|5=\մ>UUg1zUHĩƫW53^{ʄW}񪷸5^uxUϢzՍ@5jz9pZZxbzT!^u>'[A*Gu. \!a*OisT.Wm [wi*D6*zUqM꼌#~"5G:0Y= E{*z[9ƫW=EzUĢ^5Z ZjIm^UW+Z,WmY YIUdؿ]=.68fWPН;ʿ=~3d_ΙN o ^u^דWb_WO/+w͚\W=GE?76Hy7u[S}ܚ2)~!' W ޚ4Bm*x#We&jMCgǷ īzW}$t:y[_^I*kUYDZ2aiƦhNLǫ >ꔯT\ǫzW5:EK M99*r$L5+^5:|E7ifWfMkoMŵaWw9o#^;SxU;aW9U5=mNUī%oWm9%_ו}*Pty(#ӫJJ:jv5NJdQfDY 5v׫tWeR_zUQ<^2@u^'xPq,2Wh/E֓:pk(Z^xUxUVѫv( 聗]@ԋk~.MjZ^UWW}7,ƫ^zETjx~n[8=WEwn4]@xUoUkFk^zUJ7^uWNw%neW/_wl!x iDUO~DaU}y*pzAs>^u*4OZNGīL^JVOjn*Xūzl$ӯW_͚]uj:P5XkGg{o*Obmqiƫʔf;UT_[Ͻ ӫTW=_fM#V^xnUxU&ūZUO_YFW} 9" p5k"16pixUoU훯ZntOMxSʆW"Sj _/,^RN֞"u2xy«<#U5kZ0񪔸7Y0Ttk.7q++b5eNPMOd$qzj͝M8r+rYt[Hnm6Ÿ 0 2ƍʶ]U{AYuOޛ"o" #'TU6Z[,ͫg4,y4k]W-vVXP=[F«Ejp\WUWM@Ի<])= Z̍^tdzyX%t3ـLG_gxU?W l9 )=07a/nʱXʸ<6k}"C!pRͬ+Xꃑ@sWL:@j$WԅUCAD,oQaMWnK**(NMA_|rQFټ eU]qԼ%Uq8=Pɞʆ[E{NcU;Y: ^\p5 s2U`2WKQTíj0)^"$U9NT5s*ြVW|yՋ$xUW-D̫9y~Λ@`j77:mӕUg^j6x"L=W dֆyX @ȏΠzWs3%ΫZ(xUX iVumWE!xU z+ms[uT+}Uje}RYd:L*O^yUZcY uWMv*{-w"uAAGWMūaP4xՎ) `)O;jUo/^55zZ }E5Ql0Uu6,1=UGU7^5]f!3R0J 韐yU+n *U9s&jjY+yJՀjY̫:k^)NIW\3aW  _Qz቙RWMdLHsϥzT-.:LVb@WU/R/a }M:«fK6zUMcU7SG )v[v$ = TjD0WuWj 2«W6O!m)^@j78i}l}U#:*DQ?yc HB,* j`Une^tWuW-d¤ )^*hfNuTmyP#@ @UJp른zC_0 @_9 m}UIU&Z桯|:ɀ4ڷ)16V^K_U!^xq #`}Ut7U ͨydSkejKeӬt0&9"{*^ΩxU@xUk«zjoxa3߅Iūt }UW6rK_ oGx]U"T%"Z jq"^55jXXL": ֝W^ߞīЄu@=ن(*R'Tw0Mat˞ ^n+ȴHUWUͭW%o^5 `«h3UE{2[$^5U WT@IbU5COj(&vLuTk^5Xq*TW 1֌R0zH#*EͫDWmF2g@ yH5*h ^՘jy@ʷTUS77j}[[1L V!p9VU~㨒iV-ljyPj^ii[Mp[tY^!ſWSU{WԀW%^oͫfÏ'=={+%ټ**k Ȼ('dK (^u@XVoEW][ڍZc㫪M*5*96"n~ ^6oU@2U.xՐP?l -vc8U*m^+UCqT49=ǦE+^Dx4ū8WZ|H#*GW&ڬZ| 3E;J 1뫎%*Vò'u ΫZ^ZRT-l6uTP Ӏj[U"$J܄W%o}U3xVl^5Qȼƺ*xˉo5W%ļzx=Wx1/2oA_/b.¤Ϋօn'U)e}3yը۠OE0ëIX*bU= 6s8a|Uq`(U]^i(v3JL&RsUC (z.7^5 ^BZW9!8xվTŁͼ2`ͫV cZD0̫3 ?fgl+xUPoUșW ^5źs}; Z íJLՊ^՚,ͫE-Pxc\lpUɓ1hssT->g% jfＪ3kvs%O 2Լ*R4sD,U)þxռ׉W-]IΠzkTkǬSx3|H2zt ^4 z`6b-]AU~.sЃ2VW Si"\5K_5aU˼*WyUx[Xi`Tyb0Q婙H;Lێ&t W)}UW- wy]#Us^ÛAT~yUXūFj]^gxU OW-|4jgxbUjw~ڌ'7UHLpzΫLp΍WuNyՓ*^5 k<5ūaљ u[A_gWdZ<%"^vb7^5Ϋ:/ ^ZWՇ`xUU[d Uj}U4R3+d'Cū@_58x-<誐=uA=WYTeUu3K_&@EigrRݦPr*&T)O5L%bEw(:*Jꫜ@.tuǫWu}{xk!G_ˡ:Y-u^U-+^XNW=U0J-)tNKV ƶP?PUa|5OTK_J@s.k^E8XĔTAjxU «:>U5W6qNy2z j^oſwT)6X1%zǫz z-]j@^SRȋ-glW*x*eV*ͫWՔ ^UO eEQ x CGRdfJxU6~RBAUq`XיVW ^Ռx|ͫWmVnNy\j_IM[ ^XڬHfN& m𪮼'^"«VF;U@H*̫j5YP-K_j]jqh^2c{A& H Z,{z4PXFTKDxUyW܂W=ܖb&RbW }t[깘c[!ë^5NlS8'JJU6<(׽U'j>LwP'٤'k6zͭjWrƫW8WUkz5xU3 ނf"Hf4Y¼flj'UC25m UѢj1 jV*V]@2+i8+~& =O^5C_B%RQmh3R@WkKWmQ'1U2*@m^zW|\<$UW-wj|. ^4-UhjUΫ{}U(«I6i34kK^28HL&RUlPhF)B_yUJ]-^Qlyd'=]^5O]!1Ux,Z+!RTjVSƫb 2P4kIi8Ws1\jbz諒 o^l * K_Uj7T$ͫvq5b*UO WtI@㫷«k^vI,Ie|\?* yXռp0iuږ]HQ楠-xUsZVj'  a@UpxEW ּ*m g6UU +٤h^W+j9^{^5 mUMf a@UW~~Tƫ|ƫLur&؟t| /(S\?O?SŇC?'^c&(ܟSŇEs׋")C~z/ԗc~OAA)? Kɯu~Lz_??:O}/}-Lz?wWqGx|>$s^/uZ'w/>''ttzЏ$|^Ix:}+rKV,ef7o|s7?9 7^̔wojOW;'vT49g]#P؎IIvkR_b;fl'6v-c;'~9w<~LwfNv3M,)Mߟ{%YU#_j,04DX_m63mlMØxk>=1 v4)v4 IxY!i>2/VG&jXW} gE!59֮<vxx:#| a3"FjضWǬArljHq#GHܛG#KTl[pǫD"e_I?#@g=(< <_cTگaHUkoE*ݯp&Zx;˿;wԾ-.oʷ"}dVj{ABQu=L><&y-:.J=qe}ճxhx6h遁vp1P5ʱG:zTK)Tm4qQ@{h}\iUGO}p5#鞃z<REJ53V[T}nXc/1Suq]s18tcL%!cdi(7"5|Lu]{fw@3nvY?fWGk @n/N!{||ww?Ξ\iצ"%{_t7U[I.^ڦrǻr?4;m%=gw@v'3㶻:^u7\z]o>cwmY9c$?#ӮcjN]/);ȋZ\/,6endstream endobj 3 0 obj << /Type /Pages /Kids [ 7 0 R ] /Count 1 /MediaBox [0 0 612 828] >> endobj 4 0 obj << /ProcSet [/PDF /Text] /Font <> /ExtGState << >> /ColorSpace << /sRGB 5 0 R >> >> endobj 5 0 obj [/ICCBased 6 0 R] endobj 6 0 obj << /Alternate /DeviceRGB /N 3 /Length 2596 /Filter /FlateDecode >> stream xwTSϽ7PkhRH H.*1 J"6DTpDQ2(C"QDqpId߼y͛~kg}ֺLX Xňg` lpBF|،l *?Y"1P\8=W%Oɘ4M0J"Y2Vs,[|e92<se'9`2&ctI@o|N6(.sSdl-c(2-yH_/XZ.$&\SM07#1ؙYrfYym";8980m-m(]v^DW~ emi]P`/u}q|^R,g+\Kk)/C_|Rax8t1C^7nfzDp 柇u$/ED˦L L[B@ٹЖX!@~(* {d+} G͋љς}WL$cGD2QZ4 E@@A(q`1D `'u46ptc48.`R0) @Rt CXCP%CBH@Rf[(t CQhz#0 Zl`O828.p|O×X ?:0FBx$ !i@ڐH[EE1PL ⢖V6QP>U(j MFkt,:.FW8c1L&ӎ9ƌaX: rbl1 {{{;}#tp8_\8"Ey.,X%%Gщ1-9ҀKl.oo/O$&'=JvMޞxǥ{=Vs\x ‰N柜>ucKz=s/ol|ϝ?y ^d]ps~:;/;]7|WpQoH!ɻVsnYs}ҽ~4] =>=:`;cܱ'?e~!ańD#G&}'/?^xI֓?+\wx20;5\ӯ_etWf^Qs-mw3+?~O~endstream endobj 9 0 obj << /Type /Encoding /BaseEncoding /WinAnsiEncoding /Differences [ 45/minus ] >> endobj 10 0 obj << /Type /Font /Subtype /Type1 /Name /F7 /BaseFont /Times-Roman /Encoding 9 0 R >> endobj xref 0 11 0000000000 65535 f 0000000021 00000 n 0000000163 00000 n 0000233322 00000 n 0000233405 00000 n 0000233517 00000 n 0000233550 00000 n 0000000212 00000 n 0000000292 00000 n 0000236245 00000 n 0000236339 00000 n trailer << /Size 11 /Info 1 0 R /Root 2 0 R >> startxref 236438 %%EOF brms/vignettes/brms_families.Rmd0000644000176200001440000003401714275414730016521 0ustar liggesusers--- title: "Parameterization of Response Distributions in brms" author: "Paul Bürkner" date: "`r Sys.Date()`" output: rmarkdown::html_vignette: toc: yes vignette: > %\VignetteIndexEntry{Parameterization of Response Distributions in brms} %\VignetteEngine{knitr::rmarkdown} \usepackage[utf8]{inputenc} --- The purpose of this vignette is to discuss the parameterizations of the families (i.e., response distributions) used in brms. For a more general overview of the package see `vignette("brms_overview")`. ## Notation Throughout this vignette, we denote values of the response variable as $y$, a density function as $f$, and use $\mu$ to refer to the main model parameter, which is usually the mean of the response distribution or some closely related quantity. In a regression framework, $\mu$ is not estimated directly but computed as $\mu = g(\eta)$, where $\eta$ is a predictor term (see `help(brmsformula)` for details) and $g$ is the response function (i.e., inverse of the link function). ## Location shift models The density of the **gaussian** family is given by $$ f(y) = \frac{1}{\sqrt{2\pi}\sigma} \exp\left(-\frac{1}{2}\left(\frac{y - \mu}{\sigma}\right)^2\right) $$ where $\sigma$ is the residual standard deviation. The density of the **student** family is given by $$ f(y) = \frac{\Gamma((\nu + 1)/2)}{\Gamma(\nu/2)} \frac{1}{\sqrt{\nu\pi}\sigma}\left(1 + \frac{1}{\nu} \left(\frac{y - \mu}{\sigma}\right)^2\right)^{-(\nu+1)/2} $$ $\Gamma$ denotes the gamma function and $\nu > 1$ are the degrees of freedom. As $\nu \rightarrow \infty$, the student distribution becomes the gaussian distribution. The density of the **skew_normal** family is given by $$ f(y) = \frac{1}{\sqrt{2\pi}\omega} \exp\left(-\frac{1}{2} \left(\frac{y - \xi}{\omega}\right)^2 \right) \left(1 + \text{erf} \left( \alpha \left(\frac{y - \xi}{\omega \sqrt{2}} \right) \right) \right) $$ where $\xi$ is the location parameter, $\omega$ is the positive scale parameter, $\alpha$ the skewness parameter, and $\text{erf}$ denotes the error function of the gaussian distribution. To parameterize the skew-normal distribution in terms of the mean $\mu$ and standard deviation $\sigma$, $\omega$ and $\xi$ are computed as $$ \omega = \frac{\sigma}{\sqrt{1 - \frac{2}{\pi} \frac{\alpha^2}{1 + \alpha^2}}} $$ $$ \xi = \mu - \omega \frac{\alpha}{\sqrt{1 + \alpha^2}} \sqrt{\frac{2}{\pi}} $$ If $\alpha = 0$, the skew-normal distribution becomes the gaussian distribution. For location shift models, $y$ can be any real value. ## Binary and count data models The density of the **binomial** family is given by $$ f(y) = {N \choose y} \mu^{y} (1-\mu)^{N - y} $$ where $N$ is the number of trials and $y \in \{0, ... , N\}$. When all $N$ are $1$ (i.e., $y \in \{0,1\}$), the **bernoulli** distribution for binary data arises. For $y \in \mathbb{N}_0$, the density of the **poisson** family is given by $$ f(y) = \frac{\mu^{y}}{y!} \exp(-\mu) $$ The density of the **negbinomial** (negative binomial) family is $$ f(y) = {y + \phi - 1 \choose y} \left(\frac{\mu}{\mu + \phi}\right)^{y} \left(\frac{\phi}{\mu + \phi}\right)^\phi $$ where $\phi$ is a positive precision parameter. For $\phi \rightarrow \infty$, the negative binomial distribution becomes the poisson distribution. The density of the **geometric** family arises if $\phi$ is set to $1$. ## Time-to-event models With time-to-event models we mean all models that are defined on the positive reals only, that is $y \in \mathbb{R}^+$. The density of the **lognormal** family is given by $$ f(y) = \frac{1}{\sqrt{2\pi}\sigma y} \exp\left(-\frac{1}{2}\left(\frac{\log(y) - \mu}{\sigma}\right)^2\right) $$ where $\sigma$ is the residual standard deviation on the log-scale. The density of the **Gamma** family is given by $$ f(y) = \frac{(\alpha / \mu)^\alpha}{\Gamma(\alpha)} y^{\alpha-1} \exp\left(-\frac{\alpha y}{\mu}\right) $$ where $\alpha$ is a positive shape parameter. The density of the **weibull** family is given by $$ f(y) = \frac{\alpha}{s} \left(\frac{y}{s}\right)^{\alpha-1} \exp\left(-\left(\frac{y}{s}\right)^\alpha\right) $$ where $\alpha$ is again a positive shape parameter and $s = \mu / \Gamma(1 + 1 / \alpha)$ is the scale parameter to that $\mu$ is the mean of the distribution. The **exponential** family arises if $\alpha$ is set to $1$ for either the gamma or Weibull distribution. The density of the **inverse.gaussian** family is given by $$ f(y) = \left(\frac{\alpha}{2 \pi y^3}\right)^{1/2} \exp \left(\frac{-\alpha (y - \mu)^2}{2 \mu^2 y} \right) $$ where $\alpha$ is a positive shape parameter. The **cox** family implements Cox proportional hazards model which assumes a hazard function of the form $h(y) = h_0(y) \mu$ with baseline hazard $h_0(y)$ expressed via M-splines (which integrate to I-splines) in order to ensure monotonicity. The density of the cox model is then given by $$ f(y) = h(y) S(y) $$ where $S(y)$ is the survival function implied by $h(y)$. ## Extreme value models Modeling extremes requires special distributions. One may use the **weibull** distribution (see above) or the **frechet** distribution with density $$ f(y) = \frac{\nu}{s} \left(\frac{y}{s}\right)^{-1-\nu} \exp\left(-\left(\frac{y}{s}\right)^{-\nu}\right) $$ where $s = \mu / \Gamma(1 - 1 / \nu)$ is a positive scale parameter and $\nu > 1$ is a shape parameter so that $\mu$ predicts the mean of the Frechet distribution. A generalization of both distributions is the generalized extreme value distribution (family **gen_extreme_value**) with density $$ f(y) = \frac{1}{\sigma} t(y)^{\xi + 1} \exp(-t(y)) $$ where $$ t(y) = \left(1 + \xi \left(\frac{y - \mu}{\sigma} \right)\right)^{-1 / \xi} $$ with positive scale parameter $\sigma$ and shape parameter $\xi$. ## Response time models One family that is especially suited to model reaction times is the **exgaussian** ('exponentially modified Gaussian') family. Its density is given by $$ f(y) = \frac{1}{2 \beta} \exp\left(\frac{1}{2 \beta} \left(2\xi + \sigma^2 / \beta - 2 y \right) \right) \text{erfc}\left(\frac{\xi + \sigma^2 / \beta - y}{\sqrt{2} \sigma} \right) $$ where $\beta$ is the scale (inverse rate) of the exponential component, $\xi$ is the mean of the Gaussian component, $\sigma$ is the standard deviation of the Gaussian component, and $\text{erfc}$ is the complementary error function. We parameterize $\mu = \xi + \beta$ so that the main predictor term equals the mean of the distribution. Another family well suited for modeling response times is the **shifted_lognormal** distribution. It's density equals that of the **lognormal** distribution except that the whole distribution is shifted to the right by a positive parameter called *ndt* (for consistency with the **wiener** diffusion model explained below). A family concerned with the combined modeling of reaction times and corresponding binary responses is the **wiener** diffusion model. It has four model parameters each with a natural interpretation. The parameter $\alpha > 0$ describes the separation between two boundaries of the diffusion process, $\tau > 0$ describes the non-decision time (e.g., due to image or motor processing), $\beta \in [0, 1]$ describes the initial bias in favor of the upper alternative, and $\delta \in \mathbb{R}$ describes the drift rate to the boundaries (a positive value indicates a drift towards to upper boundary). The density for the reaction time at the upper boundary is given by $$ f(y) = \frac{\alpha}{(y-\tau)^3/2} \exp \! \left(- \delta \alpha \beta - \frac{\delta^2(y-\tau)}{2}\right) \sum_{k = - \infty}^{\infty} (2k + \beta) \phi \! \left(\frac{2k + \alpha \beta}{\sqrt{y - \tau}}\right) $$ where $\phi(x)$ denotes the standard normal density function. The density at the lower boundary can be obtained by substituting $1 - \beta$ for $\beta$ and $-\delta$ for $\delta$ in the above equation. In brms the parameters $\alpha$, $\tau$, and $\beta$ are modeled as auxiliary parameters named *bs* ('boundary separation'), *ndt* ('non-decision time'), and *bias* respectively, whereas the drift rate $\delta$ is modeled via the ordinary model formula that is as $\delta = \mu$. ## Quantile regression Quantile regression is implemented via family **asym_laplace** (asymmetric Laplace distribution) with density $$ f(y) = \frac{p (1 - p)}{\sigma} \exp\left(-\rho_p\left(\frac{y - \mu}{\sigma}\right)\right) $$ where $\rho_p$ is given by $\rho_p(x) = x (p - I_{x < 0})$ and $I_A$ is the indicator function of set $A$. The parameter $\sigma$ is a positive scale parameter and $p$ is the *quantile* parameter taking on values in $(0, 1)$. For this distribution, we have $P(Y < g(\eta)) = p$. Thus, quantile regression can be performed by fixing $p$ to the quantile to interest. ## Probability models The density of the **Beta** family for $y \in (0,1)$ is given by $$ f(y) = \frac{y^{\mu \phi - 1} (1-y)^{(1-\mu) \phi-1}}{B(\mu \phi, (1-\mu) \phi)} $$ where $B$ is the beta function and $\phi$ is a positive precision parameter. A multivariate generalization of the **Beta** family is the **dirichlet** family with density $$ f(y) = \frac{1}{B((\mu_{1}, \ldots, \mu_{K}) \phi)} \prod_{k=1}^K y_{k}^{\mu_{k} \phi - 1}. $$ The **dirichlet** family is implemented with the multivariate logit link function so that $$ \mu_{j} = \frac{\exp(\eta_{j})}{\sum_{k = 1}^{K} \exp(\eta_{k})} $$ For reasons of identifiability, $\eta_{\rm ref}$ is set to $0$, where ${\rm ref}$ is one of the response categories chosen as reference. An alternative to the **dirichlet** family is the **logistic_normal** family with density $$ f(y) = \frac{1}{\prod_{k=1}^K y_k} \times \text{multivariate_normal}(\tilde{y} \, | \, \mu, \sigma, \Omega) $$ where $\tilde{y}$ is the multivariate logit transformed response $$ \tilde{y} = (\log(y_1 / y_{\rm ref}), \ldots, \log(y_{\rm ref-1} / y_{\rm ref}), \log(y_{\rm ref+1} / y_{\rm ref}), \ldots, \log(y_K / y_{\rm ref})) $$ of dimension $K-1$ (excluding the reference category), which is modeled as multivariate normally distributed with latent mean and standard deviation vectors $\mu$ and $\sigma$, as well as correlation matrix $\Omega$. ## Circular models The density of the **von_mises** family for $y \in (-\pi,\pi)$ is given by $$ f(y) = \frac{\exp(\kappa \cos(y - \mu))}{2\pi I_0(\kappa)} $$ where $I_0$ is the modified Bessel function of order 0 and $\kappa$ is a positive precision parameter. ## Ordinal and categorical models For ordinal and categorical models, $y$ is one of the categories $1, ..., K$. The intercepts of ordinal models are called thresholds and are denoted as $\tau_k$, with $k \in \{1, ..., K-1\}$, whereas $\eta$ does not contain a fixed effects intercept. Note that the applied link functions $h$ are technically distribution functions $\mathbb{R} \rightarrow [0,1]$. The density of the **cumulative** family (implementing the most basic ordinal model) is given by $$ f(y) = g(\tau_{y + 1} - \eta) - g(\tau_{y} - \eta) $$ The densities of the **sratio** (stopping ratio) and **cratio** (continuation ratio) families are given by $$ f(y) = g(\tau_{y + 1} - \eta) \prod_{k = 1}^{y} (1 - g(\tau_{k} - \eta)) $$ and $$ f(y) = (1 - g(\eta - \tau_{y + 1})) \prod_{k = 1}^{y} g(\eta - \tau_{k}) $$ respectively. Note that both families are equivalent for symmetric link functions such as logit or probit. The density of the **acat** (adjacent category) family is given by $$ f(y) = \frac{\prod_{k=1}^{y} g(\eta - \tau_{k}) \prod_{k=y+1}^K(1-g(\eta - \tau_{k}))}{\sum_{k=0}^K\prod_{j=1}^k g(\eta-\tau_{j}) \prod_{j=k+1}^K(1-g(\eta - \tau_{j}))} $$ For the logit link, this can be simplified to $$ f(y) = \frac{\exp \left(\sum_{k=1}^{y} (\eta - \tau_{k}) \right)} {\sum_{k=0}^K \exp\left(\sum_{j=1}^k (\eta - \tau_{j}) \right)} $$ The linear predictor $\eta$ can be generalized to also depend on the category $k$ for a subset of predictors. This leads to category specific effects (for details on how to specify them see `help(brm)`). Note that **cumulative** and **sratio** models use $\tau - \eta$, whereas **cratio** and **acat** use $\eta - \tau$. This is done to ensure that larger values of $\eta$ increase the probability of *higher* response categories. The **categorical** family is currently only implemented with the multivariate logit link function and has density $$ f(y) = \mu_{y} = \frac{\exp(\eta_{y})}{\sum_{k = 1}^{K} \exp(\eta_{k})} $$ Note that $\eta$ does also depend on the category $k$. For reasons of identifiability, $\eta_{1}$ is set to $0$. A generalization of the **categorical** family to more than one trial is the **multinomial** family with density $$ f(y) = {N \choose y_{1}, y_{2}, \ldots, y_{K}} \prod_{k=1}^K \mu_{k}^{y_{k}} $$ where, for each category, $\mu_{k}$ is estimated via the multivariate logit link function shown above. ## Zero-inflated and hurdle models **Zero-inflated** and **hurdle** families extend existing families by adding special processes for responses that are zero. The density of a **zero-inflated** family is given by $$ f_z(y) = z + (1 - z) f(0) \quad \text{if } y = 0 \\ f_z(y) = (1 - z) f(y) \quad \text{if } y > 0 $$ where $z$ denotes the zero-inflation probability. Currently implemented families are **zero_inflated_poisson**, **zero_inflated_binomial**, **zero_inflated_negbinomial**, and **zero_inflated_beta**. The density of a **hurdle** family is given by $$ f_z(y) = z \quad \text{if } y = 0 \\ f_z(y) = (1 - z) f(y) / (1 - f(0)) \quad \text{if } y > 0 $$ Currently implemented families are **hurdle_poisson**, **hurdle_negbinomial**, **hurdle_gamma**, and **hurdle_lognormal**. The density of a **zero-one-inflated** family is given by $$ f_{\alpha, \gamma}(y) = \alpha (1 - \gamma) \quad \text{if } y = 0 \\ f_{\alpha, \gamma}(y) = \alpha \gamma \quad \text{if } y = 1 \\ f_{\alpha, \gamma}(y) = (1 - \alpha) f(y) \quad \text{if } y \notin \{0, 1\} $$ where $\alpha$ is the zero-one-inflation probability (i.e. the probability that zero or one occurs) and $\gamma$ is the conditional one-inflation probability (i.e. the probability that one occurs rather than zero). Currently implemented families are **zero_one_inflated_beta**. brms/vignettes/brms_monotonic.Rmd0000644000176200001440000002057315053072461016733 0ustar liggesusers--- title: "Estimating Monotonic Effects with brms" author: "Paul Bürkner" date: "`r Sys.Date()`" output: rmarkdown::html_vignette: toc: yes vignette: > %\VignetteIndexEntry{Estimating Monotonic Effects with brms} %\VignetteEngine{knitr::rmarkdown} \usepackage[utf8]{inputenc} params: EVAL: !r identical(Sys.getenv("NOT_CRAN"), "true") --- ```{r, SETTINGS-knitr, include=FALSE} stopifnot(require(knitr)) options(width = 90) knit_hooks$set(pngquant = knitr::hook_pngquant) opts_chunk$set( comment = NA, message = FALSE, warning = FALSE, eval = if (isTRUE(exists("params"))) params$EVAL else FALSE, dev = "ragg_png", dpi = 72, fig.retina = 1.5, fig.asp = 0.8, fig.width = 5, out.width = "60%", fig.align = "center", pngquant = "--speed=1 --quality=50" ) library(brms) ggplot2::theme_set(theme_default()) ``` ## Introduction This vignette is about monotonic effects, a special way of handling discrete predictors that are on an ordinal or higher scale (Bürkner & Charpentier, in review). A predictor, which we want to model as monotonic (i.e., having a monotonically increasing or decreasing relationship with the response), must either be integer valued or an ordered factor. As opposed to a continuous predictor, predictor categories (or integers) are not assumed to be equidistant with respect to their effect on the response variable. Instead, the distance between adjacent predictor categories (or integers) is estimated from the data and may vary across categories. This is realized by parameterizing as follows: One parameter, $b$, takes care of the direction and size of the effect similar to an ordinary regression parameter. If the monotonic effect is used in a linear model, $b$ can be interpreted as the expected average difference between two adjacent categories of the ordinal predictor. An additional parameter vector, $\zeta$, estimates the normalized distances between consecutive predictor categories which thus defines the shape of the monotonic effect. For a single monotonic predictor, $x$, the linear predictor term of observation $n$ looks as follows: $$\eta_n = b D \sum_{i = 1}^{x_n} \zeta_i$$ The parameter $b$ can take on any real value, while $\zeta$ is a simplex, which means that it satisfies $\zeta_i \in [0,1]$ and $\sum_{i = 1}^D \zeta_i = 1$ with $D$ being the number of elements of $\zeta$. Equivalently, $D$ is the number of categories (or highest integer in the data) minus 1, since we start counting categories from zero to simplify the notation. ## A Simple Monotonic Model A main application of monotonic effects are ordinal predictors that can be modeled this way without falsely treating them either as continuous or as unordered categorical predictors. In Psychology, for instance, this kind of data is omnipresent in the form of Likert scale items, which are often treated as being continuous for convenience without ever testing this assumption. As an example, suppose we are interested in the relationship of yearly income (in $) and life satisfaction measured on an arbitrary scale from 0 to 100. Usually, people are not asked for the exact income. Instead, they are asked to rank themselves in one of certain classes, say: 'below 20k', 'between 20k and 40k', 'between 40k and 100k' and 'above 100k'. We use some simulated data for illustration purposes. ```{r} income_options <- c("below_20", "20_to_40", "40_to_100", "greater_100") income <- factor(sample(income_options, 100, TRUE), levels = income_options, ordered = TRUE) mean_ls <- c(30, 60, 70, 75) ls <- mean_ls[income] + rnorm(100, sd = 7) dat <- data.frame(income, ls) ``` We now proceed with analyzing the data modeling `income` as a monotonic effect. ```{r, results='hide'} fit1 <- brm(ls ~ mo(income), data = dat) ``` The summary methods yield ```{r} summary(fit1) plot(fit1, variable = "simo", regex = TRUE) plot(conditional_effects(fit1)) ``` The distributions of the simplex parameter of `income`, as shown in the `plot` method, demonstrate that the largest difference (about 70% of the difference between minimum and maximum category) is between the first two categories. Now, let's compare of monotonic model with two common alternative models. (a) Assume `income` to be continuous: ```{r, results='hide'} dat$income_num <- as.numeric(dat$income) fit2 <- brm(ls ~ income_num, data = dat) ``` ```{r} summary(fit2) ``` or (b) Assume `income` to be an unordered factor: ```{r, results='hide'} contrasts(dat$income) <- contr.treatment(4) fit3 <- brm(ls ~ income, data = dat) ``` ```{r} summary(fit3) ``` We can easily compare the fit of the three models using leave-one-out cross-validation. ```{r} loo(fit1, fit2, fit3) ``` The monotonic model fits better than the continuous model, which is not surprising given that the relationship between `income` and `ls` is non-linear. The monotonic and the unordered factor model have almost identical fit in this example, but this may not be the case for other data sets. ## Setting Prior Distributions In the previous monotonic model, we have implicitly assumed that all differences between adjacent categories were a-priori the same, or formulated correctly, had the same prior distribution. In the following, we want to show how to change this assumption. The canonical prior distribution of a simplex parameter is the Dirichlet distribution, a multivariate generalization of the beta distribution. It is non-zero for all valid simplexes (i.e., $\zeta_i \in [0,1]$ and $\sum_{i = 1}^D \zeta_i = 1$) and zero otherwise. The Dirichlet prior has a single parameter $\alpha$ of the same length as $\zeta$. The higher $\alpha_i$ the higher the a-priori probability of higher values of $\zeta_i$. Suppose that, before looking at the data, we expected that the same amount of additional money matters more for people who generally have less money. This translates into a higher a-priori values of $\zeta_1$ (difference between 'below_20' and '20_to_40') and hence into higher values of $\alpha_1$. We choose $\alpha_1 = 2$ and $\alpha_2 = \alpha_3 = 1$, the latter being the default value of $\alpha$. To fit the model we write: ```{r, results='hide'} prior4 <- prior(dirichlet(c(2, 1, 1)), class = "simo", coef = "moincome1") fit4 <- brm(ls ~ mo(income), data = dat, prior = prior4, sample_prior = TRUE) ``` The `1` at the end of `"moincome1"` may appear strange when first working with monotonic effects. However, it is necessary as one monotonic term may be associated with multiple simplex parameters, if interactions of multiple monotonic variables are included in the model. ```{r} summary(fit4) ``` We have used `sample_prior = TRUE` to also obtain draws from the prior distribution of `simo_moincome1` so that we can visualized it. ```{r} plot(fit4, variable = "prior_simo", regex = TRUE, N = 3) ``` As is visible in the plots, `simo_moincome1[1]` was a-priori on average twice as high as `simo_moincome1[2]` and `simo_moincome1[3]` as a result of setting $\alpha_1$ to 2. ## Modeling interactions of monotonic variables Suppose, we have additionally asked participants for their age. ```{r} dat$age <- rnorm(100, mean = 40, sd = 10) ``` We are not only interested in the main effect of age but also in the interaction of income and age. Interactions with monotonic variables can be specified in the usual way using the `*` operator: ```{r, results='hide'} fit5 <- brm(ls ~ mo(income)*age, data = dat) ``` ```{r} summary(fit5) conditional_effects(fit5, "income:age") ``` ## Modelling Monotonic Group-Level Effects Suppose that the 100 people in our sample data were drawn from 10 different cities; 10 people per city. Thus, we add an identifier for `city` to the data and add some city-related variation to `ls`. ```{r} dat$city <- rep(1:10, each = 10) var_city <- rnorm(10, sd = 10) dat$ls <- dat$ls + var_city[dat$city] ``` With the following code, we fit a multilevel model assuming the intercept and the effect of `income` to vary by city: ```{r, results='hide'} fit6 <- brm(ls ~ mo(income)*age + (mo(income) | city), data = dat) ``` ```{r} summary(fit6) ``` reveals that the effect of `income` varies only little across cities. For the present data, this is not overly surprising given that, in the data simulations, we assumed `income` to have the same effect across cities. ## References Bürkner P. C. & Charpentier, E. (in review). [Monotonic Effects: A Principled Approach for Including Ordinal Predictors in Regression Models](https://osf.io/preprints/psyarxiv/9qkhj/). *PsyArXiv preprint*. brms/vignettes/brms_multivariate.Rmd0000644000176200001440000002025315053072461017427 0ustar liggesusers--- title: "Estimating Multivariate Models with brms" author: "Paul Bürkner" date: "`r Sys.Date()`" output: rmarkdown::html_vignette: toc: yes vignette: > %\VignetteIndexEntry{Estimating Multivariate Models with brms} %\VignetteEngine{knitr::rmarkdown} \usepackage[utf8]{inputenc} params: EVAL: !r identical(Sys.getenv("NOT_CRAN"), "true") --- ```{r, SETTINGS-knitr, include=FALSE} stopifnot(require(knitr)) options(width = 90) knit_hooks$set(pngquant = knitr::hook_pngquant) opts_chunk$set( comment = NA, message = FALSE, warning = FALSE, eval = if (isTRUE(exists("params"))) params$EVAL else FALSE, dev = "ragg_png", dpi = 72, fig.retina = 1.5, fig.asp = 0.8, fig.width = 5, out.width = "60%", fig.align = "center", pngquant = "--speed=1 --quality=50" ) library(brms) ggplot2::theme_set(theme_default()) ``` ## Introduction In the present vignette, we want to discuss how to specify multivariate multilevel models using **brms**. We call a model *multivariate* if it contains multiple response variables, each being predicted by its own set of predictors. Consider an example from biology. Hadfield, Nutall, Osorio, and Owens (2007) analyzed data of the Eurasian blue tit (https://en.wikipedia.org/wiki/Eurasian_blue_tit). They predicted the `tarsus` length as well as the `back` color of chicks. Half of the brood were put into another `fosternest`, while the other half stayed in the fosternest of their own `dam`. This allows to separate genetic from environmental factors. Additionally, we have information about the `hatchdate` and `sex` of the chicks (the latter being known for 94\% of the animals). ```{r data} data("BTdata", package = "MCMCglmm") head(BTdata) ``` ## Basic Multivariate Models We begin with a relatively simple multivariate normal model. ```{r fit1, message=FALSE, warning=FALSE, results='hide'} bform1 <- bf(mvbind(tarsus, back) ~ sex + hatchdate + (1|p|fosternest) + (1|q|dam)) + set_rescor(TRUE) fit1 <- brm(bform1, data = BTdata, chains = 2, cores = 2) ``` As can be seen in the model code, we have used `mvbind` notation to tell **brms** that both `tarsus` and `back` are separate response variables. The term `(1|p|fosternest)` indicates a varying intercept over `fosternest`. By writing `|p|` in between we indicate that all varying effects of `fosternest` should be modeled as correlated. This makes sense since we actually have two model parts, one for `tarsus` and one for `back`. The indicator `p` is arbitrary and can be replaced by other symbols that comes into your mind (for details about the multilevel syntax of **brms**, see `help("brmsformula")` and `vignette("brms_multilevel")`). Similarly, the term `(1|q|dam)` indicates correlated varying effects of the genetic mother of the chicks. Alternatively, we could have also modeled the genetic similarities through pedigrees and corresponding relatedness matrices, but this is not the focus of this vignette (please see `vignette("brms_phylogenetics")`). The model results are readily summarized via ```{r summary1, warning=FALSE} fit1 <- add_criterion(fit1, "loo") summary(fit1) ``` The summary output of multivariate models closely resembles those of univariate models, except that the parameters now have the corresponding response variable as prefix. Across dams, tarsus length and back color seem to be negatively correlated, while across fosternests the opposite is true. This indicates differential effects of genetic and environmental factors on these two characteristics. Further, the small residual correlation `rescor(tarsus, back)` on the bottom of the output indicates that there is little unmodeled dependency between tarsus length and back color. Although not necessary at this point, we have already computed and stored the LOO information criterion of `fit1`, which we will use for model comparisons. Next, let's take a look at some posterior-predictive checks, which give us a first impression of the model fit. ```{r pp_check1, message=FALSE} pp_check(fit1, resp = "tarsus") pp_check(fit1, resp = "back") ``` This looks pretty solid, but we notice a slight unmodeled left skewness in the distribution of `tarsus`. We will come back to this later on. Next, we want to investigate how much variation in the response variables can be explained by our model and we use a Bayesian generalization of the $R^2$ coefficient. ```{r R2_1} bayes_R2(fit1) ``` Clearly, there is much variation in both animal characteristics that we can not explain, but apparently we can explain more of the variation in tarsus length than in back color. ## More Complex Multivariate Models Now, suppose we only want to control for `sex` in `tarsus` but not in `back` and vice versa for `hatchdate`. Not that this is particular reasonable for the present example, but it allows us to illustrate how to specify different formulas for different response variables. We can no longer use `mvbind` syntax and so we have to use a more verbose approach: ```{r fit2, message=FALSE, warning=FALSE, results='hide'} bf_tarsus <- bf(tarsus ~ sex + (1|p|fosternest) + (1|q|dam)) bf_back <- bf(back ~ hatchdate + (1|p|fosternest) + (1|q|dam)) fit2 <- brm(bf_tarsus + bf_back + set_rescor(TRUE), data = BTdata, chains = 2, cores = 2) ``` Note that we have literally *added* the two model parts via the `+` operator, which is in this case equivalent to writing `mvbf(bf_tarsus, bf_back)`. See `help("brmsformula")` and `help("mvbrmsformula")` for more details about this syntax. Again, we summarize the model first. ```{r summary2, warning=FALSE} fit2 <- add_criterion(fit2, "loo") summary(fit2) ``` Let's find out, how model fit changed due to excluding certain effects from the initial model: ```{r loo12} loo(fit1, fit2) ``` Apparently, there is no noteworthy difference in the model fit. Accordingly, we do not really need to model `sex` and `hatchdate` for both response variables, but there is also no harm in including them (so I would probably just include them). To give you a glimpse of the capabilities of **brms**' multivariate syntax, we change our model in various directions at the same time. Remember the slight left skewness of `tarsus`, which we will now model by using the `skew_normal` family instead of the `gaussian` family. Since we do not have a multivariate normal (or student-t) model, anymore, estimating residual correlations is no longer possible. We make this explicit using the `set_rescor` function. Further, we investigate if the relationship of `back` and `hatchdate` is really linear as previously assumed by fitting a non-linear spline of `hatchdate`. On top of it, we model separate residual variances of `tarsus` for male and female chicks. ```{r fit3, message=FALSE, warning=FALSE, results='hide'} bf_tarsus <- bf(tarsus ~ sex + (1|p|fosternest) + (1|q|dam)) + lf(sigma ~ 0 + sex) + skew_normal() bf_back <- bf(back ~ s(hatchdate) + (1|p|fosternest) + (1|q|dam)) + gaussian() fit3 <- brm( bf_tarsus + bf_back + set_rescor(FALSE), data = BTdata, chains = 2, cores = 2, control = list(adapt_delta = 0.95) ) ``` Again, we summarize the model and look at some posterior-predictive checks. ```{r summary3, warning=FALSE} fit3 <- add_criterion(fit3, "loo") summary(fit3) ``` We see that the (log) residual standard deviation of `tarsus` is somewhat larger for chicks whose sex could not be identified as compared to male or female chicks. Further, we see from the negative `alpha` (skewness) parameter of `tarsus` that the residuals are indeed slightly left-skewed. Lastly, running ```{r me3} conditional_effects(fit3, "hatchdate", resp = "back") ``` reveals a non-linear relationship of `hatchdate` on the `back` color, which seems to change in waves over the course of the hatch dates. There are many more modeling options for multivariate models, which are not discussed in this vignette. Examples include autocorrelation structures, Gaussian processes, or explicit non-linear predictors (e.g., see `help("brmsformula")` or `vignette("brms_multilevel")`). In fact, nearly all the flexibility of univariate models is retained in multivariate models. ## References Hadfield JD, Nutall A, Osorio D, Owens IPF (2007). Testing the phenotypic gambit: phenotypic, genetic and environmental correlations of colour. *Journal of Evolutionary Biology*, 20(2), 549-557. brms/vignettes/brms_multilevel.ltx0000644000176200001440000016555114213413565017204 0ustar liggesusers\documentclass[article, nojss]{jss} %\VignetteIndexEntry{Multilevel Models with brms} %\VignetteEngine{R.rsp::tex} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %% declarations for jss.cls %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %% almost as usual \author{Paul-Christian B\"urkner} \title{Advanced Bayesian Multilevel Modeling with the \proglang{R} Package \pkg{brms}} %% for pretty printing and a nice hypersummary also set: \Plainauthor{Paul-Christian B\"urkner} %% comma-separated \Plaintitle{Advanced Bayesian Multilevel Modeling with the R Package brms} %% without formatting \Shorttitle{Advanced Bayesian Multilevel Modeling with \pkg{brms}} %% a short title (if necessary) %% an abstract and keywords \Abstract{ The \pkg{brms} package allows R users to easily specify a wide range of Bayesian single-level and multilevel models, which are fitted with the probabilistic programming language \proglang{Stan} behind the scenes. Several response distributions are supported, of which all parameters (e.g., location, scale, and shape) can be predicted at the same time thus allowing for distributional regression. Non-linear relationships may be specified using non-linear predictor terms or semi-parametric approaches such as splines or Gaussian processes. Multivariate models, in which each response variable can be predicted using the above mentioned options, can be fitted as well. To make all of these modeling options possible in a multilevel framework, \pkg{brms} provides an intuitive and powerful formula syntax, which extends the well known formula syntax of \pkg{lme4}. The purpose of the present paper is to introduce this syntax in detail and to demonstrate its usefulness with four examples, each showing other relevant aspects of the syntax. If you use \pkg{brms}, please cite this article as published in the R Journal \citep{brms2}. } \Keywords{Bayesian inference, multilevel models, distributional regression, MCMC, \proglang{Stan}, \proglang{R}} \Plainkeywords{Bayesian inference, multilevel models, distributional regression, MCMC, Stan, R} %% without formatting %% at least one keyword must be supplied %% publication information %% NOTE: Typically, this can be left commented and will be filled out by the technical editor %% \Volume{50} %% \Issue{9} %% \Month{June} %% \Year{2012} %% \Submitdate{2012-06-04} %% \Acceptdate{2012-06-04} %% The address of (at least) one author should be given %% in the following format: \Address{ Paul-Christian B\"urkner\\ E-mail: \email{paul.buerkner@gmail.com}\\ URL: \url{https://paul-buerkner.github.io} } %% It is also possible to add a telephone and fax number %% before the e-mail in the following format: %% Telephone: +43/512/507-7103 %% Fax: +43/512/507-2851 %% for those who use Sweave please include the following line (with % symbols): %% need no \usepackage{Sweave.sty} %% end of declarations %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \begin{document} %% include your article here, just as usual %% Note that you should use the \pkg{}, \proglang{} and \code{} commands. \section{Introduction} Multilevel models (MLMs) offer great flexibility for researchers across sciences \citep{brown2015, demidenko2013, gelmanMLM2006, pinheiro2006}. They allow modeling of data measured on different levels at the same time -- for instance data of students nested within classes and schools -- thus taking complex dependency structures into account. It is not surprising that many packages for R have been developed to fit MLMs. Usually, however, the functionality of these implementations is limited insofar as it is only possible to predict the mean of the response distribution. Other parameters of the response distribution, such as the residual standard deviation in linear models, are assumed constant across observations, which may be violated in many applications. Accordingly, it is desirable to allow for prediction of \emph{all} response parameters at the same time. Models doing exactly that are often referred to as \emph{distributional models} or more verbosely \emph{models for location, scale and shape} \citep{rigby2005}. Another limitation of basic MLMs is that they only allow for linear predictor terms. While linear predictor terms already offer good flexibility, they are of limited use when relationships are inherently non-linear. Such non-linearity can be handled in at least two ways: (1) by fully specifying a non-linear predictor term with corresponding parameters each of which can be predicted using MLMs \citep{lindstrom1990}, or (2) estimating the form of the non-linear relationship on the fly using splines \citep{wood2004} or Gaussian processes \citep{rasmussen2006}. The former are often simply called \emph{non-linear models}, while models applying splines are referred to as \emph{generalized additive models} (GAMs; \citeauthor{hastie1990}, \citeyear{hastie1990}). Combining all of these modeling options into one framework is a complex task, both conceptually and with regard to model fitting. Maximum likelihood methods, which are typically applied in classical 'frequentist' statistics, can reach their limits at some point and fully Bayesian methods become the go-to solutions to fit such complex models \citep{gelman2014}. In addition to being more flexible, the Bayesian framework comes with other advantages, for instance, the ability to derive probability statements for every quantity of interest or explicitly incorporating prior knowledge about parameters into the model. The former is particularly relevant in non-linear models, for which classical approaches struggle more often than not in propagating all the uncertainty in the parameter estimates to non-linear functions such as out-of-sample predictions. Possibly the most powerful program for performing full Bayesian inference available to date is Stan \citep{stanM2017, carpenter2017}. It implements Hamiltonian Monte Carlo \citep{duane1987, neal2011, betancourt2014} and its extension, the No-U-Turn (NUTS) Sampler \citep{hoffman2014}. These algorithms converge much more quickly than other Markov-Chain Monte-Carlo (MCMC) algorithms especially for high-dimensional models \citep{hoffman2014, betancourt2014, betancourt2017}. An excellent non-mathematical introduction to Hamiltonian Monte Carlo can be found in \citet{betancourt2017}. Stan comes with its own programming language, allowing for great modeling flexibility \cite{stanM2017, carpenter2017}). Many researchers may still be hesitent to use Stan directly, as every model has to be written, debugged and possibly also optimized. This may be a time-consuming and error-prone process even for researchers familiar with Bayesian inference. The \pkg{brms} package \citep{brms1}, presented in this paper, aims to remove these hurdles for a wide range of regression models by allowing the user to benefit from the merits of Stan by using extended \pkg{lme4}-like \citep{bates2015} formula syntax, with which many R users are familiar with. It offers much more than writing efficient and human-readable Stan code: \pkg{brms} comes with many post-processing and visualization functions, for instance to perform posterior predictive checks, leave-one-out cross-validation, visualization of estimated effects, and prediction of new data. The overarching aim is to have one general framework for regression modeling, which offers everything required to successfully apply regression models to complex data. To date, it already replaces and extends the functionality of dozens of other R packages, each of which is restricted to specific regression models\footnote{Unfortunately, due to the implementation via Stan, it is not easily possible for users to define their own response distributions and run them via \pkg{brms}. If you feel that a response distribution is missing in \pkg{brms}, please open an issue on GitHub (\url{https://github.com/paul-buerkner/brms}).}. The purpose of the present article is to provide an introduction of the advanced multilevel formula syntax implemented in \pkg{brms}, which allows to fit a wide and growing range of non-linear distributional multilevel models. A general overview of the package is already given in \citet{brms1}. Accordingly, the present article focuses on more recent developments. We begin by explaining the underlying structure of distributional models. Next, the formula syntax of \pkg{lme4} and its extensions implemented in \pkg{brms} are explained. Four examples that demonstrate the use of the new syntax are discussed in detail. Afterwards, the functionality of \pkg{brms} is compared with that of \pkg{rstanarm} \citep{rstanarm2017} and \pkg{MCMCglmm} \citep{hadfield2010}. We end by describing future plans for extending the package. \section{Model description} \label{model} The core of models implemented in \pkg{brms} is the prediction of the response $y$ through predicting all parameters $\theta_p$ of the response distribution $D$, which is also called the model \code{family} in many R packages. We write $$y_i \sim D(\theta_{1i}, \theta_{2i}, ...)$$ to stress the dependency on the $i\textsuperscript{th}$ observation. Every parameter $\theta_p$ may be regressed on its own predictor term $\eta_p$ transformed by the inverse link function $f_p$ that is $\theta_{pi} = f_p(\eta_{pi})$\footnote{A parameter can also be assumed constant across observations so that a linear predictor is not required.}. Such models are typically refered to as \emph{distributional models}\footnote{The models described in \citet{brms1} are a sub-class of the here described models.}. Details about the parameterization of each \code{family} are given in \code{vignette("brms\_families")}. Suppressing the index $p$ for simplicity, a predictor term $\eta$ can generally be written as $$ \eta = \mathbf{X} \beta + \mathbf{Z} u + \sum_{k = 1}^K s_k(x_k) $$ In this equation, $\beta$ and $u$ are the coefficients at population-level and group-level respectively and $\mathbf{X}, \mathbf{Z}$ are the corresponding design matrices. The terms $s_k(x_k)$ symbolize optional smooth functions of unspecified form based on covariates $x_k$ fitted via splines (see \citet{wood2011} for the underlying implementation in the \pkg{mgcv} package) or Gaussian processes \citep{williams1996}. The response $y$ as well as $\mathbf{X}$, $\mathbf{Z}$, and $x_k$ make up the data, whereas $\beta$, $u$, and the smooth functions $s_k$ are the model parameters being estimated. The coefficients $\beta$ and $u$ may be more commonly known as fixed and random effects, but I avoid theses terms following the recommendations of \citet{gelmanMLM2006}. Details about prior distributions of $\beta$ and $u$ can be found in \citet{brms1} and under \code{help("set\_prior")}. As an alternative to the strictly additive formulation described above, predictor terms may also have any form specifiable in Stan. We call it a \emph{non-linear} predictor and write $$\eta = f(c_1, c_2, ..., \phi_1, \phi_2, ...)$$ The structure of the function $f$ is given by the user, $c_r$ are known or observed covariates, and $\phi_s$ are non-linear parameters each having its own linear predictor term $\eta_{\phi_s}$ of the form specified above. In fact, we should think of non-linear parameters as placeholders for linear predictor terms rather than as parameters themselves. A frequentist implementation of such models, which inspired the non-linear syntax in \pkg{brms}, can be found in the \pkg{nlme} package \citep{nlme2016}. \section{Extended multilevel formula syntax} \label{formula_syntax} The formula syntax applied in \pkg{brms} builds upon the syntax of the R package \pkg{lme4} \citep{bates2015}. First, we will briefly explain the \pkg{lme4} syntax used to specify multilevel models and then introduce certain extensions that allow to specify much more complicated models in \pkg{brms}. An \pkg{lme4} formula has the general form \begin{Sinput} response ~ pterms + (gterms | group) \end{Sinput} The \code{pterms} part contains the population-level effects that are assumed to be the same across obervations. The \code{gterms} part contains so called group-level effects that are assumed to vary accross grouping variables specified in \code{group}. Multiple grouping factors each with multiple group-level effects are possible. Usually, \code{group} contains only a single variable name pointing to a factor, but you may also use \code{g1:g2} or \code{g1/g2}, if both \code{g1} and \code{g2} are suitable grouping factors. The \code{:} operator creates a new grouping factor that consists of the combined levels of \code{g1} and \code{g2} (you could think of this as pasting the levels of both factors together). The \code{/} operator indicates nested grouping structures and expands one grouping factor into two or more when using multiple \code{/} within one term. If, for instance, you write \code{(1 | g1/g2)}, it will be expanded to \code{(1 | g1) + (1 | g1:g2)}. Instead of \code{|} you may use \code{||} in grouping terms to prevent group-level correlations from being modeled. This may be useful in particular when modeling so many group-level effects that convergence of the fitting algorithms becomes an issue due to model complexity. One limitation of the \code{||} operator in \pkg{lme4} is that it only splits up terms so that columns of the design matrix originating from the same term are still modeled as correlated (e.g., when coding a categorical predictor; see the \code{mixed} function of the \pkg{afex} package by \citet{afex2015} for a way to avoid this behavior). While intuitive and visually appealing, the classic \pkg{lme4} syntax is not flexible enough to allow for specifying the more complex models supported by \pkg{brms}. In non-linear or distributional models, for instance, multiple parameters are predicted, each having their own population and group-level effects. Hence, multiple formulas are necessary to specify such models\footnote{Actually, it is possible to specify multiple model parts within one formula using interactions terms for instance as implemented in \pkg{MCMCglmm} \citep{hadfield2010}. However, this syntax is limited in flexibility and requires a rather deep understanding of the way R parses formulas, thus often being confusing to users.}. Then, however, specifying group-level effects of the same grouping factor to be correlated \emph{across} formulas becomes complicated. The solution implemented in \pkg{brms} (and currently unique to it) is to expand the \code{|} operator into \code{||}, where \code{} can be any value. Group-level terms with the same \code{ID} will then be modeled as correlated if they share same grouping factor(s)\footnote{It might even be further extended to \code{|fun()|}, where \code{fun} defines the type of correlation structure, defaulting to unstructured that is estimating the full correlation matrix. The \code{fun} argument is not yet supported by \pkg{brms} but could be supported in the future if other correlation structures, such as compound symmetry or Toeplitz, turn out to have reasonable practical applications and effective implementations in Stan.}. For instance, if the terms \code{(x1|ID|g1)} and \code{(x2|ID|g1)} appear somewhere in the same or different formulas passed to \pkg{brms}, they will be modeled as correlated. Further extensions of the classical \pkg{lme4} syntax refer to the \code{group} part. It is rather limited in its flexibility since only variable names combined by \code{:} or \code{/} are supported. We propose two extensions of this syntax: Firstly, \code{group} can generally be split up in its terms so that, say, \code{(1 | g1 + g2)} is expanded to \code{(1 | g1) + (1 | g2)}. This is fully consistent with the way \code{/} is handled so it provides a natural generalization to the existing syntax. Secondly, there are some special grouping structures that cannot be expressed by simply combining grouping variables. For instance, multi-membership models cannot be expressed this way. To overcome this limitation, we propose wrapping terms in \code{group} within special functions that allow specifying alternative grouping structures: \code{(gterms | fun(group))}. In \pkg{brms}, there are currently two such functions implemented, namely \code{gr} for the default behavior and \code{mm} for multi-membership terms. To be compatible with the original syntax and to keep formulas short, \code{gr} is automatically added internally if none of these functions is specified. While some non-linear relationships, such as quadratic relationships, can be expressed within the basic R formula syntax, other more complicated ones cannot. For this reason, it is possible in \pkg{brms} to fully specify non-linear predictor terms similar to how it is done in \pkg{nlme}, but fully compatible with the extended multilevel syntax described above. Suppose, for instance, we want to model the non-linear growth curve $$ y = b_1 (1 - \exp(-(x / b_2)^{b_3}) $$ between $y$ and $x$ with parameters $b_1$, $b_2$, and $b_3$ (see Example 3 in this paper for an implementation of this model with real data). Furthermore, we want all three parameters to vary by a grouping variable $g$ and model those group-level effects as correlated. Additionally $b_1$ should be predicted by a covariate $z$. We can express this in \pkg{brms} using multiple formulas, one for the non-linear model itself and one per non-linear parameter: \begin{Sinput} y ~ b1 * (1 - exp(-(x / b2) ^ b3) b1 ~ z + (1|ID|g) b2 ~ (1|ID|g) b3 ~ (1|ID|g) \end{Sinput} The first formula will not be evaluated using standard R formula parsing, but instead taken literally. In contrast, the formulas for the non-linear parameters will be evaluated in the usual way and are compatible with all terms supported by \pkg{brms}. Note that we have used the above described ID-syntax to model group-level effects as correlated across formulas. There are other syntax extensions implemented in \pkg{brms} that do not directly target grouping terms. Firstly, there are terms formally included in the \code{pterms} part that are handled separately. The most prominent examples are smooth terms specified through the \code{s} and \code{t2} functions of the \pkg{mgcv} package \citep{wood2011}. Other examples are category specific effects \code{cs}, monotonic effects \code{mo}, noise-free effects \code{me}, or Gaussian process terms \code{gp}. The former is explained in \citet{brms1}, while the latter three are documented in \code{help(brmsformula)}. Internally, these terms are extracted from \code{pterms} and not included in the construction of the population-level design matrix. Secondly, making use of the fact that \code{|} is unused on the left-hand side of $\sim$ in formula, additional information on the response variable may be specified via \begin{Sinput} response | aterms ~ \end{Sinput} The \code{aterms} part may contain multiple terms of the form \code{fun()} separated by \code{+} each providing special information on the response variable. This allows among others to weight observations, provide known standard errors for meta-analysis, or model censored or truncated data. As it is not the main topic of the present paper, we refer to \code{help("brmsformula")} and \code{help("addition-terms")} for more details. To set up the model formulas and combine them into one object, \pkg{brms} defines the \code{brmsformula} (or short \code{bf}) function. Its output can then be passed to the \code{parse\_bf} function, which splits up the formulas in separate parts and prepares them for the generation of design matrices and related data. Other packages may re-use these functions in their own routines making it easier to offer support for the above described multilevel syntax. \section{Examples} The idea of \pkg{brms} is to provide one unified framework for multilevel regression models in R. As such, the above described formula syntax in all of its variations can be applied in combination with all response distributions supported by \pkg{brms} (currently about 35 response distributions are supported; see \code{help("brmsfamily")} and \code{vignette("brms\_families")} for an overview). In this section, we will discuss four examples in detail, each focusing on certain aspects of the syntax. They are chosen to provide a broad overview of the modeling options. The first is about the number of fish caught be different groups of people. It does not actually contain any multilevel structure, but helps in understanding how to set up formulas for different model parts. The second example is about housing rents in Munich. We model the data using splines and a distributional regression approach. The third example is about cumulative insurance loss payments across several years, which is fitted using a rather complex non-linear multilevel model. Finally, the fourth example is about the performance of school children, who change school during the year, thus requiring a multi-membership model. Despite not being covered in the four examples, there are a few more modeling options that we want to briefly describe. First, \pkg{brms} allows fitting so called phylogenetic models. These models are relevant in evolutionary biology when data of many species are analyzed at the same time. Species are not independent as they come from the same phylogenetic tree, implying that different levels of the same grouping-factor (i.e., species) are likely correlated. There is a whole vignette dedicated to this topic, which can be found via \code{vignette("brms\_phylogenetics")}. Second, there is a canonical way to handle ordinal predictors, without falsely assuming they are either categorical or continuous. We call them monotonic effects and discuss them in \code{vignette("brms\_monotonic")}. Last but not least, it is possible to account for measurement error in both response and predictor variables. This is often ignored in applied regression modeling \citep{westfall2016}, although measurement error is very common in all scientific fields making use of observational data. There is no vignette yet covering this topic, but one will be added in the future. In the meantime, \code{help("brmsformula")} is the best place to start learning about such models as well as about other details of the \pkg{brms} formula syntax. \subsection{Example 1: Catching fish} An important application of the distributional regression framework of \pkg{brms} are so called zero-inflated and hurdle models. These models are helpful whenever there are more zeros in the response variable than one would naturally expect. Here, we consider an example dealing with the number of fish caught by various groups of people. On the UCLA website (\url{https://stats.idre.ucla.edu/stata/dae/zero-inflated-poisson-regression}), the data are described as follows: ``The state wildlife biologists want to model how many fish are being caught by fishermen at a state park. Visitors are asked how long they stayed, how many people were in the group, were there children in the group and how many fish were caught. Some visitors do not fish, but there is no data on whether a person fished or not. Some visitors who did fish did not catch any fish so there are excess zeros in the data because of the people that did not fish.'' \begin{Sinput} zinb <- read.csv("http://stats.idre.ucla.edu/stat/data/fish.csv") zinb$camper <- factor(zinb$camper, labels = c("no", "yes")) head(zinb) \end{Sinput} \begin{Sinput} nofish livebait camper persons child xb zg count 1 1 0 no 1 0 -0.8963146 3.0504048 0 2 0 1 yes 1 0 -0.5583450 1.7461489 0 3 0 1 no 1 0 -0.4017310 0.2799389 0 4 0 1 yes 2 1 -0.9562981 -0.6015257 0 5 0 1 no 1 0 0.4368910 0.5277091 1 6 0 1 yes 4 2 1.3944855 -0.7075348 0 \end{Sinput} As predictors we choose the number of people per group, the number of children, as well as whether or not the group consists of campers. Many groups may not catch any fish just because they do not try and so we fit a zero-inflated Poisson model. For now, we assume a constant zero-inflation probability across observations. \begin{Sinput} fit_zinb1 <- brm(count ~ persons + child + camper, data = zinb, family = zero_inflated_poisson("log")) \end{Sinput} The model is readily summarized via \begin{Sinput} summary(fit_zinb1) \end{Sinput} \begin{Sinput} Family: zero_inflated_poisson (log) Formula: count ~ persons + child + camper Data: zinb (Number of observations: 250) Samples: 4 chains, each with iter = 2000; warmup = 1000; thin = 1; total post-warmup samples = 4000 WAIC: Not computed Population-Level Effects: Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat Intercept -1.01 0.17 -1.34 -0.67 2171 1 persons 0.87 0.04 0.79 0.96 2188 1 child -1.36 0.09 -1.55 -1.18 1790 1 camper 0.80 0.09 0.62 0.98 2950 1 Family Specific Parameters: Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat zi 0.41 0.04 0.32 0.49 2409 1 Samples were drawn using sampling(NUTS). For each parameter, Eff.Sample is a crude measure of effective sample size, and Rhat is the potential scale reduction factor on split chains (at convergence, Rhat = 1). \end{Sinput} A graphical summary is available through \begin{Sinput} conditional_effects(fit_zinb1) \end{Sinput} \begin{figure}[ht] \centering \includegraphics[width=0.99\textwidth,keepaspectratio]{me_zinb1.pdf} \caption{Conditional effects plots of the \code{fit\_zinb1} model.} \label{me_zinb1} \end{figure} (see Figure \ref{me_zinb1}). In fact, the \code{conditional\_effects} method turned out to be so powerful in visualizing effects of predictors that I am using it almost as frequently as \code{summary}. According to the parameter estimates, larger groups catch more fish, campers catch more fish than non-campers, and groups with more children catch less fish. The zero-inflation probability \code{zi} is pretty large with a mean of 41\%. Please note that the probability of catching no fish is actually higher than 41\%, but parts of this probability are already modeled by the Poisson distribution itself (hence the name zero-\emph{inflation}). If you want to treat all zeros as originating from a separate process, you can use hurdle models instead (not shown here). Now, we try to additionally predict the zero-inflation probability by the number of children. The underlying reasoning is that we expect groups with more children to not even try catching fish, since children often lack the patience required for fishing. From a purely statistical perspective, zero-inflated (and hurdle) distributions are a mixture of two processes and predicting both parts of the model is natural and often very reasonable to make full use of the data. \begin{Sinput} fit_zinb2 <- brm(bf(count ~ persons + child + camper, zi ~ child), data = zinb, family = zero_inflated_poisson()) \end{Sinput} To transform the linear predictor of \code{zi} into a probability, \pkg{brms} applies the logit-link, which takes values within $[0, 1]$ and returns values on the real line. Thus, it allows the transition between probabilities and linear predictors. \begin{Sinput} summary(fit_zinb2) \end{Sinput} \begin{Sinput} Family: zero_inflated_poisson (log) Formula: count ~ persons + child + camper zi ~ child Data: zinb (Number of observations: 250) Samples: 4 chains, each with iter = 2000; warmup = 1000; thin = 1; total post-warmup samples = 4000 WAIC: Not computed Population-Level Effects: Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat Intercept -1.07 0.18 -1.43 -0.73 2322 1 persons 0.89 0.05 0.80 0.98 2481 1 child -1.17 0.10 -1.37 -1.00 2615 1 camper 0.78 0.10 0.60 0.96 3270 1 zi_Intercept -0.95 0.27 -1.52 -0.48 2341 1 zi_child 1.21 0.28 0.69 1.79 2492 1 Samples were drawn using sampling(NUTS). For each parameter, Eff.Sample is a crude measure of effective sample size, and Rhat is the potential scale reduction factor on split chains (at convergence, Rhat = 1). \end{Sinput} According to the model, trying to fish with children not only decreases the overall number fish caught (as implied by the Poisson part of the model) but also drastically increases your chance of catching no fish at all (as implied by the zero-inflation part), possibly because groups with more children spend less time or no time at all fishing. Comparing model fit via leave-one-out cross validation as implemented in the \pkg{loo} package \citep{loo2016, vehtari2016}. \begin{Sinput} LOO(fit_zinb1, fit_zinb2) \end{Sinput} \begin{Sinput} LOOIC SE fit_zinb1 1639.52 363.30 fit_zinb2 1621.35 362.39 fit_zinb1 - fit_zinb2 18.16 15.71 \end{Sinput} reveals that the second model using the number of children to predict both model parts has better fit. However, when considering the standard error of the \code{LOOIC} difference, improvement in model fit is apparently modest and not substantial. More examples of distributional model can be found in \code{vignette("brms\_distreg")}. \subsection{Example 2: Housing rents} In their book about regression modeling, \citet{fahrmeir2013} use an example about the housing rents in Munich from 1999. The data contains information about roughly 3000 apartments including among others the absolute rent (\code{rent}), rent per square meter (\code{rentsqm}), size of the apartment (\code{area}), construction year (\code{yearc}), and the district in Munich (\code{district}), where the apartment is located. The data can be found in the \pkg{gamlss.data} package \citep{gamlss.data}: \begin{Sinput} data("rent99", package = "gamlss.data") head(rent99) \end{Sinput} \begin{Sinput} rent rentsqm area yearc location bath kitchen cheating district 1 109.9487 4.228797 26 1918 2 0 0 0 916 2 243.2820 8.688646 28 1918 2 0 0 1 813 3 261.6410 8.721369 30 1918 1 0 0 1 611 4 106.4103 3.547009 30 1918 2 0 0 0 2025 5 133.3846 4.446154 30 1918 2 0 0 1 561 6 339.0256 11.300851 30 1918 2 0 0 1 541 \end{Sinput} Here, we aim at predicting the rent per square meter with the size of the apartment as well as the construction year, while taking the district of Munich into account. As the effect of both predictors on the rent is of unknown non-linear form, we model these variables using a bivariate tensor spline \citep{wood2013}. The district is accounted for via a varying intercept. \begin{Sinput} fit_rent1 <- brm(rentsqm ~ t2(area, yearc) + (1|district), data = rent99, chains = 2, cores = 2) \end{Sinput} We fit the model using just two chains (instead of the default of four chains) on two processor cores to reduce the model fitting time for the purpose of the present paper. In general, using the default option of four chains (or more) is recommended. \begin{Sinput} summary(fit_rent1) \end{Sinput} \begin{Sinput} Family: gaussian(identity) Formula: rentsqm ~ t2(area, yearc) + (1 | district) Data: rent99 (Number of observations: 3082) Samples: 2 chains, each with iter = 2000; warmup = 1000; thin = 1; total post-warmup samples = 2000 ICs: LOO = NA; WAIC = NA; R2 = NA Smooth Terms: Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat sds(t2areayearc_1) 4.93 2.32 1.61 10.77 1546 1.00 sds(t2areayearc_2) 5.78 2.87 1.58 13.15 1175 1.00 sds(t2areayearc_3) 8.09 3.19 3.66 16.22 1418 1.00 Group-Level Effects: ~district (Number of levels: 336) Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat sd(Intercept) 0.60 0.06 0.48 0.73 494 1.01 Population-Level Effects: Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat Intercept 7.80 0.11 7.59 8.02 2000 1.00 t2areayearc_1 -1.00 0.09 -1.15 -0.83 2000 1.00 t2areayearc_2 0.75 0.17 0.43 1.09 2000 1.00 t2areayearc_3 -0.07 0.16 -0.40 0.24 1579 1.00 Family Specific Parameters: Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat sigma 1.95 0.03 1.90 2.01 2000 1.00 Samples were drawn using sampling(NUTS). For each parameter, Eff.Sample is a crude measure of effective sample size, and Rhat is the potential scale reduction factor on split chains (at convergence, Rhat = 1). \end{Sinput} For models including splines, the output of \code{summary} is not tremendously helpful, but we get at least some information. Firstly, the credible intervals of the standard deviations of the coefficients forming the splines (under \code{'Smooth Terms'}) are sufficiently far away from zero to indicate non-linearity in the (combined) effect of \code{area} and \code{yearc}. Secondly, even after controlling for these predictors, districts still vary with respect to rent per square meter by a sizable amount as visible under \code{'Group-Level Effects'} in the output. To further understand the effect of the predictor, we apply graphical methods: \begin{Sinput} conditional_effects(fit_rent1, surface = TRUE) \end{Sinput} In Figure \ref{me_rent1}, the conditional effects of both predictors are displayed, while the respective other predictor is fixed at its mean. In Figure \ref{me_rent2}, the combined effect is shown, clearly demonstrating an interaction between the variables. In particular, housing rents appear to be highest for small and relatively new apartments. \begin{figure}[ht] \centering \includegraphics[width=0.99\textwidth,keepaspectratio]{me_rent1.pdf} \caption{Conditional effects plots of the \code{fit\_rent1} model for single predictors.} \label{me_rent1} \end{figure} \begin{figure}[ht] \centering \includegraphics[width=0.7\textwidth,keepaspectratio]{me_rent2.pdf} \caption{Surface plot of the \code{fit\_rent1} model for the combined effect of \code{area} and \code{yearc}.} \label{me_rent2} \end{figure} In the above example, we only considered the mean of the response distribution to vary by \code{area} and \code{yearc}, but this my not necessarily reasonable assumption, as the variation of the response might vary with these variables as well. Accordingly, we fit splines and effects of district for both the location and the scale parameter, which is called \code{sigma} in Gaussian models. \begin{Sinput} bform <- bf(rentsqm ~ t2(area, yearc) + (1|ID1|district), sigma ~ t2(area, yearc) + (1|ID1|district)) fit_rent2 <- brm(bform, data = rent99, chains = 2, cores = 2) \end{Sinput} If not otherwise specified, \code{sigma} is predicted on the log-scale to ensure it is positive no matter how the predictor term looks like. Instead of \code{(1|district)} as in the previous model, we now use \code{(1|ID1|district)} in both formulas. This results in modeling the varying intercepts of both model parts as correlated (see the description of the ID-syntax above). The group-level part of the \code{summary} output looks as follows: \begin{Sinput} Group-Level Effects: ~district (Number of levels: 336) Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat sd(Intercept) 0.60 0.06 0.49 0.73 744 1.00 sd(sigma_Intercept) 0.11 0.02 0.06 0.15 751 1.00 cor(Intercept,sigma_Intercept) 0.72 0.17 0.35 0.98 648 1.00 \end{Sinput} As visible from the positive correlation of the intercepts, districts with overall higher rent per square meter have higher variation at the same time. Lastly, we want to turn our attention to the splines. While \code{conditional\_effects} is used to visualize effects of predictors on the expected response, \code{conditional\_smooths} is used to show just the spline parts of the model: \begin{Sinput} conditional_smooths(fit_rent2) \end{Sinput} The plot on the left-hand side of Figure \ref{me_rent3} resembles the one in Figure \ref{me_rent2}, but the scale is different since only the spline is plotted. The right-hand side of \ref{me_rent3} shows the spline for \code{sigma}. Since we apply the log-link on \code{sigma} by default the spline is on the log-scale as well. As visible in the plot, the variation in the rent per square meter is highest for relatively small and old apartments, while the variation is smallest for medium to large apartments build around the 1960s. \begin{figure}[ht] \centering \includegraphics[width=0.99\textwidth,keepaspectratio]{me_rent3.pdf} \caption{Plots showing the smooth terms of the \code{fit\_rent2} model.} \label{me_rent3} \end{figure} \subsection{Example 3: Insurance loss payments} On his blog, Markus Gesmann predicts the growth of cumulative insurance loss payments over time, originated from different origin years (see \url{http://www.magesblog.com/2015/11/loss-developments-via-growth-curves-and.html}). We will use a slightly simplified version of his model for demonstration purposes here. It looks as follows: $$cum_{AY, dev} \sim N(\mu_{AY, dev}, \sigma)$$ $$\mu_{AY, dev} = ult_{AY} \left(1 - \exp\left(- \left( \frac{dev}{\theta} \right)^\omega \right) \right)$$ The cumulative insurance payments $cum$ will grow over time, and we model this dependency using the variable $dev$. Further, $ult_{AY}$ is the (to be estimated) ultimate loss of accident each year. It constitutes a non-linear parameter in our framework along with the parameters $\theta$ and $\omega$, which are responsible for the growth of the cumulative loss and are for now assumed to be the same across years. We load the data \begin{Sinput} url <- paste0("https://raw.githubusercontent.com/mages/", "diesunddas/master/Data/ClarkTriangle.csv") loss <- read.csv(url) head(loss) \end{Sinput} \begin{Sinput} AY dev cum 1 1991 6 357.848 2 1991 18 1124.788 3 1991 30 1735.330 4 1991 42 2182.708 5 1991 54 2745.596 6 1991 66 3319.994 \end{Sinput} and translate the proposed model into a non-linear \pkg{brms} model. \begin{Sinput} nlform <- bf(cum ~ ult * (1 - exp(-(dev / theta)^omega)), ult ~ 1 + (1|AY), omega ~ 1, theta ~ 1, nl = TRUE) nlprior <- c(prior(normal(5000, 1000), nlpar = "ult"), prior(normal(1, 2), nlpar = "omega"), prior(normal(45, 10), nlpar = "theta")) fit_loss1 <- brm(formula = nlform, data = loss, family = gaussian(), prior = nlprior, control = list(adapt_delta = 0.9)) \end{Sinput} In the above functions calls, quite a few things are going on. The formulas are wrapped in \code{bf} to combine them into one object. The first formula specifies the non-linear model. We set argument \code{nl = TRUE} so that \pkg{brms} takes this formula literally and instead of using standard R formula parsing. We specify one additional formula per non-linear parameter (a) to clarify what variables are covariates and what are parameters and (b) to specify the predictor term for the parameters. We estimate a group-level effect of accident year (variable \code{AY}) for the ultimate loss \code{ult}. This also shows nicely how a non-linear parameter is actually a placeholder for a linear predictor, which in the case of \code{ult}, contains only a varying intercept for year. Both \code{omega} and \code{theta} are assumed to be constant across observations so we just fit a population-level intercept. Priors on population-level effects are required and, for the present model, are actually mandatory to ensure identifiability. Otherwise, we may observe that different Markov chains converge to different parameter regions as multiple posterior distribution are equally plausible. Setting prior distributions is a difficult task especially in non-linear models. It requires some experience and knowledge both about the model that is being fitted and about the data at hand. Additionally, there is more to keep in mind to optimize the sampler's performance: Firstly, using non- or weakly informative priors in non-linear models often leads to problems even if the model is generally identified. For instance, if a zero-centered and reasonably wide prior such as \code{normal(0, 10000)} it set on \code{ult}, there is little information about \code{theta} and \code{omega} for samples of \code{ult} being close to zero, which may lead to convergence problems. Secondly, Stan works best when parameters are roughly on the same order of magnitude \citep{stan2017}. In the present example, \code{ult} is of three orders larger than \code{omega}. Still, the sampler seems to work quite well, but this may not be true for other models. One solution is to rescale parameters before model fitting. For instance, for the present example, one could have downscaled \code{ult} by replacing it with \code{ult * 1000} and correspondingly the \code{normal(5000, 1000)} prior with \code{normal(5, 1)}. In the \code{control} argument we increase \code{adapt\_delta} to get rid of a few divergent transitions (cf. \citeauthor{stan2017}, \citeyear{stan2017}; \citeauthor{brms1}, \citeyear{brms1}). Again the model is summarized via \begin{Sinput} summary(fit_loss1) \end{Sinput} \begin{Sinput} Family: gaussian (identity) Formula: cum ~ ult * (1 - exp(-(dev / theta)^omega)) ult ~ 1 + (1 | AY) omega ~ 1 theta ~ 1 Data: loss (Number of observations: 55) Samples: 4 chains, each with iter = 2000; warmup = 1000; thin = 1; total post-warmup samples = 4000 WAIC: Not computed Group-Level Effects: ~AY (Number of levels: 10) Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat sd(ult_Intercept) 745.74 231.31 421.05 1306.04 916 1 Population-Level Effects: Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat ult_Intercept 5273.70 292.34 4707.11 5852.28 798 1 omega_Intercept 1.34 0.05 1.24 1.43 2167 1 theta_Intercept 46.07 2.09 42.38 50.57 1896 1 Family Specific Parameters: Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat sigma 139.93 15.52 113.6 175.33 2358 1 Samples were drawn using sampling(NUTS). For each parameter, Eff.Sample is a crude measure of effective sample size, and Rhat is the potential scale reduction factor on split chains (at convergence, Rhat = 1). \end{Sinput} as well as \begin{Sinput} conditional_effects(fit_loss1) \end{Sinput} \begin{figure}[ht] \centering \includegraphics[width=0.7\textwidth,keepaspectratio]{me_loss1.pdf} \caption{Conditional effects plots of the \code{fit\_loss1} model.} \label{me_loss1} \end{figure} (see Figure \ref{me_loss1}). We can also visualize the cumulative insurance loss over time separately for each year. \begin{Sinput} conditions <- data.frame(AY = unique(loss$AY)) rownames(conditions) <- unique(loss$AY) me_year <- conditional_effects(fit_loss1, conditions = conditions, re_formula = NULL, method = "predict") plot(me_year, ncol = 5, points = TRUE) \end{Sinput} \begin{figure}[ht] \centering \includegraphics[width=0.99\textwidth,keepaspectratio]{me_loss1_year.pdf} \caption{Conditional effects plots of the \code{fit\_loss1} model separately for each accident year.} \label{me_loss1_year} \end{figure} (see Figure \ref{me_loss1_year}). It is evident that there is some variation in cumulative loss across accident years, for instance due to natural disasters happening only in certain years. Further, we see that the uncertainty in the predicted cumulative loss is larger for later years with fewer available data points. In the above model, we considered \code{omega} and \code{delta} to be constant across years, which may not necessarily be true. We can easily investigate this by fitting varying intercepts for all three non-linear parameters also estimating group-level correlation using the above introduced \code{ID} syntax. \begin{Sinput} nlform2 <- bf(cum ~ ult * (1 - exp(-(dev / theta)^omega)), ult ~ 1 + (1|ID1|AY), omega ~ 1 + (1|ID1|AY), theta ~ 1 + (1|ID1|AY), nl = TRUE) fit_loss2 <- update(fit_loss1, formula = nlform2, control = list(adapt_delta = 0.90)) \end{Sinput} We could have also specified all predictor terms more conveniently within one formula as \begin{Sinput} ult + omega + theta ~ 1 + (1|ID1|AY) \end{Sinput} because the structure of the predictor terms is identical. To compare model fit, we perform leave-one-out cross-validation. \begin{Sinput} LOO(fit_loss1, fit_loss2) \end{Sinput} \begin{Sinput} LOOIC SE fit_loss1 715.44 19.24 fit_loss2 720.60 19.85 fit_loss1 - fit_loss2 -5.15 5.34 \end{Sinput} Since smaller values indicate better expected out-of-sample predictions and thus better model fit, the simpler model that only has a varying intercept over parameter \code{ult} is preferred. This may not be overly surprising, given that three varying intercepts as well as three group-level correlations are probably overkill for data containing only 55 observations. Nevertheless, it nicely demonstrates how to apply the \code{ID} syntax in practice. More examples of non-linear models can be found in \code{vignette("brms\_nonlinear")}. \subsection{Example 4: Performance of school children} Suppose that we want to predict the performance of students in the final exams at the end of the year. There are many variables to consider, but one important factor will clearly be school membership. Schools might differ in the ratio of teachers and students, the general quality of teaching, in the cognitive ability of the students they draw, or other factors we are not aware of that induce dependency among students of the same school. Thus, it is advised to apply a multilevel modeling techniques including school membership as a group-level term. Of course, we should account for class membership and other levels of the educational hierarchy as well, but for the purpose of the present example, we will focus on schools only. Usually, accounting for school membership is pretty-straight forward by simply adding a varying intercept to the formula: \code{(1 | school)}. However, a non-negligible number of students might change schools during the year. This would result in a situation where one student is a member of multiple schools and so we need a multi-membership model. Setting up such a model not only requires information on the different schools students attend during the year, but also the amount of time spend at each school. The latter can be used to weight the influence each school has on its students, since more time attending a school will likely result in greater influence. For now, let us assume that students change schools maximally once a year and spend equal time at each school. We will later see how to relax these assumptions. Real educational data are usually relatively large and complex so that we simulate our own data for the purpose of this tutorial paper. We simulate 10 schools and 1000 students, with each school having the same expected number of 100 students. We model 10\% of students as changing schools. \begin{Sinput} data_mm <- sim_multi_mem(nschools = 10, nstudents = 1000, change = 0.1) head(data_mm) \end{Sinput} \begin{Sinput} s1 s2 w1 w2 y 1 8 9 0.5 0.5 16.27422 2 10 9 0.5 0.5 18.71387 3 5 3 0.5 0.5 23.65319 4 3 5 0.5 0.5 22.35204 5 5 3 0.5 0.5 16.38019 6 10 6 0.5 0.5 17.63494 \end{Sinput} The code of function \code{sim\_multi\_mem} can be found in the online supplement of the present paper. For reasons of better illustration, students changing schools appear in the first rows of the data. Data of students being only at a single school looks as follows: \begin{Sinput} data_mm[101:106, ] \end{Sinput} \begin{Sinput} s1 s2 w1 w2 y 101 2 2 0.5 0.5 27.247851 102 9 9 0.5 0.5 24.041427 103 4 4 0.5 0.5 12.575001 104 2 2 0.5 0.5 21.203644 105 4 4 0.5 0.5 12.856166 106 4 4 0.5 0.5 9.740174 \end{Sinput} Thus, school variables are identical, but we still have to specify both in order to pass the data appropriately. Incorporating no other predictors into the model for simplicity, a multi-membership model is specified as \begin{Sinput} fit_mm <- brm(y ~ 1 + (1 | mm(s1, s2)), data = data_mm) \end{Sinput} The only new syntax element is that multiple grouping factors (\code{s1} and \code{s2}) are wrapped in \code{mm}. Everything else remains exactly the same. Note that we did not specify the relative weights of schools for each student and thus, by default, equal weights are assumed. \begin{Sinput} summary(fit_mm) \end{Sinput} \begin{Sinput} Family: gaussian (identity) Formula: y ~ 1 + (1 | mm(s1, s2)) Data: data_mm (Number of observations: 1000) Samples: 4 chains, each with iter = 2000; warmup = 1000; thin = 1; total post-warmup samples = 4000 WAIC: Not computed Group-Level Effects: ~mms1s2 (Number of levels: 10) Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat sd(Intercept) 2.76 0.82 1.69 4.74 682 1.01 Population-Level Effects: Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat Intercept 19 0.93 17.06 20.8 610 1 Family Specific Parameters: Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat sigma 3.58 0.08 3.43 3.75 2117 1 Samples were drawn using sampling(NUTS). For each parameter, Eff.Sample is a crude measure of effective sample size, and Rhat is the potential scale reduction factor on split chains (at convergence, Rhat = 1). \end{Sinput} With regard to the assumptions made in the above example, it is unlikely that all children who change schools stay in both schools equally long. To relax this assumption, we have to specify weights. First, we amend the simulated data to contain non-equal weights for students changing schools. For all other students, weighting does of course not matter as they stay in the same school anyway. \begin{Sinput} data_mm[1:100, "w1"] <- runif(100, 0, 1) data_mm[1:100, "w2"] <- 1 - data_mm[1:100, "w1"] head(data_mm) \end{Sinput} \begin{Sinput} s1 s2 w1 w2 y 1 8 9 0.3403258 0.65967423 16.27422 2 10 9 0.1771435 0.82285652 18.71387 3 5 3 0.9059811 0.09401892 23.65319 4 3 5 0.4432007 0.55679930 22.35204 5 5 3 0.8052026 0.19479738 16.38019 6 10 6 0.5610243 0.43897567 17.63494 \end{Sinput} Incorporating these weights into the model is straight forward. \begin{Sinput} fit_mm2 <- brm(y ~ 1 + (1 | mm(s1, s2, weights = cbind(w1, w2))), data = data_mm) \end{Sinput} The summary output is similar to the previous, so we do not show it here. The second assumption that students change schools only once a year, may also easily be relaxed by providing more than two grouping factors, say, \code{mm(s1, s2, s3)}. \section{Comparison between packages} Over the years, many R packages have been developed that implement MLMs, each being more or less general in their supported models. In \cite{brms1}, I compared \pkg{brms} with \pkg{lme4} \citep{bates2015}, \pkg{MCMCglmm} \citep{hadfield2010}, \pkg{rstanarm} \citep{rstanarm2017}, and \pkg{rethinking} \citep{mcelreath2017}. Since then, quite a few new features have been added in particular to \pkg{brms} and \pkg{rstanarm}. Accordingly, in the present paper, I will update these comparisons, but focus on \pkg{brms}, \pkg{rstanarm}, and \pkg{MCMCglmm} as the possibly most important R packages implementing Bayesian MLMs. While \pkg{brms} and \pkg{rstanarm} are both based on the probabilistic programming language \pkg{Stan}, \pkg{MCMCglmm} implements its own custom MCMC algorithm. Modeling options and other important information of these packages are summarized in Table~\ref{comparison} and will be discussed in detail below. Regarding general model classes, all three packages support the most common types such as linear, count data and certain survival models. Currently, \pkg{brms} and \pkg{MCMCglmm} provide more flexibility when modeling categorical and ordinal data. Additionally, they offer support for zero-inflated and hurdle models to account for access zeros in the data (see Example 1 above). For survival / time-to-event models, \pkg{rstanarm} offers great flexibility via the \code{stan\_jm} function, which allows for complex association structures between time-to-event data and one or more models of longitudinal covariates (for details see \url{https://cran.r-project.org/web/packages/rstanarm/vignettes/jm.html}). Model classes currently specific to \pkg{brms} are robust linear models using Student's t-distribution (family \code{student}) as well as response times models via the exponentially modified Gaussian (family \code{exgaussian}) distribution or the Wiener diffusion model (family \code{wiener}). The latter allows to simultaneously model dichotomous decisions and their corresponding response times (for a detailed example see \url{http://singmann.org/wiener-model-analysis-with-brms-part-i/}). All three packages offer many additional modeling options, with \pkg{brms} currently having the greatest flexibility (see Table~\ref{comparison} for a summary). Moreover, the packages differ in the general framework, in which they are implemented: \pkg{brms} and \pkg{MCMCglmm} each come with a single model fitting function (\code{brm} and \code{MCMCglmm} respectively), through which all of their models can be specified. Further, their framework allows to seamlessly combine most modeling options with each other in the same model. In contrast, the approach of \pkg{rstanarm} is to emulate existing functions of other packages. This has the advantage of an easier transition between classical and Bayesian models, since the syntax used to specify models stays the same. However, it comes with the main disadvantage that many modeling options cannot be used in combination within the same model. Information criteria are available in all three packages. The advantages of WAIC and LOO implemented in \pkg{brms} and \pkg{rstanarm}, are their less restrictive assumptions and that their standard errors can be easily estimated to get a better sense of the uncertainty in the criteria. Comparing the prior options of the packages, \pkg{brms} offers a little more flexibility than \pkg{MCMCglmm} and \pkg{rstanarm}, as virtually any prior distribution can be applied on population-level effects as well as on the standard deviations of group-level effects. In addition, I believe that the way priors are specified in \pkg{brms} is more intuitive as it is directly evident what prior is actually applied. In \pkg{brms}, Bayes factors are available both via Savage-Dickey ratios \citep{wagenmakers2010} and bridge-sampling \citep{bridgesampling2017}, while \pkg{rstanarm} allows for the latter option. For a detailed comparison with respect to sampling efficiency, see \cite{brms1}. \begin{table}[hbtp] \centering \begin{tabular}{llll} & \parbox{2cm}{\pkg{brms}} & \parbox{2cm}{\pkg{rstanarm}} & \parbox{2cm}{\pkg{MCMCglmm}} \\ \hline \\ [-1.5ex] \parbox{6cm}{\textbf{Model classes}} & & & \\ [1ex] Linear models & yes & yes & yes \\ Robust linear models & yes & no & no \\ Count data models & yes & yes & yes \\ Survival models & yes & yes$^1$ & yes \\ Response times models & yes & no & no \\ Beta models & yes & yes & no \\ Categorical models & yes & yes$^2$ & yes \\ Multinomial models & no & no & yes \\ Ordinal models & various & cumulative$^2$ & cumulative \\ Zero-inflated and hurdle models & yes & no & yes \\ \hline \\ [-1.5ex] \parbox{5cm}{\textbf{Modeling options}} & & & \\ [1ex] Variable link functions & various & various & no \\ Multilevel structures & yes & yes & yes \\ Multi-membership & yes & no & yes \\ Multivariate responses & yes & yes$^3$ & yes \\ Non-linear predictors & yes & limited$^4$ & no \\ Distributional regression & yes & no & no \\ Finite mixtures & yes & no & no \\ Splines (additive models) & yes & yes & yes \\ Gaussian Processes & yes & no & no \\ Temporal autocorrelation & yes & yes$^{2, 5}$ & no \\ Spatial autocorrelation & yes & yes$^{2, 5}$ & no \\ Monotonic effects & yes & no & no \\ Category specific effects & yes & no & no \\ Measurement error & yes & no & no \\ Weights & yes & yes & no \\ Offset & yes & yes & using priors \\ Censored data & yes & yes$^1$ & yes \\ Truncated data & yes & no & no \\ Customized covariances & yes & no & yes \\ Missing value imputation & no & no & no \\ \hline \\ [-1.5ex] \textbf{Bayesian specifics} & & & \\ [1ex] Population-level priors & flexible & flexible & normal \\ Group-level priors & normal & normal & normal \\ Covariance priors & flexible & restricted$^6$ & restricted$^7$ \\ Bayes factors & yes & yes$^8$ & no \\ Parallelization & yes & yes & no \\ \hline \\ [-1.5ex] \textbf{Other} & & & \\ [1ex] Estimator & HMC, NUTS & HMC, NUTS & MH, Gibbs$^9$ \\ Information criterion & WAIC, LOO & WAIC, LOO & DIC \\ C++ compiler required & yes & no & no \\ \hline \end{tabular} \caption{ Comparison of the capabilities of the \pkg{brms}, \pkg{rstanarm} and \pkg{MCMCglmm} packages. Notes: (1) Advanced functionality available via \code{stan\_jm}. (2) No group-level terms and related functionality allowed. (3) Cannot be combined with other modeling options such as splines. (4) Functionality limited to linear Gaussian models and certein pre-specified non-linear functions. (5) Functionality available only on GitHub branches (\url{https://github.com/stan-dev/rstanarm}). (6) For details see \cite{hadfield2010}. (7) For details see \url{https://github.com/stan-dev/rstanarm/wiki/Prior-distributions}. (8) Available via the \pkg{bridgesampling} package \citep{bridgesampling2017}. (9) Estimator consists of a combination of both algorithms. } \label{comparison} \end{table} \section{Conclusion} The present paper is meant to introduce R users and developers to the extended \pkg{lme4} formula syntax applied in \pkg{brms}. Only a subset of modeling options were discussed in detail, which ensured the paper was not too broad. For some of the more basic models that \pkg{brms} can fit, see \citet{brms1}. Many more examples can be found in the growing number of vignettes accompanying the package (see \code{vignette(package = "brms")} for an overview). To date, \pkg{brms} is already one of the most flexible R packages when it comes to regression modeling. However, for the future, there are quite a few more features that I am planning to implement (see \url{https://github.com/paul-buerkner/brms/issues} for the current list of issues). In addition to smaller, incremental updates, I have two specific features in mind: (1) latent variables estimated via confirmatory factor analysis and (2) missing value imputation. I receive ideas and suggestions from users almost every day -- for which I am always grateful -- and so the list of features that will be implemented in the proceeding versions of \pkg{brms} will continue to grow. \section*{Acknowledgments} First of all, I would like to thank the Stan Development Team for creating the probabilistic programming language Stan, which is an incredibly powerful and flexible tool for performing full Bayesian inference. Without it, \pkg{brms} could not fit a single model. Furthermore, I want to thank Heinz Holling, Donald Williams and Ruben Arslan for valuable comments on earlier versions of the paper. I also would like to thank the many users who reported bugs or had ideas for new features, thus helping to continuously improve \pkg{brms}. \bibliography{citations_multilevel} \end{document} brms/vignettes/brms_threading.Rmd0000644000176200001440000005632115053072461016673 0ustar liggesusers--- title: "Running brms models with within-chain parallelization" author: "Sebastian Weber & Paul Bürkner" date: "`r Sys.Date()`" output: rmarkdown::html_vignette: toc: yes vignette: > %\VignetteIndexEntry{Running brms models with within-chain parallelization} %\VignetteEngine{knitr::rmarkdown} \usepackage[utf8]{inputenc} params: EVAL: !r identical(Sys.getenv("NOT_CRAN"), "true") --- ```{r, SETTINGS-knitr, include=FALSE} stopifnot(require(knitr)) options(width = 90) knit_hooks$set(pngquant = knitr::hook_pngquant) opts_chunk$set( comment = NA, message = FALSE, warning = FALSE, eval = if (isTRUE(exists("params"))) params$EVAL else FALSE, dev = "ragg_png", dpi = 72, fig.retina = 1.5, fig.asp = 0.8, fig.width = 5, out.width = "60%", fig.align = "center", pngquant = "--speed=1 --quality=50" ) library(ggplot2) library(brms) theme_set(theme_default()) ``` ```{r, fake-data-sim, include=FALSE, eval=TRUE} set.seed(54647) # number of observations N <- 1E4 # number of group levels G <- round(N / 10) # number of predictors P <- 3 # regression coefficients beta <- rnorm(P) # sampled covariates, group means and fake data fake <- matrix(rnorm(N * P), ncol = P) dimnames(fake) <- list(NULL, paste0("x", 1:P)) # fixed effect part and sampled group membership fake <- transform( as.data.frame(fake), theta = fake %*% beta, g = sample.int(G, N, replace=TRUE) ) # add random intercept by group fake <- merge(fake, data.frame(g = 1:G, eta = rnorm(G)), by = "g") # linear predictor fake <- transform(fake, mu = theta + eta) # sample Poisson data fake <- transform(fake, y = rpois(N, exp(mu))) # shuffle order of data rows to ensure even distribution of computational effort fake <- fake[sample.int(N, N),] # drop not needed row names rownames(fake) <- NULL ``` ```{r, model-poisson, include=FALSE} model_poisson <- brm( y ~ 1 + x1 + x2 + (1 | g), data = fake, family = poisson(), iter = 500, # short sampling to speedup example chains = 2, prior = prior(normal(0,1), class = b) + prior(constant(1), class = sd, group = g), backend = "cmdstanr", threads = threading(4), save_pars = save_pars(all = TRUE) ) ``` ```{r, benchmark, include=FALSE} # Benchmarks given model with cross-product of tuning parameters CPU # cores, grainsize and iterations. Models are run with either static # or non-static scheduler and initial values are set by default to 0 on the # unconstrained scale. Function returns a data-frame with the # cross-product of the tuning parameters and as result column the # respective runtime. benchmark_threading <- function(model, cores = 1, grainsize = 1, iter = 100, static = FALSE) { winfo <- extract_warmup_info(model) sims <- rstan::extract(model$fit) init <- list(extract_draw(sims, 1)) scaling_model <- update( model, refresh = 0, threads = threading(1, grainsize = grainsize[1], static = static), chains = 1, iter = 2, backend = "cmdstanr" ) run_benchmark <- function(cores, size, iter) { bench_fit <- update( scaling_model, warmup=0, iter = iter, chains = 1, seed = 1234, init = init, refresh = 0, save_warmup=TRUE, threads = threading(cores, grainsize = size, static = static), inv_metric=winfo$inv_metric[[1]], step_size=winfo$step_size[[1]], adapt_engaged=FALSE ) lf <- sum(subset(nuts_params(bench_fit, inc_warmup=TRUE), Parameter=="n_leapfrog__")$Value) elapsed <- sum(colSums(rstan::get_elapsed_time(bench_fit$fit))) c(num_leapfrog=lf, runtime=elapsed) } cases <- expand.grid(cores = cores, grainsize = grainsize, iter = iter) res <- with(cases, mapply(run_benchmark, cores, grainsize, iter)) cbind(cases, as.data.frame(t(res))) } benchmark_reference <- function(model, iter=100, init=0) { winfo <- extract_warmup_info(model) sims <- rstan::extract(model$fit) init <- list(extract_draw(sims, 1)) ref_model <- update( model, refresh = 0, threads = NULL, chains = 1, iter = 2, backend = "cmdstanr" ) run_benchmark_ref <- function(iter_bench) { bench_fit <- update( ref_model, warmup=0, iter = iter_bench, chains = 1, seed = 1234, init = init, refresh = 0, inv_metric=winfo$inv_metric[[1]], step_size=winfo$step_size[[1]], adapt_engaged=FALSE ) lf <- sum(subset(nuts_params(bench_fit, inc_warmup=TRUE), Parameter=="n_leapfrog__")$Value) elapsed <- sum(colSums(rstan::get_elapsed_time(bench_fit$fit))) c(num_leapfrog=lf, runtime=elapsed) } ref <- sapply(iter, run_benchmark_ref) ref <- cbind(as.data.frame(t(ref)), iter=iter) ref } extract_warmup_info <- function(bfit) { adapt <- lapply(rstan::get_adaptation_info(bfit$fit), strsplit, split="\\n") step_size <- lapply(adapt, function(a) as.numeric(strsplit(a[[1]][[1]], " = ")[[1]][2])) inv_metric <- lapply(adapt, function(a) as.numeric(strsplit(sub("^# ", "", a[[1]][[3]]), ", ")[[1]])) list(step_size=step_size, inv_metric=inv_metric) } extract_draw <- function(sims, draw) { lapply(sims, brms:::slice, dim = 1, i = draw, drop = TRUE) } ``` ## Introduction Full Bayesian inference is a computationally very demanding task and often we wish to run our models faster in shorter walltime. With modern computers we nowadays have multiple processors available on a given machine such that the use of running the inference in parallel will shorten the overall walltime. While between-chain parallelization is straightforward by merely launching multiple chains at the same time, the use of within-chain parallelization is more complicated in various ways. This vignette aims to introduce the user to within-chain parallelization with **brms**, since its efficient use depends on various aspects specific to the users model. ## Quick summary Assuming you have a **brms** model which you wish to evaluate faster by using more cores per chain, for example: ```{r, eval=FALSE} fit_serial <- brm( count ~ zAge + zBase * Trt + (1|patient), data = epilepsy, family = poisson(), chains = 4, cores = 4, backend = "cmdstanr" ) ``` Then you can simply add threading support to an existing model with the `update` mechanism as follows, provided your stan version is at least 2.26 (whether using `rstan` or `cmdstan`): ```{r, eval=FALSE} fit_parallel <- update( fit_serial, chains = 2, cores = 2, backend = "cmdstanr", threads = threading(2) ) ``` The example above assumes that 4 cores are available which are best used without within-chain parallelization by running 4 chains in parallel. When using within chain parallelization it is still advisable to use just as many threads *in total* as you have CPU cores. It's thus sensible in this case to reduce the number of chains running in parallel to just 2, but allow each chain to use 2 threads. Obviously this will reduce the number of iterations in the posterior here as we assumed a fixed amount of 4 cores. - Only apply within-chain parallelization to large problems which take more than a few minutes at least to calculate. The `epilepsy` example above is actually too small to gain in speed (just a few seconds per chain on this machine). - Within-chain parallelization is less efficient than between-chain parallelization. So only use within-chain parallelism if more CPUs can be used to run the entire analysis. - Due to details of the model and data-set, speedups with more cores can be very limited. Not every model amends to within-chain parallelization and an empirical evaluation is in some cases advisable. - Enabling threading *usually* slows down any model to some extent and this slowdown must be offset by sufficient cores per chain in order to really gain in execution speed. - Doubling the execution speed with few cores is a lot easier than obtaining larger speedups with even more cores. - Models with computationally expensive likelihoods are easier to parallelize than less expensive likelihoods. For example, the Poisson distribution involves expensive $\log\Gamma$ functions whereas the normal likelihood is very cheap to calculate in comparison. - Models with many parameters (e.g., multilevel models) carry a large overhead when running in parallel. - With a larger overhead of the model, the likelihood must be sufficiently expensive such that the relative computational cost of likelihood to parallelization overhead is favorable. - Avoid using hyper-threading, that is, only use as many threads as you have physical cores available. - Ensure that the data is randomly sorted such that consecutive subsets of the data are roughly of the same computational effort. ## Within-chain parallelization The within-chain parallelization implemented in **brms** is based on the `reduce_sum` facility in Stan. The basic principle that `reduce_sum` uses is to split a large summation into arbitrary smaller partial sums. Due to the commutativity and associativity of the sum operation these smaller partial sums can be evaluated in any order and in parallel from one another. **brms** leverages `reduce_sum` to evaluate the log-likelihood of the model in parallel as for example $$ \begin{aligned} l(y|\theta) &= \sum_{i=1}^N l_i(y_i| \theta) \\ &= \sum_{i=1}^{S_1} l_i(y_i| \theta) + \sum_{i=S_1+1}^N l_i(y_i| \theta). \end{aligned} $$ As a consequence, the within-chain parallelization requires mutually independent log-likelihood terms which restricts its applicability to some degree. Furthermore, the within-chain parallelization is only applicable to the evaluation of the data likelihood while all other parts of the model, for example priors, will remain running serially. Thus, only a partial fraction of the entire Stan model will run in parallel which limits the potential speedup one may obtain. The theoretical speedup for a partially in parallel running program is described by [Amdahl‘s law](https://en.wikipedia.org/wiki/Amdahl%27s_law). For example, with 90% of the computational load running in parallel one can essentially double the execution speed with 2 cores while 8 cores may only speedup the program by at most 5x. How large the computational cost of the log-likelihood is in relation to the entire model is very dependent on the model of the user. In practice, the speedups are even smaller than the theoretical speedups. This is caused by the additional overhead implied by forming multiple smaller sums than just one large one. For example, for each partial sum formed the entire parameter vector $\theta$ has to be copied in memory for Stan to be able to calculate the gradient of the log-likelihood. Hence, with more partial sums, more copying is necessary as opposed to evaluating just one large sum. Whether the additional copying is indeed relevant depends on the computational cost of the log-likelihood of each term and the number of parameters. For a model with a computationally cheap normal log-likelihood, this effect is more important than for a model with a Poisson log-likelihood, and for multilevel models with many parameters more copying is needed than for simpler regression models. It may therefore be necessary to form sufficiently large partial sums to warrant an efficient parallel execution. The size of the partial sums is referred to as the `grainsize`, which is set to a reasonable default value. However, for some models this tuning parameter requires some attention from the user for optimal performance. Finally, it is important to note that by default the exact size and order of the partial sums is not stable as it is adjusted to the load of the system. As a result, exact numerical reproducibility is not guaranteed by default. In order to warrant the same size and order of the partial sums, the `static` option must be used and set to `TRUE`, which uses a deterministic scheduler for the parallel work. ## Example model As a toy demonstration, we use here a multilevel Poisson model. The model is a varying intercept model with $`r N`$ data observation which are grouped into $`r G`$ groups. Each data item has $`r P`$ continuous covariates. The simulation code for the fake data can be found in the appendix and it's first $10$ rows are: ```{r} kable(head(fake, 10), digits = 3) ``` The **brms** model fitting this data is: ```{r, eval=FALSE} <> ``` Here we have fixed the standard deviation of the between-group variation for the intercept to the true value of $1$ as used in the simulation. This is to avoid unfavorable geometry of the problem allowing us to concentrate on computational aspects alone. The Poisson likelihood is a relatively expensive likelihood due to the use of $\log\Gamma$ function as opposed to, for example, a normal likelihood which does is by far less expensive operations. Moreover, this example is chosen in order to demonstrate parallelization overhead implied by a large number of parameters. ## Managing parallelization overhead As discussed above, the key mechanism to run Stan programs with parallelization is to split the large sum over independent log likelihood terms into arbitrary smaller *partial sums*. Creating more *partial sums* allows to increase simultaneous parallel computations in a granular way, but at the same time additional overhead is introduced through the requirement to copy the entire parameter vector for each *partial sum* formed along with further overhead due to splitting up a single large task into multiple smaller ones. By default, **brms** will choose a sensible `grainsize` which defines how large a given *partial sum* will roughly be. The actual chunk size is automatically tuned whenever the default non-static scheduler is used, which is the recommended choice to start with. As noted before, only the static scheduler is giving fully deterministic results since the chunk size and order of partial sums will be the same during sampling. While we expect that the default `grainsize` in **brms** is reasonably good for many models, it can improve performance if one tunes the `grainsize` specifically to a given model and data-set. We suggest to increase successively the number of chunks a given data set is split into with the static scheduler and run this on a single core. This way one can control the number of *partial sum* accurately and monitor the execution time as it increases. These experiments are run with only a single chain and very short iteration numbers as we are not interested in the statistical results, but rather aim to be able to explore the tuning parameter space of the chunk size as quickly as possible. The number of iterations needed to get reliable runtime estimates for a given chunk size will depend on many details and the easiest way to determine this is to run this benchmark with multiple number of iterations. Whenever their results match approximately, then the iteration numbers are sufficient. In order to decrease the variation between runs, we also fix the random seed, initial value and the tuning parameters of the sampler (step size and mass matrix). Below is an example R code demonstrating such a benchmark. The utility function `benchmark_threading` is shown and explained in the appendix. ```{r, chunking-scale, message=FALSE, warning=FALSE, results='hide'} chunking_bench <- transform( data.frame(chunks = 4^(0:3)), grainsize = ceiling(N / chunks) ) iter_test <- c(10, 20, 40) # very short test runs scaling_chunking <- benchmark_threading( model_poisson, cores = 1, grainsize = chunking_bench$grainsize, # test various grainsizes iter = iter_test, static = TRUE # with static partitioner ) # run as reference the model *without* reduce_sum ref <- benchmark_reference(model_poisson, iter_test) # for additional data munging please refer to the appendix ``` ```{r, munge-chunking-scaling, include=FALSE} scaling_chunking <- merge(scaling_chunking, chunking_bench, by = "grainsize") single_chunk <- transform( subset(scaling_chunking, chunks == 1), num_leapfrog_single = num_leapfrog, num_leapfrog = NULL, runtime_single = runtime, runtime = NULL, grainsize = NULL, chunks=NULL ) scaling_chunking <- transform( merge(scaling_chunking, single_chunk), slowdown = runtime/runtime_single, iter = factor(iter), runtime_single = NULL ) ref <- transform(ref, iter=factor(iter)) ``` Graphically summarizing the results shows that with more than 8 chunks the overhead is about 10% and increasing further with more chunks. For models without many parameters, no such overhead should be observed. Furthermore, one can see that 25 and 50 iterations give similar results implying that 25 iterations suffice for stable runtime estimates for these (and the following) benchmarks. The overhead of up to 20% in this example with 16 chunks may seem large due to the scaling of the plot. One must not forget that when we start to use more CPU cores, the overhead is easily offset, but it limits the maximal speedup we can get. For example, some 2 units of computation become 2.4 units due to the overhead such that on 2 cores we don't quite double the execution speed, but rather get a 1.6x increase in speed instead of a 2x speedup. Considering in addition the time per leapfrog step of the NUTS sampler shows on an absolute scale similar information as before. The upside of this representation is that we can visualize the slowdown in relation to the program *without* `reduce_sum`. As we can see, the additional overhead due to merely enabling `reduce_sum` is substantial in this example. This is attributed in the specific example to the large number of random effects. ```{r} ggplot(scaling_chunking) + aes(chunks, slowdown, colour = iter, shape = iter) + geom_line() + geom_point() + scale_x_log10(breaks = scaling_chunking$chunks) + scale_y_log10(breaks=seq(0.8, 2.5, by=0.1)) + ggtitle("Slowdown with increasing number of chunks") ggplot(scaling_chunking) + aes(chunks, 1E3 * runtime/num_leapfrog, colour = iter, shape=iter) + geom_line() + geom_point() + scale_x_log10(breaks = scaling_chunking$chunks) + scale_y_log10(breaks=seq(0.1, 2.0, by=0.1)) + geom_hline(data=ref, aes(yintercept=1E3 * runtime/num_leapfrog, colour=iter), linetype=I(2)) + ggtitle("Time per leapfrog step vs number of chunks", "Dashed line is reference model without reduce_sum") + ylab("Time per leapfrog step [ms]") ``` ## Parallelization speedup In practice, we are often interested in so-called "hard-scaling" properties of the parallelization system. That is, for a fixed problem size we would like to know how much faster we can execute the Stan program with increasing number of threads. As nowadays CPUs usually run with so-called hyper-threading, it is also of interest if this technique is beneficial for Stan programs as well (spoiler alert: it's not useful). As we have seen before, the `grainsize` can have an impact on the performance and is as such a tuning parameter. Below we demonstrate some exemplary R code which runs a benchmark with varying number of CPU cores and varying number of `grainsize`s. ```{r, speedup-scale, message=FALSE, warning=FALSE, results='hide'} num_cpu <- parallel::detectCores(logical = FALSE) num_cpu_logical <- parallel::detectCores(logical = TRUE) grainsize_default <- ceiling(N / (2 * num_cpu)) cores <- c(2^seq(0, floor(log2(num_cpu_logical))), num_cpu, num_cpu_logical) cores <- sort(unique(cores)) grainsize <- c(grainsize_default, grainsize_default/2, grainsize_default/4) grainsize <- round(grainsize) iter_scaling <- 20 scaling_cores <- benchmark_threading( model_poisson, cores = cores, grainsize = grainsize, iter = iter_scaling, static = FALSE ) single_core <- transform( subset(scaling_cores, cores == 1), runtime_single = runtime, num_leapfrog=NULL, runtime=NULL, cores = NULL ) scaling_cores <- transform( merge(scaling_cores, single_core), speedup = runtime_single/runtime, grainsize = factor(grainsize) ) ``` It is important to consider the absolute runtime and the relative speedup vs. running on a single core. The relative speedup can be misleading if the single core runtime is very slow in which case speed gains on more CPUs may look overly good. Considering instead the absolute runtime avoids this problem. After all, we are interested in the shortest walltime we can get rather than any relative speedups. ```{r} ggplot(scaling_cores) + aes(cores, runtime, shape = grainsize, color = grainsize) + geom_vline(xintercept = num_cpu, linetype = 3) + geom_line() + geom_point() + scale_x_log10(breaks = scaling_cores$cores) + scale_y_log10(breaks=seq(0.1, 1.4, by=0.1)) + theme(legend.position = c(0.85, 0.8)) + geom_hline(data=subset(ref, iter==iter_scaling), aes(yintercept=runtime), linetype=I(2)) + ggtitle("Runtime with varying number of cores", "Dashed line is reference model without reduce_sum") ggplot(scaling_cores) + aes(cores, speedup, shape = grainsize, color = grainsize) + geom_abline(slope = 1, intercept = 0, linetype = 2) + geom_vline(xintercept = num_cpu, linetype = 3) + geom_line() + geom_point() + scale_x_log10(breaks=scaling_cores$cores) + scale_y_log10(breaks=scaling_cores$cores) + theme(aspect.ratio = 1) + coord_fixed(xlim = c(1, num_cpu_logical), ylim = c(1, num_cpu_logical)) + ggtitle("Relative speedup vs 1 core") ``` The vertical dotted line marks the physical number of CPU cores on the machine this was run. The horizontal dashed line in the plot with absolute runtime marks the respective runtime of the model *without* `reduce_sum` and the dashed unity line in the plot with the relative speedup marks the theoretical maximal speedup. We can see that there is no further reduction in execution time when increasing the thread count to be greater than the number of physical CPUs. Hence, the use of hyper-threading is not helpful when aiming to maximize the speed of a Stan program. Moreover, the use of threading outperforms the single core runtime only when using more than 4 cores in this example. For this example, the shown `grainsize`s matter on some machines but not on others, so your results may look quite different from what is shown here. The overall speedups may not seem impressive in this case, which is attributed in this case to the large number of parameters relative to the number of observations. However, we can still outperform the single core runtime when using many cores. Though the most important advantage of threading is that with an increasing data set size, the user has the option to use a brute-force approach to balance the increase in walltime needed. ```{r} kable(scaling_cores, digits = 2) ``` For a given Stan model one should usually choose the number of chains and the number of threads per chain to be equal to the number of (physical) cores one wishes to use. Only if different chains of the model have relatively different execution times (which they should not have, but it occurs sometimes in practice), then one may consider the use of hyper-threading. Doing so will share the resources evenly across all chains and whenever the fastest chain finishes, the freed resources can be given to the still running chains. ## Appendix ### Fake data simulation ```{r, eval=FALSE} <> ``` ### Poisson example model ```{r, eval=FALSE} <> ``` ### Threading benchmark function ```{r, eval=FALSE} <> ``` ### Munging of slowdown with chunking data ```{r, eval=FALSE} <> ``` brms/vignettes/brms_nonlinear.Rmd0000644000176200001440000003034515053072461016711 0ustar liggesusers--- title: "Estimating Non-Linear Models with brms" author: "Paul Bürkner" date: "`r Sys.Date()`" output: rmarkdown::html_vignette: toc: yes vignette: > %\VignetteIndexEntry{Estimating Non-Linear Models with brms} %\VignetteEngine{knitr::rmarkdown} \usepackage[utf8]{inputenc} params: EVAL: !r identical(Sys.getenv("NOT_CRAN"), "true") --- ```{r, SETTINGS-knitr, include=FALSE} stopifnot(require(knitr)) options(width = 90) knit_hooks$set(pngquant = knitr::hook_pngquant) opts_chunk$set( comment = NA, message = FALSE, warning = FALSE, eval = if (isTRUE(exists("params"))) params$EVAL else FALSE, dev = "ragg_png", dpi = 72, fig.retina = 1.5, fig.asp = 0.8, fig.width = 5, out.width = "60%", fig.align = "center", pngquant = "--speed=1 --quality=50" ) library(brms) ggplot2::theme_set(theme_default()) ``` ## Introduction This vignette provides an introduction on how to fit non-linear multilevel models with **brms**. Non-linear models are incredibly flexible and powerful, but require much more care with respect to model specification and priors than typical generalized linear models. Ignoring group-level effects for the moment, the predictor term $\eta_n$ of a generalized linear model for observation $n$ can be written as follows: $$\eta_n = \sum_{i = 1}^K b_i x_{ni}$$ where $b_i$ is the regression coefficient of predictor $i$ and $x_{ni}$ is the data of predictor $i$ for observation $n$. This also comprises interaction terms and various other data transformations. However, the structure of $\eta_n$ is always linear in the sense that the regression coefficients $b_i$ are multiplied by some predictor values and then summed up. This implies that the hypothetical predictor term $$\eta_n = b_1 \exp(b_2 x_n)$$ would *not* be a *linear* predictor anymore and we could not fit it using classical techniques of generalized linear models. We thus need a more general model class, which we will call *non-linear* models. Note that the term 'non-linear' does not say anything about the assumed distribution of the response variable. In particular it does not mean 'not normally distributed' as we can apply non-linear predictor terms to all kinds of response distributions (for more details on response distributions available in **brms** see `vignette("brms_families")`). ## A Simple Non-Linear Model We begin with a simple example using simulated data. ```{r} b <- c(2, 0.75) x <- rnorm(100) y <- rnorm(100, mean = b[1] * exp(b[2] * x)) dat1 <- data.frame(x, y) ``` As stated above, we cannot use a generalized linear model to estimate $b$ so we go ahead an specify a non-linear model. ```{r, results='hide'} prior1 <- prior(normal(1, 2), nlpar = "b1") + prior(normal(0, 2), nlpar = "b2") fit1 <- brm(bf(y ~ b1 * exp(b2 * x), b1 + b2 ~ 1, nl = TRUE), data = dat1, prior = prior1) ``` When looking at the above code, the first thing that becomes obvious is that we changed the `formula` syntax to display the non-linear formula including predictors (i.e., `x`) and parameters (i.e., `b1` and `b2`) wrapped in a call to `bf`. This stands in contrast to classical **R** formulas, where only predictors are given and parameters are implicit. The argument `b1 + b2 ~ 1` serves two purposes. First, it provides information, which variables in `formula` are parameters, and second, it specifies the linear predictor terms for each parameter. In fact, we should think of non-linear parameters as placeholders for linear predictor terms rather than as parameters themselves (see also the following examples). In the present case, we have no further variables to predict `b1` and `b2` and thus we just fit intercepts that represent our estimates of $b_1$ and $b_2$ in the model equation above. The formula `b1 + b2 ~ 1` is a short form of `b1 ~ 1, b2 ~ 1` that can be used if multiple non-linear parameters share the same formula. Setting `nl = TRUE` tells **brms** that the formula should be treated as non-linear. In contrast to generalized linear models, priors on population-level parameters (i.e., 'fixed effects') are often mandatory to identify a non-linear model. Thus, **brms** requires the user to explicitly specify these priors. In the present example, we used a `normal(1, 2)` prior on (the population-level intercept of) `b1`, while we used a `normal(0, 2)` prior on (the population-level intercept of) `b2`. Setting priors is a non-trivial task in all kinds of models, especially in non-linear models, so you should always invest some time to think of appropriate priors. Quite often, you may be forced to change your priors after fitting a non-linear model for the first time, when you observe different MCMC chains converging to different posterior regions. This is a clear sign of an identification problem and one solution is to set stronger (i.e., more narrow) priors. To obtain summaries of the fitted model, we apply ```{r} summary(fit1) plot(fit1) plot(conditional_effects(fit1), points = TRUE) ``` The `summary` method reveals that we were able to recover the true parameter values pretty nicely. According to the `plot` method, our MCMC chains have converged well and to the same posterior. The `conditional_effects` method visualizes the model-implied (non-linear) regression line. We might be also interested in comparing our non-linear model to a classical linear model. ```{r, results='hide'} fit2 <- brm(y ~ x, data = dat1) ``` ```{r} summary(fit2) ``` To investigate and compare model fit, we can apply graphical posterior predictive checks, which make use of the **bayesplot** package on the backend. ```{r} pp_check(fit1) pp_check(fit2) ``` We can also easily compare model fit using leave-one-out cross-validation. ```{r} loo(fit1, fit2) ``` Since smaller `LOOIC` values indicate better model fit, it is immediately evident that the non-linear model fits the data better, which is of course not too surprising since we simulated the data from exactly that model. ## A Real-World Non-Linear model On his blog, Markus Gesmann predicts the growth of cumulative insurance loss payments over time, originated from different origin years (see https://www.magesblog.com/post/2015-11-03-loss-developments-via-growth-curves-and/). We will use a slightly simplified version of his model for demonstration purposes here. It looks as follows: $$cum_{AY, dev} \sim N(\mu_{AY, dev}, \sigma)$$ $$\mu_{AY, dev} = ult_{AY} \left(1 - \exp\left(- \left( \frac{dev}{\theta} \right)^\omega \right) \right)$$ The cumulative insurance payments $cum$ will grow over time, and we model this dependency using the variable $dev$. Further, $ult_{AY}$ is the (to be estimated) ultimate loss of accident each year. It constitutes a non-linear parameter in our framework along with the parameters $\theta$ and $\omega$, which are responsible for the growth of the cumulative loss and are assumed to be the same across years. The data is already shipped with brms. ```{r} data(loss) head(loss) ``` and translate the proposed model into a non-linear **brms** model. ```{r, results='hide'} fit_loss <- brm( bf(cum ~ ult * (1 - exp(-(dev/theta)^omega)), ult ~ 1 + (1|AY), omega ~ 1, theta ~ 1, nl = TRUE), data = loss, family = gaussian(), prior = c( prior(normal(5000, 1000), nlpar = "ult"), prior(normal(1, 2), nlpar = "omega"), prior(normal(45, 10), nlpar = "theta") ), control = list(adapt_delta = 0.9) ) ``` We estimate a group-level effect of accident year (variable `AY`) for the ultimate loss `ult`. This also shows nicely how a non-linear parameter is actually a placeholder for a linear predictor, which in case of `ult`, contains only an varying intercept over year. Again, priors on population-level effects are required and, for the present model, are actually mandatory to ensure identifiability. We summarize the model using well known methods. ```{r} summary(fit_loss) plot(fit_loss, N = 3, ask = FALSE) conditional_effects(fit_loss) ``` Next, we show marginal effects separately for each year. ```{r} conditions <- data.frame(AY = unique(loss$AY)) rownames(conditions) <- unique(loss$AY) me_loss <- conditional_effects( fit_loss, conditions = conditions, re_formula = NULL, method = "predict" ) plot(me_loss, ncol = 5, points = TRUE) ``` It is evident that there is some variation in cumulative loss across accident years, for instance due to natural disasters happening only in certain years. Further, we see that the uncertainty in the predicted cumulative loss is larger for later years with fewer available data points. For a more detailed discussion of this data set, see Section 4.5 in Gesmann & Morris (2020). ## Advanced Item-Response Models As a third example, we want to show how to model more advanced item-response models using the non-linear model framework of **brms**. For simplicity, suppose we have a single forced choice item with three alternatives of which only one is correct. Our response variable is whether a person answers the item correctly (1) or not (0). Person are assumed to vary in their ability to answer the item correctly. However, every person has a 33% chance of getting the item right just by guessing. We thus simulate some data to reflect this situation. ```{r} inv_logit <- function(x) 1 / (1 + exp(-x)) ability <- rnorm(300) p <- 0.33 + 0.67 * inv_logit(ability) answer <- ifelse(runif(300, 0, 1) < p, 1, 0) dat_ir <- data.frame(ability, answer) ``` The most basic item-response model is equivalent to a simple logistic regression model. ```{r, results='hide'} fit_ir1 <- brm(answer ~ ability, data = dat_ir, family = bernoulli()) ``` However, this model completely ignores the guessing probability and will thus likely come to biased estimates and predictions. ```{r} summary(fit_ir1) plot(conditional_effects(fit_ir1), points = TRUE) ``` A more sophisticated approach incorporating the guessing probability looks as follows: ```{r, results='hide'} fit_ir2 <- brm( bf(answer ~ 0.33 + 0.67 * inv_logit(eta), eta ~ ability, nl = TRUE), data = dat_ir, family = bernoulli("identity"), prior = prior(normal(0, 5), nlpar = "eta") ) ``` It is very important to set the link function of the `bernoulli` family to `identity` or else we will apply two link functions. This is because our non-linear predictor term already contains the desired link function (`0.33 + 0.67 * inv_logit`), but the `bernoulli` family applies the default `logit` link on top of it. This will of course lead to strange and uninterpretable results. Thus, please make sure that you set the link function to `identity`, whenever your non-linear predictor term already contains the desired link function. ```{r} summary(fit_ir2) plot(conditional_effects(fit_ir2), points = TRUE) ``` Comparing model fit via leave-one-out cross-validation ```{r} loo(fit_ir1, fit_ir2) ``` shows that both model fit the data equally well, but remember that predictions of the first model might still be misleading as they may well be below the guessing probability for low ability values. Now, suppose that we don't know the guessing probability and want to estimate it from the data. This can easily be done changing the previous model just a bit. ```{r, results='hide'} fit_ir3 <- brm( bf(answer ~ guess + (1 - guess) * inv_logit(eta), eta ~ 0 + ability, guess ~ 1, nl = TRUE), data = dat_ir, family = bernoulli("identity"), prior = c( prior(normal(0, 5), nlpar = "eta"), prior(beta(1, 1), nlpar = "guess", lb = 0, ub = 1) ) ) ``` Here, we model the guessing probability as a non-linear parameter making sure that it cannot exceed the interval $[0, 1]$. We did not estimate an intercept for `eta`, as this will lead to a bias in the estimated guessing parameter (try it out; this is an excellent example of how careful one has to be in non-linear models). ```{r} summary(fit_ir3) plot(fit_ir3) plot(conditional_effects(fit_ir3), points = TRUE) ``` The results show that we are able to recover the simulated model parameters with this non-linear model. Of course, real item-response data have multiple items so that accounting for item and person variability (e.g., using a multilevel model with varying intercepts) becomes necessary as we have multiple observations per item and person. Luckily, this can all be done within the non-linear framework of **brms** and I hope that this vignette serves as a good starting point. ## References Gesmann M. & Morris J. (2020). Hierarchical Compartmental Reserving Models. *CAS Research Papers*. brms/vignettes/me_loss1.pdf0000644000176200001440000001416013155225616015452 0ustar liggesusers%PDF-1.4 %ρ\r 1 0 obj << /CreationDate (D:20170910140948) /ModDate (D:20170910140948) /Title (R Graphics Output) /Producer (R 3.4.1) /Creator (R) >> endobj 2 0 obj << /Type /Catalog /Pages 3 0 R >> endobj 7 0 obj << /Type /Page /Parent 3 0 R /Contents 8 0 R /Resources 4 0 R >> endobj 8 0 obj << /Length 2231 /Filter /FlateDecode >> stream xXˎ]߯RZ"כֿĀHf, DHjŖ%$RC>6Sϟj"1 C#]ki#_"{K~%Z"F?ڌezۭ'}q]c$Z3+qjCшi6t<Њf4rz*J+צ'(asQu)Qf3V]}V1s,KwE2g)eF*1׀OѷKw@CZR[?9p[ip9-#Ÿ,qb_ BM{?zv;".>(sߞc)hEA W'm`T{8Oy$R'+_|ݪa Ly'x 6:L,gw ӚNk_2\]Vqx.?h"`=DS<_~W ĵxdzb',xWɰɣEכ_5Ϋ. b۸bN񔔘?Ά~#-hXї.b-_Tʅi^+_S\!_QLpy<&}|mo~} ,;^gxr~Xa|.coJ<8Og>zKy0k'_=ׯOg#ߡK=9a%CoF+[׭Wy=p=}w{C]/~CO[zumL=Xfz PO]auz>^-(OXrv˛.;:ʣnci+]U~>g7g]vyG}忻@vy y~8#/N^~=B{ih%\ Wc{A6t{7\TmGg~^WGϹSvsfޢc;9,>톶67=}]r{L{4v0^?|/`_Qrt}j9Jj>,G)ɑ|__p ᖑO=?~h4CggV-G9!}`N3]3#vLh\,#+*`ji`^q'F>\ݟ# 1w[/ZJO^]qsnk]|dvke'OI<xK~Iǖ6׫^&<=wYKVuTw|ة?mendstream endobj 3 0 obj << /Type /Pages /Kids [ 7 0 R ] /Count 1 /MediaBox [0 0 288 216] >> endobj 4 0 obj << /ProcSet [/PDF /Text] /Font <> /ExtGState << /GS1 11 0 R /GS257 12 0 R /GS258 13 0 R >> /ColorSpace << /sRGB 5 0 R >> >> endobj 5 0 obj [/ICCBased 6 0 R] endobj 6 0 obj << /Alternate /DeviceRGB /N 3 /Length 2596 /Filter /FlateDecode >> stream xwTSϽ7PkhRH H.*1 J"6DTpDQ2(C"QDqpId߼y͛~kg}ֺLX Xňg` lpBF|،l *?Y"1P\8=W%Oɘ4M0J"Y2Vs,[|e92<se'9`2&ctI@o|N6(.sSdl-c(2-yH_/XZ.$&\SM07#1ؙYrfYym";8980m-m(]v^DW~ emi]P`/u}q|^R,g+\Kk)/C_|Rax8t1C^7nfzDp 柇u$/ED˦L L[B@ٹЖX!@~(* {d+} G͋љς}WL$cGD2QZ4 E@@A(q`1D `'u46ptc48.`R0) @Rt CXCP%CBH@Rf[(t CQhz#0 Zl`O828.p|O×X ?:0FBx$ !i@ڐH[EE1PL ⢖V6QP>U(j MFkt,:.FW8c1L&ӎ9ƌaX: rbl1 {{{;}#tp8_\8"Ey.,X%%Gщ1-9ҀKl.oo/O$&'=JvMޞxǥ{=Vs\x ‰N柜>ucKz=s/ol|ϝ?y ^d]ps~:;/;]7|WpQoH!ɻVsnYs}ҽ~4] =>=:`;cܱ'?e~!ańD#G&}'/?^xI֓?+\wx20;5\ӯ_etWf^Qs-mw3+?~O~endstream endobj 9 0 obj << /Type /Encoding /BaseEncoding /WinAnsiEncoding /Differences [ 45/minus ] >> endobj 10 0 obj << /Type /Font /Subtype /Type1 /Name /F7 /BaseFont /Times-Roman /Encoding 9 0 R >> endobj 11 0 obj << /Type /ExtGState /CA 1.000 >> endobj 12 0 obj << /Type /ExtGState /ca 0.400 >> endobj 13 0 obj << /Type /ExtGState /ca 1.000 >> endobj xref 0 14 0000000000 65535 f 0000000021 00000 n 0000000163 00000 n 0000002595 00000 n 0000002678 00000 n 0000002830 00000 n 0000002863 00000 n 0000000212 00000 n 0000000292 00000 n 0000005558 00000 n 0000005652 00000 n 0000005751 00000 n 0000005800 00000 n 0000005849 00000 n trailer << /Size 14 /Info 1 0 R /Root 2 0 R >> startxref 5898 %%EOF brms/vignettes/ppc_mm1.pdf0000644000176200001440000007500113042165067015263 0ustar liggesusers%PDF-1.4 %ρ\r 1 0 obj << /CreationDate (D:20170125191102) /ModDate (D:20170125191102) /Title (R Graphics Output) /Producer (R 3.3.2) /Creator (R) >> endobj 2 0 obj << /Type /Catalog /Pages 3 0 R >> endobj 7 0 obj << /Type /Page /Parent 3 0 R /Contents 8 0 R /Resources 4 0 R >> endobj 8 0 obj << /Length 27077 /Filter /FlateDecode >> stream xKeKvU+&tѵ,$yHVaW9d[T!h pVwُxso毿o~_k~_|O_~2?|_m~N_M_4}ot~÷mOW9ѱh}F':]=Zs95~`z~] ң>~a={/lKc6ݢ}Mt_8 Ǚp_oph='ڏo?-S݉ڷhQG yhkhS{K Z{{U-D?eO_Ô{o9lѺ%m[ڽ=گDңc\xv-ƕ;p/ s֩76գkGV$[\۽_#kֵ-:z{Yވ[Wcڽ_DqMDW!X۽=ϬE>\֫ڽ#[mmEۖs?Ѣζq-:GgТus<Ӣ֫Z4e{dKzUoGU-:DWh<콤q[-}lzj9EǑ6OW6^բn{jv%jբ_帖^ko{Uv֫ZthｪE7Qk g?zkﭛ[4ZƮGQk}O:ѫ.J9ѫcJ<ѫc-ߖѫneoEZ޷DݴhcｪEǜ=:zj=m^բjWUߍvvqw -oE+-zKiz'jEgs뺥ߖ[4zv[zU=[Uk֫z{/Q{-ݞGU+3BZj=콪1ڜ:^1cZzP~Tc3ou-luk齪'3QkE-}ۭWm^ꮽ? آ֫Zo:zh{UwѾRט[O-3_[_wU-EmIo14`Zji=+ܙcѸ^ٯ^{j=f=޽;k}d^H{mE}wcOoDZEWyֺ֞ǘբZ 9OSք@֪Z`XkS±jo9[ 0VksNz:WkJKQcn'+ښȒo{b'l,1R}g%齇޳W5_;a{?:h˕TZMzzG [m}ׅ2VSEڰ]nnZ뗐_Ǭտvq+ęF;Qχq_'cnV}-eb ܗ&'q_1. s[w>ډqah_׍mr痱v c >~9{<}=.^_6\?6'q_M!v ]B]zsf˹ \Xm\VS>dWmbm8ڃp8eY? &n}vn`:AѹX*jn]zT֦6_}11xsȦy?h}j_^ܧu Sٰ TB܆1 nxnP^{F6 w¹ =cl`ۋ6q A ֗6^;R[M>^魴֨ޟ0ul{<|gZEܦ&~ξ4?^|=6Js禾h?7ml @{Ysޟto?I'ϧ7iJs-ǂ7<#͚cGxy=m<b_I-Vo} ;L?m66n+1gZ~h66}FXKܙuڬ;cg8Y?vG"=+yF}(=kq7Ng6Խg⓸ϏUֱ771_.i߭-g#;|x~qMNlzGݧ13=wܾf;ˉH{џ[{$NަMkϹ+hAϽgWJwFYӟYHb-ۛ?_ "33>\lzx-JV's?dvN=o{Iv縘?wVk|َ ҞZpwߜOx܆w=};<== ܇r/yO猧ywg{47J!nc07=>H"kk1m=7ٖc ϮzE(}~^zǚ:V>?==vdd9ևc:֏{~o }zYkS]}zvK)ꛊqVv=ݧ ĥֽG51,=E؞L,=7a%"~3]k6 K̭ב7f/rB2Gq^.Yilz:%“B[{q IM&T7~Dedv=l=`,c;XucF`R=G}X\16$Zzzlׄce~#:I;e}^ؽ_H(͸lvv=G /e?H^GRi GVVI#cҳ1g`#mumi{8vJ|鲎궇w鸅8Gjf%;SDz%tdNUqL#9yrL$H,jYwj72.[L{KK=5.]X/W Im\JyFieako}4x F7F/y}z"p'l]reqͬgZG~1>N key'3=y)ivN=e[D}Sa D e;DDOt~!':^ Ot~ۆ:&?@d l_h?(+esp|5m1  <;RgS+@x&c  #?kdB{u|n_ <_YdEY ;쟿=`7+ːa}}<@!@ء$@x  _3טS@xsO٭_SO<@xj <@% @xR $ ^k f ޲oُّS@x g]@xlf ||X %98a;- |g N'-\Xd;%jwֳpKva%aaX @xS7,@x[5@xӬ >ZOꣵ LvF -/dz_7 r `20Mf鬙/57V2ͮ+;L^1aV2Lx?wFqÄ(„wrY2A&FC=LLa00cMjE&|x}0fޟ9LT Lr0TL-Qp_c g `mÄOpt0E _ &|q6S048L30$6˄7LxfWLx 0@ ^wtB+C&܁Y>&qY&^;q}{D =0.N{^=pÄ4‘@ᾬM?Tx,rGheܲަ}2s3 hx 3/87+8Id&Fo^|3퍰5|r>|s>.u#t]~vbn"=1S>|zsqҹy#\,u}Ntr$>|hÇ'>|‡;J8+& fZ۽am y ߑd)==g5$|-| ^@u֝>ӀkYy=)Ad ;vk‡7>>0‡7A7NbÇ7>>q`>^L>|6sOa$o>\4|a'|%>z-u҇"[a+Ç[C=^|x|!l]ul2P ×$v! =v<{>||aFߕg*QŇ/qqpehplcZ|xw>HF!^Fa@|8W9sl|xβR>|3ÇL@`G0s #U0Ň)N\p Q@ߏ!LpN+yy gpXZxK0^p)Θ`4C0| F0^pY&(N69÷WU)΂A0pC0<4kO4#_9^Na0׉`n`l;|I90& r_|xc-></҇KtŎWζ7|xfq>ܣ`'d2Ak,Ü*OiKs(>g |q,rd|iq WLUt < |,D u\ŇG{Pax|3&ÇdGFS0gÜ?_i!a&6!r}N$|xc>|xtApg oÇ7Njo8 o>s\.|xg+>uHvBÇwۆd[‡wuΉqu*o-j}'9‡]!j EÇV 'Xω\K[:'‡= >|a >^uB'ÇOv'>|ȕ-9 1b&|0|>|qZ>փ+38|-|ORasŇ H' Bxl"Q gebx#((9-XQ^1doU ŰtU:l_:PŰ4SŰ4C0(O\txI7axCYo3Q鰊R0V E֮t.Bwq)|_:L.}*;$ >TDBX9cS:F!͂)ctPAμ)M4pe8bx z)w(U|>H1:(3^>ytt>YHϛbbX:b<^*_Tr8t BC:|):tXt_ŰeT 3bbxE!bXş)A`,JOi5tB}_[ZbXEaR *pQ {*^(WŰT Wbx!;bxaQ1lR1#a?aJ1_ʤbp_!oUtut?HaO@xs}33>{H:|N?^:|=Z >Hɍ?JU /o*U .:L6&x'07:Jc tKQ /*-Ooӑ c\$dp! >آv C|77ra8rM:<#8˃08\ Y.N\5xWqʅOpxhW`8raJpPS``^yK.# |mʅ9t\xSDȅpWʅ/x`\88rC.|֧g7pn C. ,B.|g|G.i "F.,-@88x~&hAF΀47 ,n&M4bP,x*ra\i?: 7ra~ȅ@B _g^rOh?::8*8O`8#C,8D|~GW8Vp88xHOp:g KKuWIpWp"8xU= &ݎ\xF.0Ǫ|}ȝ48_ncr׭D ;'O}(lCn . \ ( EALꅻb@~a lok[<͂NqT4I-w>ӎ.QS UߙYso{zQBgY X wFC["wQK]Iׅ]YHH;U Fk6X-wc%Tp.o1C w f+mpi4+m4SmKnZG =-m0m0GiUlHrt6x~A >>nۿK [6oiwJ_RE/{C>JU: e:*K^'^kzZC{_p_0WߌG=?oi4[ťjG-6Zm Vk6XS?h6`<-C_O +;?ZA'm0gxK诧U -upTh] R 66X`UjWq6`hF\Rh~/|Oԋ6!em0 2K3N:hOnL:`" ?`'005|bhEMh7qoc%} g6X^wtxG N.Giwq Y ^>u@P|?l&q(hwqorK4ɥU"6X_ m0wJ% mzҡ >0{2p*M08 B%  C;:6`I0;:= zG^рd;z}iK, 0 g }`pBapH #  ^0j` c >`/0Dȁ:^)r" >ʁe qo`u!$ vv6{0,9(`%`Mr`;SsE#=0x} 0xUv;TZ@q `I9E 4a] ѷ6C6ܫ6hח66X1҆68WUJS # X>ϟ`2hDxGwtѣ=;z(~;pn;u;z=}G}_`άw;:_0|`K<ǓYmBm ?Vl\=QigQk6x`|6x'Xq m["/i ^>cFG7@`(h7 `2hɟ &{6HKFLUʦ0% ء0dD.z Ǔ` fI f B_`|p0n~Ph =я6x=`6 lw1#a`ɁO`*-aƵ,hapo`0(~_08Y<Ǔ/ Go\0h80}^8`r `*t7\ɞq* ńw$ j```0Ld`0;`05!wF$xGKKl-@`0C/p`0Vm0|Wm"]MV}*`Ti( ^ w.*0 >?oֈݥ a7*}QWa-enlwQKxɁRyS:Fު%}(9R*%m-RRKxGZ«Zj ;k-vc-a{C Ȇu {B6|ˊa! wpML-aSKxOaٰe\|᰾ o?a| jaÓaöp]|o>Fo6|.hwFs FF9 fPlxQ llmlҩAh_hmņv1l(lR/So%+7V lmvoFSη-e$p6}aˆeaQS (K(eço [GB6,K [D6X6, T:,et*.SK8%/5lj†q3zFkF7;EQ|Ć6.ذCeó|aìK[lxEI]xto&Fo:ɔ + ^T†oaa|h}Y3lX3`ذ$lML}R7ʥa>eòqt?V#o!k} zapÆo_а3d8mGa+aq&`xV;RHmޑC%ba]"0, /d= փ >9)E+`X]`X-/E tZ`X*`X7`x O0wJQa- Üa!'++0xW0BA0T»C ǂr~7 #+0\{@˧iY`+oE *V& ކHDH a<`x4R O`KiU'h\`8cKpR /Y§a >Sc8݀aa'`Ѐy10L@0k: `xe [02Ea`FEr0[Xt&`BGF 0C0{qp !qpY }óg W5߀UT)*n.m 6uA%|=$8]N|(Ѣ>Lg:TQ**G%X.^,T JxR4|< W0<6ɏit{/ U%< J8.U g#JI*lT b&!J#0TmѮ*lT o/0TYΆMpNOV%|}3h=T)h$Fs hLaf8o0(LJXSMG%\{MG%\}MF4:Uhj5AѢi4hF4ќ@%=*_;)T,Q S 0BT¬$P cJ.*aP SZ0P P YP STQ@9k*%w f ^*oJx͢0ffSEǓ sn0R7`0;$ØI EF_DMitE-ٚFGyiCH[P S"0 sP0, 00l⨄L _qATKa-?lQ),%4OZj!]f,|>b!DXP/(}-0*(- (lO>ibE_>AY`PHS+"<)""b"bD_;0%?@~""""~∈a!]O^ _ GS`DЯX`rŗei (_@q<_ _yUV>r_ 8`:\{D*PZ Ph (@X`A"WˇK(^ǀbD) (~IDl  PLAa ߂_ _?bMŚ<mςbx'/(!RU`*0lAy OZ6ok@A2@zooOϪ%6gIwrI-ŋ%ŋ%fAbk -A%(.:@|( (| (1ϋg3݀ZI=@Żx:>A7O]@xXZ_j!m-? 揃SGޥGO/^qV>|sX<|+ ?Z/WGG5` 4 voa*x#tIKJ~4 fAq?$çCC ~HO9[KYǍX@O@O˾B' ?2|hV2|ŀ wγ+!ǦcpaȰ2 .dx߆ +2Qdx !* U8dXY(dX&djʐvȰZ7+CCW88 Eq(xzqȰJm%f.>y)aq=dԤdXvȰcȰfĐaEa6ů?2mcG#UV2(X0a< Ix ̪F8ddxS#+HV2]d?l%' 3=dUpTE6 ë<0_0DZ2 d^;s? C92 HUCpoȰ'J ó%Ù ;@! EH'/#aOK4Gop7MF.7dXdV#?07XaIBpGGY !nǡ = ?y>QId8d8AӒ֮tx?lG"$iwJ× Àd5H3+ι3%è sp%rHZ$81Wd|Ҩ$7QÐC?z\'a3 V9Pc DžZ?z,?:WpưA6 Z?z~$RbAj%;QI+^!a֒%fu2́*Ȱ6dx+2 BɍBk c2fI}2g s2 $@˨r£?^!"׋ G2d8ސa8a 1$:!K2=dxdxa)aj%cOIdY$ã Bq$"eQ w YA* <U2 G2̻E2|gs㪐aO#[2b2Zj8d=d d%dSaJ""26dxCT2˗dxBu 2\*߮7 2i$ìCw8GNV)TF2%ц w Ӳ F2L0': S$|a uGr$̩H*.Q1d=>dڥm.2< [\7d^<\O·P:U 2 O:Q:g؁%S|";QPXh$6 @ᶨ;ᙃB:@ 𡺘:ZWغMf]aՙ@aIR ^/unKA_;PG S.a+( ^+Yhj$YU=|PBm=}Zx3ugPxMi wR [gT(ֺ»ja @dI~ PN2PXP4PZ—@ Pb#bR _M _,3t@(\CPԖ@oM>xW?P(|TWiK=:Øy_ufb=d8KWa s}uYb_=c>_=p}(|o 7!npj@aAez:WUS&yQ[P@uU딬zX5Y5-aBaą·N@qҿ~0 ; u: sA<ld0-4>(| [B(_(Pԡ0BC'u>պ@aw»€{9W'ooW=!NPx=PxSެ ?ÛjpN (X\W{@u}u| @ᵜZ=T^nչ yZ(P^ o:ASW /s+,x uRZWXuXWwpH鏂3n*g))'t"cE=>һlV00VBU%S<(C -/D \qLwD\L8%- "_q1Dx8Ëa3)[gEK<*iVvxo|uOo!9" "،xӒYDrq)ET""'oxXhVqJ%".&,tJ,">ag"C+"NSؚхAĺ-]VKD|ÞO"{!0 /C D0_1"- & jK gÓ8h jq&BFq oxUJUbxz3 0,">dAODvUb,"F\8[&L P"3FD-"VK "+DRbSd$P0m2nGN%#<wI |0+^K<|3&xv݇xU,s pN*?L#1I c$_у˫qw/"'[Tx~Uc xx9aFBe,!^,BhS(pdƊ("f}ZQG<<#A'5 s"q:Gt1X*}uW飠pw>K /i8\\W-*MrDW4ҧ_WiD"bSAķ{"*ˢ*}`U1җnKTQ{Z,8<OZ3j-MVtZZ9RpxR d'pXnAr]kSn4ZK 7u=aN}V&6 w) h&ZK~0^Y:p>_pEog8\0pV/V=L8[8>V [' {*;g |pCkZfc-}Pi-D)'Q T1^y>*'߷Lzz`1 חt)K\ҔEF1LR g ^]Ű%U Ss F1LζnXùSa6:UP = V-ql/ZOmUkc88>Z blpXpXx&>aQa30pǫp;V[1|V[Y8\Р+m@[1e &SvXU:p9pv߸0۲[+ypc}{Xџ/CU|pL;ppIJ:XvXSv8CŰ)Z:_kiZK;}>Uޅ3Vew6m/v~o ᭬7 U` /a uLWb yj:8N*n L0sa wÛ]bQ*఩N*e5 N[8[8CVp)c߁֐{aa6Mvw]-wa9`؂πF;|Ktﰱ k\YG,-XhE;|hw9a</OcYa_Z8O> ajqT;V0hhY0AJpF!Ř9W%f._0,S_ o_/0 'Uz6U:aCdp0'qpN7Zpifh}82`x>pз%LGy˃9`ڵaea]êÖv Y I0Y^óF#aWMWŤd%̀aUȖ>aTrr-7H0LVD0 mn]aĂa%bÞ\ {0\9`B a6GMUra4` P`X #`x}KiËvn c#s0, /^Ɖ%Xx>:aԀa,7lm { rZjPnba)7yR )7Vᷫ4~K;0O Qb/cB+`i`a<( S0?UP7`$`r}hWҜ  /*=z?`yJ_/0^*} S\Ǧ\Ǻ0" 0|*{QJ0|Ws({T ΋(? (8)7s0;3l W-V-0bjU;<^`x{8K0  )D;LtKi=f]`cX#y,Ylzsi2zwĻkc!3 0=V.7kvΚ%`Da>ȟ dN zZ0k6`.冕t s >p Ubg%`b[r +a'}CiuXy,.a=7 U0'",7[w,c}[\/D?WE gj 0ݥj ,ְ@ K O R-\@HU XT kZ0jSi֦V-|k*5R w@.C ܹR !~;w|3Lj `|U cj [Zn5l-[k ;YkX iaۏ\Pj XZ%k kAlawp޴pQ#9J{Bp3Y@! s0= _YFPp]bwRjᾴ |X U ªkU~,]ª‹ fXҧ iқB7j BZw1@Xpj%'T ?ak uy0 Ta8¥N§f\@Sm6r2>zV4#V!' ,+dVhaCaa+ O[8e50H4@Z~ S:P*0ְRPuf>*PQ ƪ7!j|ja )G-{_K-llK p@}J-|ʈQ 'kZ8Yja<^_CaK֯0B=jp1 Q + vO0@WjvGRn  R r V ֏(9ja}Q ے1^-(+vY.ȁvr0OBI(|jw80«ЁU%̦7(^jM ߊeV J|»8P~uT~סp>(lmyc,((ΰRPC-|ks-PXS“a»NpXKZx"Z8= ZxG-NCpR =ҹ25k(PR!UjypJ j-5 04R/RMRRù*50.Fha~(v]%Na=)pJ #<0RxD[j lL"Ujx0RiUj8ݹJ 0-5LA` O0ZbӧZ3jӧZxR.T~ )5J Ua1X _j'P|=  &Cӝ>0o}S (<^`  /Bi@B ( /Px+@aŒ@@P:sҙ4<7^4>Pze(=2VCX:k(=4a pK ("BC G S2`cB|'(f 4 ϸ Ϙ kn(<`   @00%@a@a& 0 40 Px& )ZFM &($ (   c V(A^0ZWQj P;P@aW[)1ja$MA-eušTP?`= C0 /@`30;PRe(t 5b(= V(Pz@#O)J\jR l:PW (L+ # b9`f s(L0čR=5Pj|4jaLP kDFQ s]Ņ1Wq~j,q P2A-B7jac(>xyeMUjU pœC-0UvP Z-jas&PX)Pji cZtQ 7ja-Mp/Ba (PDG-\:jYpg .'UtNlJ) JEPR 2J]0 4 [%p)WA*˦p Z/̀ag4_)kÞ.r>N0g_6[)N.Q /X«Fe1`X[np]ϩMeާ`EO)'m¥\ 0i V-`,`Xk gAsa0LmTMaݣ鱕`jU 9U`#Cp)Ö  Wm_}*wmQ k >=@>Q -;>:RCR XF),X Ϟ /*FzÂmkb#FO2 r,o cS`EfaQ0,( (0|K)h;ó`0`pa*0 lP^`/0 -0|$Â00*)×v_aO O6`d [V0| c5X`x 8b\XhsZý=m8jlg< NU _k&9+>JI0|X60o0ܓ'e- =ީ+`X_a".:7 c[ ajaR~lQ cRߴ`:Ia╍AXMN³b“6.`x,`xo))PJamU [ URaT#UQaXJtTP%lAKTRagpYRaXeTTR%F%Q2UzMUG>YU φ]%,A%,*0“cU@R '5[*a0*k_@@[*CpT>z7AJ8mT7*a0`r#7]CF%|Q "ߨOvTš<U՘ҧaU z t [Lh!ѻ$O}5.S먄W#>Fl{ 5;9@X"@xzp“|GI= @#X75@xQJ x!@x>`]6Ѻc@<@CBVFla*N@blᴜ06@Oժ0,[JxY @#/"_ D40 >z{ZhdUa8 pZ+ VBGD}nNHa 0/GUz죯70^>5<* T3՗}K%+GC>:?Tate->"p.C}a* + τG|WB* ˷/÷~ d/_[*>gRt),G@&@E9 R2ǽFUMd @f@>?T9-pP3 OU@{ g  sx |ȉF@f  h.@>_bWq*g -xJU1@9L c+:x *^?T1.U@^Qk mE(?*TK*I*6X:la+[HH8=ΨH<ƖRh*=T;x%8ΪtU/*&ZTVU_PU_8(S1Hnzd nzl4QZvӁȌDe7=Vee7= oHicEUUHi&Ue+q2ڪHO4-/U1KULHƘ/LL"EVE菭H?y%VGT$KHDыH1O|2_Y֔4K2>,5fӘٴ[UiJl1!"S4'lz -ʽh,іn4H\AnDȘu7BοgY*Bc6} dg^fyM~4ØM-n/yL٬yќiMJO%[j6ٴG*4>܋)lk6v]!_yL_M{$B42@MolT"ٴDY3j̦Dd_*D̦*Uϟ*%GhD 6bjEj-rAʣ?OO8b6-6N->$Rj̦lZszͦц!jA3P[\1xriEȮEGDl !k/BV d̬Aȗ|~V"ޫ1S/Hhx!r!;7Ae B[[F(U[lIŇHmu7A+y~2 bEjO/m!Rb=+EV3T[_b-VpT"-_141.X2ºPdPdtPU'j)2E#+E΃"6Cl"^ӚBM^4c(.Y> EyC0Pd*"e[=HL(I-YP E@WPd6)EOK,KOEVME>e̡ȇ7y煖44WiC?"+4XpkZ["k EVIqȻV̡LRUk:dŋґs:GYO6GM2~(ReZi٦P(5BNZ"E E.us(E"+Y"KZBه"ϟbΑk^9ȎPdբȧ*PddkȗJa)2UQ(2y"yȋ89CqQdR4/#+1GV<"•x3"ě:b)2"Ĺ*B S\%CQC=EvlbZ*WxMsW)6kz"k%+^&5(r`.~yMbeŏ4]&ʅ"K t(ra7!zMiy(ۿǿοÿ_~8Pyo<}O-c^8WJ^.W~n?g~M^s)8S0뻞\ ԁ-nGWW˺޿֩x__%>GG/?|y_o7GGNn}>AZK_К?jM|b׻C2;?~,B|> endobj 4 0 obj << /ProcSet [/PDF /Text] /Font <> /ExtGState << /GS1 12 0 R /GS2 13 0 R /GS257 14 0 R >> /ColorSpace << /sRGB 5 0 R >> >> endobj 5 0 obj [/ICCBased 6 0 R] endobj 6 0 obj << /Alternate /DeviceRGB /N 3 /Length 2596 /Filter /FlateDecode >> stream xwTSϽ7PkhRH H.*1 J"6DTpDQ2(C"QDqpId߼y͛~kg}ֺLX Xňg` lpBF|،l *?Y"1P\8=W%Oɘ4M0J"Y2Vs,[|e92<se'9`2&ctI@o|N6(.sSdl-c(2-yH_/XZ.$&\SM07#1ؙYrfYym";8980m-m(]v^DW~ emi]P`/u}q|^R,g+\Kk)/C_|Rax8t1C^7nfzDp 柇u$/ED˦L L[B@ٹЖX!@~(* {d+} G͋љς}WL$cGD2QZ4 E@@A(q`1D `'u46ptc48.`R0) @Rt CXCP%CBH@Rf[(t CQhz#0 Zl`O828.p|O×X ?:0FBx$ !i@ڐH[EE1PL ⢖V6QP>U(j MFkt,:.FW8c1L&ӎ9ƌaX: rbl1 {{{;}#tp8_\8"Ey.,X%%Gщ1-9ҀKl.oo/O$&'=JvMޞxǥ{=Vs\x ‰N柜>ucKz=s/ol|ϝ?y ^d]ps~:;/;]7|WpQoH!ɻVsnYs}ҽ~4] =>=:`;cܱ'?e~!ańD#G&}'/?^xI֓?+\wx20;5\ӯ_etWf^Qs-mw3+?~O~endstream endobj 9 0 obj << /Type /Encoding /BaseEncoding /WinAnsiEncoding /Differences [ 45/minus ] >> endobj 10 0 obj << /Type /Font /Subtype /Type1 /Name /F7 /BaseFont /Times-Roman /Encoding 9 0 R >> endobj 11 0 obj << /Type /Font /Subtype /Type1 /Name /F9 /BaseFont /Times-Italic /Encoding 9 0 R >> endobj 12 0 obj << /Type /ExtGState /CA 0.702 >> endobj 13 0 obj << /Type /ExtGState /CA 1.000 >> endobj 14 0 obj << /Type /ExtGState /ca 1.000 >> endobj xref 0 15 0000000000 65535 f 0000000021 00000 n 0000000163 00000 n 0000027442 00000 n 0000027525 00000 n 0000027686 00000 n 0000027719 00000 n 0000000212 00000 n 0000000292 00000 n 0000030414 00000 n 0000030508 00000 n 0000030607 00000 n 0000030707 00000 n 0000030756 00000 n 0000030805 00000 n trailer << /Size 15 /Info 1 0 R /Root 2 0 R >> startxref 30854 %%EOF brms/vignettes/kidney_conditional_effects.pdf0000644000176200001440000002451513606326627021307 0ustar liggesusers%PDF-1.4 %ρ\r 1 0 obj << /CreationDate (D:20170125183821) /ModDate (D:20170125183821) /Title (R Graphics Output) /Producer (R 3.3.2) /Creator (R) >> endobj 2 0 obj << /Type /Catalog /Pages 3 0 R >> endobj 7 0 obj << /Type /Page /Parent 3 0 R /Contents 8 0 R /Resources 4 0 R >> endobj 8 0 obj << /Length 6431 /Filter /FlateDecode >> stream x\ˮGr߯8Ki3]gl m,H ,`/ȈKA^ }u[_o8n='ӎ1/n}wXڽ[zK;ųO~?ǽۓ{﷑ҽ۫>4XH<vpw<-N>dc3\~/67^RÄ8kݰ?_=ǧ_o^~:9}~8L&nb8}/w&r8.ɱ.p;.yb倇,X:Ã'1MPap|b9U߆'ǃgNɿ5l_OίvǮc&R)/noYtk%O^~X<;]| ׷ק[ nX?`_gקlտݭ^3qw;4Ḻ%s133-fLjKrKYJsNְmN8^?/4zn>m~>_?/b6M~{n6L_2__XHڹqT#qi&h_sw \}֯~fn毚d&Zl<6mOa`|Lgjw`'@~3y-AyWL&[a[M~@aw4}xL6iӮmnIczp95ຍS-x,ySLKǒ79zZ/`GZOZo``ʗPi7s#pK_ǦOC 0Ӳ7G2e/_\Gx,^0_sv)B>}{<<CϱeX/]3|D|D|w# y;wCWKS'k[7XW<|߃?p~(>_$79?$uGR>/}_:ŗ)ic}HtH"m|@Eqr!Ϸo5IkcgdlI=o2~q}`[;>=??g3?;Xt@0WO'|0||ȒṞZze;.|/ko zj^B{{Ob}ǧ+ut`cSSIO=gϞO(&^՟^'o{?l6p"* \y_|߾>9 "$㤱="O 8 TTTӌ]otBp"0z;zv|FSٚOFpѐ#υйy:qDžԇ/~ҾSO}?s5؃~k{?ޞqHEiE;$БÓHO#9%<>=5'?Ȩ~F6`㗲o`\wv]zvCFi,>"ya;Msڟ߬g;1ZȀ9E^R^w~7=YXw ,jWMC(Y[w zv/LdW>'v IS]N4Hmeҫ\Ӿ.dYup]/vEh)ǡGrd͝c[ /w\#Aܖ0qϾ_i&~!^w#+^EwC>@cBϯy7 ކFF`Um(\"r)lȻ%E"iٶ0W*~[A zjtbwF0Fl)yu+/j)5VVOqrsGڋ-ʞ/j5@3K rRtdOhg>ns$oft^XKF\0CEzdj9dwPuU4*r~3ے7^oforJCт'xp{z,VW3ʎtv siM]PUM~3[s$@i>Fd[2[變+{ٖTeNyҼET{xiD f7Oo>ܺ(tA;J%99p(6O:bnW֠^of>p.1ȥNUi*iǪN r3 @QSUϪUWU xYU X[qy@/< r-s{I4&: rJ;r1$\Hz!:%G\N9Hj$qzl}|/ڙ];gѨD#d!z5Xwd:$ک uJlQ,ӈ^.␱h`@#ڸf8H&IVpFߟ}tkyp{gL7S)k/xHL0ɦ-uRŊR\|xH: UmK piB!c,Hř E`Ώ vN1!$FĈp$b=6 72-|>0˸N)0@,$Y <!Y!'=83#\6`Gq 9ΐ}BKufcpBF XaqX'WHk+T`y6-\ 7x3WcE 'C0Ϙ4yRQ3lL8WxU>-]8{FK)?`oL$0sW(!0gTMA;Wq+LgbIM@q$]))Ҥ*ΗpqѱosYߢr=h A$HAbQAskZ%SUUNUUQDO2XJ9ʷJtK@҈$ =g49SߩONi,l=q*EYb۔#8eU.P9[xҢ:q}+ fQu2XRzG7e3 3r,TtXfꤑЄfh`Ii~3rY4Ω/АHѰg2oSJe̮JO̦GMw*ٌJ)Է6 NuENխ@˽Լ\X{*w->U֑ӟp 0PT^X& E3j@alFH`I@H{+0V q S} 8x2W` ۨn`,}cO1,ʢ|F`5NE)x>"1CEQ"@U(vzdPgɝ<i"V8ΫNBRqD6e,t8 GD P뭈"ڬ&IFasݹ,`+[ߌe,/ЖC=\eyOҸZrT.Չ=/GiO)|H "VO}s'~jޣVZpEŶ./oo;u.Z|kh^KiR.oH1TN09Ixh{(}?endstream endobj 3 0 obj << /Type /Pages /Kids [ 7 0 R ] /Count 1 /MediaBox [0 0 504 828] >> endobj 4 0 obj << /ProcSet [/PDF /Text] /Font << /F1 10 0 R /F7 11 0 R >> /ExtGState << /GS1 12 0 R /GS257 13 0 R /GS258 14 0 R >> /ColorSpace << /sRGB 5 0 R >> >> endobj 5 0 obj [/ICCBased 6 0 R] endobj 6 0 obj << /Alternate /DeviceRGB /N 3 /Length 2596 /Filter /FlateDecode >> stream xwTSϽ7PkhRH H.*1 J"6DTpDQ2(C"QDqpId߼y͛~kg}ֺLX Xňg` lpBF|،l *?Y"1P\8=W%Oɘ4M0J"Y2Vs,[|e92<se'9`2&ctI@o|N6(.sSdl-c(2-yH_/XZ.$&\SM07#1ؙYrfYym";8980m-m(]v^DW~ emi]P`/u}q|^R,g+\Kk)/C_|Rax8t1C^7nfzDp 柇u$/ED˦L L[B@ٹЖX!@~(* {d+} G͋љς}WL$cGD2QZ4 E@@A(q`1D `'u46ptc48.`R0) @Rt CXCP%CBH@Rf[(t CQhz#0 Zl`O828.p|O×X ?:0FBx$ !i@ڐH[EE1PL ⢖V6QP>U(j MFkt,:.FW8c1L&ӎ9ƌaX: rbl1 {{{;}#tp8_\8"Ey.,X%%Gщ1-9ҀKl.oo/O$&'=JvMޞxǥ{=Vs\x ‰N柜>ucKz=s/ol|ϝ?y ^d]ps~:;/;]7|WpQoH!ɻVsnYs}ҽ~4] =>=:`;cܱ'?e~!ańD#G&}'/?^xI֓?+\wx20;5\ӯ_etWf^Qs-mw3+?~O~endstream endobj 9 0 obj << /Type /Encoding /BaseEncoding /WinAnsiEncoding /Differences [ 45/minus ] >> endobj 10 0 obj << /Type /Font /Subtype /Type1 /Name /F1 /BaseFont /ZapfDingbats >> endobj 11 0 obj << /Type /Font /Subtype /Type1 /Name /F7 /BaseFont /Times-Roman /Encoding 9 0 R >> endobj 12 0 obj << /Type /ExtGState /CA 1.000 >> endobj 13 0 obj << /Type /ExtGState /ca 0.400 >> endobj 14 0 obj << /Type /ExtGState /ca 1.000 >> endobj xref 0 15 0000000000 65535 f 0000000021 00000 n 0000000163 00000 n 0000006795 00000 n 0000006878 00000 n 0000007042 00000 n 0000007075 00000 n 0000000212 00000 n 0000000292 00000 n 0000009770 00000 n 0000009864 00000 n 0000009948 00000 n 0000010047 00000 n 0000010096 00000 n 0000010145 00000 n trailer << /Size 15 /Info 1 0 R /Root 2 0 R >> startxref 10194 %%EOF brms/vignettes/citations_multilevel.bib0000644000176200001440000002444614160105076020154 0ustar liggesusers% Encoding: UTF-8 @Article{brms2, title = {Advanced {Bayesian} Multilevel Modeling with the {R} Package {brms}}, author = {Paul-Christian Bürkner}, journal = {The R Journal}, year = {2018}, volume = {10}, number = {1}, pages = {395--411}, doi = {10.32614/RJ-2018-017}, encoding = {UTF-8}, } @Article{vehtari2016, author = {Vehtari, Aki and Gelman, Andrew and Gabry, Jonah}, title = {Practical Bayesian Model Evaluation Using Leave-One-Out Cross-Validation and WAIC}, journal = {Statistics and Computing}, year = {2016}, pages = {1--20}, publisher = {Springer}, } @Book{fahrmeir2013, title = {Regression: models, methods and applications}, publisher = {Springer Science \& Business Media}, year = {2013}, author = {Fahrmeir, Ludwig and Kneib, Thomas and Lang, Stefan and Marx, Brian}, } @Manual{gamlss.data, title = {gamlss.data: GAMLSS Data}, author = {Mikis Stasinopoulos and Bob Rigby}, year = {2016}, note = {R package version 5.0-0}, url = {https://CRAN.R-project.org/package=gamlss.data}, } @Article{wood2013, author = {Wood, Simon N and Scheipl, Fabian and Faraway, Julian J}, title = {Straightforward intermediate rank tensor product smoothing in mixed models}, journal = {Statistics and Computing}, year = {2013}, pages = {1--20}, publisher = {Springer}, } @Manual{mcelreath2017, title = {rethinking: Statistical Rethinking Course and Book Package}, author = {Richard McElreath}, year = {2017}, note = {R package version 1.59}, owner = {Paul}, timestamp = {2016.03.04}, url = {https://github.com/rmcelreath/rethinking}, } @Article{wagenmakers2010, author = {Wagenmakers, Eric-Jan and Lodewyckx, Tom and Kuriyal, Himanshu and Grasman, Raoul}, title = {Bayesian hypothesis testing for psychologists: A tutorial on the Savage--Dickey method}, journal = {Cognitive psychology}, year = {2010}, volume = {60}, number = {3}, pages = {158--189}, publisher = {Elsevier}, } @Manual{bridgesampling2017, title = {bridgesampling: Bridge Sampling for Marginal Likelihoods and Bayes Factors}, author = {Quentin F. Gronau and Henrik Singmann}, year = {2017}, note = {R package version 0.4-0}, url = {https://CRAN.R-project.org/package=bridgesampling}, } @BOOK{brown2015, title = {Applied Mixed Models in Medicine}, publisher = {John Wiley \& Sons}, year = {2015}, author = {Brown, Helen and Prescott, Robin}, owner = {Paul}, timestamp = {2015.06.19} } @Book{demidenko2013, title = {Mixed Models: Theory and Applications with R}, publisher = {John Wiley \& Sons}, year = {2013}, author = {Demidenko, Eugene}, owner = {Paul}, timestamp = {2015.06.19}, } @Book{gelmanMLM2006, title = {Data Analysis Using Regression and Multilevel/Hierarchical Models}, publisher = {Cambridge University Press}, year = {2006}, author = {Gelman, Andrew and Hill, Jennifer}, owner = {Paul}, timestamp = {2016.02.21}, } @Book{pinheiro2006, title = {Mixed-Effects Models in S and S-PLUS}, publisher = {Springer-Verlage Science \& Business Media}, year = {2006}, author = {Pinheiro, Jose and Bates, Douglas}, owner = {Paul}, timestamp = {2015.06.19}, } @Article{rigby2005, author = {Rigby, Robert A and Stasinopoulos, D Mikis}, title = {Generalized Additive Models for Location, Scale and Shape}, journal = {Journal of the Royal Statistical Society C (Applied Statistics)}, year = {2005}, volume = {54}, number = {3}, pages = {507--554}, publisher = {Wiley Online Library}, } @Article{lindstrom1990, author = {Lindstrom, Mary J and Bates, Douglas M}, title = {Nonlinear Mixed Effects Models for Repeated Measures Data}, journal = {Biometrics}, year = {1990}, pages = {673--687}, publisher = {JSTOR}, } @Article{wood2004, author = {Wood, Simon N}, title = {Stable and Efficient Multiple Smoothing Parameter Estimation for Generalized Additive Models}, journal = {Journal of the American Statistical Association}, year = {2004}, volume = {99}, number = {467}, pages = {673--686}, publisher = {Taylor \& Francis}, } @Article{rasmussen2006, author = {Rasmussen, Carl Edward and Williams, C. K. I.}, title = {Gaussian processes for machine learning}, year = {2006}, publisher = {Massachusetts Institute of Technology}, } @BOOK{hastie1990, title = {Generalized Additive Models}, publisher = {CRC Press}, year = {1990}, author = {Hastie, Trevor J and Tibshirani, Robert J}, volume = {43}, owner = {Paul}, timestamp = {2015.09.07} } @BOOK{gelman2014, title = {Bayesian Data Analysis}, publisher = {Taylor \& Francis}, year = {2014}, author = {Gelman, Andrew and Carlin, John B and Stern, Hal S and Rubin, Donald B}, volume = {2}, owner = {Paul}, timestamp = {2015.06.20} } @Manual{stanM2017, title = {Stan Modeling Language: User's Guide and Reference Manual}, author = {{Stan Development Team}}, year = {2017}, owner = {Paul}, timestamp = {2015.06.18}, url = {http://mc-stan.org/manual.html}, } @Article{carpenter2017, author = {Carpenter, B. and Gelman, A. and Hoffman, M. and Lee, D. and Goodrich, B. and Betancourt, M. and Brubaker, M. A. and Guo, J. and Li, P. and Ridell, A.}, title = {Stan: A Probabilistic Programming Language}, journal = {Journal of Statistical Software}, year = {2017}, owner = {Paul}, timestamp = {2015.06.19}, } @ARTICLE{duane1987, author = {Duane, Simon and Kennedy, Anthony D and Pendleton, Brian J and Roweth, Duncan}, title = {Hybrid Monte Carlo}, journal = {Physics Letters B}, year = {1987}, volume = {195}, pages = {216--222}, number = {2}, owner = {Paul}, publisher = {Elsevier}, timestamp = {2015.06.19} } @InBook{neal2011, chapter = {MCMC Using Hamiltonian Dynamics}, title = {Handbook of Markov Chain Monte Carlo}, publisher = {CRC Press}, year = {2011}, author = {Neal, Radford M}, volume = {2}, owner = {Paul}, timestamp = {2015.06.19}, } @Article{betancourt2014, author = {Betancourt, MJ and Byrne, Simon and Livingstone, Samuel and Girolami, Mark}, title = {The Geometric Foundations of Hamiltonian Monte Carlo}, journal = {arXiv preprint arXiv:1410.5110}, year = {2014}, } @ARTICLE{hoffman2014, author = {Hoffman, Matthew D and Gelman, Andrew}, title = {The No-U-Turn Sampler: Adaptively Setting Path Lengths in Hamiltonian Monte Carlo}, journal = {The Journal of Machine Learning Research}, year = {2014}, volume = {15}, pages = {1593--1623}, number = {1}, owner = {Paul}, publisher = {JMLR. org}, timestamp = {2015.06.19} } @Article{betancourt2017, author = {Michael Betancourt}, title = {A Conceptual Introduction to Hamiltonian Monte Carlo}, journal = {arXiv preprint}, year = {2017}, url = {https://arxiv.org/pdf/1701.02434.pdf}, } @ARTICLE{bates2015, author = {Douglas Bates and Martin M{\"a}chler and Ben Bolker and Steve Walker}, title = {Fitting Linear Mixed-Effects Models Using \pkg{lme4}}, journal = {Journal of Statistical Software}, year = {2015}, volume = {67}, pages = {1--48}, number = {1}, owner = {Paul}, timestamp = {2015.11.13} } @Article{hadfield2010, author = {Hadfield, Jarrod D}, title = {MCMC Methods for Multi-Response Generalized Linear Mixed Models: the \pkg{MCMCglmm} {R} Package}, journal = {Journal of Statistical Software}, year = {2010}, volume = {33}, number = {2}, pages = {1--22}, owner = {Paul}, timestamp = {2015.06.18}, } @Manual{rstanarm2017, title = {rstanarm: {Bayesian} applied regression modeling via {Stan}.}, author = {{Stan Development Team}}, year = {2017}, note = {R package version 2.17.2}, url = {http://mc-stan.org/}, } @Manual{afex2015, title = {\pkg{afex}: Analysis of Factorial Experiments}, author = {Henrik Singmann and Ben Bolker and Jake Westfall}, year = {2015}, note = {R package version 0.15-2}, owner = {Paul}, timestamp = {2016.02.13}, url = {https://CRAN.R-project.org/package=afex}, } @Article{brms1, author = {Paul-Christian B\"urkner}, title = {\pkg{brms}: An {R} Package for Bayesian Multilevel Models using Stan}, journal = {Journal of Statistical Software}, year = {2017}, encoding = {UTF-8}, } @Article{wood2011, author = {Wood, Simon N}, title = {Fast Stable Restricted Maximum Likelihood and Marginal Likelihood Estimation of Semiparametric Generalized Linear Models}, journal = {Journal of the Royal Statistical Society: Series B (Statistical Methodology)}, year = {2011}, volume = {73}, number = {1}, pages = {3--36}, publisher = {Wiley Online Library}, } @InProceedings{williams1996, author = {Williams, Christopher KI and Rasmussen, Carl Edward}, title = {Gaussian processes for regression}, booktitle = {Advances in neural information processing systems}, year = {1996}, pages = {514--520}, } @MANUAL{nlme2016, title = {\pkg{nlme}: Linear and Nonlinear Mixed Effects Models}, author = {Jose Pinheiro and Douglas Bates and Saikat DebRoy and Deepayan Sarkar and {R Core Team}}, year = {2016}, note = {R package version 3.1-124}, owner = {Paul}, timestamp = {2016.03.06}, url = {http://CRAN.R-project.org/package=nlme} } @Article{westfall2016, author = {Westfall, Jacob and Yarkoni, Tal}, title = {Statistically Controlling for Confounding Constructs is Harder than You Think}, journal = {PloS one}, year = {2016}, volume = {11}, number = {3}, pages = {e0152719}, publisher = {Public Library of Science}, } @Manual{loo2016, title = {\pkg{loo}: {E}fficient Leave-One-Out Cross-Validation and {WAIC} for {B}ayesian Models.}, author = {Aki Vehtari and Andrew Gelman and Jonah Gabry}, year = {2016}, note = {R package version 1.0.0}, url = {https://github.com/stan-dev/loo}, } @Manual{stan2017, title = {Stan: A C++ Library for Probability and Sampling, Version 2.17.0}, author = {{Stan Development Team}}, year = {2017}, owner = {Paul}, timestamp = {2015.06.18}, url = {http://mc-stan.org/}, } @Comment{jabref-meta: databaseType:bibtex;} brms/vignettes/citations_overview.bib0000644000176200001440000005616214160105076017640 0ustar liggesusers% Encoding: UTF-8 @Article{brms1, author = {Paul-Christian B\"urkner}, title = {{brms}: An {R} Package for Bayesian Multilevel Models using Stan}, journal = {Journal of Statistical Software}, year = {2017}, volume = {80}, number = {1}, pages = {1--28}, encoding = {UTF-8}, doi = {10.18637/jss.v080.i01} } @BOOK{brown2015, title = {Applied Mixed Models in Medicine}, publisher = {John Wiley \& Sons}, year = {2015}, author = {Brown, Helen and Prescott, Robin}, owner = {Paul}, timestamp = {2015.06.19} } @ARTICLE{lunn2000, author = {Lunn, David J and Thomas, Andrew and Best, Nicky and Spiegelhalter, David}, title = {\pkg{WinBUGS} a Bayesian Modelling Framework: Concepts, Structure, and Extensibility}, journal = {Statistics and {C}omputing}, year = {2000}, volume = {10}, pages = {325--337}, number = {4}, owner = {Paul}, publisher = {Springer}, timestamp = {2015.06.18} } @MANUAL{spiegelhalter2003, title = {\pkg{WinBUGS} Version - 1.4 User Manual}, author = {Spiegelhalter, David and Thomas, Andrew and Best, Nicky and Lunn, Dave}, year = {2003}, journal = {MRC Biostatistics Unit, Cambridge}, owner = {Paul}, publisher = {version}, timestamp = {2015.06.18}, url = {http://www.mrc-bsu.cam.ac.uk/bugs} } @MANUAL{spiegelhalter2007, title = {\pkg{OpenBUGS} User Manual, Version 3.0.2}, author = {Spiegelhalter, D and Thomas, A and Best, N and Lunn, D}, year = {2007}, journal = {MRC Biostatistics Unit, Cambridge}, owner = {Paul}, timestamp = {2015.06.18} } @MANUAL{plummer2013, title = {\pkg{JAGS}: Just Another Gibs Sampler}, author = {Plummer, Martyn}, year = {2013}, owner = {Paul}, timestamp = {2015.01.20}, url = {http://mcmc-jags.sourceforge.net/} } @ARTICLE{hadfield2010, author = {Hadfield, Jarrod D}, title = {MCMC Methods for Multi-Response Generalized Linear Mixed Models: the \pkg{MCMCglmm} \proglang{R} Package}, journal = {Journal of Statistical Software}, year = {2010}, volume = {33}, pages = {1--22}, number = {2}, owner = {Paul}, timestamp = {2015.06.18} } @Manual{stan2017, title = {\proglang{Stan}: A \proglang{C++} Library for Probability and Sampling, Version 2.14.0}, author = {{Stan Development Team}}, year = {2017}, owner = {Paul}, timestamp = {2015.06.18}, url = {http://mc-stan.org/}, } @Article{carpenter2017, author = {Carpenter, B. and Gelman, A. and Hoffman, M. and Lee, D. and Goodrich, B. and Betancourt, M. and Brubaker, M. A. and Guo, J. and Li, P. and Ridell, A.}, title = {\proglang{Stan}: A Probabilistic Programming Language}, journal = {Journal of Statistical Software}, year = {2017}, owner = {Paul}, timestamp = {2015.06.19}, } @ARTICLE{metropolis1953, author = {Metropolis, Nicholas and Rosenbluth, Arianna W and Rosenbluth, Marshall N and Teller, Augusta H and Teller, Edward}, title = {Equation of State Calculations by Fast Computing Machines}, journal = {The Journal of Chemical Physics}, year = {1953}, volume = {21}, pages = {1087--1092}, number = {6}, owner = {Paul}, publisher = {AIP Publishing}, timestamp = {2015.06.19} } @ARTICLE{hastings1970, author = {Hastings, W Keith}, title = {Monte Carlo Sampling Methods Using Markov Chains and their Applications}, journal = {Biometrika}, year = {1970}, volume = {57}, pages = {97--109}, number = {1}, owner = {Paul}, publisher = {Biometrika Trust}, timestamp = {2015.06.19} } @ARTICLE{geman1984, author = {Geman, Stuart and Geman, Donald}, title = {Stochastic Relaxation, Gibbs Distributions, and the Bayesian Restoration of Images}, journal = {IEEE Transactions on Pattern Analysis and Machine Intelligence}, year = {1984}, pages = {721--741}, number = {6}, owner = {Paul}, publisher = {IEEE}, timestamp = {2015.06.19} } @ARTICLE{gelfand1990, author = {Gelfand, Alan E and Smith, Adrian FM}, title = {Sampling-Based Approaches to Calculating Marginal Densities}, journal = {Journal of the American Statistical Association}, year = {1990}, volume = {85}, pages = {398--409}, number = {410}, owner = {Paul}, publisher = {Taylor \& Francis Group}, timestamp = {2015.06.19} } @ARTICLE{damien1999, author = {Damien, Paul and Wakefield, Jon and Walker, Stephen}, title = {Gibbs Sampling for Bayesian Non-Conjugate and Hierarchical Models by Using Auxiliary Variables}, journal = {Journal of the Royal Statistical Society B, Statistical Methodology}, year = {1999}, pages = {331--344}, owner = {Paul}, publisher = {JSTOR}, timestamp = {2015.06.19} } @ARTICLE{neal2003, author = {Neal, Radford M.}, title = {Slice Sampling}, journal = {The Annals of Statistics}, year = {2003}, pages = {705--741}, owner = {Paul}, publisher = {JSTOR}, timestamp = {2015.06.19} } @InBook{neal2011, chapter = {MCMC Using Hamiltonian Dynamics}, title = {Handbook of Markov Chain Monte Carlo}, publisher = {CRC Press}, year = {2011}, author = {Neal, Radford M}, volume = {2}, owner = {Paul}, timestamp = {2015.06.19}, } @ARTICLE{hoffman2014, author = {Hoffman, Matthew D and Gelman, Andrew}, title = {The No-U-Turn Sampler: Adaptively Setting Path Lengths in Hamiltonian Monte Carlo}, journal = {The Journal of Machine Learning Research}, year = {2014}, volume = {15}, pages = {1593--1623}, number = {1}, owner = {Paul}, publisher = {JMLR. org}, timestamp = {2015.06.19} } @BOOK{gelman2014, title = {Bayesian Data Analysis}, publisher = {Taylor \& Francis}, year = {2014}, author = {Gelman, Andrew and Carlin, John B and Stern, Hal S and Rubin, Donald B}, volume = {2}, owner = {Paul}, timestamp = {2015.06.20} } @Manual{stanM2017, title = {\proglang{Stan} Modeling Language: User's Guide and Reference Manual}, author = {{Stan Development Team}}, year = {2017}, owner = {Paul}, timestamp = {2015.06.18}, url = {http://mc-stan.org/manual.html}, } @Article{rigby2005, author = {Rigby, Robert A and Stasinopoulos, D Mikis}, title = {Generalized Additive Models for Location, Scale and Shape}, journal = {Journal of the Royal Statistical Society C (Applied Statistics)}, year = {2005}, volume = {54}, number = {3}, pages = {507--554}, publisher = {Wiley Online Library}, } @Article{lindstrom1990, author = {Lindstrom, Mary J and Bates, Douglas M}, title = {Nonlinear Mixed Effects Models for Repeated Measures Data}, journal = {Biometrics}, year = {1990}, pages = {673--687}, publisher = {JSTOR}, } @Article{wood2004, author = {Wood, Simon N}, title = {Stable and Efficient Multiple Smoothing Parameter Estimation for Generalized Additive Models}, journal = {Journal of the American Statistical Association}, year = {2004}, volume = {99}, number = {467}, pages = {673--686}, publisher = {Taylor \& Francis}, } @Article{rasmussen2006, author = {Rasmussen, Carl Edward and Williams, C. K. I.}, title = {Gaussian processes for machine learning}, year = {2006}, publisher = {Massachusetts Institute of Technology}, } @Article{betancourt2014, author = {Betancourt, MJ and Byrne, Simon and Livingstone, Samuel and Girolami, Mark}, title = {The Geometric Foundations of Hamiltonian Monte Carlo}, journal = {arXiv preprint arXiv:1410.5110}, year = {2014}, } @Article{betancourt2017, author = {Michael Betancourt}, title = {A Conceptual Introduction to Hamiltonian Monte Carlo}, journal = {arXiv preprint}, year = {2017}, url = {https://arxiv.org/pdf/1701.02434.pdf}, } @Manual{rstanarm2017, title = {rstanarm: {Bayesian} applied regression modeling via {Stan}.}, author = {{Stan Development Team}}, year = {2017}, note = {R package version 2.17.2}, url = {http://mc-stan.org/}, } @InProceedings{williams1996, author = {Williams, Christopher KI and Rasmussen, Carl Edward}, title = {Gaussian processes for regression}, booktitle = {Advances in neural information processing systems}, year = {1996}, pages = {514--520}, } @Article{westfall2016, author = {Westfall, Jacob and Yarkoni, Tal}, title = {Statistically Controlling for Confounding Constructs is Harder than You Think}, journal = {PloS one}, year = {2016}, volume = {11}, number = {3}, pages = {e0152719}, publisher = {Public Library of Science}, } @BOOK{demidenko2013, title = {Mixed Models: Theory and Applications with \proglang{R}}, publisher = {John Wiley \& Sons}, year = {2013}, author = {Demidenko, Eugene}, owner = {Paul}, timestamp = {2015.06.19} } @Book{pinheiro2006, title = {Mixed-Effects Models in \proglang{S} and \proglang{S-PLUS}}, publisher = {Springer-Verlage Science \& Business Media}, year = {2006}, author = {Pinheiro, Jose and Bates, Douglas}, owner = {Paul}, timestamp = {2015.06.19}, } @MANUAL{Rcore2015, title = {\proglang{R}: A Language and Environment for Statistical Computing}, author = {{R Core Team}}, organization = {\proglang{R} Foundation for Statistical Computing}, address = {Vienna, Austria}, year = {2015}, owner = {Paul}, timestamp = {2015.01.20}, url = {http://www.R-project.org/} } @ARTICLE{bates2015, author = {Douglas Bates and Martin M{\"a}chler and Ben Bolker and Steve Walker}, title = {Fitting Linear Mixed-Effects Models Using \pkg{lme4}}, journal = {Journal of Statistical Software}, year = {2015}, volume = {67}, pages = {1--48}, number = {1}, owner = {Paul}, timestamp = {2015.11.13} } @ARTICLE{mcgilchrist1991, author = {McGilchrist, CA and Aisbett, CW}, title = {Regression with Frailty in Survival Analysis}, journal = {Biometrics}, year = {1991}, pages = {461--466}, owner = {Paul}, publisher = {JSTOR}, timestamp = {2015.08.15} } @ARTICLE{ezzet1991, author = {Ezzet, Farkad and Whitehead, John}, title = {A Random Effects Model for Ordinal Responses from a Crossover Trial}, journal = {Statistics in Medicine}, year = {1991}, volume = {10}, pages = {901--907}, number = {6}, owner = {Paul}, publisher = {Wiley Online Library}, timestamp = {2015.09.03} } @Book{gelmanMLM2006, title = {Data Analysis Using Regression and Multilevel/Hierarchical Models}, publisher = {Cambridge University Press}, year = {2006}, author = {Gelman, Andrew and Hill, Jennifer}, owner = {Paul}, timestamp = {2016.02.21}, } @Book{fox2011, title = {An R companion to Applied Regression, Second Edition}, publisher = {Sage}, year = {2011}, author = {Fox, John and Weisberg, Sanford}, } @ARTICLE{lewandowski2009, author = {Lewandowski, Daniel and Kurowicka, Dorota and Joe, Harry}, title = {Generating Random Correlation Matrices Based on Vines and Extended Onion Method}, journal = {Journal of Multivariate Analysis}, year = {2009}, volume = {100}, pages = {1989--2001}, number = {9}, owner = {Paul}, publisher = {Elsevier}, timestamp = {2015.07.23} } @ARTICLE{juarez2010, author = {Ju{\'a}rez, Miguel A and Steel, Mark FJ}, title = {Model-Based Clustering of Non-Gaussian Panel Data Based on Skew-t Distributions}, journal = {Journal of Business \& Economic Statistics}, year = {2010}, volume = {28}, pages = {52--66}, number = {1}, owner = {Paul}, publisher = {Taylor \& Francis}, timestamp = {2015.11.06} } @ARTICLE{creutz1988, author = {Creutz, Michael}, title = {Global Monte Carlo Algorithms for Many-Fermion Systems}, journal = {Physical Review D}, year = {1988}, volume = {38}, pages = {1228}, number = {4}, owner = {Paul}, publisher = {APS}, timestamp = {2015.08.10} } @BOOK{griewank2008, title = {Evaluating Derivatives: Principles and Techniques of Algorithmic Differentiation}, publisher = {Siam}, year = {2008}, author = {Griewank, Andreas and Walther, Andrea}, owner = {Paul}, timestamp = {2015.08.10} } @ARTICLE{watanabe2010, author = {Watanabe, Sumio}, title = {Asymptotic Equivalence of Bayes Cross Validation and Widely Applicable Information Criterion in Singular Learning Theory}, journal = {The Journal of Machine Learning Research}, year = {2010}, volume = {11}, pages = {3571--3594}, owner = {Paul}, publisher = {JMLR. org}, timestamp = {2015.08.10} } @TECHREPORT{gelfand1992, author = {Gelfand, Alan E and Dey, Dipak K and Chang, Hong}, title = {Model Determination Using Predictive Distributions with Implementation via Sampling-Based Methods}, institution = {DTIC Document}, year = {1992}, owner = {Paul}, timestamp = {2015.08.17} } @ARTICLE{ionides2008, author = {Ionides, Edward L}, title = {Truncated Importance Sampling}, journal = {Journal of Computational and Graphical Statistics}, year = {2008}, volume = {17}, pages = {295--311}, number = {2}, owner = {Paul}, publisher = {Taylor \& Francis}, timestamp = {2015.08.17} } @ARTICLE{vehtari2015, author = {Aki Vehtari and Andrew Gelman and Jonah Gabry}, title = {Efficient Implementation of Leave-One-Out Cross-Validation and WAIC for Evaluating Fitted Bayesian Models}, journal = {Unpublished manuscript}, year = {2015}, pages = {1--22}, owner = {Paul}, timestamp = {2015.08.26}, url = {http://www.stat.columbia.edu/~gelman/research/unpublished/loo_stan.pdf} } @ARTICLE{vanderlinde2005, author = {van der Linde, Angelika}, title = {DIC in Variable Selection}, journal = {Statistica Neerlandica}, year = {2005}, volume = {59}, pages = {45--56}, number = {1}, owner = {Paul}, publisher = {Wiley Online Library}, timestamp = {2015.08.10} } @Manual{loo2016, title = {\pkg{loo}: {E}fficient Leave-One-Out Cross-Validation and {WAIC} for {B}ayesian Models.}, author = {Aki Vehtari and Andrew Gelman and Jonah Gabry}, year = {2016}, note = {R package version 1.0.0}, url = {https://github.com/stan-dev/loo}, } @MANUAL{Xcode2015, title = {\pkg{Xcode} Software, Version~7}, author = {{Apple Inc.}}, address = {Cupertino, USA}, year = {2015}, owner = {Paul}, timestamp = {2015.01.20}, url = {https://developer.apple.com/xcode/} } @Article{masters1982, author = {Masters, Geoff N}, title = {A {R}asch Model for Partial Credit Scoring}, journal = {Psychometrika}, year = {1982}, volume = {47}, number = {2}, pages = {149--174}, owner = {Paul}, publisher = {Springer}, timestamp = {2015.02.08}, } @ARTICLE{tutz1990, author = {Tutz, Gerhard}, title = {Sequential Item Response Models with an Ordered Response}, journal = {British Journal of Mathematical and Statistical Psychology}, year = {1990}, volume = {43}, pages = {39--55}, number = {1}, owner = {Paul}, publisher = {Wiley Online Library}, timestamp = {2015.02.01} } @ARTICLE{yee2010, author = {Yee, Thomas W}, title = {The \pkg{VGAM} Package for Categorical Data Analysis}, journal = {Journal of Statistical Software}, year = {2010}, volume = {32}, pages = {1--34}, number = {10}, owner = {Paul}, timestamp = {2015.09.04} } @ARTICLE{andrich1978b, author = {Andrich, David}, title = {Application of a Psychometric Rating Model to Ordered Categories which are Scored with Successive Integers}, journal = {Applied Psychological Measurement}, year = {1978}, volume = {2}, pages = {581--594}, number = {4}, owner = {Paul}, publisher = {Sage Publications}, timestamp = {2015.01.27} } @ARTICLE{andersen1977, author = {Andersen, Erling B}, title = {Sufficient Statistics and Latent Trait Models}, journal = {Psychometrika}, year = {1977}, volume = {42}, pages = {69--81}, number = {1}, owner = {Paul}, publisher = {Springer}, timestamp = {2015.01.27} } @ARTICLE{vanderark2001, author = {Van Der Ark, L Andries}, title = {Relationships and Properties of Polytomous Item Response Theory Models}, journal = {Applied Psychological Measurement}, year = {2001}, volume = {25}, pages = {273--282}, number = {3}, owner = {Paul}, publisher = {Sage Publications}, timestamp = {2015.01.26} } @Book{tutz2000, title = {Die {A}nalyse {K}ategorialer {D}aten: {A}nwendungsorientierte {E}inf{\"u}hrung in {L}ogit-{M}odellierung und {K}ategoriale {R}egression}, publisher = {Oldenbourg Verlag}, year = {2000}, author = {Tutz, Gerhard}, owner = {Paul}, timestamp = {2015.01.23}, } @MANUAL{rstanarm2016, title = {rstanarm: Bayesian Applied Regression Modeling via \pkg{Stan}}, author = {Jonah Gabry and Ben Goodrich}, year = {2016}, note = {R package version 2.9.0-3}, owner = {Paul}, timestamp = {2016.03.04}, url = {https://CRAN.R-project.org/package=rstanarm} } @MANUAL{mcelreath2016, title = {rethinking: Statistical Rethinking Course and Book Package}, author = {Richard McElreath}, year = {2016}, note = {R package version 1.58}, owner = {Paul}, timestamp = {2016.03.04}, url = {https://github.com/rmcelreath/rethinking} } @MANUAL{nlme2016, title = {\pkg{nlme}: Linear and Nonlinear Mixed Effects Models}, author = {Jose Pinheiro and Douglas Bates and Saikat DebRoy and Deepayan Sarkar and {R Core Team}}, year = {2016}, note = {R package version 3.1-124}, owner = {Paul}, timestamp = {2016.03.06}, url = {http://CRAN.R-project.org/package=nlme} } @BOOK{hastie1990, title = {Generalized Additive Models}, publisher = {CRC Press}, year = {1990}, author = {Hastie, Trevor J and Tibshirani, Robert J}, volume = {43}, owner = {Paul}, timestamp = {2015.09.07} } @Article{wood2011, author = {Wood, Simon N}, title = {Fast Stable Restricted Maximum Likelihood and Marginal Likelihood Estimation of Semiparametric Generalized Linear Models}, journal = {Journal of the Royal Statistical Society: Series B (Statistical Methodology)}, year = {2011}, volume = {73}, number = {1}, pages = {3--36}, publisher = {Wiley Online Library}, } @BOOK{zuur2014, title = {A beginner's Guide to Generalized Additive Models with \proglang{R}}, publisher = {Highland Statistics Limited}, year = {2014}, author = {Zuur, Alain F}, owner = {Paul}, timestamp = {2016.03.04} } @ARTICLE{chung2013, author = {Yeojin Chung and Sophia Rabe-Hesketh and Vincent Dorie and Andrew Gelman and Jingchen Liu}, title = {A nondegenerate penalized likelihood estimator for variance parameters in multilevel models}, journal = {Psychometrika}, year = {2013}, volume = {78}, pages = {685--709}, number = {4}, owner = {Paul}, publisher = {Springer}, timestamp = {2016.02.22}, url = {http://gllamm.org/} } @ARTICLE{duane1987, author = {Duane, Simon and Kennedy, Anthony D and Pendleton, Brian J and Roweth, Duncan}, title = {Hybrid Monte Carlo}, journal = {Physics Letters B}, year = {1987}, volume = {195}, pages = {216--222}, number = {2}, owner = {Paul}, publisher = {Elsevier}, timestamp = {2015.06.19} } @ARTICLE{natarajan2000, author = {Natarajan, Ranjini and Kass, Robert E}, title = {Reference Bayesian Methods for Generalized Linear Mixed Models}, journal = {Journal of the American Statistical Association}, year = {2000}, volume = {95}, pages = {227--237}, number = {449}, owner = {Paul}, publisher = {Taylor \& Francis}, timestamp = {2015.07.23} } @ARTICLE{kass2006, author = {Kass, Robert E and Natarajan, Ranjini}, title = {A Default Conjugate Prior for Variance Components in Generalized Linear Mixed Models (Comment on Article by Browne and Draper)}, journal = {Bayesian Analysis}, year = {2006}, volume = {1}, pages = {535--542}, number = {3}, owner = {Paul}, publisher = {International Society for Bayesian Analysis}, timestamp = {2015.07.23} } @ARTICLE{plummer2008, author = {Plummer, Martyn}, title = {Penalized Loss Functions for Bayesian Model Comparison}, journal = {Biostatistics}, year = {2008}, owner = {Paul}, publisher = {Biometrika Trust}, timestamp = {2015.08.10} } @ARTICLE{spiegelhalter2002, author = {Spiegelhalter, David J and Best, Nicola G and Carlin, Bradley P and Van Der Linde, Angelika}, title = {Bayesian Measures of Model Complexity and Fit}, journal = {Journal of the Royal Statistical Society B, Statistical Methodology}, year = {2002}, volume = {64}, pages = {583--639}, number = {4}, owner = {Paul}, publisher = {Wiley Online Library}, timestamp = {2015.09.02} } @MANUAL{Rtools2015, title = {\pkg{Rtools} Software, Version~3.3}, author = {{R Core Team}}, organization = {\proglang{R} Foundation for Statistical Computing}, address = {Vienna, Austria}, year = {2015}, owner = {Paul}, timestamp = {2015.01.20}, url = {https://cran.r-project.org/bin/windows/Rtools/} } @Manual{afex2015, title = {\pkg{afex}: Analysis of Factorial Experiments}, author = {Henrik Singmann and Ben Bolker and Jake Westfall}, year = {2015}, note = {R package version 0.15-2}, owner = {Paul}, timestamp = {2016.02.13}, url = {https://CRAN.R-project.org/package=afex}, } @INPROCEEDINGS{carvalho2009, author = {Carvalho, Carlos M and Polson, Nicholas G and Scott, James G}, title = {Handling Sparsity via the Horseshoe}, booktitle = {International Conference on Artificial Intelligence and Statistics}, year = {2009}, pages = {73--80}, owner = {Paul}, timestamp = {2015.11.09} } @ARTICLE{carvalho2010, author = {Carvalho, Carlos M and Polson, Nicholas G and Scott, James G}, title = {The Horseshoe Estimator for Sparse Signals}, journal = {Biometrika}, year = {2010}, pages = {1--16}, owner = {Paul}, publisher = {Biometrika Trust}, timestamp = {2015.11.09} } @ARTICLE{gelman2006, author = {Gelman, Andrew}, title = {Prior Distributions for Variance Parameters in Hierarchical Models}, journal = {Bayesian Analysis}, year = {2006}, volume = {1}, pages = {515--534}, number = {3}, owner = {Paul}, publisher = {International Society for Bayesian Analysis}, timestamp = {2015.07.15} } @Article{gelman1992, author = {Gelman, Andrew and Rubin, Donald B}, title = {Inference from Iterative Simulation Using Multiple Sequences}, journal = {Statistical Science}, year = {1992}, pages = {457--472}, publisher = {JSTOR}, } @MANUAL{gabry2015, title = {\pkg{shinystan}: Interactive Visual and Numerical Diagnostics and Posterior Analysis for Bayesian Models}, author = {Jonah Gabry}, year = {2015}, note = {\proglang{R}~Package Version~2.0.0}, owner = {Paul}, timestamp = {2015.08.26}, url = {http://CRAN.R-project.org/package=shinystan} } @ARTICLE{samejima1969, author = {Samejima, Fumiko}, title = {Estimation of Latent Ability Using a Response Pattern of Graded Scores}, journal = {Psychometrika Monograph Supplement}, year = {1969}, owner = {Paul}, timestamp = {2015.01.27} } @MISC{christensen2015, author = {R. H. B. Christensen}, title = {\pkg{ordinal} -- Regression Models for Ordinal Data}, year = {2015}, note = {\proglang{R} package version 2015.6-28. http://www.cran.r-project.org/package=ordinal/}, owner = {Paul}, timestamp = {2015.09.04} } @ARTICLE{andrich1978a, author = {Andrich, David}, title = {A Rating Formulation for Ordered Response Categories}, journal = {Psychometrika}, year = {1978}, volume = {43}, pages = {561--573}, number = {4}, owner = {Paul}, publisher = {Springer}, timestamp = {2015.01.27} } @Comment{jabref-meta: databaseType:bibtex;} brms/data/0000755000176200001440000000000013237615575012144 5ustar liggesusersbrms/data/kidney.rda0000644000176200001440000000133213202254050014071 0ustar liggesusersBZh91AY&SYk%\LDUUN@@@@@@ CSDJoSM4چ5=OD!IF L =y5hS@ @h4h4 M 4 4ѣ@FMI)L S@2{d1f}%1LH!&QX%xa!!SEW,^/E+aa,F9xo?F{*V4F6/r:4M]jI.X^ZhDEJ)_ H`hჃIR(Zqr D M-j׊><̃L4nbhV36IB)p7$M_l$# 0`H0qٹ`X8Bg|cD Tv$ūR$v5$Xbix_2S!0Yj**"ł$@PY"X1U`,X1F( RR#"jL'SHa Hmdd< h'/pg4:r$xLX5bԚ2?fR_!uʮjRbE°q AZ 㲆LحEΟJ4f[DTA(S229}՜b h۔1P.WLВ.p Jbrms/data/loss.rda0000644000176200001440000000146013737314535013612 0ustar liggesusersBZh91AY&SY,P^w}cwj;P|ui("mOM 4=M !z4hiCdhڀ h<&J)dfijhzzzj!@@4d*!CC@dF hh h@*5=OԏS C@12@ɣA@4h Iik e!EǼO$g`Y6hs D+"D`F#Vjf@MbbRY F}#Ju ˢ-x< -`!ҽR@؍6 +瘄Sogi?qRWoX90=l{)']CJ?{"(Őbj>Exm̔!ԴBIaw@h4L*zzAꪦ?O424hh24&&44hL! MF@ M  FL@рahd2ih4L@""&&ELLhڛDGbjD6)4̦G=LDOO&d4z=Fe4<Ѧi3)R%w4jm{\ ̛<0gc1ɑYrr~.&5:kYtsKvN"xLSUPv' ƗSi|SXdgj=w([zDܗ˫n̶}fnMɞr2& Ѿcdh&֛.k &SPg::Pjތ_.olYQ4MQfٰ3L I\79cV83SJi9l4Ɖ8Pf1333i1ߵ->¤-U$ p* FB*IQ\^8 RI%Ta0IQY-kF*82+B8ۦY%i"ʹtlie}dzs-UV,G$#OG#z4d2FTr!TBFh) 4CQ $i@CY Dii! HBC d2B$'9iM]UP%l123456789:9:;<=>?@ABCDDEFGHIJKLMNOPRSTUVWXYZ[\]^_`abcddefghiS5Uu6V KO͐B,U})@]B@x>]y#<-L $̤%TBJfLoƜ""""""""""""""""""""""""*5~-@)zI $JO$,T"BLbRWI!#*@ ‰! ֕'[GdJ{!dD*8rW$TG:WŨ$PPPT'^sĘI3 Eʏ*LEj9#t,tPFTh2^7gl-TmGKF2J- F1.TkHۅȴg #wGxØ5+^=zM&۞ sܪI$I$]vи\/˥۷n!UYB(TUUE {.{)e )`EYeMir {^ZZ۲Z[qJR 0 1x^zUUWd oL0ֲֲֲֲYjU*4 YY]uZ*+Yp0J뮺UUZʡ!!!!!!!!4@”0,0 ",UU[/I$I$@2[Bд/KKKmUUU}1ZI$I$ƀҁm KmUUV$I$I?`Ja/뮵UU\ *I$I$P ,Ey` r'F:c:AkD4ώ~=#xGfSpp=ޝ6 1QԚάOr'2A >6f3%'Y^U%𴪲UMAklMz "*"cQ/UDI(Q@¡b-hK PQ% Eh BT% T+-CJ;M>k 7IV'8Poǽ/#!~--:q~F]֍,|U#\Q7eo+tWb\{nc?T ђ|c|~811Oh NM0't^GcYv'x=0 zN :GmOKy{;S'DN?@|9# ϳY?g0Hek m;\kWVd > 啪HO4s7#)b|ڔ_a˚}dv% {3:pɵ9" v oZS?H"ŹV-瞼y+=i3OH/G"aCW0ݖy%Ke^o 僨%L}𮔯vJt!Q}AIƓ+*8i,Ri- Af@N\:ӷ;;H|8SVvtyGݞGNj!=@͉?k>ٝAMrjMA3AMl &йϟPN"`Gt=L.E8i o,3v\_bd9ŻZۜ`` w-8pS wfra͓:!9jGt2ī|830b8n蘓/ ܔ_9r;AU;S|O0b2`G2`P珸q%mfEx& ”e= 2.26. # brms 2.20.0 ### New Features * Apply the `horseshoe` and `R2D2` priors globally, that is, for all additive predictor terms specified in the same formula. (#1492) * Use `as.brmsprior` to transform objects into a `brmsprior`. (#1491) * Use matrix data as non-linear covariates. (#1488) ### Other Changes * No longer support the `lasso` prior as it is not a good shrinkage prior and incompatible with the newly implemented global shrinkage prior framework. * No longer support multiple deprecated prior options for categorical and multivariate models after around 3 years of deprecation. (#1420) * Deprecate argument `newdata` of `get_refmodel.brmsfit()`. (#1502) * Disallow binomial models without `trials` argument after several years of deprecation. (#1501) ### Bug Fixes * Fix a long-standing bug in the post-processing of spline models that could lead to non-sensible results if predictions were performed on a different machine than where the model was originally fitted. Old spline models can be repaired via `restructure`. Special thanks to Simon Wood, Ruben Arslan, Marta Kołczyńska, Patrick Hogan, and Urs Kalbitzer. (#1465) * Fix a bunch of minor issues occurring for rare feature combinations. # brms 2.19.0 ### New Features * Model unstructured autocorrelation matrices via the `unstr` term thanks to the help of Sebastian Weber. (#1435) * Model ordinal data with an extra category (non-response or similar) via the `hurdle_cumulative` family thanks to Stephen Wild. (#1448) * Improve user control over model recompilation via argument `recompile` in post-processing methods that require a compiled Stan model. * Extend control over the `point_estimate` feature in `prepare_predictions` via the new argument `ndraws_point_estimate`. * Add support for the latent projection available in **projpred** versions >= 2.4.0. (#1451) ### Bug Fixes * Fix a Stan syntax error in threaded models with `lasso` priors. (#1427) * Fix Stan compilation issues for some of the more special link functions such as `cauchit` or `softplus`. * Fix a bug for predictions in **projpred**, previously requiring more variables in `newdata` than necessary. (#1457, #1459, #1460) # brms 2.18.0 ### New Features * Support regression splines with fixed degrees of freedom specified via `s(..., fx = TRUE)`. * Reuse user-specified control arguments originally passed to the Stan backend in `update` and related methods. (#1373, #1378) * Allow to retain unused factors levels via `drop_unused_levels = FALSE` in `brm` and related functions. (#1346) * Automatically update old default priors based on new input when when updating models via `update.brmsfit`. (#1380) * Allow to use `dirichlet` priors for more parameter types. (#1165) ### Other Changes * Improve efficiency of converting models fitted with `backend = "cmdstanr"` to `stanfit` objects thanks to Simon Mills and Jacob Socolar. (#1331) * Allow for more `O1` optimization of brms-generated Stan models thanks to Aki Vehtari. (#1382) ### Bug Fixes * Fix problems with missing boundaries of `sdme` parameters in models with known response standard errors thanks to Solomon Kurz. (#1348) * Fix Stan code of `gamma` models with `softplus` link. * Allow for more flexible data inputs to `brm_multiple`. (#1383) * Ensure that `control_params` returns the right values for models fitted with the `cmdstanr` backend. (#1390) * Fix problems in multivariate spline models when using the `subset` addition term. (#1385) # brms 2.17.0 ### New Features * Add full user control for boundaries of most parameters via the `lb` and `ub` arguments of `set_prior` and related functions. (#878, #1094) * Add family `logistic_normal` for simplex responses. (#1274) * Add argument `future_args` to `kfold` and `reloo` for additional control over parallel execution via futures. * Add families `beta_binomial` & `zero_inflated_beta_binomial` for potentially over-dispersed and zero-inflated binomial response models thanks to Hayden Rabel. (#1319 & #1311) * Display `ppd_*` plots in `pp_check` via argument `prefix`. (#1313) * Support the `log` link in binomial and beta type families. (#1316) * Support **projpred**'s augmented-data projection. (#1292, #1294) ### Other changes * Argument `brms_seed` has been added to `get_refmodel.brmsfit()`. (#1287) * Deprecate argument `inits` in favor of `init` for consistency with the Stan backends. * Improve speed of the `summary` method for high-dimensional models. (#1330) ### Bug Fixes * Fix Stan code of threaded multivariate models thanks to Anirban Mukherjee. (#1277) * Fix usage of `int_conditions` in `conditional_smooths` thanks to Urs Kalbitzer. (#1280) * Fix an error sometimes occurring for multilevel (reference) models in `projpred`'s K-fold CV. (#1286) * Fix response values in `make_standata` for `bernoulli` families when only 1s are present thanks to Facundo Munoz. (#1298) * Fix `pp_check` for censored responses to work for all plot types thanks to Hayden Rabel. (#1327) * Ensure that argument `overwrite` in `add_criterion` works as expected for all criteria thanks to Andrew Milne. (#1323) * Fix a problem in `launch_shinystan` occurring when warmup draws were saved thanks to Frank Weber. (#1257, #1329) * Fix numerical stability problems in `log_lik` for ordinal models. (#1192) # brms 2.16.3 ### Other changes * Move `projpred` from `Imports:` to `Suggests:`. This has the important implication that users need to load or attach `projpred` themselves if they want to use it (the more common case is probably attaching, which is achieved by `library(projpred)`). (#1222) ### Bug Fixes * Ensure that argument `overwrite` in `add_criterion` is working as intended thanks to Ruben Arslan. (#1219) * Fix a bug in `get_refmodel.brmsfit()` (i.e., when using `projpred` for a `"brmsfit"`) causing offsets not to be recognized. (#1220) * Several further minor bug fixes. # brms 2.16.1 ### Bug Fixes * Fix a bug causing problems during post-processing of models fitted with older versions of brms and the `cmdstanr` backend thanks to Riccardo Fusaroli. (#1218) # brms 2.16.0 ### New Features * Support several methods of the `posterior` package. (#1204) * Substantially extend compatibility of `brms` models with `emmeans` thanks to Mattan S. Ben-Shachar. (#907, #1134) * Combine missing value (`mi`) terms with `subset` addition terms. (#1063) * Expose function `get_dpar` for use in the post-processing of custom families thank to Martin Modrak. (#1131) * Support the `squareplus` link function in all families and distributional parameters that also allow for the `log` link function. * Add argument `incl_thres` to `posterior_linpred.brmsfit()` allowing to subtract the threshold-excluding linear predictor from the thresholds in case of an ordinal family. (#1137) * Add a `"mock"` backend option to facilitate testing thanks to Martin Modrak. (#1116) * Add option `file_refit = "always"` to always overwrite models stored via the `file` argument. (#1151) * Initial GPU support via OpenCL thanks to the help Rok Češnovar. (#1166) * Support argument `robust` in method `hypothesis`. (#1170) * Vectorize the Stan code of custom likelihoods via argument `loop` of `custom_family`. (#1084) * Experimentally allow category specific effects for ordinal `cumulative` models. (#1060) * Regenerate Stan code of an existing model via argument `regenerate` of method `stancode`. * Support `expose_functions` for models fitted with the `cmdstanr` backend thanks to Sebastian Weber. (#1176) * Support `log_prob` and related functionality in models fitted with the `cmdstanr` backend via function `add_rstan_model`. (#1184) ### Other Changes * Remove use of `cbind` to express multivariate models after over two years of deprecation (please use `mvbind` instead). * Method `posterior_linpred(transform = TRUE)` is now equal to `posterior_epred(dpar = "mu")` and no longer deprecated. * Refactor and extend internal post-processing functions for ordinal and categorical models thanks to Frank Weber. (#1159) * Ignore `NA` values in interval censored boundaries as long as they are unused. (#1070) * Take offsets into account when deriving default priors for overall intercept parameters. (#923) * Soft deprecate measurement error (`me`) terms in favor of the more general and consistent missing value (`mi`) terms. (#698) ### Bug Fixes * Fix an issue in the post-processing of non-normal ARMA models thanks to Thomas Buehrens. (#1149) * Fix an issue with default baseline hazard knots in `cox` models thanks to Malcolm Gillies. (#1143) * Fix a bug in non-linear models caused by accidental merging of operators in the non-linear formula thanks to Fernando Miguez. (#1142) * Correctly trigger a refit for `file_refit = "on_change"` if factor level names have changed thanks to Martin Modrak. (#1128) * Validate factors in `validate_newdata` even when they are simultaneously used as predictors and grouping variables thanks to Martin Modrak. (#1141) * Fix a bug in the Stan code generation of threaded mixture models with predicted mixture probabilities thanks to Riccardo Fusaroli. (#1150) * Remove duplicated Stan code related to the `horseshoe` prior thanks to Max Joseph. (#1167) * Fix an issue in the post-processing of non-looped non-linear parameters thanks to Sebastian Weber. * Fix an issue in the Stan code of threaded non-looped non-linear models thanks to Sebastian Weber. (#1175) * Fix problems in the post-processing of multivariate meta-analytic models that could lead to incorrect handling of known standard errors. # brms 2.15.0 ### New Features * Turn off normalization in the Stan model via argument `normalize`. to increase sampling efficiency thanks to Andrew Johnson. (#1017, #1053) * Enable `posterior_predict` for truncated continuous models even if the required CDF or quantile functions are unavailable. * Update and export `validate_prior` to validate priors supplied by the user. * Add support for within-chain threading with `rstan (Stan >= 2.25)` backend. * Apply the R2-D2 shrinkage prior to population-level coefficients via function `R2D2` to be used in `set_prior`. * Extend support for `arma` correlation structures in non-normal families. * Extend scope of variables passed via `data2` for use in the evaluation of most model terms. * Refit models previously stored on disc only when necessary thanks to Martin Modrak. The behavior can be controlled via `file_refit`. (#1058) * Allow for a finer tuning of informational messages printed in `brm` via the `silent` argument. (#1076) * Allow `stanvars` to alter distributional parameters. (#1061) * Allow `stanvars` to be used inside threaded likelihoods. (#1111) ### Other Changes * Improve numerical stability of ordinal sequential models (families `sratio` and `cratio`) thanks to Andrew Johnson. (#1087) ### Bug Fixes * Allow fitting `multinomial` models with the `cmdstanr` backend thanks to Andrew Johnson. (#1033) * Allow user-defined Stan functions in threaded models. (#1034) * Allow usage of the `:` operator in autocorrelation terms. * Fix Stan code generation when specifying coefficient-level priors on spline terms. * Fix numerical issues occurring in edge cases during post-processing of Gaussian processes thanks to Marta Kołczyńska. * Fix an error during post-processing of new levels in multi-membership terms thanks to Guilherme Mohor. * Fix a bug in the Stan code of threaded `wiener` drift diffusion models thanks to the GitHub user yanivabir. (#1085) * Fix a bug in the threaded Stan code for GPs with categorical `by` variables thanks to Reece Willoughby. (#1081) * Fix a bug in the threaded Stan code when using QR decomposition thanks to Steve Bronder. (#1086) * Include offsets in `emmeans` related methods thanks to Russell V. Lenth. (#1096) # brms 2.14.4 ### New Features * Support `projpred` version 2.0 for variable selection in generalized linear and additive multilevel models thanks to Alejandro Catalina. * Support `by` variables in multi-membership terms. * Use Bayesian bootstrap in `loo_R2`. ### Bug Fixes * Allow non-linear terms in threaded models. * Allow multi-membership terms in threaded models. * Allow `se` addition terms in threaded models. * Allow `categorical` families in threaded models. * Fix updating of parameters in `loo_moment_match`. * Fix facet labels in `conditional_effects` thanks to Isaac Petersen. (#1014) # brms 2.14.0 ### New Features * Experimentally support within-chain parallelization via `reduce_sum` using argument `threads` in `brm` thanks to Sebastian Weber. (#892) * Add algorithm `fixed_param` to sample from fixed parameter values. (#973) * No longer remove `NA` values in `data` if there are unused because of the `subset` addition argument. (#895) * Combine `by` variables and within-group correlation matrices in group-level terms. (#674) * Add argument `robust` to the `summary` method. (#976) * Parallelize evaluation of the `posterior_predict` and `log_lik` methods via argument `cores`. (#819) * Compute effective number of parameters in `kfold`. * Show prior sources and vectorization in the `print` output of `brmsprior` objects. (#761) * Store unused variables in the model's data frame via argument `unused` of function `brmsformula`. * Support posterior mean predictions in `emmeans` via `dpar = "mean"` thanks to Russell V. Lenth. (#993) * Improve control of which parameters should be saved via function `save_pars` and corresponding argument in `brm`. (#746) * Add method `posterior_smooths` to computing predictions of individual smooth terms. (#738) * Allow to display grouping variables in `conditional_effects` using the `effects` argument. (#1012) ### Other Changes * Improve sampling efficiency for a lot of models by using Stan's GLM-primitives even in non-GLM cases. (#984) * Improve sampling efficiency of multilevel models with within-group covariances thanks to David Westergaard. (#977) * Deprecate argument `probs` in the `conditional_effects` method in favor of argument `prob`. ### Bug Fixes * Fix a problem in `pp_check` inducing wronger observation orders in time series models thanks to Fiona Seaton. (#1007) * Fix multiple problems with `loo_moment_match` that prevented it from working for some more complex models. # brms 2.13.5 ### New Features * Support the Cox proportional hazards model for time-to-event data via family `cox`. (#230, #962) * Support method `loo_moment_match`, which can be used to update a `loo` object when Pareto k estimates are large. ### Other Changes * Improve the prediction behavior in post-processing methods when sampling new levels of grouping factors via `sample_new_levels = "uncertainty"`. (#956) ### Bug Fixes * Fix minor problems with MKL on CRAN. # brms 2.13.3 ### New Features * Fix shape parameters across multiple monotonic terms via argument `id` in function `mo` to ensure conditionally monotonic effects. (#924) * Support package `rtdists` as additional backend of `wiener` distribution functions thanks to the help of Henrik Singmann. (#385) ### Bug Fixes * Fix generated Stan Code of models with improper global priors and `constant` priors on some coefficients thanks to Frank Weber. (#919) * Fix a bug in `conditional_effects` occurring for categorical models with matrix predictors thanks to Jamie Cranston. (#933) ### Other Changes * Adjust behavior of the `rate` addition term so that it also affects the `shape` parameter in `negbinomial` models thanks to Edward Abraham. (#915) * Adjust the default inverse-gamma prior on length-scale parameters of Gaussian processes to be less extreme in edge cases thanks to Topi Paananen. # brms 2.13.0 ### New Features * Constrain ordinal thresholds to sum to zero via argument `threshold` in ordinal family functions thanks to the help of Marta Kołczyńska. * Support `posterior_linpred` as method in `conditional_effects`. * Use `std_normal` in the Stan code for improved efficiency. * Add arguments `cor`, `id`, and `cov` to the functions `gr` and `mm` for easy specification of group-level correlation structures. * Improve workflow to feed back brms-created models which were fitted somewhere else back into brms. (#745) * Improve argument `int_conditions` in `conditional_effects` to work for all predictors not just interactions. * Support multiple imputation of data passed via `data2` in `brm_multiple`. (#886) * Fully support the `emmeans` package thanks to the help of Russell V. Lenth. (#418) * Control the within-block position of Stan code added via `stanvar` using the `position` argument. ### Bug Fixes * Fix issue in Stan code of models with multiple `me` terms thanks to Chris Chatham. (#855, #856) * Fix scaling problems in the estimation of ordinal models with multiple threshold vectors thanks to Marta Kołczyńska and Rok Češnovar. * Allow usage of `std_normal` in `set_prior` thanks to Ben Goodrich. (#867) * Fix Stan code of distributional models with `weibull`, `frechet`, or `inverse.gaussian` families thanks to Brian Huey and Jack Caster. (#879) * Fix Stan code of models which are truncated and weighted at the same time thanks to Michael Thompson. (#884) * Fix Stan code of multivariate models with custom families and data variables passed to the likelihood thanks to Raoul Wolf. (#906) ### Other Changes * Reduce minimal scale of several default priors from 10 to 2.5. The resulting priors should remain weakly informative. * Automatically group observations in `gp` for increased efficiency. * Rename `parse_bf` to `brmsterms` and deprecate the former function. * Rename `extract_draws` to `prepare_predictions` and deprecate the former function. * Deprecate using a model-dependent `rescor` default. * Deprecate argument `cov_ranef` in `brm` and related functions. * Improve several internal interfaces. This should not have any user-visible changes. * Simplify the parameterization of the horseshoe prior thanks to Aki Vehtari. (#873) * Store fixed distributional parameters as regular draws so that they behave as if they were estimated in post-processing methods. # brms 2.12.0 ### New Features * Fix parameters to constants via the `prior` argument. (#783) * Specify autocorrelation terms directly in the model formula. (#708) * Translate integer covariates in non-linear formulas to integer arrays in Stan. * Estimate `sigma` in combination with fixed correlation matrices via autocorrelation term `fcor`. * Use argument `data2` in `brm` and related functions to pass data objects which cannot be passed via `data`. The usage of `data2` will be extended in future versions. * Compute pointwise log-likelihood values via `log_lik` for non-factorizable Student-t models. (#705) ### Bug Fixes * Fix output of `posterior_predict` for `multinomial` models thanks to Ivan Ukhov. * Fix selection of group-level terms via `re_formula` in multivariate models thanks to Maxime Dahirel. (#834) * Enforce correct ordering of terms in `re_formula` thanks to @ferberkl. (#844) * Fix post-processing of multivariate multilevel models when multiple IDs are used for the same grouping factor thanks to @lott999. (#835) * Store response category names of ordinal models in the output of `posterior_predict` again thanks to Mattew Kay. (#838) * Handle `NA` values more consistently in `posterior_table` thanks to Anna Hake. (#845) * Fix a bug in the Stan code of models with multiple monotonic varying effects across different groups thanks to Julian Quandt. ### Other Changes * Rename `offset` variables to `offsets` in the generated Stan code as the former will be reserved in the new stanc3 compiler. # brms 2.11.1 ### Bug Fixes * Fix version requirement of the `loo` package. * Fix effective sample size note in the `summary` output. (#824) * Fix an edge case in the handling of covariates in special terms thanks to Andrew Milne. (#823) * Allow restructuring objects multiple times with different brms versions thanks to Jonathan A. Nations. (#828) * Fix validation of ordered factors in `newdata` thanks to Andrew Milne. (#830) # brms 2.11.0 ### New Features * Support grouped ordinal threshold vectors via addition argument `resp_thres`. (#675) * Support method `loo_subsample` for performing approximate leave-one-out cross-validation for large data. * Allow storing more model fit criteria via `add_criterion`. (#793) ### Bug Fixes * Fix prediction uncertainties of new group levels for `sample_new_levels = "uncertainty"` thanks to Dominic Magirr. (#779) * Fix problems when using `pp_check` on censored models thanks to Andrew Milne. (#744) * Fix error in the generated Stan code of multivariate `zero_inflated_binomial` models thanks to Raoul Wolf. (#756) * Fix predictions of spline models when using addition argument `subset` thanks to Ruben Arslan. * Fix out-of-sample predictions of AR models when predicting more than one step ahead. * Fix problems when using `reloo` or `kfold` with CAR models. * Fix problems when using `fitted(..., scale = "linear")` with multinomial models thanks to Santiago Olivella. (#770) * Fix problems in the `as.mcmc` method for thinned models thanks to @hoxo-m. (#811) * Fix problems in parsing covariates of special effects terms thanks to Riccardo Fusaroli (#813) ### Other Changes * Rename `marginal_effects` to `conditional_effects` and `marginal_smooths` to `conditional_smooths`. (#735) * Rename `stanplot` to `mcmc_plot`. * Add method `pp_expect` as an alias of `fitted`. (#644) * Model fit criteria computed via `add_criterion` are now stored in the `brmsfit$criteria` slot. * Deprecate `resp_cat` in favor of `resp_thres`. * Deprecate specifying global priors on regression coefficients in categorical and multivariate models. * Improve names of weighting methods in `model_weights`. * Deprecate reserved variable `intercept` in favor of `Intercept`. * Deprecate argument `exact_match` in favor of `fixed`. * Deprecate functions `add_loo` and `add_waic` in favor of `add_criterion`. # brms 2.10.0 ### New Features * Improve convergence diagnostics in the `summary` output. (#712) * Use primitive Stan GLM functions whenever possible. (#703) * Pass real and integer data vectors to custom families via the addition arguments `vreal` and `vint`. (#707) * Model compound symmetry correlations via `cor_cosy`. (#403) * Predict `sigma` in combination with several autocorrelation structures. (#403) * Use addition term `rate` to conveniently handle denominators of rate responses in log-linear models. * Fit BYM2 CAR models via `cor_car` thanks to the case study and help of Mitzi Morris. ### Other Changes * Substantially improve the sampling efficiency of SAR models thanks to the GitHub user aslez. (#680) * No longer allow changing the boundaries of autocorrelation parameters. * Set the number of trials to 1 by default in `marginal_effects` if not specified otherwise. (#718) * Use non-standard evaluation for addition terms. * Name temporary intercept parameters more consistently in the Stan code. ### Bug Fixes * Fix problems in the post-processing of `me` terms with grouping factors thanks to the GitHub user tatters. (#706) * Allow grouping variables to start with a dot thanks to Bruno Nicenboim. (#679) * Allow the `horseshoe` prior in categorical and related models thanks to the Github user tatters. (#678) * Fix extraction of prior samples for overall intercepts in `prior_samples` thanks to Jonas Kristoffer Lindelov. (#696) * Allow underscores to be used in category names of categorical responses thanks to Emmanuel Charpentier. (#672) * Fix Stan code of multivariate models with multi-membership terms thanks to the Stan discourse user Pia. * Improve checks for non-standard variable names thanks to Ryan Holbrook. (#721) * Fix problems when plotting facetted spaghetti plots via `marginal_smooths` thanks to Gavin Simpson. (#740) # brms 2.9.0 ### New Features * Specify non-linear ordinal models. (#623) * Allow to fix thresholds in ordinal mixture models (#626) * Use the `softplus` link function in various families. (#622) * Use QR decomposition of design matrices via argument `decomp` of `brmsformula` thanks to the help of Ben Goodrich. (#640) * Define argument `sparse` separately for each model formula. * Allow using `bayes_R2` and `loo_R2` with ordinal models. (#639) * Support `cor_arma` in non-normal models. (#648) ### Other Changes * Change the parameterization of monotonic effects to improve their interpretability. (#578) * No longer support the `cor_arr` and `cor_bsts` correlation structures after a year of deprecation. * Refactor internal evaluation of special predictor terms. * Improve penalty of splines thanks to Ben Goodrich and Ruben Arslan. ### Bug Fixes * Fix a problem when applying `marginal_effects` to measurement error models thanks to Jonathan A. Nations. (#636) * Fix computation of log-likelihood values for weighted mixture models. * Fix computation of fitted values for truncated lognormal and weibull models. * Fix checking of response boundaries for models with missing values thanks to Lucas Deschamps. * Fix Stan code of multivariate models with both residual correlations and missing value terms thanks to Solomon Kurz. * Fix problems with interactions of special terms when extracting variable names in `marginal_effects`. * Allow compiling a model in `brm_multiple` without sampling thanks to Will Petry. (#671) # brms 2.8.0 ### New Features * Fit multinomial models via family `multinomial`. (#463) * Fit Dirichlet models via family `dirichlet`. (#463) * Fit conditional logistic models using the `categorical` and `multinomial` families together with non-linear formula syntax. (#560) * Choose the reference category of `categorical` and related families via argument `refcat` of the corresponding family functions. * Use different subsets of the data in different univariate parts of a multivariate model via addition argument `subset`. (#360) * Control the centering of population-level design matrices via argument `center` of `brmsformula` and related functions. * Add an `update` method for `brmsfit_multiple` objects. (#615) * Split folds after `group` in the `kfold` method. (#619) ### Other changes * Deprecate `compare_ic` and instead recommend `loo_compare` for the comparison of `loo` objects to ensure consistency between packages. (#414) * Use the **glue** package in the Stan code generation. (#549) * Introduce `mvbind` to eventually replace `cbind` in the formula syntax of multivariate models. * Validate several sampling-related arguments in `brm` before compiling the Stan model. (#576) * Show evaluated vignettes on CRAN again. (#591) * Export function `get_y` which is used to extract response values from `brmsfit` objects. ### Bug fixes * Fix an error when trying to change argument `re_formula` in `bayes_R2` thanks to the GitHub user emieldl. (#592) * Fix occasional problems when running chains in parallel via the **future** package thanks to Jared Knowles. (#579) * Ensure correct ordering of response categories in ordinal models thanks to Jonas Kristoffer Lindelov. (#580) * Ignore argument `resp` of `marginal_effects` in univariate models thanks to Vassilis Kehayas. (#589) * Correctly disable cell-mean coding in varying effects. * Allow to fix parameter `ndt` in drift diffusion models. * Fix Stan code for t-distributed varying effects thanks to Ozgur Asar. * Fix an error in the post-processing of monotonic effects occurring for multivariate models thanks to James Rae. (#598) * Fix lower bounds in truncated discrete models. * Fix checks of the original data in `kfold` thanks to the GitHub user gcolitti. (#602) * Fix an error when applying the `VarCorr` method to meta-analytic models thanks to Michael Scharkow. (#616) # brms 2.7.0 ### New features * Fit approximate and non-isotropic Gaussian processes via `gp`. (#540) * Enable parallelization of model fitting in `brm_multiple` via the future package. (#364) * Perform posterior predictions based on k-fold cross-validation via `kfold_predict`. (#468) * Indicate observations for out-of-sample predictions in ARMA models via argument `oos` of `extract_draws`. (#539) ### Other changes * Allow factor-like variables in smooth terms. (#562) * Make plotting of `marginal_effects` more robust to the usage of non-standard variable names. * Deactivate certain data validity checks when using custom families. * Improve efficiency of adjacent category models. * No longer print informational messages from the Stan parser. ### Bug fixes * Fix an issue that could result in a substantial efficiency drop of various post-processing methods for larger models. * Fix an issue when that resulted in an error when using `fitted(..., scale = "linear")` with ordinal models thanks to Andrew Milne. (#557) * Allow setting priors on the overall intercept in sparse models. * Allow sampling from models with only a single observation that also contain an offset thanks to Antonio Vargas. (#545) * Fix an error when sampling from priors in mixture models thanks to Jacki Buros Novik. (#542) * Fix a problem when trying to sample from priors of parameter transformations. * Allow using `marginal_smooths` with ordinal models thanks to Andrew Milne. (#570) * Fix an error in the post-processing of `me` terms thanks to the GitHub user hlluik. (#571) * Correctly update `warmup` samples when using `update.brmsfit`. # brms 2.6.0 ### New features * Fit factor smooth interactions thanks to Simon Wood. * Specify separate priors for thresholds in ordinal models. (#524) * Pass additional arguments to `rstan::stan_model` via argument `stan_model_args` in `brm`. (#525) * Save model objects via argument `file` in `add_ic` after adding model fit criteria. (#478) * Compute density ratios based on MCMC samples via `density_ratio`. * Ignore offsets in various post-processing methods via argument `offset`. * Update addition terms in formulas via `update_adterms`. ### Other changes * Improve internal modularization of smooth terms. * Reduce size of internal example models. ### Bug fixes * Correctly plot splines with factorial covariates via `marginal_smooths`. * Allow sampling from priors in intercept only models thanks to Emmanuel Charpentier. (#529) * Allow logical operators in non-linear formulas. # brms 2.5.0 ### New features * Improve `marginal_effects` to better display ordinal and categorical models via argument `categorical`. (#491, #497) * Improve method `kfold` to offer more options for specifying omitted subsets. (#510) * Compute estimated values of non-linear parameters via argument `nlpar` in method `fitted`. * Disable automatic cell-mean coding in model formulas without an intercept via argument `cmc` of `brmsformula` and related functions thanks to Marie Beisemann. * Allow using the `bridge_sampler` method even if prior samples are drawn within the model. (#485) * Specify post-processing functions of custom families directly in `custom_family`. * Select a subset of coefficients in `fixef`, `ranef`, and `coef` via argument `pars`. (#520) * Allow to `overwrite` already stored fit indices when using `add_ic`. ### Other changes * Ignore argument `resp` when post-processing univariate models thanks to Ruben Arslan. (#488) * Deprecate argument `ordinal` of `marginal_effects`. (#491) * Deprecate argument `exact_loo` of `kfold`. (#510) * Deprecate usage of `binomial` families without specifying `trials`. * No longer sample from priors of population-level intercepts when using the default intercept parameterization. ### Bug fixes * Correctly sample from LKJ correlation priors thanks to Donald Williams. * Remove stored fit indices when calling `update` on brmsfit objects thanks to Emmanuel Charpentier. (#490) * Fix problems when predicting a single data point using spline models thanks to Emmanuel Charpentier. (#494) * Set `Post.Prob = 1` if `Evid.Ratio = Inf` in method `hypothesis` thanks to Andrew Milne. (#509) * Ensure correct handling of argument `file` in `brm_multiple`. # brms 2.4.0 ### New features * Define custom variables in all of Stan's program blocks via function `stanvar`. (#459) * Change the scope of non-linear parameters to be global within univariate models. (#390) * Allow to automatically group predictor values in Gaussian processes specified via `gp`. This may lead to a considerable increase in sampling efficiency. (#300) * Compute LOO-adjusted R-squared using method `loo_R2`. * Compute non-linear predictors outside of a loop over observations by means of argument `loop` in `brmsformula`. * Fit non-linear mixture models. (#456) * Fit censored or truncated mixture models. (#469) * Allow `horseshoe` and `lasso` priors to be set on special population-level effects. * Allow vectors of length greater one to be passed to `set_prior`. * Conveniently save and load fitted model objects in `brm` via argument `file`. (#472) * Display posterior probabilities in the output of `hypothesis`. ### Other changes * Deprecate argument `stan_funs` in `brm` in favor of using the `stanvars` argument for the specification of custom Stan functions. * Deprecate arguments `flist` and `...` in `nlf`. * Deprecate argument `dpar` in `lf` and `nlf`. ### Bug fixes * Allow custom families in mixture models thanks to Noam Ross. (#453) * Ensure compatibility with **mice** version 3.0. (#455) * Fix naming of correlation parameters of group-level terms with multiple subgroups thanks to Kristoffer Magnusson. (#457) * Improve scaling of default priors in `lognormal` models (#460). * Fix multiple problems in the post-processing of categorical models. * Fix validation of nested grouping factors in post-processing methods when passing new data thanks to Liam Kendall. # brms 2.3.1 ### New features * Allow censoring and truncation in zero-inflated and hurdle models. (#430) * Export zero-inflated and hurdle distribution functions. ### Other changes * Improve sampling efficiency of the ordinal families `cumulative`, `sratio`, and `cratio`. (#433) * Allow to specify a single k-fold subset in method `kfold`. (#441) ### Bug fixes * Fix a problem in `launch_shinystan` due to which the maximum treedepth was not correctly displayed thanks to Paul Galpern. (#431) # brms 2.3.0 ### Features * Extend `cor_car` to support intrinsic CAR models in pairwise difference formulation thanks to the case study of Mitzi Morris. * Compute `loo` and related methods for non-factorizable normal models. ### Other changes * Rename quantile columns in `posterior_summary`. This affects the output of `predict` and related methods if `summary = TRUE`. (#425) * Use hashes to check if models have the same response values when performing model comparisons. (#414) * No longer set `pointwise` dynamically in `loo` and related methods. (#416) * No longer show information criteria in the summary output. * Simplify internal workflow to implement native response distributions. (#421) ### Bug fixes * Allow `cor_car` in multivariate models with residual correlations thanks to Quentin Read. (#427) * Fix a problem in the Stan code generation of distributional `beta` models thanks to Hans van Calster. (#404) * Fix `launch_shinystan.brmsfit` so that all parameters are now shown correctly in the diagnose tab. (#340) # brms 2.2.0 ### Features * Specify custom response distributions with function `custom_family`. (#381) * Model missing values and measurement error in responses using the `mi` addition term. (#27, #343) * Allow missing values in predictors using `mi` terms on the right-hand side of model formulas. (#27) * Model interactions between the special predictor terms `mo`, `me`, and `mi`. (#313) * Introduce methods `model_weights` and `loo_model_weights` providing several options to compute model weights. (#268) * Introduce method `posterior_average` to extract posterior samples averaged across models. (#386) * Allow hyperparameters of group-level effects to vary over the levels of a categorical covariate using argument `by` in function `gr`. (#365) * Allow predictions of measurement-error models with new data. (#335) * Pass user-defined variables to Stan via `stanvar`. (#219, #357) * Allow ordinal families in mixture models. (#389) * Model covariates in multi-membership structures that vary over the levels of the grouping factor via `mmc` terms. (#353) * Fit shifted log-normal models via family `shifted_lognormal`. (#218) * Specify nested non-linear formulas. * Introduce function `make_conditions` to ease preparation of conditions for `marginal_effects`. ### Other changes * Change the parameterization of `weibull` and `exgaussian` models to be consistent with other model classes. Post-processing of related models fitted with earlier version of `brms` is no longer possible. * Treat integer responses in `ordinal` models as directly indicating categories even if the lowest integer is not one. * Improve output of the `hypothesis` method thanks to the ideas of Matti Vuorre. (#362) * Always plot `by` variables as facets in `marginal_smooths`. * Deprecate the `cor_bsts` correlation structure. ### Bug fixes * Allow the `:` operator to combine groups in multi-membership terms thanks to Gang Chen. * Avoid an unexpected error when calling `LOO` with argument `reloo = TRUE` thanks to Peter Konings. (#348) * Fix problems in `predict` when applied to categorical models thanks to Lydia Andreyevna Krasilnikova and Thomas Vladeck. (#336, #345) * Allow truncation in multivariate models with missing values thanks to Malte Lau Petersen. (#380) * Force time points to be unique within groups in autocorrelation structures thanks to Ruben Arslan. (#363) * Fix problems when post-processing multiple uncorrelated group-level terms of the same grouping factor thanks to Ivy Jansen. (#374) * Fix a problem in the Stan code of multivariate `weibull` and `frechet` models thanks to the GitHub user philj1s. (#375) * Fix a rare error when post-processing `binomial` models thanks to the GitHub user SeanH94. (#382) * Keep attributes of variables when preparing the `model.frame` thanks to Daniel Luedecke. (#393) # brms 2.1.0 ### Features * Fit models on multiple imputed datasets via `brm_multiple` thanks to Ruben Arslan. (#27) * Combine multiple `brmsfit` objects via function `combine_models`. * Compute model averaged posterior predictions with method `pp_average`. (#319) * Add new argument `ordinal` to `marginal_effects` to generate special plots for ordinal models thanks to the idea of the GitHub user silberzwiebel. (#190) * Use informative inverse-gamma priors for length-scale parameters of Gaussian processes. (#275) * Compute hypotheses for all levels of a grouping factor at once using argument `scope` in method `hypothesis`. (#327) * Vectorize user-defined `Stan` functions exported via `export_functions` using argument `vectorize`. * Allow predicting new data in models with ARMA autocorrelation structures. ### Bug fixes * Correctly recover noise-free coefficients through `me` terms thanks to Ruben Arslan. As a side effect, it is no longer possible to define priors on noise-free `Xme` variables directly, but only on their hyper-parameters `meanme` and `sdme`. * Fix problems in renaming parameters of the `cor_bsts` structure thanks to Joshua Edward Morten. (#312) * Fix some unexpected errors when predicting from ordinal models thanks to David Hervas and Florian Bader. (#306, #307, #331) * Fix problems when estimating and predicting multivariate ordinal models thanks to David West. (#314) * Fix various minor problems in autocorrelation structures thanks to David West. (#320) # brms 2.0.1 ### Features * Export the helper functions `posterior_summary` and `posterior_table` both being used to summarize posterior samples and predictions. ### Bug fixes * Fix incorrect computation of intercepts in `acat` and `cratio` models thanks to Peter Phalen. (#302) * Fix `pointwise` computation of `LOO` and `WAIC` in multivariate models with estimated residual correlation structure. * Fix problems in various S3 methods sometimes requiring unused variables to be specified in `newdata`. * Fix naming of Stan models thanks to Hao Ran Lai. # brms 2.0.0 This is the second major release of `brms`. The main new feature are generalized multivariate models, which now support everything already possible in univariate models, but with multiple response variables. Further, the internal structure of the package has been improved considerably to be easier to maintain and extend in the future. In addition, most deprecated functionality and arguments have been removed to provide a clean new start for the package. Models fitted with `brms` 1.0 or higher should remain fully compatible with `brms` 2.0. ### Features * Add support for generalized multivariate models, where each of the univariate models may have a different family and autocorrelation structure. Residual correlations can be estimated for multivariate `gaussian` and `student` models. All features supported in univariate models are now also available in multivariate models. (#3) * Specify different formulas for different categories in `categorical` models. * Add weakly informative default priors for the parameter class `Intercept` to improve convergence of more complex distributional models. * Optionally display the MC standard error in the `summary` output. (#280) * Add argument `re.form` as an alias of `re_formula` to the methods `posterior_predict`, `posterior_linpred`, and `predictive_error` for consistency with other packages making use of these methods. (#283) ### Other changes * Refactor many parts of the package to make it more consistent and easier to extend. * Show the link functions of all distributional parameters in the `summary` output. (#277) * Reduce working memory requirements when extracting posterior samples for use in `predict` and related methods thanks to Fanyi Zhang. (#224) * Remove deprecated aliases of functions and arguments from the package. (#278) * No longer support certain prior specifications, which were previously labeled as deprecated. * Remove the deprecated addition term `disp` from the package. * Remove old versions of methods `fixef`, `ranef`, `coef`, and `VarCorr`. * No longer support models fitted with `brms` < 1.0, which used the multivariate `'trait'` syntax originally deprecated in `brms` 1.0. * Make posterior sample extraction in the `summary` method cleaner and less error prone. * No longer fix the seed for random number generation in `brm` to avoid unexpected behavior in simulation studies. ### Bug fixes * Store `stan_funs` in `brmsfit` objects to allow using `update` on models with user-defined Stan functions thanks to Tom Wallis. (#288) * Fix problems in various post-processing methods when applied to models with the reserved variable `intercept` in group-level terms thanks to the GitHub user ASKurz. (#279) * Fix an unexpected error in `predict` and related methods when setting `sample_new_levels = "gaussian"` in models with only one group-level effect. Thanks to Timothy Mastny. (#286) # brms 1.10.2 ### Features * Allow setting priors on noise-free variables specified via function `me`. * Add arguments `Ksub`, `exact_loo` and `group` to method `kfold` for defining omitted subsets according to a grouping variable or factor. * Allow addition argument `se` in `skew_normal` models. ### Bug fixes * Ensure correct behavior of horseshoe and lasso priors in multivariate models thanks to Donald Williams. * Allow using `identity` links on all parameters of the `wiener` family thanks to Henrik Singmann. (#276) * Use reasonable dimnames in the output of `fitted` when returning linear predictors of ordinal models thanks to the GitHub user atrolle. (#274) * Fix problems in `marginal_smooths` occurring for multi-membership models thanks to Hans Tierens. # brms 1.10.0 ### Features * Rebuild monotonic effects from scratch to allow specifying interactions with other variables. (#239) * Introduce methods `posterior_linpred` and `posterior_interval` for consistency with other model fitting packages based on `Stan`. * Introduce function `theme_black` providing a black `ggplot2` theme. * Specify special group-level effects within the same terms as ordinary group-level effects. * Add argument `prob` to `summary`, which allows to control the width of the computed uncertainty intervals. (#259) * Add argument `newdata` to the `kfold` method. * Add several arguments to the `plot` method of `marginal_effects` to improve control over the appearences of the plots. ### Other changes * Use the same noise-free variables for all model parts in measurement error models. (#257) * Make names of local-level terms used in the `cor_bsts` structure more informative. * Store the `autocor` argument within `brmsformula` objects. * Store posterior and prior samples in separate slots in the output of method `hypothesis`. * No longer change the default theme of `ggplot2` when attaching `brms`. (#256) * Make sure signs of estimates are not dropped when rounding to zero in `summary.brmsfit`. (#263) * Refactor parts of `extract_draws` and `linear_predictor` to be more consistent with the rest of the package. ### Bug fixes * Do not silence the `Stan` parser when calling `brm` to get informative error messages about invalid priors. * Fix problems with spaces in priors passed to `set_prior`. * Handle non `data.frame` objects correctly in `hypothesis.default`. * Fix a problem relating to the colour of points displayed in `marginal_effects`. # brms 1.9.0 ### Features * Perform model comparisons based on marginal likelihoods using the methods `bridge_sampler`, `bayes_factor`, and `post_prob` all powered by the `bridgesampling` package. * Compute a Bayesian version of R-squared with the `bayes_R2` method. * Specify non-linear models for all distributional parameters. * Combine multiple model formulas using the `+` operator and the helper functions `lf`, `nlf`, and `set_nl`. * Combine multiple priors using the `+` operator. * Split the `nlpar` argument of `set_prior` into the three arguments `resp`, `dpar`, and `nlpar` to allow for more flexible prior specifications. ### Other changes * Refactor parts of the package to prepare for the implementation of more flexible multivariate models in future updates. * Keep all constants in the log-posterior in order for `bridge_sampler` to be working correctly. * Reduce the amount of renaming done within the `stanfit` object. * Rename argument `auxpar` of `fitted.brmsfit` to `dpar`. * Use the `launch_shinystan` generic provided by the `shinystan` package. * Set `bayesplot::theme_default()` as the default `ggplot2` theme when attaching `brms`. * Include citations of the `brms` overview paper as published in the Journal of Statistical Software. ### Bug fixes * Fix problems when calling `fitted` with `hurdle_lognormal` models thanks to Meghna Krishnadas. * Fix problems when predicting `sigma` in `asym_laplace` models thanks to Anna Josefine Sorensen. # brms 1.8.0 ### Features * Fit conditional autoregressive (CAR) models via function `cor_car` thanks to the case study of Max Joseph. * Fit spatial autoregressive (SAR) models via function `cor_sar`. Currently works for families `gaussian` and `student`. * Implement skew normal models via family `skew_normal`. Thanks to Stephen Martin for suggestions on the parameterization. * Add method `reloo` to perform exact cross-validation for problematic observations and `kfold` to perform k-fold cross-validation thanks to the Stan Team. * Regularize non-zero coefficients in the `horseshoe` prior thanks to Juho Piironen and Aki Vehtari. * Add argument `new_objects` to various post-processing methods to allow for passing of data objects, which cannot be passed via `newdata`. * Improve parallel execution flexibility via the `future` package. ### Other changes * Improve efficiency and stability of ARMA models. * Throw an error when the intercept is removed in an ordinal model instead of silently adding it back again. * Deprecate argument `threshold` in `brm` and instead recommend passing `threshold` directly to the ordinal family functions. * Throw an error instead of a message when invalid priors are passed. * Change the default value of the `autocor` slot in `brmsfit` objects to an empty `cor_brms` object. * Shorten `Stan` code by combining declarations and definitions where possible. ### Bug fixes * Fix problems in `pp_check` when the variable specified in argument `x` has attributes thanks to Paul Galpern. * Fix problems when computing fitted values for truncated discrete models based on new data thanks to Nathan Doogan. * Fix unexpected errors when passing models, which did not properly initialize, to various post-processing methods. * Do not accidently drop the second dimension of matrices in `summary.brmsfit` for models with only a single observation. # brms 1.7.0 ### Features * Fit latent Gaussian processes of one or more covariates via function `gp` specified in the model formula (#221). * Rework methods `fixef`, `ranef`, `coef`, and `VarCorr` to be more flexible and consistent with other post-processing methods (#200). * Generalize method `hypothesis` to be applicable on all objects coercible to a `data.frame` (#198). * Visualize predictions via spaghetti plots using argument `spaghetti` in `marginal_effects` and `marginal_smooths`. * Introduce method `add_ic` to store and reuse information criteria in fitted model objects (#220). * Allow for negative weights in multi-membership grouping structures. * Introduce an `as.array` method for `brmsfit` objects. ### Other changes * Show output of \R code in HTML vignettes thanks to Ben Goodrich (#158). * Resolve citations in PDF vignettes thanks to Thomas Kluth (#223). * Improve sampling efficiency for `exgaussian` models thanks to Alex Forrence (#222). * Also transform data points when using argument `transform` in `marginal_effects` thanks to Markus Gesmann. ### Bug fixes * Fix an unexpected error in `marginal_effects` occurring for some models with autocorrelation terms thanks to Markus Gesmann. * Fix multiple problems occurring for models with the `cor_bsts` structure thanks to Andrew Ellis. # brms 1.6.1 ### Features * Implement zero-one-inflated beta models via family `zero_one_inflated_beta`. * Allow for more link functions in zero-inflated and hurdle models. ### Other changes * Ensure full compatibility with `bayesplot` version 1.2.0. * Deprecate addition argument `disp`. ### Bug fixes * Fix problems when setting priors on coefficients of auxiliary parameters when also setting priors on the corresponding coefficients of the mean parameter. Thanks to Matti Vuorre for reporting this bug. * Allow ordered factors to be used as grouping variables thanks to the GitHub user itissid. # brms 1.6.0 ### Features * Fit finite mixture models using family function `mixture`. * Introduce method `pp_mixture` to compute posterior probabilities of mixture component memberships thanks to a discussion with Stephen Martin. * Implement different ways to sample new levels of grouping factors in `predict` and related methods through argument `sample_new_levels`. Thanks to Tom Wallis and Jonah Gabry for a detailed discussion about this feature. * Add methods `loo_predict`, `loo_linpred`, and `loo_predictive_interval` for computing LOO predictions thanks to Aki Vehtari and Jonah Gabry. * Allow using `offset` in formulas of non-linear and auxiliary parameters. * Allow sparse matrix multiplication in non-linear and distributional models. * Allow using the `identity` link for all auxiliary parameters. * Introduce argument `negative_rt` in `predict` and `posterior_predict` to distinguish responses on the upper and lower boundary in `wiener` diffusion models thanks to Guido Biele. * Introduce method `control_params` to conveniently extract control parameters of the NUTS sampler. * Introduce argument `int_conditions` in `marginal_effects` for enhanced plotting of two-way interactions thanks to a discussion with Thomas Kluth. * Improve flexibility of the `conditions` argument of `marginal_effects`. * Extend method `stanplot` to correctly handle some new `mcmc_` plots of the `bayesplot` package. ### Other changes * Improve the `update` method to only recompile models when the `Stan` code changes. * Warn about divergent transitions when calling `summary` or `print` on `brmsfit` objects. * Warn about unused variables in argument `conditions` when calling `marginal_effects`. * Export and document several distribution functions that were previously kept internal. ### Bug fixes * Fix problems with the inclusion of offsets occurring for more complicated formulas thanks to Christian Stock. * Fix a bug that led to invalid Stan code when sampling from priors in intercept only models thanks to Tom Wallis. * Correctly check for category specific group-level effects in non-ordinal models thanks to Wayne Folta. * Fix problems in `pp_check` when specifying argument `newdata` together with arguments `x` or `group`. * Rename the last column in the output of `hypothesis` to `"star"` in order to avoid problems with zero length column names thanks to the GitHub user puterleat. * Add a missing new line statement at the end of the `summary` output thanks to Thomas Kluth. # brms 1.5.1 ### Features * Allow `horseshoe` and `lasso` priors to be applied on population-level effects of non-linear and auxiliary parameters. * Force recompiling `Stan` models in `update.brmsfit` via argument `recompile`. ### Other changes * Avoid indexing of matrices in non-linear models to slightly improve sampling speed. ### Bug fixes * Fix a severe problem (introduced in version 1.5.0), when predicting `Beta` models thanks to Vivian Lam. * Fix problems when summarizing some models fitted with older version of `brms` thanks to Vivian Lam. * Fix checks of argument `group` in method `pp_check` thanks to Thomas K. * Get arguments `subset` and `nsamples` working correctly in `marginal_smooths`. # brms 1.5.0 ### Features * Implement the generalized extreme value distribution via family `gen_extreme_value`. * Improve flexibility of the `horseshoe` prior thanks to Juho Piironen. * Introduce auxiliary parameter `mu` as an alternative to specifying effects within the `formula` argument in function `brmsformula`. * Return fitted values of auxiliary parameters via argument `auxpar` of method `fitted`. * Add vignette `"brms_multilevel"`, in which the advanced formula syntax of `brms` is explained in detail using several examples. ### Other changes * Refactor various parts of the package to ease implementation of mixture and multivariate models in future updates. This should not have any user visible effects. * Save the version number of `rstan` in element `version` of `brmsfit` objects. ### Bug fixes * Fix a rare error when predicting `von_mises` models thanks to John Kirwan. # brms 1.4.0 ### Features * Fit quantile regression models via family `asym_laplace` (asymmetric Laplace distribution). * Specify non-linear models in a (hopefully) more intuitive way using `brmsformula`. * Fix auxiliary parameters to certain values through `brmsformula`. * Allow `family` to be specified in `brmsformula`. * Introduce family `frechet` for modelling strictly positive responses. * Allow truncation and censoring at the same time. * Introduce function `prior_` allowing to specify priors using one-sided formulas or `quote`. * Pass priors to `Stan` directly without performing any checks by setting `check = FALSE` in `set_prior`. * Introduce method `nsamples` to extract the number of posterior samples. * Export the main formula parsing function `parse_bf`. * Add more options to customize two-dimensional surface plots created by `marginal_effects` or `marginal_smooths`. ### Other changes * Change structure of `brmsformula` objects to be more reliable and easier to extend. * Make sure that parameter `nu` never falls below `1` to reduce convergence problems when using family `student`. * Deprecate argument `nonlinear`. * Deprecate family `geometric`. * Rename `cov_fixed` to `cor_fixed`. * Make handling of addition terms more transparent by exporting and documenting related functions. * Refactor helper functions of the `fitted` method to be easier to extend in the future. * Remove many units tests of internal functions and add tests of user-facing functions instead. * Import some generics from `nlme` instead of `lme4` to remove dependency on the latter one. * Do not apply `structure` to `NULL` anymore to get rid of warnings in R-devel. ### Bug fixes * Fix problems when fitting smoothing terms with factors as `by` variables thanks to Milani Chaloupka. * Fix a bug that could cause some monotonic effects to be ignored in the `Stan` code thanks to the GitHub user bschneider. * Make sure that the data of models with only a single observation are compatible with the generated `Stan` code. * Handle argument `algorithm` correctly in `update.brmsfit`. * Fix a bug sometimes causing an error in `marginal_effects` when using family `wiener` thanks to Andrew Ellis. * Fix problems in `fitted` when applied to `zero_inflated_beta` models thanks to Milani Chaloupka. * Fix minor problems related to the prediction of autocorrelated models. * Fix a few minor bugs related to the backwards compatibility of multivariate and related models fitted with `brms` < 1.0.0. # brms 1.3.1 ### Features * Introduce the auxiliary parameter `disc` ('discrimination') to be used in ordinal models. By default it is not estimated but fixed to one. * Create `marginal_effects` plots of two-way interactions of variables that were not explicitely modeled as interacting. ### Other changes * Move `rstan` to 'Imports' and `Rcpp` to 'Depends' in order to avoid loading `rstan` into the global environment automatically. ### Bug fixes * Fix a bug leading to unexpected errors in some S3 methods when applied to ordinal models. # brms 1.3.0 ### Features * Fit error-in-variables models using function `me` in the model formulae. * Fit multi-membership models using function `mm` in grouping terms. * Add families `exgaussian` (exponentially modified Gaussian distribution) and `wiener` (Wiener diffusion model distribution) specifically suited to handle for response times. * Add the `lasso` prior as an alternative to the `horseshoe` prior for sparse models. * Add the methods `log_posterior`, `nuts_params`, `rhat`, and `neff_ratio` for `brmsfit` objects to conveniently access quantities used to diagnose sampling behavior. * Combine chains in method `as.mcmc` using argument `combine_chains`. * Estimate the auxiliary parameter `sigma` in models with known standard errors of the response by setting argument `sigma` to `TRUE` in addition function `se`. * Allow visualizing two-dimensional smooths with the `marginal_smooths` method. ### Other changes * Require argument `data` to be explicitely specified in all user facing functions. * Refactor the `stanplot` method to use `bayesplot` on the backend. * Use the `bayesplot` theme as the default in all plotting functions. * Add the abbreviations `mo` and `cs` to specify monotonic and category specific effects respectively. * Rename generated variables in the data.frames returned by `marginal_effects` to avoid potential naming conflicts. * Deprecate argument `cluster` and use the native `cores` argument of `rstan` instead. * Remove argument `cluster_type` as it is no longer required to apply forking. * Remove the deprecated `partial` argument. # brms 1.2.0 ### Features * Add the new family `hurdle_lognormal` specifically suited for zero-inflated continuous responses. * Introduce the `pp_check` method to perform various posterior predictive checks using the `bayesplot` package. * Introduce the `marginal_smooths` method to better visualize smooth terms. * Allow varying the scale of global shrinkage parameter of the `horseshoe` prior. * Add functions `prior` and `prior_string` as aliases of `set_prior`, the former allowing to pass arguments without quotes `""` using non-standard evaluation. * Introduce four new vignettes explaining how to fit non-linear models, distributional models, phylogenetic models, and monotonic effects respectively. * Extend the `coef` method to better handle category specific group-level effects. * Introduce the `prior_summary` method for `brmsfit` objects to obtain a summary of prior distributions applied. * Sample from the prior of the original population-level intercept when `sample_prior = TRUE` even in models with an internal temporary intercept used to improve sampling efficiency. * Introduce methods `posterior_predict`, `predictive_error` and `log_lik` as (partial) aliases of `predict`, `residuals`, and `logLik` respectively. ### Other changes * Improve computation of Bayes factors in the `hypothesis` method to be less influenced by MCMC error. * Improve documentation of default priors. * Refactor internal structure of some formula and prior evaluating functions. This should not have any user visible effects. * Use the `bayesplot` package as the new backend of `plot.brmsfit`. ### Bug fixes * Better mimic `mgcv` when parsing smooth terms to make sure all arguments are correctly handled. * Avoid an error occurring during the prediction of new data when grouping factors with only a single factor level were supplied thanks to Tom Wallis. * Fix `marginal_effects` to consistently produce plots for all covariates in non-linear models thanks to David Auty. * Improve the `update` method to better recognize situations where recompliation of the `Stan` code is necessary thanks to Raphael P.H. * Allow to correctly `update` the `sample_prior` argument to value `"only"`. * Fix an unexpected error occurring in many S3 methods when the thinning rate is not a divisor of the total number of posterior samples thanks to Paul Zerr. # brms 1.1.0 ### Features * Estimate monotonic group-level effects. * Estimate category specific group-level effects. * Allow `t2` smooth terms based on multiple covariates. * Estimate interval censored data via the addition argument `cens` in the model formula. * Allow to compute `residuals` also based on predicted values instead of fitted values. ### Other changes * Use the prefix `bcs` in parameter names of category specific effects and the prefix `bm` in parameter names of monotonic effects (instead of the prefix `b`) to simplify their identification. * Ensure full compatibility with `ggplot2` version 2.2. ### Bug fixes * Fix a bug that could result in incorrect threshold estimates for `cumulative` and `sratio` models thanks to Peter Congdon. * Fix a bug that sometimes kept distributional `gamma` models from being compiled thanks to Tim Beechey. * Fix a bug causing an error in `predict` and related methods when two-level factors or logical variables were used as covariates in non-linear models thanks to Martin Schmettow. * Fix a bug causing an error when passing lists to additional arguments of smoothing functions thanks to Wayne Folta. * Fix a bug causing an error in the `prior_samples` method for models with multiple group-level terms that refer to the same grouping factor thanks to Marco Tullio Liuzza. * Fix a bug sometimes causing an error when calling `marginal_effects` for weighted models. # brms 1.0.1 \subsection{MINOR CHANGES * Center design matrices inside the Stan code instead of inside `make_standata`. * Get rid of several warning messages occurring on CRAN. # brms 1.0.0 This is one of the largest updates of `brms` since its initial release. In addition to many new features, the multivariate `'trait'` syntax has been removed from the package as it was confusing for users, required much special case coding, and was hard to maintain. See `help(brmsformula)` for details of the formula syntax applied in `brms`. ### Features * Allow estimating correlations between group-level effects defined across multiple formulae (e.g., in non-linear models) by specifying IDs in each grouping term via an extended `lme4` syntax. * Implement distributional regression models allowing to fully predict auxiliary parameters of the response distribution. Among many other possibilities, this can be used to model heterogeneity of variances. * Zero-inflated and hurdle models do not use multivariate syntax anymore but instead have special auxiliary parameters named `zi` and `hu` defining zero-inflation / hurdle probabilities. * Implement the `von_mises` family to model circular responses. * Introduce the `brmsfamily` function for convenient specification of `family` objects. * Allow predictions of `t2` smoothing terms for new data. * Feature vectors as arguments for the addition argument `trunc` in order to model varying truncation points. ### Other changes * Remove the `cauchy` family after several months of deprecation. * Make sure that group-level parameter names are unambiguous by adding double underscores thanks to the idea of the GitHub user schmettow. * The `predict` method now returns predicted probabilities instead of absolute frequencies of samples for ordinal and categorical models. * Compute the linear predictor in the model block of the Stan program instead of in the transformed parameters block. This avoids saving samples of unnecessary parameters to disk. Thanks goes to Rick Arrano for pointing me to this issue. * Colour points in `marginal_effects` plots if sensible. * Set the default of the `robust` argument to `TRUE` in `marginal_effects.brmsfit`. ### Bug fixes * Fix a bug that could occur when predicting factorial response variables for new data. Only affects categorical and ordinal models. * Fix a bug that could lead to duplicated variable names in the Stan code when sampling from priors in non-linear models thanks to Tom Wallis. * Fix problems when trying to pointwise evaluate non-linear formulae in `logLik.brmsfit` thanks to Tom Wallis. * Ensure full compatibility of the `ranef` and `coef` methods with non-linear models. * Fix problems that occasionally occurred when handling `dplyr` datasets thanks to the GitHub user Atan1988. # brms 0.10.0 ### Features * Add support for generalized additive mixed models (GAMMs). Smoothing terms can be specified using the `s` and `t2` functions in the model formula. * Introduce `as.data.frame` and `as.matrix` methods for `brmsfit` objects. ### Other changes * The `gaussian("log")` family no longer implies a log-normal distribution, but a normal distribution with log-link to match the behavior of `glm`. The log-normal distribution can now be specified via family `lognormal`. * Update syntax of `Stan` models to match the recommended syntax of `Stan` 2.10. ### Bug fixes * The `ngrps` method should now always return the correct result for non-linear models. * Fix problems in `marginal_effects` for models using the reserved variable `intercept` thanks to Frederik Aust. * Fix a bug in the `print` method of `brmshypothesis` objects that could lead to duplicated and thus invalid row names. * Residual standard deviation parameters of multivariate models are again correctly displayed in the output of the `summary` method. * Fix problems when using variational Bayes algorithms with `brms` while having `rstan` >= 2.10.0 installed thanks to the GitHub user cwerner87. # brms 0.9.1 ### Features * Allow the '/' symbol in group-level terms in the `formula` argument to indicate nested grouping structures. * Allow to compute `WAIC` and `LOO` based on the pointwise log-likelihood using argument `pointwise` to substantially reduce memory requirements. ### Other changes * Add horizontal lines to the errorbars in `marginal_effects` plots for factors. ### Bug fixes * Fix a bug that could lead to a cryptic error message when changing some parts of the model `formula` using the `update` method. * Fix a bug that could lead to an error when calling `marginal_effects` for predictors that were generated with the `base::scale` function thanks to Tom Wallis. * Allow interactions of numeric and categorical predictors in `marginal_effects` to be passed to the `effects` argument in any order. * Fix a bug that could lead to incorrect results of `predict` and related methods when called with `newdata` in models using the `poly` function thanks to Brock Ferguson. * Make sure that user-specified factor contrasts are always applied in multivariate models. # brms 0.9.0 ### Features * Add support for `monotonic` effects allowing to use ordinal predictors without assuming their categories to be equidistant. * Apply multivariate formula syntax in categorical models to considerably increase modeling flexibility. * Add the addition argument `disp` to define multiplicative factors on dispersion parameters. For linear models, `disp` applies to the residual standard deviation `sigma` so that it can be used to weight observations. * Treat the fixed effects design matrix as sparse by using the `sparse` argument of `brm`. This can considerably reduce working memory requirements if the predictors contain many zeros. * Add the `cor_fixed` correlation structure to allow for fixed user-defined covariance matrices of the response variable. * Allow to pass self-defined `Stan` functions via argument `stan_funs` of `brm`. * Add the `expose_functions` method allowing to expose self-defined `Stan` functions in `R`. * Extend the functionality of the `update` method to allow all model parts to be updated. * Center the fixed effects design matrix also in multivariate models. This may lead to increased sampling speed in models with many predictors. ### Other changes * Refactor `Stan` code and data generating functions to be more consistent and easier to extent. * Improve checks of user-define prior specifications. * Warn about models that have not converged. * Make sure that regression curves computed by the `marginal_effects` method are always smooth. * Allow to define category specific effects in ordinal models directly within the `formula` argument. ### Bug fixes * Fix problems in the generated `Stan` code when using very long non-linear model formulas thanks to Emmanuel Charpentier. * Fix a bug that prohibited to change priors on single standard deviation parameters in non-linear models thanks to Emmanuel Charpentier. * Fix a bug that prohibited to use nested grouping factors in non-linear models thanks to Tom Wallis. * Fix a bug in the linear predictor computation within `R`, occurring for ordinal models with multiple category specific effects. This could lead to incorrect outputs of `predict`, `fitted`, and `logLik` for these models. * Make sure that the global `"contrasts"` option is not used when post-processing a model. # brms 0.8.0 ### Features * Implement generalized non-linear models, which can be specified with the help of the `nonlinear` argument in `brm`. * Compute and plot marginal effects using the `marginal_effects` method thanks to the help of Ruben Arslan. * Implement zero-inflated beta models through family `zero_inflated_beta` thanks to the idea of Ali Roshan Ghias. * Allow to restrict domain of fixed effects and autocorrelation parameters using new arguments `lb` and `ub` in function `set_prior` thanks to the idea of Joel Gombin. * Add an `as.mcmc` method for compatibility with the `coda` package. * Allow to call the `WAIC`, `LOO`, and `logLik` methods with new data. ### Other changes * Make sure that `brms` is fully compatible with `loo` version 0.1.5. * Optionally define the intercept as an ordinary fixed effect to avoid the reparametrization via centering of the fixed effects design matrix. * Do not compute the WAIC in `summary` by default anymore to reduce computation time of the method for larger models. * The `cauchy` family is now deprecated and will be removed soon as it often has convergence issues and not much practical application anyway. * Change the default settings of the number of chains and warmup samples to the defaults of `rstan` (i.e., `chains = 4` and `warmup = iter / 2`). * Do not remove bad behaving chains anymore as they may point to general convergence problems that are dangerous to ignore. * Improve flexibility of the `theme` argument in all plotting functions. * Only show the legend once per page, when computing trace and density plots with the `plot` method. * Move code of self-defined `Stan` functions to `inst/chunks` and incorporate them into the models using `rstan::stanc_builder`. Also, add unit tests for these functions. ### Bug fixes * Fix problems when predicting with `newdata` for zero-inflated and hurdle models thanks to Ruben Arslan. * Fix problems when predicting with `newdata` if it is a subset of the data stored in a `brmsfit` object thanks to Ruben Arslan. * Fix data preparation for multivariate models if some responses are `NA` thanks to Raphael Royaute. * Fix a bug in the `predict` method occurring for some multivariate models so that it now always returns the predictions of all response variables, not just the first one. * Fix a bug in the log-likelihood computation of `hurdle_poisson` and `hurdle_negbinomial` models. This may lead to minor changes in the values obtained by `WAIC` and `LOO` for these models. * Fix some backwards compatibility issues of models fitted with version <= 0.5.0 thanks to Ulf Koether. # brms 0.7.0 ### Features * Use variational inference algorithms as alternative to the NUTS sampler by specifying argument `algorithm` in the `brm` function. * Implement beta regression models through family `Beta`. * Implement zero-inflated binomial models through family `zero_inflated_binomial`. * Implement multiplicative effects for family `bernoulli` to fit (among others) 2PL IRT models. * Generalize the `formula` argument for zero-inflated and hurdle models so that predictors can be included in only one of the two model parts thanks to the idea of Wade Blanchard. * Combine fixed and random effects estimates using the new `coef` method. * Call the `residuals` method with `newdata` thanks to the idea of Friederike Holz-Ebeling. * Allow new levels of random effects grouping factors in the `predict`, `fitted`, and `residuals` methods using argument `allow_new_levels`. * Selectively exclude random effects in the `predict`, `fitted`, and `residuals` methods using argument `re_formula`. * Add a `plot` method for objects returned by method `hypothesis` to visualize prior and posterior distributions of the hypotheses being tested. ### Other changes * Improve evaluation of the response part of the `formula` argument to reliably allow terms with more than one variable (e.g., `y/x ~ 1`). * Improve sampling efficiency of models containing many fixed effects through centering the fixed effects design matrix thanks to Wayne Folta. * Improve sampling efficiency of models containing uncorrelated random effects specified by means of `(random || group)` terms in `formula` thanks to Ali Roshan Ghias. * Utilize user-defined functions in the `Stan` code of ordinal models to improve readability as well as sampling efficiency. * Make sure that model comparisons using `LOO` or `WAIC` are only performed when models are based on the same responses. * Use some generic functions of the `lme4` package to avoid unnecessary function masking. This leads to a change in the argument order of method `VarCorr`. * Change the `ggplot` theme in the `plot` method through argument `theme`. * Remove the `n.` prefix in arguments `n.iter`, `n.warmup`, `n.thin`, `n.chains`, and `n.cluster` of the `brm` function. The old argument names remain usable as deprecated aliases. * Amend names of random effects parameters to simplify matching with their respective grouping factor levels. ### Bug fixes * Fix a bug in the `hypothesis` method that could cause valid model parameters to be falsely reported as invalid. * Fix a bug in the `prior_samples` method that could cause prior samples of parameters of the same class to be artificially correlated. * Fix `Stan` code of linear models with moving-average effects and non-identity link functions so that they no longer contain code related solely to autoregressive effects. * Fix a bug in the evaluation of `formula` that could cause complicated random effects terms to be falsely treated as fixed effects. * Fix several bugs when calling the `fitted` and `predict` methods with `newdata` thanks to Ali Roshan Ghias. # brms 0.6.0 ### Features * Add support for zero-inflated and hurdle models thanks to the idea of Scott Baldwin. * Implement inverse gaussian models through family `inverse.gaussian`. * Allow to specify truncation boundaries of the response variable thanks to the idea of Maciej Beresewicz. * Add support for autoregressive (AR) effects of residuals, which can be modeled using the `cor_ar` and `cor_arma` functions. * Stationary autoregressive-moving-average (ARMA) effects of order one can now also be fitted using special covariance matrices. * Implement multivariate student-t models. * Binomial and ordinal families now support the `cauchit` link function. * Allow family functions to be used in the `family` argument. * Easy access to various `rstan` plotting functions using the `stanplot` method. * Implement horseshoe priors to model sparsity in fixed effects coefficients thanks to the idea of Josh Chang. * Automatically scale default standard deviation priors so that they remain only weakly informative independent on the response scale. * Report model weights computed by the `loo` package when comparing multiple fitted models. ### Other changes * Separate the fixed effects Intercept from other fixed effects in the `Stan` code to slightly improve sampling efficiency. * Move autoregressive (AR) effects of the response from the `cor_ar` to the `cor_arr` function as the result of implementing AR effects of residuals. * Improve checks on argument `newdata` used in the `fitted` and `predict` method. * Method `standata` is now the only way to extract data that was passed to `Stan` from a `brmsfit` object. * Slightly improve `Stan` code for models containing no random effects. * Change the default prior of the degrees of freedom of the `student` family to `gamma(2,0.1)`. * Improve readability of the output of method `VarCorr`. * Export the `make_stancode` function to give users direct access to `Stan` code generated by `brms`. * Rename the `brmdata` function to `make_standata`. The former remains usable as a deprecated alias. * Improve documentation to better explain differences in autoregressive effects across R packages. ### Bug fixes * Fix a bug that could cause an unexpected error when the `predict` method was called with `newdata`. * Avoid side effects of the `rstan` compilation routines that could occasionally cause R to crash. * Make `brms` work correctly with `loo` version 0.1.3 thanks to Mauricio Garnier Villarreal and Jonah Gabry. * Fix a bug that could cause WAIC and LOO estimates to be slightly incorrect for `gaussian` models with `log` link. # brms 0.5.0 ### Features * Compute the Watanabe-Akaike information criterion (WAIC) and leave-one-out cross-validation (LOO) using the `loo` package. * Provide an interface to `shinystan` with S3 method `launch_shiny`. * New functions `get_prior` and `set_prior` to make prior specifications easier. * Log-likelihood values and posterior predictive samples can now be calculated within R after the model has been fitted. * Make predictions based on new data using S3 method `predict`. * Allow for customized covariance structures of grouping factors with multiple random effects. * New S3 methods `fitted` and `residuals` to compute fitted values and residuals, respectively. ### Other changes * Arguments `WAIC` and `predict` are removed from the `brm` function, as they are no longer necessary. * New argument `cluster_type` in function `brm` allowing to choose the cluster type created by the parallel package. * Remove chains that fail to initialize while sampling in parallel leaving the other chains untouched. * Redesign trace and density plots to be faster and more stable. * S3 method `VarCorr` now always returns covariance matrices regardless of whether correlations were estimated. ### Bug fixes * Fix a bug in S3 method `hypothesis` related to the calculation of Bayes-factors for point hypotheses. * User-defined covariance matrices that are not strictly positive definite for numerical reasons should now be handled correctly. * Fix problems when a factor is used as fixed effect and as random effects grouping variable at the same time thanks to Ulf Koether. * Fix minor issues with internal parameter naming. * Perform additional checking on user defined priors. # brms 0.4.1 ### Features * Allow for sampling from all specified proper priors in the model. * Compute Bayes-factors for point hypotheses in S3 method `hypothesis`. ### Bug fixes * Fix a bug that could cause an error for models with multiple grouping factors thanks to Jonathan Williams. * Fix a bug that could cause an error for weighted poisson and exponential models. # brms 0.4.0 ### Features * Implement the Watanabe-Akaike Information Criterion (WAIC). * Implement the `||`-syntax for random effects allowing for the estimation of random effects standard deviations without the estimation of correlations. * Allow to combine multiple grouping factors within one random effects argument using the interaction symbol `:`. * Generalize S3 method `hypothesis` to be used with all parameter classes not just fixed effects. In addition, one-sided hypothesis testing is now possible. * Introduce new family `multigaussian` allowing for multivariate normal regression. * Introduce new family `bernoulli` for dichotomous response variables as a more efficient alternative to families `binomial` or `categorical` in this special case. ### Other changes * Slightly change the internal structure of brms to reflect that `rstan` is finally on CRAN. * Thoroughly check validity of the response variable before the data is passed to `Stan`. * Prohibit variable names containing double underscores `__` to avoid naming conflicts. * Allow function calls with several arguments (e.g. `poly(x,3)`) in the formula argument of function `brm`. * Always center random effects estimates returned by S3 method `ranef` around zero. * Prevent the use of customized covariance matrices for grouping factors with multiple random effects for now. * Remove any experimental `JAGS` code from the package. ### Bug fixes * Fix a bug in S3 method `hypothesis` leading to an error when numbers with decimal places were used in the formulation of the hypotheses. * Fix a bug in S3 method `ranef` that caused an error for grouping factors with only one random effect. * Fix a bug that could cause the fixed intercept to be wrongly estimated in the presence of multiple random intercepts thanks to Jarrod Hadfield. # brms 0.3.0 ### Features * Introduce new methods `parnames` and `posterior_samples` for class 'brmsfit' to extract parameter names and posterior samples for given parameters, respectively. * Introduce new method `hypothesis` for class `brmsfit` allowing to test non-linear hypotheses concerning fixed effects. * Introduce new argument `addition` in function brm to get a more flexible approach in specifying additional information on the response variable (e.g., standard errors for meta-analysis). Alternatively, this information can also be passed to the `formula` argument directly. * Introduce weighted and censored regressions through argument `addition` of function brm. * Introduce new argument `cov.ranef` in the `brm` function allowing for customized covariance structures of random effects thanks to the idea of Boby Mathew. * Introduce new argument `autocor` in function brm allowing for autocorrelation of the response variable. * Introduce new functions `cor.ar`, `cor.ma`, and `cor.arma`, to be used with argument `autocor` for modeling autoregressive, moving-average, and autoregressive-moving-average models. ### Other changes * Amend parametrization of random effects to increase efficiency of the sampling algorithms. * Improve vectorization of sampling statements. ### Bug fixes * Fix a bug that could cause an error when fitting poisson models while `predict = TRUE`. * Fix a bug that caused an error when sampling only one chain while `silent = TRUE`. # brms 0.2.0 ### Features * New S3 class `brmsfit` to be returned by the `brm` function. * New methods for class `brmsfit`: `summary`, `print`, `plot`, `predict`, `fixef`, `ranef`, `VarCorr`, `nobs`, `ngrps`, and `formula`. * Introduce new argument `silent` in the `brm` function, allowing to suppress most of `Stan`'s intermediate output. * Introduce new families `negbinomial` (negative binomial) and `geometric` to allow for more flexibility in modeling count data. ### Other changes * Amend warning and error messages to make them more informative. * Correct examples in the documentation. * Extend the README file. ### Bug fixes * Fix a bug that caused problems when formulas contained more complicated function calls. * Fix a bug that caused an error when posterior predictives were sampled for family `cumulative`. * Fix a bug that prohibited to use of improper flat priors for parameters that have proper priors by default. # brms 0.1.0 * Initial release version brms/inst/0000755000176200001440000000000015057753140012201 5ustar liggesusersbrms/inst/CITATION0000644000176200001440000000330214213413565013331 0ustar liggesusersbibentry( bibtype = "Article", title = "{brms}: An {R} Package for {Bayesian} Multilevel Models Using {Stan}", author = person(given = "Paul-Christian", family = "Bürkner"), journal = "Journal of Statistical Software", year = "2017", volume = "80", number = "1", pages = "1--28", doi = "10.18637/jss.v080.i01", header = "To cite brms in publications use:", textVersion = paste( "Paul-Christian Bürkner (2017).", "brms: An R Package for Bayesian Multilevel Models Using Stan.", "Journal of Statistical Software, 80(1), 1-28.", "doi:10.18637/jss.v080.i01" ), encoding = "UTF-8" ) bibentry( bibtype = "Article", title = "Advanced {Bayesian} Multilevel Modeling with the {R} Package {brms}", author = person(given = "Paul-Christian", family = "Bürkner"), journal = "The R Journal", year = "2018", volume = "10", number = "1", pages = "395--411", doi = "10.32614/RJ-2018-017", textVersion = paste( "Paul-Christian Bürkner (2018).", "Advanced Bayesian Multilevel Modeling with the R Package brms.", "The R Journal, 10(1), 395-411.", "doi:10.32614/RJ-2018-017" ), encoding = "UTF-8" ) bibentry( bibtype = "Article", title = "Bayesian Item Response Modeling in {R} with {brms} and {Stan}", author = person(given = "Paul-Christian", family = "Bürkner"), journal = "Journal of Statistical Software", year = "2021", volume = "100", number = "5", pages = "1--54", doi = "10.18637/jss.v100.i05", textVersion = paste( "Paul-Christian Bürkner (2021).", "Bayesian Item Response Modeling in R with brms and Stan.", "Journal of Statistical Software, 100(5), 1-54.", "doi:10.18637/jss.v100.i05" ), encoding = "UTF-8" ) brms/inst/chunks/0000755000176200001440000000000015053072461013470 5ustar liggesusersbrms/inst/chunks/fun_cholesky_cor_ar1.stan0000644000176200001440000000113014527413457020462 0ustar liggesusers /* compute the cholesky factor of an AR1 correlation matrix * Args: * ar: AR1 autocorrelation * nrows: number of rows of the covariance matrix * Returns: * A nrows x nrows matrix */ matrix cholesky_cor_ar1(real ar, int nrows) { matrix[nrows, nrows] mat; vector[nrows - 1] gamma; mat = diag_matrix(rep_vector(1, nrows)); for (i in 2:nrows) { gamma[i - 1] = pow(ar, i - 1); for (j in 1:(i - 1)) { mat[i, j] = gamma[i - j]; mat[j, i] = gamma[i - j]; } } return cholesky_decompose(mat ./ (1 - ar^2)); } brms/inst/chunks/fun_hurdle_negbinomial.stan0000644000176200001440000000600114213413565021054 0ustar liggesusers /* hurdle negative binomial log-PDF of a single response * Args: * y: the response value * mu: mean parameter of negative binomial distribution * phi: shape parameter of negative binomial distribution * hu: hurdle probability * Returns: * a scalar to be added to the log posterior */ real hurdle_neg_binomial_lpmf(int y, real mu, real phi, real hu) { if (y == 0) { return bernoulli_lpmf(1 | hu); } else { return bernoulli_lpmf(0 | hu) + neg_binomial_2_lpmf(y | mu, phi) - log1m((phi / (mu + phi))^phi); } } /* hurdle negative binomial log-PDF of a single response * logit parameterization for the hurdle part * Args: * y: the response value * mu: mean parameter of negative binomial distribution * phi: phi parameter of negative binomial distribution * hu: linear predictor of hurdle part * Returns: * a scalar to be added to the log posterior */ real hurdle_neg_binomial_logit_lpmf(int y, real mu, real phi, real hu) { if (y == 0) { return bernoulli_logit_lpmf(1 | hu); } else { return bernoulli_logit_lpmf(0 | hu) + neg_binomial_2_lpmf(y | mu, phi) - log1m((phi / (mu + phi))^phi); } } /* hurdle negative binomial log-PDF of a single response * log parameterization for the negative binomial part * Args: * y: the response value * eta: linear predictor for negative binomial distribution * phi phi parameter of negative binomial distribution * hu: hurdle probability * Returns: * a scalar to be added to the log posterior */ real hurdle_neg_binomial_log_lpmf(int y, real eta, real phi, real hu) { if (y == 0) { return bernoulli_lpmf(1 | hu); } else { return bernoulli_lpmf(0 | hu) + neg_binomial_2_log_lpmf(y | eta, phi) - log1m((phi / (exp(eta) + phi))^phi); } } /* hurdle negative binomial log-PDF of a single response * log parameterization for the negative binomial part * logit parameterization for the hurdle part * Args: * y: the response value * eta: linear predictor for negative binomial distribution * phi: phi parameter of negative binomial distribution * hu: linear predictor of hurdle part * Returns: * a scalar to be added to the log posterior */ real hurdle_neg_binomial_log_logit_lpmf(int y, real eta, real phi, real hu) { if (y == 0) { return bernoulli_logit_lpmf(1 | hu); } else { return bernoulli_logit_lpmf(0 | hu) + neg_binomial_2_log_lpmf(y | eta, phi) - log1m((phi / (exp(eta) + phi))^phi); } } // hurdle negative binomial log-CCDF and log-CDF functions real hurdle_neg_binomial_lccdf(int y, real mu, real phi, real hu) { return bernoulli_lpmf(0 | hu) + neg_binomial_2_lccdf(y | mu, phi) - log1m((phi / (mu + phi))^phi); } real hurdle_neg_binomial_lcdf(int y, real mu, real phi, real hu) { return log1m_exp(hurdle_neg_binomial_lccdf(y | mu, phi, hu)); } brms/inst/chunks/fun_tan_half.stan0000644000176200001440000000143714572627361017022 0ustar liggesusers /* compute the tan_half link * Args: * x: a scalar in (-pi, pi) * Returns: * a scalar in (-Inf, Inf) */ real tan_half(real x) { return tan(x / 2); } /* compute the tan_half link (vectorized) * Args: * x: a vector in (-pi, pi) * Returns: * a vector in (-Inf, Inf) */ vector tan_half(vector x) { return tan(x / 2); } /* compute the inverse of the tan_half link * Args: * y: a scalar in (-Inf, Inf) * Returns: * a scalar in (-pi, pi) */ real inv_tan_half(real y) { return 2 * atan(y); } /* compute the inverse of the tan_half link (vectorized) * Args: * y: a vector in (-Inf, Inf) * Returns: * a vector in (-pi, pi) */ vector inv_tan_half(vector y) { return 2 * atan(y); } brms/inst/chunks/fun_sequence.stan0000644000176200001440000000052414527413457017051 0ustar liggesusers /* integer sequence of values * Args: * start: starting integer * end: ending integer * Returns: * an integer sequence from start to end */ array[] int sequence(int start, int end) { array[end - start + 1] int seq; for (n in 1:num_elements(seq)) { seq[n] = n + start - 1; } return seq; } brms/inst/chunks/fun_zero_inflated_poisson.stan0000644000176200001440000000565114213413565021636 0ustar liggesusers /* zero-inflated poisson log-PDF of a single response * Args: * y: the response value * lambda: mean parameter of the poisson distribution * zi: zero-inflation probability * Returns: * a scalar to be added to the log posterior */ real zero_inflated_poisson_lpmf(int y, real lambda, real zi) { if (y == 0) { return log_sum_exp(bernoulli_lpmf(1 | zi), bernoulli_lpmf(0 | zi) + poisson_lpmf(0 | lambda)); } else { return bernoulli_lpmf(0 | zi) + poisson_lpmf(y | lambda); } } /* zero-inflated poisson log-PDF of a single response * logit parameterization of the zero-inflation part * Args: * y: the response value * lambda: mean parameter of the poisson distribution * zi: linear predictor for zero-inflation part * Returns: * a scalar to be added to the log posterior */ real zero_inflated_poisson_logit_lpmf(int y, real lambda, real zi) { if (y == 0) { return log_sum_exp(bernoulli_logit_lpmf(1 | zi), bernoulli_logit_lpmf(0 | zi) + poisson_lpmf(0 | lambda)); } else { return bernoulli_logit_lpmf(0 | zi) + poisson_lpmf(y | lambda); } } /* zero-inflated poisson log-PDF of a single response * log parameterization for the poisson part * Args: * y: the response value * eta: linear predictor for poisson distribution * zi: zero-inflation probability * Returns: * a scalar to be added to the log posterior */ real zero_inflated_poisson_log_lpmf(int y, real eta, real zi) { if (y == 0) { return log_sum_exp(bernoulli_lpmf(1 | zi), bernoulli_lpmf(0 | zi) + poisson_log_lpmf(0 | eta)); } else { return bernoulli_lpmf(0 | zi) + poisson_log_lpmf(y | eta); } } /* zero-inflated poisson log-PDF of a single response * log parameterization for the poisson part * logit parameterization of the zero-inflation part * Args: * y: the response value * eta: linear predictor for poisson distribution * zi: linear predictor for zero-inflation part * Returns: * a scalar to be added to the log posterior */ real zero_inflated_poisson_log_logit_lpmf(int y, real eta, real zi) { if (y == 0) { return log_sum_exp(bernoulli_logit_lpmf(1 | zi), bernoulli_logit_lpmf(0 | zi) + poisson_log_lpmf(0 | eta)); } else { return bernoulli_logit_lpmf(0 | zi) + poisson_log_lpmf(y | eta); } } // zero-inflated poisson log-CCDF and log-CDF functions real zero_inflated_poisson_lccdf(int y, real lambda, real zi) { return bernoulli_lpmf(0 | zi) + poisson_lccdf(y | lambda); } real zero_inflated_poisson_lcdf(int y, real lambda, real zi) { return log1m_exp(zero_inflated_poisson_lccdf(y | lambda, zi)); } brms/inst/chunks/fun_wiener_diffusion.stan0000644000176200001440000000122214527413457020574 0ustar liggesusers /* Wiener diffusion log-PDF for a single response * Args: * y: reaction time data * dec: decision data (0 or 1) * alpha: boundary separation parameter > 0 * tau: non-decision time parameter > 0 * beta: initial bias parameter in [0, 1] * delta: drift rate parameter * Returns: * a scalar to be added to the log posterior */ real wiener_diffusion_lpdf(real y, int dec, real alpha, real tau, real beta, real delta) { if (dec == 1) { return wiener_lpdf(y | alpha, tau, beta, delta); } else { return wiener_lpdf(y | alpha, tau, 1 - beta, - delta); } } brms/inst/chunks/fun_logm1.stan0000644000176200001440000000136414572627230016257 0ustar liggesusers /* compute the logm1 link * Args: * p: a positive scalar * Returns: * a scalar in (-Inf, Inf) */ real logm1(real y) { return log(y - 1.0); } /* compute the logm1 link (vectorized) * Args: * p: a positive vector * Returns: * a vector in (-Inf, Inf) */ vector logm1(vector y) { return log(y - 1.0); } /* compute the inverse of the logm1 link * Args: * y: a scalar in (-Inf, Inf) * Returns: * a positive scalar */ real expp1(real y) { return exp(y) + 1.0; } /* compute the inverse of the logm1 link (vectorized) * Args: * y: a vector in (-Inf, Inf) * Returns: * a positive vector */ vector expp1(vector y) { return exp(y) + 1.0; } brms/inst/chunks/fun_hurdle_lognormal.stan0000644000176200001440000000271014213413565020565 0ustar liggesusers /* hurdle lognormal log-PDF of a single response * Args: * y: the response value * mu: mean parameter of the lognormal distribution * sigma: sd parameter of the lognormal distribution * hu: hurdle probability * Returns: * a scalar to be added to the log posterior */ real hurdle_lognormal_lpdf(real y, real mu, real sigma, real hu) { if (y == 0) { return bernoulli_lpmf(1 | hu); } else { return bernoulli_lpmf(0 | hu) + lognormal_lpdf(y | mu, sigma); } } /* hurdle lognormal log-PDF of a single response * logit parameterization of the hurdle part * Args: * y: the response value * mu: mean parameter of the lognormal distribution * sigma: sd parameter of the lognormal distribution * hu: linear predictor for the hurdle part * Returns: * a scalar to be added to the log posterior */ real hurdle_lognormal_logit_lpdf(real y, real mu, real sigma, real hu) { if (y == 0) { return bernoulli_logit_lpmf(1 | hu); } else { return bernoulli_logit_lpmf(0 | hu) + lognormal_lpdf(y | mu, sigma); } } // hurdle lognormal log-CCDF and log-CDF functions real hurdle_lognormal_lccdf(real y, real mu, real sigma, real hu) { return bernoulli_lpmf(0 | hu) + lognormal_lccdf(y | mu, sigma); } real hurdle_lognormal_lcdf(real y, real mu, real sigma, real hu) { return log1m_exp(hurdle_lognormal_lccdf(y | mu, sigma, hu)); } brms/inst/chunks/fun_sparse_car_lpdf.stan0000644000176200001440000000303714524350752020365 0ustar liggesusers /* Return the log probability of a proper conditional autoregressive (CAR) * prior with a sparse representation for the adjacency matrix * Full credit to Max Joseph (https://github.com/mbjoseph/CARstan) * Args: * phi: Vector containing the CAR parameters for each location * car: Dependence (usually spatial) parameter for the CAR prior * sdcar: Standard deviation parameter for the CAR prior * Nloc: Number of locations * Nedges: Number of edges (adjacency pairs) * Nneigh: Number of neighbors for each location * eigenW: Eigenvalues of D^(-1/2) * W * D^(-1/2) * edges1, edges2: Sparse representation of adjacency matrix * Details: * D = Diag(Nneigh) * Returns: * Log probability density of CAR prior up to additive constant */ real sparse_car_lpdf(vector phi, real car, real sdcar, int Nloc, int Nedges, data vector Nneigh, data vector eigenW, array[] int edges1, array[] int edges2) { real tau; // precision parameter row_vector[Nloc] phit_D; // phi' * D row_vector[Nloc] phit_W; // phi' * W vector[Nloc] ldet; tau = inv_square(sdcar); phit_D = (phi .* Nneigh)'; phit_W = rep_row_vector(0, Nloc); for (i in 1:Nedges) { phit_W[edges1[i]] = phit_W[edges1[i]] + phi[edges2[i]]; phit_W[edges2[i]] = phit_W[edges2[i]] + phi[edges1[i]]; } for (i in 1:Nloc) { ldet[i] = log1m(car * eigenW[i]); } return 0.5 * (Nloc * log(tau) + sum(ldet) - tau * (phit_D * phi - car * (phit_W * phi))); } brms/inst/chunks/fun_cloglog.stan0000644000176200001440000000057114572627200016662 0ustar liggesusers /* compute the cloglog link * Args: * p: a scalar in (0, 1) * Returns: * a scalar in (-Inf, Inf) */ real cloglog(real p) { return log(-log1m(p)); } /* compute the cloglog link (vectorized) * Args: * p: a vector in (0, 1) * Returns: * a vector in (-Inf, Inf) */ vector cloglog(vector p) { return log(-log1m(p)); } brms/inst/chunks/fun_zero_inflated_asym_laplace.stan0000644000176200001440000000440514213413565022572 0ustar liggesusers /* zero-inflated asymmetric laplace log-PDF for a single response * Args: * y: the response value * mu: location parameter * sigma: positive scale parameter * quantile: quantile parameter in (0, 1) * zi: zero-inflation probability * Returns: * a scalar to be added to the log posterior */ real zero_inflated_asym_laplace_lpdf(real y, real mu, real sigma, real quantile, real zi) { if (y == 0) { return bernoulli_lpmf(1 | zi); } else { return bernoulli_lpmf(0 | zi) + asym_laplace_lpdf(y | mu, sigma, quantile); } } /* zero-inflated asymmetric laplace log-PDF for a single response * Args: * y: the response value * mu: location parameter * sigma: positive scale parameter * quantile: quantile parameter in (0, 1) * zi: linear predictor of the zero-inflation probability * Returns: * a scalar to be added to the log posterior */ real zero_inflated_asym_laplace_logit_lpdf(real y, real mu, real sigma, real quantile, real zi) { if (y == 0) { return bernoulli_logit_lpmf(1 | zi); } else { return bernoulli_logit_lpmf(0 | zi) + asym_laplace_lpdf(y | mu, sigma, quantile); } } // zero-inflated asymmetric laplace log-CDF function real zero_inflated_asym_laplace_lcdf(real y, real mu, real sigma, real quantile, real zi) { if (y < 0) { return bernoulli_lpmf(0 | zi) + asym_laplace_lcdf(y | mu, sigma, quantile); } else { return log_sum_exp(bernoulli_lpmf(1 | zi), bernoulli_lpmf(0 | zi) + asym_laplace_lcdf(y | mu, sigma, quantile)); } } // zero-inflated asymmetric laplace log-CCDF function real zero_inflated_asym_laplace_lccdf(real y, real mu, real sigma, real quantile, real zi) { if (y > 0) { return bernoulli_lpmf(0 | zi) + asym_laplace_lccdf(y | mu, sigma, quantile); } else { return log_sum_exp(bernoulli_lpmf(1 | zi), bernoulli_lpmf(0 | zi) + asym_laplace_lccdf(y | mu, sigma, quantile)); } } brms/inst/chunks/fun_scale_r_cor_by.stan0000644000176200001440000000136114527413457020206 0ustar liggesusers /* compute correlated group-level effects with 'by' variables * Args: * z: matrix of unscaled group-level effects * SD: matrix of standard deviation parameters * L: an array of cholesky factor correlation matrices * Jby: index which grouping level belongs to which by level * Returns: * matrix of scaled group-level effects */ matrix scale_r_cor_by(matrix z, matrix SD, array[] matrix L, array[] int Jby) { // r is stored in another dimension order than z matrix[cols(z), rows(z)] r; array[size(L)] matrix[rows(L[1]), cols(L[1])] LC; for (i in 1:size(LC)) { LC[i] = diag_pre_multiply(SD[, i], L[i]); } for (j in 1:rows(r)) { r[j] = transpose(LC[Jby[j]] * z[, j]); } return r; } brms/inst/chunks/fun_zero_one_inflated_beta.stan0000644000176200001440000000143714527413457021726 0ustar liggesusers /* zero-one-inflated beta log-PDF of a single response * Args: * y: response value * mu: mean parameter of the beta part * phi: precision parameter of the beta part * zoi: zero-one-inflation probability * coi: conditional one-inflation probability * Returns: * a scalar to be added to the log posterior */ real zero_one_inflated_beta_lpdf(real y, real mu, real phi, real zoi, real coi) { row_vector[2] shape = [mu * phi, (1 - mu) * phi]; if (y == 0) { return bernoulli_lpmf(1 | zoi) + bernoulli_lpmf(0 | coi); } else if (y == 1) { return bernoulli_lpmf(1 | zoi) + bernoulli_lpmf(1 | coi); } else { return bernoulli_lpmf(0 | zoi) + beta_lpdf(y | shape[1], shape[2]); } } brms/inst/chunks/fun_zero_inflated_binomial.stan0000644000176200001440000000671014213413565021733 0ustar liggesusers /* zero-inflated binomial log-PDF of a single response * Args: * y: the response value * trials: number of trials of the binomial part * theta: probability parameter of the binomial part * zi: zero-inflation probability * Returns: * a scalar to be added to the log posterior */ real zero_inflated_binomial_lpmf(int y, int trials, real theta, real zi) { if (y == 0) { return log_sum_exp(bernoulli_lpmf(1 | zi), bernoulli_lpmf(0 | zi) + binomial_lpmf(0 | trials, theta)); } else { return bernoulli_lpmf(0 | zi) + binomial_lpmf(y | trials, theta); } } /* zero-inflated binomial log-PDF of a single response * logit parameterization of the zero-inflation part * Args: * y: the response value * trials: number of trials of the binomial part * theta: probability parameter of the binomial part * zi: linear predictor for zero-inflation part * Returns: * a scalar to be added to the log posterior */ real zero_inflated_binomial_logit_lpmf(int y, int trials, real theta, real zi) { if (y == 0) { return log_sum_exp(bernoulli_logit_lpmf(1 | zi), bernoulli_logit_lpmf(0 | zi) + binomial_lpmf(0 | trials, theta)); } else { return bernoulli_logit_lpmf(0 | zi) + binomial_lpmf(y | trials, theta); } } /* zero-inflated binomial log-PDF of a single response * logit parameterization of the binomial part * Args: * y: the response value * trials: number of trials of the binomial part * eta: linear predictor for binomial part * zi: zero-inflation probability * Returns: * a scalar to be added to the log posterior */ real zero_inflated_binomial_blogit_lpmf(int y, int trials, real eta, real zi) { if (y == 0) { return log_sum_exp(bernoulli_lpmf(1 | zi), bernoulli_lpmf(0 | zi) + binomial_logit_lpmf(0 | trials, eta)); } else { return bernoulli_lpmf(0 | zi) + binomial_logit_lpmf(y | trials, eta); } } /* zero-inflated binomial log-PDF of a single response * logit parameterization of the binomial part * logit parameterization of the zero-inflation part * Args: * y: the response value * trials: number of trials of the binomial part * eta: linear predictor for binomial part * zi: linear predictor for zero-inflation part * Returns: * a scalar to be added to the log posterior */ real zero_inflated_binomial_blogit_logit_lpmf(int y, int trials, real eta, real zi) { if (y == 0) { return log_sum_exp(bernoulli_logit_lpmf(1 | zi), bernoulli_logit_lpmf(0 | zi) + binomial_logit_lpmf(0 | trials, eta)); } else { return bernoulli_logit_lpmf(0 | zi) + binomial_logit_lpmf(y | trials, eta); } } // zero-inflated binomial log-CCDF and log-CDF functions real zero_inflated_binomial_lccdf(int y, int trials, real theta, real zi) { return bernoulli_lpmf(0 | zi) + binomial_lccdf(y | trials, theta); } real zero_inflated_binomial_lcdf(int y, int trials, real theta, real zi) { return log1m_exp(zero_inflated_binomial_lccdf(y | trials, theta, zi)); } brms/inst/chunks/fun_cholesky_cor_cosy.stan0000644000176200001440000000104214527413457020756 0ustar liggesusers /* compute the cholesky factor of a compound symmetry correlation matrix * Args: * cosy: compound symmetry correlation * nrows: number of rows of the covariance matrix * Returns: * A nrows x nrows covariance matrix */ matrix cholesky_cor_cosy(real cosy, int nrows) { matrix[nrows, nrows] mat; mat = diag_matrix(rep_vector(1, nrows)); for (i in 2:nrows) { for (j in 1:(i - 1)) { mat[i, j] = cosy; mat[j, i] = mat[i, j]; } } return cholesky_decompose(mat); } brms/inst/chunks/fun_scale_time_err_flex.stan0000644000176200001440000000302515053072461021222 0ustar liggesusers /* scale and correlate time-series residuals * allows for flexible correlation matrix subsets * Deviating Args: * Jtime: array of time indices per group * Returns: * vector of scaled and correlated residuals */ vector scale_time_err_flex(vector zerr, real sderr, matrix chol_cor, array[] int nobs, array[] int begin, array[] int end, array[,] int Jtime) { vector[rows(zerr)] err; int I = size(nobs); array[I] int has_err = rep_array(0, I); int i = 1; matrix[rows(chol_cor), cols(chol_cor)] L; matrix[rows(chol_cor), cols(chol_cor)] Cov; L = sderr * chol_cor; Cov = multiply_lower_tri_self_transpose(L); while (i <= I) { array[nobs[i]] int iobs = Jtime[i, 1:nobs[i]]; matrix[nobs[i], nobs[i]] L_i; if (is_equal(iobs, sequence(1, rows(L)))) { // all timepoints are present in this group L_i = L; } else { // arbitrary subsets cannot be taken on L directly L_i = cholesky_decompose(Cov[iobs, iobs]); } err[begin[i]:end[i]] = L_i * zerr[begin[i]:end[i]]; has_err[i] = 1; // find all additional groups where we have the same timepoints for (j in (i+1):I) { if (has_err[j] == 0 && is_equal(Jtime[j], Jtime[i]) == 1) { err[begin[j]:end[j]] = L_i * zerr[begin[j]:end[j]]; has_err[j] = 1; } } while (i <= I && has_err[i] == 1) { i += 1; } } return err; } brms/inst/chunks/fun_scale_r_cor_by_cov.stan0000644000176200001440000000332314524352014021041 0ustar liggesusers /* compute correlated group-level effects with 'by' variables * in the presence of a within-group covariance matrix * Args: * z: matrix of unscaled group-level effects * SD: matrix of standard deviation parameters * L: an array of cholesky factor correlation matrices * Jby: index which grouping level belongs to which by level * Lcov: cholesky factor of within-group correlation matrix * Returns: * matrix of scaled group-level effects */ matrix scale_r_cor_by_cov(matrix z, matrix SD, array[] matrix L, array[] int Jby, matrix Lcov) { vector[num_elements(z)] z_flat = to_vector(z); vector[num_elements(z)] r = rep_vector(0, num_elements(z)); array[size(L)] matrix[rows(L[1]), cols(L[1])] LC; int rows_z = rows(z); int rows_L = rows(L[1]); for (i in 1:size(LC)) { LC[i] = diag_pre_multiply(SD[, i], L[i]); } // kronecker product of cholesky factors times a vector for (icov in 1:rows(Lcov)) { for (jcov in 1:icov) { if (Lcov[icov, jcov] > 1e-10) { // avoid calculating products between unrelated individuals for (i in 1:rows_L) { for (j in 1:i) { // incremented element of the output vector int k = (rows_L * (icov - 1)) + i; // applied element of the input vector int l = (rows_L * (jcov - 1)) + j; // column number of z to which z_flat[l] belongs int m = (l - 1) / rows_z + 1; r[k] = r[k] + Lcov[icov, jcov] * LC[Jby[m]][i, j] * z_flat[l]; } } } } } // r is returned in another dimension order than z return to_matrix(r, cols(z), rows(z), 0); } brms/inst/chunks/fun_scale_time_err.stan0000644000176200001440000000155615053072461020213 0ustar liggesusers /* scale and correlate time-series residuals * using the Cholesky factor of the correlation matrix * Args: * zerr: standardized and independent residuals * sderr: standard deviation of the residuals * chol_cor: cholesky factor of the correlation matrix * nobs: number of observations in each group * begin: the first observation in each group * end: the last observation in each group * Returns: * vector of scaled and correlated residuals */ vector scale_time_err(vector zerr, real sderr, matrix chol_cor, array[] int nobs, array[] int begin, array[] int end) { vector[rows(zerr)] err; for (i in 1:size(nobs)) { matrix[nobs[i], nobs[i]] L_i; L_i = sderr * chol_cor[1:nobs[i], 1:nobs[i]]; err[begin[i]:end[i]] = L_i * zerr[begin[i]:end[i]]; } return err; } brms/inst/chunks/fun_gp_matern32.stan0000644000176200001440000000167215053072461017356 0ustar liggesusers /* compute a latent Gaussian process with Matern 3/2 kernel * Args: * x: array of continuous predictor values * sdgp: marginal SD parameter * lscale: length-scale parameter * zgp: vector of independent standard normal variables * Returns: * a vector to be added to the linear predictor */ vector gp_matern32(data array[] vector x, real sdgp, vector lscale, vector zgp) { int Dls = rows(lscale); int N = size(x); matrix[N, N] cov; if (Dls == 1) { // one dimensional or isotropic GP cov = gp_matern32_cov(x, sdgp, lscale[1]); } else { // multi-dimensional non-isotropic GP cov = gp_matern32_cov(x[, 1], sdgp, lscale[1]); for (d in 2:Dls) { cov = cov .* gp_matern32_cov(x[, d], 1, lscale[d]); } } for (n in 1:N) { // deal with numerical non-positive-definiteness cov[n, n] += 1e-12; } return cholesky_decompose(cov) * zgp; } brms/inst/chunks/fun_which_range.stan0000644000176200001440000000230414524350752017510 0ustar liggesusers /* how many elements are in a range of integers? * Args: * x: an integer array * start: start of the range (inclusive) * end: end of the range (inclusive) * Returns: * a scalar integer */ int size_range(array[] int x, int start, int end) { int out = 0; for (i in 1:size(x)) { out += (x[i] >= start && x[i] <= end); } return out; } /* which elements are in a range of integers? * Args: * x: an integer array * start: start of the range (inclusive) * end: end of the range (inclusive) * Returns: * an integer array */ array[] int which_range(array[] int x, int start, int end) { array[size_range(x, start, end)] int out; int j = 1; for (i in 1:size(x)) { if (x[i] >= start && x[i] <= end) { out[j] = i; j += 1; } } return out; } /* adjust array values to x - start + 1 * Args: * x: an integer array * start: start of the range of values in x (inclusive) * Returns: * an integer array */ array[] int start_at_one(array[] int x, int start) { array[size(x)] int out; for (i in 1:size(x)) { out[i] = x[i] - start + 1; } return out; } brms/inst/chunks/fun_normal_lagsar.stan0000644000176200001440000000146314527413457020065 0ustar liggesusers /* normal log-pdf for spatially lagged responses * Args: * y: the response vector * mu: mean parameter vector * sigma: residual standard deviation * rho: positive autoregressive parameter * W: spatial weight matrix * eigenW: precomputed eigenvalues of W * Returns: * a scalar to be added to the log posterior */ real normal_lagsar_lpdf(vector y, vector mu, real sigma, real rho, data matrix W, data vector eigenW) { int N = rows(y); real inv_sigma2 = inv_square(sigma); matrix[N, N] W_tilde = add_diag(-rho * W, 1); vector[N] half_pred; real log_det; half_pred = W_tilde * y - mu; log_det = sum(log1m(rho * eigenW)); return 0.5 * N * log(inv_sigma2) + log_det - 0.5 * dot_self(half_pred) * inv_sigma2; } brms/inst/chunks/fun_logistic_normal.stan0000644000176200001440000000246314527413457020432 0ustar liggesusers /* multi-logit transform * Args: * y: simplex vector of length D * ref: a single integer in 1:D indicating the reference category * Returns: * an unbounded real vector of length D - 1 */ vector multi_logit(vector y, int ref) { vector[rows(y) - 1] x; for (i in 1:(ref - 1)) { x[i] = log(y[i]) - log(y[ref]); } for (i in (ref+1):rows(y)) { x[i - 1] = log(y[i]) - log(y[ref]); } return(x); } /* logistic-normal log-PDF * Args: * y: simplex vector of response values (length D) * mu: vector of means on the logit scale (length D-1) * sigma: vector for standard deviations on the logit scale (length D-1) * Lcor: Cholesky correlation matrix on the logit scale (dim D-1) * ref: a single integer in 1:D indicating the reference category * Returns: * a scalar to be added to the log posterior */ real logistic_normal_cholesky_cor_lpdf(vector y, vector mu, vector sigma, matrix Lcor, int ref) { int D = rows(y); vector[D - 1] x = multi_logit(y, ref); matrix[D - 1, D - 1] Lcov = diag_pre_multiply(sigma, Lcor); // multi-normal plus Jacobian adjustment of multivariate logit transform return multi_normal_cholesky_lpdf(x | mu, Lcov) - sum(log(y)); } brms/inst/chunks/fun_add_int.stan0000644000176200001440000000054515053072461016635 0ustar liggesusers /* add a single integer to an array of integers * Args: * x: array of integers * y: a single integer * Returns: * an array of intergers of the same length as x */ array[] int add_int(array[] int x, int y) { array[num_elements(x)] int out; for (n in 1:num_elements(x)) { out[n] = x[n] + y; } return out; } brms/inst/chunks/fun_hurdle_poisson.stan0000644000176200001440000000475314213413565020276 0ustar liggesusers /* hurdle poisson log-PDF of a single response * Args: * y: the response value * lambda: mean parameter of the poisson distribution * hu: hurdle probability * Returns: * a scalar to be added to the log posterior */ real hurdle_poisson_lpmf(int y, real lambda, real hu) { if (y == 0) { return bernoulli_lpmf(1 | hu); } else { return bernoulli_lpmf(0 | hu) + poisson_lpmf(y | lambda) - log1m_exp(-lambda); } } /* hurdle poisson log-PDF of a single response * logit parameterization of the hurdle part * Args: * y: the response value * lambda: mean parameter of the poisson distribution * hu: linear predictor for hurdle part * Returns: * a scalar to be added to the log posterior */ real hurdle_poisson_logit_lpmf(int y, real lambda, real hu) { if (y == 0) { return bernoulli_logit_lpmf(1 | hu); } else { return bernoulli_logit_lpmf(0 | hu) + poisson_lpmf(y | lambda) - log1m_exp(-lambda); } } /* hurdle poisson log-PDF of a single response * log parameterization for the poisson part * Args: * y: the response value * eta: linear predictor for poisson part * hu: hurdle probability * Returns: * a scalar to be added to the log posterior */ real hurdle_poisson_log_lpmf(int y, real eta, real hu) { if (y == 0) { return bernoulli_lpmf(1 | hu); } else { return bernoulli_lpmf(0 | hu) + poisson_log_lpmf(y | eta) - log1m_exp(-exp(eta)); } } /* hurdle poisson log-PDF of a single response * log parameterization for the poisson part * logit parameterization of the hurdle part * Args: * y: the response value * eta: linear predictor for poisson part * hu: linear predictor for hurdle part * Returns: * a scalar to be added to the log posterior */ real hurdle_poisson_log_logit_lpmf(int y, real eta, real hu) { if (y == 0) { return bernoulli_logit_lpmf(1 | hu); } else { return bernoulli_logit_lpmf(0 | hu) + poisson_log_lpmf(y | eta) - log1m_exp(-exp(eta)); } } // hurdle poisson log-CCDF and log-CDF functions real hurdle_poisson_lccdf(int y, real lambda, real hu) { return bernoulli_lpmf(0 | hu) + poisson_lccdf(y | lambda) - log1m_exp(-lambda); } real hurdle_poisson_lcdf(int y, real lambda, real hu) { return log1m_exp(hurdle_poisson_lccdf(y | lambda, hu)); } brms/inst/chunks/fun_zero_inflated_beta.stan0000644000176200001440000000323014213413565021046 0ustar liggesusers /* zero-inflated beta log-PDF of a single response * Args: * y: the response value * mu: mean parameter of the beta distribution * phi: precision parameter of the beta distribution * zi: zero-inflation probability * Returns: * a scalar to be added to the log posterior */ real zero_inflated_beta_lpdf(real y, real mu, real phi, real zi) { row_vector[2] shape = [mu * phi, (1 - mu) * phi]; if (y == 0) { return bernoulli_lpmf(1 | zi); } else { return bernoulli_lpmf(0 | zi) + beta_lpdf(y | shape[1], shape[2]); } } /* zero-inflated beta log-PDF of a single response * logit parameterization of the zero-inflation part * Args: * y: the response value * mu: mean parameter of the beta distribution * phi: precision parameter of the beta distribution * zi: linear predictor for zero-inflation part * Returns: * a scalar to be added to the log posterior */ real zero_inflated_beta_logit_lpdf(real y, real mu, real phi, real zi) { row_vector[2] shape = [mu * phi, (1 - mu) * phi]; if (y == 0) { return bernoulli_logit_lpmf(1 | zi); } else { return bernoulli_logit_lpmf(0 | zi) + beta_lpdf(y | shape[1], shape[2]); } } // zero-inflated beta log-CCDF and log-CDF functions real zero_inflated_beta_lccdf(real y, real mu, real phi, real zi) { row_vector[2] shape = [mu * phi, (1 - mu) * phi]; return bernoulli_lpmf(0 | zi) + beta_lccdf(y | shape[1], shape[2]); } real zero_inflated_beta_lcdf(real y, real mu, real phi, real zi) { return log1m_exp(zero_inflated_beta_lccdf(y | mu, phi, zi)); } brms/inst/chunks/fun_student_t_lagsar.stan0000644000176200001440000000177114213413565020600 0ustar liggesusers /* student-t log-pdf for spatially lagged responses * Args: * y: the response vector * nu: degrees of freedom parameter * mu: mean parameter vector * sigma: residual scale parameter * rho: positive autoregressive parameter * W: spatial weight matrix * eigenW: precomputed eigenvalues of W * Returns: * a scalar to be added to the log posterior */ real student_t_lagsar_lpdf(vector y, real nu, vector mu, real sigma, real rho, data matrix W, data vector eigenW) { int N = rows(y); real K = rows(y); // avoid integer division warning real inv_sigma2 = inv_square(sigma); matrix[N, N] W_tilde = add_diag(-rho * W, 1); vector[N] half_pred; real log_det; half_pred = W_tilde * y - mu; log_det = sum(log1m(rho * eigenW)); return - K / 2 * log(nu) + lgamma((nu + K) / 2) - lgamma(nu / 2) + 0.5 * K * log(inv_sigma2) + log_det - (nu + K) / 2 * log1p(dot_self(half_pred) * inv_sigma2 / nu); } brms/inst/chunks/fun_r2d2.stan0000644000176200001440000000042714527413457016014 0ustar liggesusers /* compute scale parameters of the R2D2 prior * Args: * phi: local weight parameters * tau2: global scale parameter * Returns: * scale parameter vector of the R2D2 prior */ vector scales_R2D2(vector phi, real tau2) { return sqrt(phi * tau2); } brms/inst/chunks/fun_normal_errorsar.stan0000644000176200001440000000147114527413457020452 0ustar liggesusers /* normal log-pdf for spatially lagged residuals * Args: * y: the response vector * mu: mean parameter vector * sigma: residual standard deviation * rho: positive autoregressive parameter * W: spatial weight matrix * eigenW: precomputed eigenvalues of W * Returns: * a scalar to be added to the log posterior */ real normal_errorsar_lpdf(vector y, vector mu, real sigma, real rho, data matrix W, data vector eigenW) { int N = rows(y); real inv_sigma2 = inv_square(sigma); matrix[N, N] W_tilde = add_diag(-rho * W, 1); vector[N] half_pred; real log_det; half_pred = W_tilde * (y - mu); log_det = sum(log1m(rho * eigenW)); return 0.5 * N * log(inv_sigma2) + log_det - 0.5 * dot_self(half_pred) * inv_sigma2; } brms/inst/chunks/fun_horseshoe.stan0000644000176200001440000000110214527413457017231 0ustar liggesusers /* Efficient computation of the horseshoe scale parameters * see Appendix C.1 in https://projecteuclid.org/euclid.ejs/1513306866 * Args: * lambda: local shrinkage parameters * tau: global shrinkage parameter * c2: slap regularization parameter * Returns: * scale parameter vector of the horseshoe prior */ vector scales_horseshoe(vector lambda, real tau, real c2) { int K = rows(lambda); vector[K] lambda2 = square(lambda); vector[K] lambda_tilde = sqrt(c2 * lambda2 ./ (c2 + tau^2 * lambda2)); return lambda_tilde * tau; } brms/inst/chunks/fun_zero_inflated_beta_binomial.stan0000644000176200001440000000500114527413457022726 0ustar liggesusers /* zero-inflated beta-binomial log-PDF of a single response * Args: * y: the response value * trials: number of trials of the binomial part * mu: mean parameter of the beta distribution * phi: precision parameter of the beta distribution * zi: zero-inflation probability * Returns: * a scalar to be added to the log posterior */ real zero_inflated_beta_binomial_lpmf(int y, int trials, real mu, real phi, real zi) { if (y == 0) { return log_sum_exp(bernoulli_lpmf(1 | zi), bernoulli_lpmf(0 | zi) + beta_binomial_lpmf(0 | trials, mu * phi, (1 - mu) * phi)); } else { return bernoulli_lpmf(0 | zi) + beta_binomial_lpmf(y | trials, mu * phi, (1 - mu) * phi); } } /* zero-inflated beta-binomial log-PDF of a single response * logit parameterization of the zero-inflation part * Args: * y: the response value * trials: number of trials of the binomial part * mu: mean parameter of the beta distribution * phi: precision parameter of the beta distribution * zi: linear predictor for zero-inflation part * Returns: * a scalar to be added to the log posterior */ real zero_inflated_beta_binomial_logit_lpmf(int y, int trials, real mu, real phi, real zi) { if (y == 0) { return log_sum_exp(bernoulli_logit_lpmf(1 | zi), bernoulli_logit_lpmf(0 | zi) + beta_binomial_lpmf(0 | trials, mu * phi, (1 - mu) * phi)); } else { return bernoulli_logit_lpmf(0 | zi) + beta_binomial_lpmf(y | trials, mu * phi, (1 - mu) * phi); } } // zero-inflated beta-binomial log-CCDF and log-CDF functions real zero_inflated_beta_binomial_lccdf(int y, int trials, real mu, real phi, real zi) { return bernoulli_lpmf(0 | zi) + beta_binomial_lccdf(y | trials, mu * phi, (1 - mu) * phi); } real zero_inflated_beta_binomial_lcdf(int y, int trials, real mu, real phi, real zi) { return log1m_exp(zero_inflated_beta_binomial_lccdf(y | trials, mu, phi, zi)); } brms/inst/chunks/fun_cauchit.stan0000644000176200001440000000146214572627171016663 0ustar liggesusers /* compute the cauchit link * Args: * p: a scalar in (0, 1) * Returns: * a scalar in (-Inf, Inf) */ real cauchit(real p) { return tan(pi() * (p - 0.5)); } /* compute the cauchit link (vectorized) * Args: * p: a vector in (0, 1) * Returns: * a vector in (-Inf, Inf) */ vector cauchit(vector p) { return tan(pi() * (p - 0.5)); } /* compute the inverse of the cauchit link * Args: * y: a scalar in (-Inf, Inf) * Returns: * a scalar in (0, 1) */ real inv_cauchit(real y) { return atan(y) / pi() + 0.5; } /* compute the inverse of the cauchit link (vectorized) * Args: * y: a vector in (-Inf, Inf) * Returns: * a vector in (0, 1) */ vector inv_cauchit(vector y) { return atan(y) / pi() + 0.5; } brms/inst/chunks/fun_spd_gp_matern52.stan0000644000176200001440000000220715053072461020221 0ustar liggesusers /* Spectral density function of a Gaussian process with Matern 5/2 kernel * Args: * x: array of numeric values of dimension NB x D * sdgp: marginal SD parameter * lscale: vector of length-scale parameters * Returns: * numeric vector of length NB of the SPD evaluated at 'x' */ vector spd_gp_matern52(data array[] vector x, real sdgp, vector lscale) { int NB = dims(x)[1]; int D = dims(x)[2]; int Dls = rows(lscale); real constant = square(sdgp) * (2^D * pi()^(D / 2.0) * tgamma((D + 5.0) / 2) * 5^(5.0 / 2)) / (0.75 * sqrt(pi())); real expo = -(D + 5.0) / 2; vector[NB] out; if (Dls == 1) { // one dimensional or isotropic GP real lscale2 = square(lscale[1]); constant = constant * lscale[1]^D; for (m in 1:NB) { out[m] = constant * (5 + lscale2 * dot_self(x[m]))^expo; } } else { // multi-dimensional non-isotropic GP vector[Dls] lscale2 = square(lscale); constant = constant * prod(lscale); for (m in 1:NB) { out[m] = constant * (5 + dot_product(lscale2, square(x[m])))^expo; } } return out; } brms/inst/chunks/fun_softit.stan0000644000176200001440000000151014572627356016552 0ustar liggesusers /* compute the softit link * Args: * p: a scalar in (0, 1) * Returns: * a scalar in (-Inf, Inf) */ real softit(real p) { return log(expm1(-p / (p - 1))); } /* compute the softit link (vectorized) * Args: * p: a vector in (0, 1) * Returns: * a vector in (-Inf, Inf) */ vector softit(vector p) { return log(expm1(-p / (p - 1))); } /* compute the inverse of the sofit link * Args: * y: a scalar in (-Inf, Inf) * Returns: * a scalar in (0, 1) */ real inv_softit(real y) { return log1p_exp(y) / (1 + log1p_exp(y)); } /* compute the inverse of the sofit link (vectorized) * Args: * y: a vector in (-Inf, Inf) * Returns: * a vector in (0, 1) */ vector inv_softit(vector y) { return log1p_exp(y) / (1 + log1p_exp(y)); } brms/inst/chunks/fun_scale_r_cor_cov.stan0000644000176200001440000000256714213413565020364 0ustar liggesusers /* compute correlated group-level effects * in the presence of a within-group covariance matrix * Args: * z: matrix of unscaled group-level effects * SD: vector of standard deviation parameters * L: cholesky factor correlation matrix * Lcov: cholesky factor of within-group correlation matrix * Returns: * matrix of scaled group-level effects */ matrix scale_r_cor_cov(matrix z, vector SD, matrix L, matrix Lcov) { vector[num_elements(z)] z_flat = to_vector(z); vector[num_elements(z)] r = rep_vector(0, num_elements(z)); matrix[rows(L), cols(L)] LC = diag_pre_multiply(SD, L); int rows_z = rows(z); int rows_L = rows(L); // kronecker product of cholesky factors times a vector for (icov in 1:rows(Lcov)) { for (jcov in 1:icov) { if (Lcov[icov, jcov] > 1e-10) { // avoid calculating products between unrelated individuals for (i in 1:rows_L) { for (j in 1:i) { // incremented element of the output vector int k = (rows_L * (icov - 1)) + i; // applied element of the input vector int l = (rows_L * (jcov - 1)) + j; r[k] = r[k] + Lcov[icov, jcov] * LC[i, j] * z_flat[l]; } } } } } // r is returned in another dimension order than z return to_matrix(r, cols(z), rows(z), 0); } brms/inst/chunks/fun_normal_time_se.stan0000644000176200001440000001047514552264061020235 0ustar liggesusers /* multi-normal log-PDF for time-series covariance structures * in Cholesky parameterization and assuming homogoneous variances * and known standard errors * Args: * y: response vector * mu: mean parameter vector * sigma: residual standard deviation * se2: square of user defined standard errors * chol_cor: cholesky factor of the correlation matrix * nobs: number of observations in each group * begin: the first observation in each group * end: the last observation in each group * Returns: * sum of the log-PDF values of all observations */ real normal_time_hom_se_lpdf(vector y, vector mu, real sigma, data vector se2, matrix chol_cor, array[] int nobs, array[] int begin, array[] int end) { int I = size(nobs); vector[I] lp; matrix[rows(chol_cor), cols(chol_cor)] Cov; Cov = multiply_lower_tri_self_transpose(sigma * chol_cor); for (i in 1:I) { matrix[nobs[i], nobs[i]] Cov_i = Cov[1:nobs[i], 1:nobs[i]]; // need to add 'se' to the covariance matrix itself Cov_i += diag_matrix(se2[begin[i]:end[i]]); lp[i] = multi_normal_lpdf(y[begin[i]:end[i]] | mu[begin[i]:end[i]], Cov_i); } return sum(lp); } /* multi-normal log-PDF for time-series covariance structures * in Cholesky parameterization and assuming heterogenous variances * and known standard errors * Deviating Args: * sigma: residual standard deviation vector * Returns: * sum of the log-PDF values of all observations */ real normal_time_het_se_lpdf(vector y, vector mu, vector sigma, data vector se2, matrix chol_cor, array[] int nobs, array[] int begin, array[] int end) { int I = size(nobs); vector[I] lp; for (i in 1:I) { matrix[nobs[i], nobs[i]] Cov_i; Cov_i = diag_pre_multiply(sigma[begin[i]:end[i]], chol_cor[1:nobs[i], 1:nobs[i]]); // need to add 'se' to the covariance matrix itself Cov_i = multiply_lower_tri_self_transpose(Cov_i); Cov_i += diag_matrix(se2[begin[i]:end[i]]); lp[i] = multi_normal_lpdf(y[begin[i]:end[i]] | mu[begin[i]:end[i]], Cov_i); } return sum(lp); } /* multi-normal log-PDF for time-series covariance structures * in Cholesky parameterization and assuming homogoneous variances * and known standard errors * allows for flexible correlation matrix subsets * Deviating Args: * Jtime: array of time indices per group * Returns: * sum of the log-PDF values of all observations */ real normal_time_hom_se_flex_lpdf(vector y, vector mu, real sigma, data vector se2, matrix chol_cor, array[] int nobs, array[] int begin, array[] int end, array[,] int Jtime) { int I = size(nobs); vector[I] lp; matrix[rows(chol_cor), cols(chol_cor)] Cov; Cov = multiply_lower_tri_self_transpose(sigma * chol_cor); for (i in 1:I) { array[nobs[i]] int iobs = Jtime[i, 1:nobs[i]]; matrix[nobs[i], nobs[i]] Cov_i = Cov[iobs, iobs]; Cov_i += diag_matrix(se2[begin[i]:end[i]]); lp[i] = multi_normal_lpdf(y[begin[i]:end[i]] | mu[begin[i]:end[i]], Cov_i); } return sum(lp); } /* multi-normal log-PDF for time-series covariance structures * in Cholesky parameterization and assuming heterogenous variances * and known standard errors * allows for flexible correlation matrix subsets * Deviating Args: * sigma: residual standard deviation vector * Jtime: array of time indices per group * Returns: * sum of the log-PDF values of all observations */ real normal_time_het_se_flex_lpdf(vector y, vector mu, vector sigma, data vector se2, matrix chol_cor, array[] int nobs, array[] int begin, array[] int end, array[,] int Jtime) { int I = size(nobs); vector[I] lp; matrix[rows(chol_cor), cols(chol_cor)] Cor; Cor = multiply_lower_tri_self_transpose(chol_cor); for (i in 1:I) { array[nobs[i]] int iobs = Jtime[i, 1:nobs[i]]; matrix[nobs[i], nobs[i]] Cov_i; Cov_i = quad_form_diag(Cor[iobs, iobs], sigma[begin[i]:end[i]]); Cov_i += diag_matrix(se2[begin[i]:end[i]]); lp[i] = multi_normal_lpdf(y[begin[i]:end[i]] | mu[begin[i]:end[i]], Cov_i); } return sum(lp); } brms/inst/chunks/fun_multinomial_logit.stan0000644000176200001440000000047414527413457020775 0ustar liggesusers /* multinomial-logit log-PMF * Args: * y: array of integer response values * mu: vector of category logit probabilities * Returns: * a scalar to be added to the log posterior */ real multinomial_logit2_lpmf(array[] int y, vector mu) { return multinomial_lpmf(y | softmax(mu)); } brms/inst/chunks/fun_discrete_weibull.stan0000644000176200001440000000122414527413457020564 0ustar liggesusers /* discrete Weibull log-PMF for a single response * Args: * y: the response value * mu: location parameter on the unit interval * shape: positive shape parameter * Returns: * a scalar to be added to the log posterior */ real discrete_weibull_lpmf(int y, real mu, real shape) { return log(mu^y^shape - mu^(y+1)^shape); } // discrete Weibull log-CDF for a single response real discrete_weibull_lcdf(int y, real mu, real shape) { return log1m(mu^(y + 1)^shape); } // discrete Weibull log-CCDF for a single response real discrete_weibull_lccdf(int y, real mu, real shape) { return lmultiply((y + 1)^shape, mu); } brms/inst/chunks/fun_normal_time.stan0000644000176200001440000001267114762060524017547 0ustar liggesusers /* multi-normal log-PDF for time-series covariance structures * in Cholesky parameterization and assuming homogoneous variances * Args: * y: response vector * mu: mean parameter vector * sigma: residual standard deviation * chol_cor: cholesky factor of the correlation matrix * nobs: number of observations in each group * begin: the first observation in each group * end: the last observation in each group * Returns: * sum of the log-PDF values of all observations */ real normal_time_hom_lpdf(vector y, vector mu, real sigma, matrix chol_cor, array[] int nobs, array[] int begin, array[] int end) { int I = size(nobs); vector[I] lp; matrix[rows(chol_cor), cols(chol_cor)] L = sigma * chol_cor; for (i in 1:I) { matrix[nobs[i], nobs[i]] L_i = L[1:nobs[i], 1:nobs[i]]; lp[i] = multi_normal_cholesky_lpdf( y[begin[i]:end[i]] | mu[begin[i]:end[i]], L_i ); } return sum(lp); } /* multi-normal log-PDF for time-series covariance structures * in Cholesky parameterization and assuming heterogenous variances * Deviating Args: * sigma: residual standard deviation vector * Returns: * sum of the log-PDF values of all observations */ real normal_time_het_lpdf(vector y, vector mu, vector sigma, matrix chol_cor, array[] int nobs, array[] int begin, array[] int end) { int I = size(nobs); vector[I] lp; for (i in 1:I) { matrix[nobs[i], nobs[i]] L_i; L_i = diag_pre_multiply(sigma[begin[i]:end[i]], chol_cor[1:nobs[i], 1:nobs[i]]); lp[i] = multi_normal_cholesky_lpdf( y[begin[i]:end[i]] | mu[begin[i]:end[i]], L_i ); } return sum(lp); } /* multi-normal log-PDF for time-series covariance structures * in Cholesky parameterization and assuming homogoneous variances * allows for flexible correlation matrix subsets * Deviating Args: * Jtime: array of time indices per group * Returns: * sum of the log-PDF values of all observations */ real normal_time_hom_flex_lpdf(vector y, vector mu, real sigma, matrix chol_cor, array[] int nobs, array[] int begin, array[] int end, array[,] int Jtime) { real lp = 0.0; int I = size(nobs); array[I] int has_lp = rep_array(0, I); int i = 1; matrix[rows(chol_cor), cols(chol_cor)] L; matrix[rows(chol_cor), cols(chol_cor)] Cov; L = sigma * chol_cor; Cov = multiply_lower_tri_self_transpose(L); while (i <= I) { array[nobs[i]] int iobs = Jtime[i, 1:nobs[i]]; array[I-i+1] int lp_terms = rep_array(0, I-i+1); matrix[nobs[i], nobs[i]] L_i; if (is_equal(iobs, sequence(1, rows(L)))) { // all timepoints are present in this group L_i = L; } else { // arbitrary subsets cannot be taken on L directly L_i = cholesky_decompose(Cov[iobs, iobs]); } has_lp[i] = 1; lp_terms[1] = 1; // find all additional groups where we have the same timepoints for (j in (i+1):I) { if (has_lp[j] == 0 && is_equal(Jtime[j], Jtime[i]) == 1) { has_lp[j] = 1; lp_terms[j-i+1] = 1; } } // vectorize the log likelihood by stacking the vectors lp += multi_normal_cholesky_lpdf( stack_vectors(y, nobs[i], lp_terms, begin[i:I], end[i:I]) | stack_vectors(mu, nobs[i], lp_terms, begin[i:I], end[i:I]), L_i ); while (i <= I && has_lp[i] == 1) { i += 1; } } return lp; } /* multi-normal log-PDF for time-series covariance structures * in Cholesky parameterization and assuming heterogenous variances * allows for flexible correlation matrix subsets * Deviating Args: * sigma: residual standard deviation vectors * Jtime: array of time indices per group * Returns: * sum of the log-PDF values of all observations */ real normal_time_het_flex_lpdf(vector y, vector mu, vector sigma, matrix chol_cor, array[] int nobs, array[] int begin, array[] int end, array[,] int Jtime) { int I = size(nobs); vector[I] lp; array[I] int has_lp = rep_array(0, I); int i = 1; matrix[rows(chol_cor), cols(chol_cor)] Cor; Cor = multiply_lower_tri_self_transpose(chol_cor); while (i <= I) { array[nobs[i]] int iobs = Jtime[i, 1:nobs[i]]; matrix[nobs[i], nobs[i]] Lcor_i; matrix[nobs[i], nobs[i]] L_i; if (is_equal(iobs, sequence(1, rows(chol_cor)))) { // all timepoints are present in this group Lcor_i = chol_cor; } else { // arbitrary subsets cannot be taken on chol_cor directly Lcor_i = cholesky_decompose(Cor[iobs, iobs]); } L_i = diag_pre_multiply(sigma[begin[i]:end[i]], Lcor_i); lp[i] = multi_normal_cholesky_lpdf(y[begin[i]:end[i]] | mu[begin[i]:end[i]], L_i); has_lp[i] = 1; // find all additional groups where we have the same timepoints for (j in (i+1):I) { if (has_lp[j] == 0 && is_equal(Jtime[j], Jtime[i]) == 1) { // group j may have different sigmas that group i L_i = diag_pre_multiply(sigma[begin[j]:end[j]], Lcor_i); lp[j] = multi_normal_cholesky_lpdf(y[begin[j]:end[j]] | mu[begin[j]:end[j]], L_i); has_lp[j] = 1; } } while (i <= I && has_lp[i] == 1) { i += 1; } } return sum(lp); } brms/inst/chunks/fun_zero_inflated_negbinomial.stan0000644000176200001440000000712714213413565022430 0ustar liggesusers /* zero-inflated negative binomial log-PDF of a single response * Args: * y: the response value * mu: mean parameter of negative binomial distribution * phi: shape parameter of negative binomial distribution * zi: zero-inflation probability * Returns: * a scalar to be added to the log posterior */ real zero_inflated_neg_binomial_lpmf(int y, real mu, real phi, real zi) { if (y == 0) { return log_sum_exp(bernoulli_lpmf(1 | zi), bernoulli_lpmf(0 | zi) + neg_binomial_2_lpmf(0 | mu, phi)); } else { return bernoulli_lpmf(0 | zi) + neg_binomial_2_lpmf(y | mu, phi); } } /* zero-inflated negative binomial log-PDF of a single response * logit parameterization of the zero-inflation part * Args: * y: the response value * mu: mean parameter of negative binomial distribution * phi: shape parameter of negative binomial distribution * zi: linear predictor for zero-inflation part * Returns: * a scalar to be added to the log posterior */ real zero_inflated_neg_binomial_logit_lpmf(int y, real mu, real phi, real zi) { if (y == 0) { return log_sum_exp(bernoulli_logit_lpmf(1 | zi), bernoulli_logit_lpmf(0 | zi) + neg_binomial_2_lpmf(0 | mu, phi)); } else { return bernoulli_logit_lpmf(0 | zi) + neg_binomial_2_lpmf(y | mu, phi); } } /* zero-inflated negative binomial log-PDF of a single response * log parameterization for the negative binomial part * Args: * y: the response value * eta: linear predictor for negative binomial distribution * phi: shape parameter of negative binomial distribution * zi: zero-inflation probability * Returns: * a scalar to be added to the log posterior */ real zero_inflated_neg_binomial_log_lpmf(int y, real eta, real phi, real zi) { if (y == 0) { return log_sum_exp(bernoulli_lpmf(1 | zi), bernoulli_lpmf(0 | zi) + neg_binomial_2_log_lpmf(0 | eta, phi)); } else { return bernoulli_lpmf(0 | zi) + neg_binomial_2_log_lpmf(y | eta, phi); } } /* zero-inflated negative binomial log-PDF of a single response * log parameterization for the negative binomial part * logit parameterization of the zero-inflation part * Args: * y: the response value * eta: linear predictor for negative binomial distribution * phi: shape parameter of negative binomial distribution * zi: linear predictor for zero-inflation part * Returns: * a scalar to be added to the log posterior */ real zero_inflated_neg_binomial_log_logit_lpmf(int y, real eta, real phi, real zi) { if (y == 0) { return log_sum_exp(bernoulli_logit_lpmf(1 | zi), bernoulli_logit_lpmf(0 | zi) + neg_binomial_2_log_lpmf(0 | eta, phi)); } else { return bernoulli_logit_lpmf(0 | zi) + neg_binomial_2_log_lpmf(y | eta, phi); } } // zero_inflated negative binomial log-CCDF and log-CDF functions real zero_inflated_neg_binomial_lccdf(int y, real mu, real phi, real hu) { return bernoulli_lpmf(0 | hu) + neg_binomial_2_lccdf(y | mu, phi); } real zero_inflated_neg_binomial_lcdf(int y, real mu, real phi, real hu) { return log1m_exp(zero_inflated_neg_binomial_lccdf(y | mu, phi, hu)); } brms/inst/chunks/fun_normal_fcor.stan0000644000176200001440000000176214213413565017537 0ustar liggesusers /* multi-normal log-PDF for fixed correlation matrices * assuming homogoneous variances * Args: * y: response vector * mu: mean parameter vector * sigma: residual standard deviation * chol_cor: cholesky factor of the correlation matrix * Returns: * sum of the log-PDF values of all observations */ real normal_fcor_hom_lpdf(vector y, vector mu, real sigma, data matrix chol_cor) { return multi_normal_cholesky_lpdf(y | mu, sigma * chol_cor); } /* multi-normal log-PDF for fixed correlation matrices * assuming heterogenous variances * Args: * y: response vector * mu: mean parameter vector * sigma: residual standard deviation vector * chol_cor: cholesky factor of the correlation matrix * Returns: * sum of the log-PDF values of all observations */ real normal_fcor_het_lpdf(vector y, vector mu, vector sigma, data matrix chol_cor) { return multi_normal_cholesky_lpdf(y | mu, diag_pre_multiply(sigma, chol_cor)); } brms/inst/chunks/fun_gen_extreme_value.stan0000644000176200001440000000254314213413565020732 0ustar liggesusers /* generalized extreme value log-PDF for a single response * Args: * y: the response value * mu: location parameter * sigma: scale parameter * xi: shape parameter * Returns: * a scalar to be added to the log posterior */ real gen_extreme_value_lpdf(real y, real mu, real sigma, real xi) { real x = (y - mu) / sigma; if (xi == 0) { return - log(sigma) - x - exp(-x); } else { real t = 1 + xi * x; real inv_xi = 1 / xi; return - log(sigma) - (1 + inv_xi) * log(t) - pow(t, -inv_xi); } } /* generalized extreme value log-CDF for a single response * Args: * y: a quantile * mu: location parameter * sigma: scale parameter * xi: shape parameter * Returns: * log(P(Y <= y)) */ real gen_extreme_value_lcdf(real y, real mu, real sigma, real xi) { real x = (y - mu) / sigma; if (xi == 0) { return - exp(-x); } else { return - pow(1 + xi * x, - 1 / xi); } } /* generalized extreme value log-CCDF for a single response * Args: * y: a quantile * mu: location parameter * sigma: scale parameter * xi: shape parameter * Returns: * log(P(Y > y)) */ real gen_extreme_value_lccdf(real y, real mu, real sigma, real xi) { return log1m_exp(gen_extreme_value_lcdf(y | mu, sigma, xi)); } brms/inst/chunks/fun_cholesky_cor_ma1.stan0000644000176200001440000000111114527413457020454 0ustar liggesusers /* compute the cholesky factor of a MA1 correlation matrix * Args: * ma: MA1 autocorrelation * nrows: number of rows of the covariance matrix * Returns: * A nrows x nrows MA1 covariance matrix */ matrix cholesky_cor_ma1(real ma, int nrows) { matrix[nrows, nrows] mat; mat = diag_matrix(rep_vector(1 + ma^2, nrows)); if (nrows > 1) { mat[1, 2] = ma; for (i in 2:(nrows - 1)) { mat[i, i - 1] = ma; mat[i, i + 1] = ma; } mat[nrows, nrows - 1] = ma; } return cholesky_decompose(mat); } brms/inst/chunks/fun_student_t_time_se.stan0000644000176200001440000001066514552264061020757 0ustar liggesusers /* multi-student-t log-PDF for time-series covariance structures * in Cholesky parameterization and assuming homogoneous variances * and known standard errors * Args: * y: response vector * nu: degrees of freedom parameter * mu: mean parameter vector * sigma: scale parameter * se2: square of user defined standard errors * chol_cor: cholesky factor of the correlation matrix * nobs: number of observations in each group * begin: the first observation in each group * end: the last observation in each group * Returns: * sum of the log-PDF values of all observations */ real student_t_time_hom_se_lpdf(vector y, real nu, vector mu, real sigma, data vector se2, matrix chol_cor, array[] int nobs, array[] int begin, array[] int end) { int I = size(nobs); vector[I] lp; matrix[rows(chol_cor), cols(chol_cor)] Cov; Cov = multiply_lower_tri_self_transpose(sigma * chol_cor); for (i in 1:I) { matrix[nobs[i], nobs[i]] Cov_i = Cov[1:nobs[i], 1:nobs[i]]; // need to add 'se' to the covariance matrix itself Cov_i += diag_matrix(se2[begin[i]:end[i]]); lp[i] = multi_student_t_lpdf(y[begin[i]:end[i]] | nu, mu[begin[i]:end[i]], Cov_i); } return sum(lp); } /* multi-student-t log-PDF for time-series covariance structures * in Cholesky parameterization and assuming heterogenous variances * and known standard errors * Deviating Args: * sigma: scale parameter vector * Returns: * sum of the log-PDF values of all observations */ real student_t_time_het_se_lpdf(vector y, real nu, vector mu, vector sigma, data vector se2, matrix chol_cor, array[] int nobs, array[] int begin, array[] int end) { int I = size(nobs); vector[I] lp; for (i in 1:I) { matrix[nobs[i], nobs[i]] Cov_i; Cov_i = diag_pre_multiply(sigma[begin[i]:end[i]], chol_cor[1:nobs[i], 1:nobs[i]]); Cov_i = multiply_lower_tri_self_transpose(Cov_i); Cov_i += diag_matrix(se2[begin[i]:end[i]]); lp[i] = multi_student_t_lpdf(y[begin[i]:end[i]] | nu, mu[begin[i]:end[i]], Cov_i); } return sum(lp); } /* multi-student-t log-PDF for time-series covariance structures * in Cholesky parameterization and assuming homogoneous variances * and known standard errors * allows for flexible correlation matrix subsets * Deviating Args: * Jtime: array of time indices per group * Returns: * sum of the log-PDF values of all observations */ real student_t_time_hom_se_flex_lpdf(vector y, real nu, vector mu, real sigma, data vector se2, matrix chol_cor, array[] int nobs, array[] int begin, array[] int end, array[,] int Jtime) { int I = size(nobs); vector[I] lp; matrix[rows(chol_cor), cols(chol_cor)] Cov; Cov = multiply_lower_tri_self_transpose(sigma * chol_cor); for (i in 1:I) { array[nobs[i]] int iobs = Jtime[i, 1:nobs[i]]; matrix[nobs[i], nobs[i]] Cov_i = Cov[iobs, iobs]; Cov_i += diag_matrix(se2[begin[i]:end[i]]); lp[i] = multi_student_t_lpdf(y[begin[i]:end[i]] | nu, mu[begin[i]:end[i]], Cov_i); } return sum(lp); } /* multi-student-t log-PDF for time-series covariance structures * in Cholesky parameterization and assuming heterogenous variances * and known standard errors * allows for flexible correlation matrix subsets * Deviating Args: * sigma: scale parameter vector * Jtime: array of time indices per group * Returns: * sum of the log-PDF values of all observations */ real student_t_time_het_se_flex_lpdf(vector y, real nu, vector mu, vector sigma, data vector se2, matrix chol_cor, array[] int nobs, array[] int begin, array[] int end, array[,] int Jtime) { int I = size(nobs); vector[I] lp; matrix[rows(chol_cor), cols(chol_cor)] Cor; Cor = multiply_lower_tri_self_transpose(chol_cor); for (i in 1:I) { array[nobs[i]] int iobs = Jtime[i, 1:nobs[i]]; matrix[nobs[i], nobs[i]] Cov_i; Cov_i = quad_form_diag(Cor[iobs, iobs], sigma[begin[i]:end[i]]); Cov_i += diag_matrix(se2[begin[i]:end[i]]); lp[i] = multi_student_t_lpdf(y[begin[i]:end[i]] | nu, mu[begin[i]:end[i]], Cov_i); } return sum(lp); } brms/inst/chunks/fun_student_t_fcor.stan0000644000176200001440000000250714213413565020256 0ustar liggesusers /* multi-student-t log-PDF for fixed correlation matrices * assuming homogoneous variances * Args: * y: response vector * nu: degrees of freedom parameter * mu: mean parameter vector * sigma: scale parameter * chol_cor: cholesky factor of the correlation matrix * Returns: * sum of the log-PDF values of all observations */ real student_t_fcor_hom_lpdf(vector y, real nu, vector mu, real sigma, data matrix chol_cor) { int N = rows(chol_cor); matrix[N, N] Cov = multiply_lower_tri_self_transpose(sigma * chol_cor); return multi_student_t_lpdf(y | nu, mu, Cov); } /* multi-student-t log-PDF for fixed correlation matrices * assuming heterogenous variances * Args: * y: response vector * nu: degrees of freedom parameter * mu: mean parameter vector * sigma: scale parameter vector * chol_cor: cholesky factor of the correlation matrix * Returns: * sum of the log-PDF values of all observations */ real student_t_fcor_het_lpdf(vector y, real nu, vector mu, vector sigma, data matrix chol_cor) { int N = rows(chol_cor); matrix[N, N] Cov = diag_pre_multiply(sigma, chol_cor); Cov = multiply_lower_tri_self_transpose(Cov); return multi_student_t_lpdf(y | nu, mu, Cov); } brms/inst/chunks/fun_cholesky_cor_arma1.stan0000644000176200001440000000130714527413457021006 0ustar liggesusers /* compute the cholesky factor of an ARMA1 correlation matrix * Args: * ar: AR1 autocorrelation * ma: MA1 autocorrelation * nrows: number of rows of the covariance matrix * Returns: * A nrows x nrows matrix */ matrix cholesky_cor_arma1(real ar, real ma, int nrows) { matrix[nrows, nrows] mat; vector[nrows] gamma; mat = diag_matrix(rep_vector(1 + ma^2 + 2 * ar * ma, nrows)); gamma[1] = (1 + ar * ma) * (ar + ma); for (i in 2:nrows) { gamma[i] = gamma[1] * pow(ar, i - 1); for (j in 1:(i - 1)) { mat[i, j] = gamma[i - j]; mat[j, i] = gamma[i - j]; } } return cholesky_decompose(mat ./ (1 - ar^2)); } brms/inst/chunks/fun_gp_exponential.stan0000644000176200001440000000176015053072461020247 0ustar liggesusers /* compute a latent Gaussian process with exponential kernel * also known as the Matern 1/2 kernel * Args: * x: array of continuous predictor values * sdgp: marginal SD parameter * lscale: length-scale parameter * zgp: vector of independent standard normal variables * Returns: * a vector to be added to the linear predictor */ vector gp_exponential(data array[] vector x, real sdgp, vector lscale, vector zgp) { int Dls = rows(lscale); int N = size(x); matrix[N, N] cov; if (Dls == 1) { // one dimensional or isotropic GP cov = gp_exponential_cov(x, sdgp, lscale[1]); } else { // multi-dimensional non-isotropic GP cov = gp_exponential_cov(x[, 1], sdgp, lscale[1]); for (d in 2:Dls) { cov = cov .* gp_exponential_cov(x[, d], 1, lscale[d]); } } for (n in 1:N) { // deal with numerical non-positive-definiteness cov[n, n] += 1e-12; } return cholesky_decompose(cov) * zgp; } brms/inst/chunks/fun_xbeta.stan0000644000176200001440000001151115053072461016331 0ustar liggesusers /* Extended-support-beta log-PDF of a single response * see Kosmidis & Zeileis 2024; https://arxiv.org/abs/2409.07233 * Args: * y: the response value * mu: mean parameter of the beta distribution * phi: precision parameter of the beta distribution * kappa: the exceedance parameter (called u in the paper) * Returns: * a scalar to be added to the log posterior */ real xbeta_lpdf(real y, real mu, real phi, real kappa) { real denom = (1 + 2 * kappa); if (y <= 0) return beta_proportion_lcdf(kappa / denom | mu, phi); else if (y >= 1) return beta_proportion_lccdf((1 + kappa) / denom | mu, phi); else return beta_proportion_lpdf((y + kappa) / denom | mu, phi) - log(denom); } // vectorized versions of xbeta_lpdf real xbeta_lpdf(vector y, vector mu, vector phi, vector kappa) { int N = size(y); int N_zer = 0; int N_one = 0; int N_oth = 0; int i_zer = 0; int i_one = 0; int i_oth = 0; for (i in 1:N) { N_zer += y[i] <= 0; N_one += y[i] >= 1; N_oth += (y[i] > 0) && (y[i] < 1); } array[N_zer] int zer; array[N_one] int one; array[N_oth] int oth; for (i in 1:N) { if (y[i] <= 0) { i_zer += 1; zer[i_zer] = i; } else if (y[i] >= 1) { i_one += 1; one[i_one] = i; } else { i_oth += 1; oth[i_oth] = i; } } real ll_zer = beta_proportion_lcdf(kappa[zer] ./ (1 + 2 * kappa[zer]) | mu[zer], phi[zer]); real ll_one = beta_proportion_lccdf((1 + kappa[one]) ./ (1 + 2 * kappa[one]) | mu[one], phi[one]); real ll_oth = beta_proportion_lpdf((y[oth] + kappa[oth]) ./ (1 + 2 * kappa[oth]) | mu[oth], phi[oth]) - sum(log(1 + 2 * kappa[oth])); real ll = ll_zer + ll_one + ll_oth; return ll; } real xbeta_lpdf(vector y, vector mu, vector phi, real kappa) { int N = size(y); int N_zer = 0; int N_one = 0; int N_oth = 0; int i_zer = 0; int i_one = 0; int i_oth = 0; for (i in 1:N) { N_zer += y[i] <= 0; N_one += y[i] >= 1; N_oth += (y[i] > 0) && (y[i] < 1); } array[N_zer] int zer; array[N_one] int one; array[N_oth] int oth; for (i in 1:N) { if (y[i] <= 0) { i_zer += 1; zer[i_zer] = i; } else if (y[i] >= 1) { i_one += 1; one[i_one] = i; } else { i_oth += 1; oth[i_oth] = i; } } real ll_zer = beta_proportion_lcdf(kappa / (1 + 2 * kappa) | mu[zer], phi[zer]); real ll_one = beta_proportion_lccdf((1 + kappa) / (1 + 2 * kappa) | mu[one], phi[one]); real ll_oth = beta_proportion_lpdf((y[oth] + kappa) / (1 + 2 * kappa) | mu[oth], phi[oth]) - N_oth * log(1 + 2 * kappa); real ll = ll_zer + ll_one + ll_oth; return ll; } real xbeta_lpdf(vector y, vector mu, real phi, vector kappa) { int N = size(y); int N_zer = 0; int N_one = 0; int N_oth = 0; int i_zer = 0; int i_one = 0; int i_oth = 0; for (i in 1:N) { N_zer += y[i] <= 0; N_one += y[i] >= 1; N_oth += (y[i] > 0) && (y[i] < 1); } array[N_zer] int zer; array[N_one] int one; array[N_oth] int oth; for (i in 1:N) { if (y[i] <= 0) { i_zer += 1; zer[i_zer] = i; } else if (y[i] >= 1) { i_one += 1; one[i_one] = i; } else { i_oth += 1; oth[i_oth] = i; } } real ll_zer = beta_proportion_lcdf(kappa[zer] ./ (1 + 2 * kappa[zer]) | mu[zer], phi); real ll_one = beta_proportion_lccdf((1 + kappa[one]) ./ (1 + 2 * kappa[one]) | mu[one], phi); real ll_oth = beta_proportion_lpdf((y[oth] + kappa[oth]) ./ (1 + 2 * kappa[oth]) | mu[oth], phi) - sum(log(1 + 2 * kappa[oth])); real ll = ll_zer + ll_one + ll_oth; return ll; } real xbeta_lpdf(vector y, vector mu, real phi, real kappa) { int N = size(y); int N_zer = 0; int N_one = 0; int N_oth = 0; int i_zer = 0; int i_one = 0; int i_oth = 0; for (i in 1:N) { N_zer += y[i] <= 0; N_one += y[i] >= 1; N_oth += (y[i] > 0) && (y[i] < 1); } array[N_zer] int zer; array[N_one] int one; array[N_oth] int oth; for (i in 1:N) { if (y[i] <= 0) { i_zer += 1; zer[i_zer] = i; } else if (y[i] >= 1) { i_one += 1; one[i_one] = i; } else { i_oth += 1; oth[i_oth] = i; } } real ll_zer = beta_proportion_lcdf(kappa / (1 + 2 * kappa) | mu[zer], phi); real ll_one = beta_proportion_lccdf((1 + kappa) / (1 + 2 * kappa) | mu[one], phi); real ll_oth = beta_proportion_lpdf((y[oth] + kappa) / (1 + 2 * kappa) | mu[oth], phi) - N_oth * log(1 + 2 * kappa); real ll = ll_zer + ll_one + ll_oth; return ll; } brms/inst/chunks/fun_spd_gp_exp_quad.stan0000644000176200001440000000213015053072461020365 0ustar liggesusers /* Spectral density function of a Gaussian process * with squared exponential covariance kernel * Args: * x: array of numeric values of dimension NB x D * sdgp: marginal SD parameter * lscale: vector of length-scale parameters * Returns: * numeric vector of length NB of the SPD evaluated at 'x' */ vector spd_gp_exp_quad(data array[] vector x, real sdgp, vector lscale) { int NB = dims(x)[1]; int D = dims(x)[2]; int Dls = rows(lscale); real constant = square(sdgp) * sqrt(2 * pi())^D; vector[NB] out; if (Dls == 1) { // one dimensional or isotropic GP real neg_half_lscale2 = -0.5 * square(lscale[1]); constant = constant * lscale[1]^D; for (m in 1:NB) { out[m] = constant * exp(neg_half_lscale2 * dot_self(x[m])); } } else { // multi-dimensional non-isotropic GP vector[Dls] neg_half_lscale2 = -0.5 * square(lscale); constant = constant * prod(lscale); for (m in 1:NB) { out[m] = constant * exp(dot_product(neg_half_lscale2, square(x[m]))); } } return out; } brms/inst/chunks/fun_sparse_icar_lpdf.stan0000644000176200001440000000256014524350752020536 0ustar liggesusers /* Return the log probability of an intrinsic conditional autoregressive * (ICAR) prior with a sparse representation for the adjacency matrix * Full credit to Max Joseph (https://github.com/mbjoseph/CARstan) * Args: * phi: Vector containing the CAR parameters for each location * sdcar: Standard deviation parameter for the CAR prior * Nloc: Number of locations * Nedges: Number of edges (adjacency pairs) * Nneigh: Number of neighbors for each location * eigenW: Eigenvalues of D^(-1/2) * W * D^(-1/2) * edges1, edges2: Sparse representation of adjacency matrix * Details: * D = Diag(Nneigh) * Returns: * Log probability density of CAR prior up to additive constant */ real sparse_icar_lpdf(vector phi, real sdcar, int Nloc, int Nedges, data vector Nneigh, data vector eigenW, array[] int edges1, array[] int edges2) { real tau; // precision parameter row_vector[Nloc] phit_D; // phi' * D row_vector[Nloc] phit_W; // phi' * W tau = inv_square(sdcar); phit_D = (phi .* Nneigh)'; phit_W = rep_row_vector(0, Nloc); for (i in 1:Nedges) { phit_W[edges1[i]] = phit_W[edges1[i]] + phi[edges2[i]]; phit_W[edges2[i]] = phit_W[edges2[i]] + phi[edges1[i]]; } return 0.5 * ((Nloc - 1) * log(tau) - tau * (phit_D * phi - (phit_W * phi))); } brms/inst/chunks/fun_dirichlet_logit.stan0000644000176200001440000000053614527413457020411 0ustar liggesusers /* dirichlet-logit log-PDF * Args: * y: vector of real response values * mu: vector of category logit probabilities * phi: precision parameter * Returns: * a scalar to be added to the log posterior */ real dirichlet_logit_lpdf(vector y, vector mu, real phi) { return dirichlet_lpdf(y | softmax(mu) * phi); } brms/inst/chunks/fun_monotonic.stan0000644000176200001440000000047014527413457017246 0ustar liggesusers /* compute monotonic effects * Args: * scale: a simplex parameter * i: index to sum over the simplex * Returns: * a scalar between 0 and rows(scale) */ real mo(vector scale, int i) { if (i == 0) { return 0; } else { return rows(scale) * sum(scale[1:i]); } } brms/inst/chunks/fun_gp_exp_quad.stan0000644000176200001440000000170315053072461017524 0ustar liggesusers /* compute a latent Gaussian process with squared exponential kernel * Args: * x: array of continuous predictor values * sdgp: marginal SD parameter * lscale: length-scale parameter * zgp: vector of independent standard normal variables * Returns: * a vector to be added to the linear predictor */ vector gp_exp_quad(data array[] vector x, real sdgp, vector lscale, vector zgp) { int Dls = rows(lscale); int N = size(x); matrix[N, N] cov; if (Dls == 1) { // one dimensional or isotropic GP cov = gp_exp_quad_cov(x, sdgp, lscale[1]); } else { // multi-dimensional non-isotropic GP cov = gp_exp_quad_cov(x[, 1], sdgp, lscale[1]); for (d in 2:Dls) { cov = cov .* gp_exp_quad_cov(x[, d], 1, lscale[d]); } } for (n in 1:N) { // deal with numerical non-positive-definiteness cov[n, n] += 1e-12; } return cholesky_decompose(cov) * zgp; } brms/inst/chunks/fun_student_t_errorsar.stan0000644000176200001440000000177714213413565021174 0ustar liggesusers /* student-t log-pdf for spatially lagged residuals * Args: * y: the response vector * nu: degrees of freedom parameter * mu: mean parameter vector * sigma: residual scale parameter * rho: positive autoregressive parameter * W: spatial weight matrix * eigenW: precomputed eigenvalues of W * Returns: * a scalar to be added to the log posterior */ real student_t_errorsar_lpdf(vector y, real nu, vector mu, real sigma, real rho, data matrix W, data vector eigenW) { int N = rows(y); real K = rows(y); // avoid integer division warning real inv_sigma2 = inv_square(sigma); matrix[N, N] W_tilde = add_diag(-rho * W, 1); vector[N] half_pred; real log_det; half_pred = W_tilde * (y - mu); log_det = sum(log1m(rho * eigenW)); return - K / 2 * log(nu) + lgamma((nu + K) / 2) - lgamma(nu / 2) + 0.5 * K * log(inv_sigma2) + log_det - (nu + K) / 2 * log1p(dot_self(half_pred) * inv_sigma2 / nu); } brms/inst/chunks/fun_com_poisson.stan0000644000176200001440000001212115053072461017554 0ustar liggesusers // log approximate normalizing constant of the COM poisson distribuion // based on equations (4) and (31) of doi:10.1007/s10463-017-0629-6 // Args: see log_Z_com_poisson() real log_Z_com_poisson_approx(real log_mu, real nu) { real nu2 = nu^2; real log_common = log(nu) + log_mu / nu; array[4] real resids; real ans; real lcte = (nu * exp(log_mu / nu)) - ((nu - 1) / (2 * nu) * log_mu + (nu - 1) / 2 * log(2 * pi()) + 0.5 * log(nu)); real c_1 = (nu2 - 1) / 24; real c_2 = (nu2 - 1) / 1152 * (nu2 + 23); real c_3 = (nu2 - 1) / 414720 * (5 * square(nu2) - 298 * nu2 + 11237); resids[1] = 1; resids[2] = c_1 * exp(-1 * log_common); resids[3] = c_2 * exp(-2 * log_common); resids[4] = c_3 * exp(-3 * log_common); ans = lcte + log(sum(resids)); return ans; } // log of kth term of the normalizing series of the COM Poisson distribution // Args: // log_mu: log location parameter // shape: positive shape parameter // k: k-th term real log_k_term(real log_mu, real nu, int k) { return (k - 1) * log_mu - nu * lgamma(k); } // bound for the remainder of the normalizing series of the COM Poisson // distribution given the last two terms in log-scale // Args: // k_current_term: the log of a_k term // k_previous_term: the log of a_(k-1) term real bound_remainder(real k_current_term, real k_previous_term) { return k_current_term - log(- expm1(k_current_term - k_previous_term)); } // stopping criterio with bucket // Args: // k_current_term: the log of a_k term // k_previous_term: the log of a_(k-1) term // k: k term of the series // leps: log(eps) int stopping_criterio_bucket(real k_current_term, real k_previous_term, int k, real leps) { if (k % 50 == 0) { return (bound_remainder(k_current_term, k_previous_term) >= leps); } return (1e300 >= leps); // Int > leps } // log normalizing constant of the COM Poisson distribution // implementation inspired by code of Ben Goodrich // improved following suggestions of Sebastian Weber (#892) // Args: // log_mu: log location parameter // shape: positive shape parameter real log_Z_com_poisson(real log_mu, real nu) { real log_Z; int k = 2; int M = 10000; real leps = -23 * log2(); vector[M] log_Z_terms; if (nu == 1) { return exp(log_mu); } // nu == 0 or Inf will fail in this parameterization if (nu <= 0) { reject("nu must be positive"); } if (nu == positive_infinity()) { reject("nu must be finite"); } if (log_mu * nu >= log(1.5) && log_mu >= log(1.5)) { return log_Z_com_poisson_approx(log_mu, nu); } // direct computation of the truncated series // check if the Mth term of the series pass in the stopping criteria if (bound_remainder(log_k_term(log_mu, nu, M), log_k_term(log_mu, nu, M - 1)) >= leps) { reject("nu is too close to zero."); } // first 2 terms of the series log_Z_terms[1] = log_k_term(log_mu, nu, 1); log_Z_terms[2] = log_k_term(log_mu, nu, 2); while (((log_Z_terms[k] >= log_Z_terms[k-1]) || (stopping_criterio_bucket(log_Z_terms[k], log_Z_terms[k-1], k, leps))) && k < M) { k += 1; log_Z_terms[k] = log_k_term(log_mu, nu, k); } log_Z = log_sum_exp(log_Z_terms[1:k]); return log_Z; } // COM Poisson log-PMF for a single response (log parameterization) // Args: // y: the response value // log_mu: log location parameter // shape: positive shape parameter real com_poisson_log_lpmf(int y, real log_mu, real nu) { if (nu == 1) return poisson_log_lpmf(y | log_mu); return y * log_mu - nu * lgamma(y + 1) - log_Z_com_poisson(log_mu, nu); } // COM Poisson log-PMF for a single response real com_poisson_lpmf(int y, real mu, real nu) { if (nu == 1) return poisson_lpmf(y | mu); return com_poisson_log_lpmf(y | log(mu), nu); } // COM Poisson log-CDF for a single response real com_poisson_lcdf(int y, real mu, real nu) { real log_mu; real log_Z; // log denominator vector[y] log_num_terms; // terms of the log numerator if (nu == 1) { return poisson_lcdf(y | mu); } // nu == 0 or Inf will fail in this parameterization if (nu <= 0) { reject("nu must be positive"); } if (nu == positive_infinity()) { reject("nu must be finite"); } if (y > 10000) { reject("cannot handle y > 10000"); } log_mu = log(mu); if (y * log_mu - nu * lgamma(y + 1) <= -36.0) { // y is large enough for the CDF to be very close to 1; return 0; } log_Z = log_Z_com_poisson(log_mu, nu); if (y == 0) { return -log_Z; } // first 2 terms of the series log_num_terms[1] = log1p_exp(nu * log_mu); // remaining terms of the series until y for (k in 2:y) { log_num_terms[k] = k * log_mu - nu * lgamma(k + 1); } return log_sum_exp(log_num_terms) - log_Z; } // COM Poisson log-CCDF for a single response real com_poisson_lccdf(int y, real mu, real nu) { return log1m_exp(com_poisson_lcdf(y | mu, nu)); } brms/inst/chunks/fun_softplus.stan0000644000176200001440000000064314572627305017121 0ustar liggesusers /* softplus link function inverse to 'log1p_exp' * Args: * x: a positive scalar * Returns: * a scalar in (-Inf, Inf) */ real log_expm1(real x) { return log(expm1(x)); } /* softplus link function inverse to 'log1p_exp' (vectorized) * Args: * x: a positive vector * Returns: * a vector in (-Inf, Inf) */ vector log_expm1(vector x) { return log(expm1(x)); } brms/inst/chunks/fun_scale_xi.stan0000644000176200001440000000205714572627255017036 0ustar liggesusers /* scale auxiliary parameter xi to a suitable region * expecting sigma to be a scalar * Args: * xi: unscaled shape parameter * y: response values * mu: location parameter * sigma: scale parameter * Returns: * scaled shape parameter xi */ real scale_xi(real xi, vector y, vector mu, real sigma) { vector[rows(y)] x = (y - mu) / sigma; vector[2] bounds = [-inv(min(x)), -inv(max(x))]'; real lb = min(bounds); real ub = max(bounds); return inv_logit(xi) * (ub - lb) + lb; } /* scale auxiliary parameter xi to a suitable region * expecting sigma to be a vector * Args: * xi: unscaled shape parameter * y: response values * mu: location parameter * sigma: scale parameter * Returns: * scaled shape parameter xi */ real scale_xi(real xi, vector y, vector mu, vector sigma) { vector[rows(y)] x = (y - mu) ./ sigma; vector[2] bounds = [-inv(min(x)), -inv(max(x))]'; real lb = min(bounds); real ub = max(bounds); return inv_logit(xi) * (ub - lb) + lb; } brms/inst/chunks/fun_dirichlet_multinomial_logit.stan0000644000176200001440000000122015053072461023001 0ustar liggesusers /* dirichlet-multinomial-logit log-PMF * Args: * y: array of integer response values * mu: vector of category logit probabilities * phi: precision parameter (sum of Dirichlet alphas) * Returns: * a scalar to be added to the log posterior */ real dirichlet_multinomial_logit2_lpmf(array[] int y, vector mu, real phi) { // get Dirichlet alphas int N = num_elements(mu); vector[N] alpha = phi * softmax(mu); // get trials from y real T = sum(y); return lgamma(phi) + lgamma(T + 1.0) - lgamma(T + phi) + sum(lgamma(to_vector(y) + alpha)) - sum(lgamma(alpha)) - sum(lgamma(to_vector(y) + 1)); } brms/inst/chunks/fun_hurdle_gamma.stan0000644000176200001440000000264714213413565017666 0ustar liggesusers /* hurdle gamma log-PDF of a single response * Args: * y: the response value * alpha: shape parameter of the gamma distribution * beta: rate parameter of the gamma distribution * hu: hurdle probability * Returns: * a scalar to be added to the log posterior */ real hurdle_gamma_lpdf(real y, real alpha, real beta, real hu) { if (y == 0) { return bernoulli_lpmf(1 | hu); } else { return bernoulli_lpmf(0 | hu) + gamma_lpdf(y | alpha, beta); } } /* hurdle gamma log-PDF of a single response * logit parameterization of the hurdle part * Args: * y: the response value * alpha: shape parameter of the gamma distribution * beta: rate parameter of the gamma distribution * hu: linear predictor for the hurdle part * Returns: * a scalar to be added to the log posterior */ real hurdle_gamma_logit_lpdf(real y, real alpha, real beta, real hu) { if (y == 0) { return bernoulli_logit_lpmf(1 | hu); } else { return bernoulli_logit_lpmf(0 | hu) + gamma_lpdf(y | alpha, beta); } } // hurdle gamma log-CCDF and log-CDF functions real hurdle_gamma_lccdf(real y, real alpha, real beta, real hu) { return bernoulli_lpmf(0 | hu) + gamma_lccdf(y | alpha, beta); } real hurdle_gamma_lcdf(real y, real alpha, real beta, real hu) { return log1m_exp(hurdle_gamma_lccdf(y | alpha, beta, hu)); } brms/inst/chunks/fun_gp_matern52.stan0000644000176200001440000000167215053072461017360 0ustar liggesusers /* compute a latent Gaussian process with Matern 5/2 kernel * Args: * x: array of continuous predictor values * sdgp: marginal SD parameter * lscale: length-scale parameter * zgp: vector of independent standard normal variables * Returns: * a vector to be added to the linear predictor */ vector gp_matern52(data array[] vector x, real sdgp, vector lscale, vector zgp) { int Dls = rows(lscale); int N = size(x); matrix[N, N] cov; if (Dls == 1) { // one dimensional or isotropic GP cov = gp_matern52_cov(x, sdgp, lscale[1]); } else { // multi-dimensional non-isotropic GP cov = gp_matern52_cov(x[, 1], sdgp, lscale[1]); for (d in 2:Dls) { cov = cov .* gp_matern52_cov(x[, d], 1, lscale[d]); } } for (n in 1:N) { // deal with numerical non-positive-definiteness cov[n, n] += 1e-12; } return cholesky_decompose(cov) * zgp; } brms/inst/chunks/fun_stack_vectors.stan0000644000176200001440000000101614552261755020110 0ustar liggesusers /* grouped data stored linearly in "data" as indexed by begin and end * is repacked to be stacked into an array of vectors. */ array[] vector stack_vectors(vector long_data, int n, array[] int stack, array[] int begin, array[] int end) { int S = sum(stack); int G = size(stack); array[S] vector[n] stacked; int j = 1; for (i in 1:G) { if (stack[i] == 1) { stacked[j] = long_data[begin[i]:end[i]]; j += 1; } } return stacked; } brms/inst/chunks/fun_asym_laplace.stan0000644000176200001440000000342514213413565017666 0ustar liggesusers /* helper function for asym_laplace_lpdf * Args: * y: the response value * quantile: quantile parameter in (0, 1) */ real rho_quantile(real y, real quantile) { if (y < 0) { return y * (quantile - 1); } else { return y * quantile; } } /* asymmetric laplace log-PDF for a single response * Args: * y: the response value * mu: location parameter * sigma: positive scale parameter * quantile: quantile parameter in (0, 1) * Returns: * a scalar to be added to the log posterior */ real asym_laplace_lpdf(real y, real mu, real sigma, real quantile) { return log(quantile * (1 - quantile)) - log(sigma) - rho_quantile((y - mu) / sigma, quantile); } /* asymmetric laplace log-CDF for a single quantile * Args: * y: a quantile * mu: location parameter * sigma: positive scale parameter * quantile: quantile parameter in (0, 1) * Returns: * a scalar to be added to the log posterior */ real asym_laplace_lcdf(real y, real mu, real sigma, real quantile) { if (y < mu) { return log(quantile) + (1 - quantile) * (y - mu) / sigma; } else { return log1m((1 - quantile) * exp(-quantile * (y - mu) / sigma)); } } /* asymmetric laplace log-CCDF for a single quantile * Args: * y: a quantile * mu: location parameter * sigma: positive scale parameter * quantile: quantile parameter in (0, 1) * Returns: * a scalar to be added to the log posterior */ real asym_laplace_lccdf(real y, real mu, real sigma, real quantile) { if (y < mu) { return log1m(quantile * exp((1 - quantile) * (y - mu) / sigma)); } else { return log1m(quantile) - quantile * (y - mu) / sigma; } } brms/inst/chunks/fun_scale_r_cor.stan0000644000176200001440000000064314527413457017516 0ustar liggesusers /* compute correlated group-level effects * Args: * z: matrix of unscaled group-level effects * SD: vector of standard deviation parameters * L: cholesky factor correlation matrix * Returns: * matrix of scaled group-level effects */ matrix scale_r_cor(matrix z, vector SD, matrix L) { // r is stored in another dimension order than z return transpose(diag_pre_multiply(SD, L) * z); } brms/inst/chunks/fun_cox.stan0000644000176200001440000000471115053072461016023 0ustar liggesusers /* distribution functions of the Cox proportional hazards model * parameterize hazard(t) = baseline(t) * mu * so that higher values of 'mu' imply lower survival times * Args: * y: the response value; currently ignored as the relevant * information is passed via 'bhaz' and 'cbhaz' * mu: positive location parameter * bhaz: baseline hazard * cbhaz: cumulative baseline hazard */ real cox_lhaz(real y, real mu, real bhaz, real cbhaz) { return log(bhaz) + log(mu); } vector cox_lhaz(vector y, vector mu, vector bhaz, vector cbhaz) { return log(bhaz) + log(mu); } // equivalent to the log survival function real cox_lccdf(real y, real mu, real bhaz, real cbhaz) { return - cbhaz * mu; } real cox_lccdf(vector y, vector mu, vector bhaz, vector cbhaz) { return - dot_product(cbhaz, mu); } real cox_lcdf(real y, real mu, real bhaz, real cbhaz) { return log1m_exp(cox_lccdf(y | mu, bhaz, cbhaz)); } real cox_lcdf(vector y, vector mu, vector bhaz, vector cbhaz) { return sum(log1m_exp(- cbhaz .* mu)); } real cox_lpdf(real y, real mu, real bhaz, real cbhaz) { return cox_lhaz(y, mu, bhaz, cbhaz) + cox_lccdf(y | mu, bhaz, cbhaz); } real cox_lpdf(vector y, vector mu, vector bhaz, vector cbhaz) { return sum(cox_lhaz(y, mu, bhaz, cbhaz)) + cox_lccdf(y | mu, bhaz, cbhaz); } // Distribution functions of the Cox model in log parameterization real cox_log_lhaz(real y, real log_mu, real bhaz, real cbhaz) { return log(bhaz) + log_mu; } vector cox_log_lhaz(vector y, vector log_mu, vector bhaz, vector cbhaz) { return log(bhaz) + log_mu; } real cox_log_lccdf(real y, real log_mu, real bhaz, real cbhaz) { return - cbhaz * exp(log_mu); } real cox_log_lccdf(vector y, vector log_mu, vector bhaz, vector cbhaz) { return - dot_product(cbhaz, exp(log_mu)); } real cox_log_lcdf(real y, real log_mu, real bhaz, real cbhaz) { return log1m_exp(cox_log_lccdf(y | log_mu, bhaz, cbhaz)); } real cox_log_lcdf(vector y, vector log_mu, vector bhaz, vector cbhaz) { return sum(log1m_exp(- cbhaz .* exp(log_mu))); } real cox_log_lpdf(real y, real log_mu, real bhaz, real cbhaz) { return cox_log_lhaz(y, log_mu, bhaz, cbhaz) + cox_log_lccdf(y | log_mu, bhaz, cbhaz); } real cox_log_lpdf(vector y, vector log_mu, vector bhaz, vector cbhaz) { return sum(cox_log_lhaz(y, log_mu, bhaz, cbhaz)) + cox_log_lccdf(y | log_mu, bhaz, cbhaz); } brms/inst/chunks/fun_inv_gaussian.stan0000644000176200001440000000322314572627206017725 0ustar liggesusers /* inverse Gaussian log-PDF for a single response * Args: * y: the response value * mu: positive mean parameter * shape: positive shape parameter * Returns: * a scalar to be added to the log posterior */ real inv_gaussian_lpdf(real y, real mu, real shape) { return 0.5 * log(shape / (2 * pi())) - 1.5 * log(y) - 0.5 * shape * square((y - mu) / (mu * sqrt(y))); } /* vectorized inverse Gaussian log-PDF * Args: * y: response vector * mu: positive mean parameter vector * shape: positive shape parameter * Returns: * a scalar to be added to the log posterior */ real inv_gaussian_lpdf(vector y, vector mu, real shape) { return 0.5 * rows(y) * log(shape / (2 * pi())) - 1.5 * sum(log(y)) - 0.5 * shape * dot_self((y - mu) ./ (mu .* sqrt(y))); } /* inverse Gaussian log-CDF for a single quantile * Args: * y: a quantile * mu: positive mean parameter * shape: positive shape parameter * Returns: * log(P(Y <= y)) */ real inv_gaussian_lcdf(real y, real mu, real shape) { return log(Phi(sqrt(shape) / sqrt(y) * (y / mu - 1)) + exp(2 * shape / mu) * Phi(-sqrt(shape) / sqrt(y) * (y / mu + 1))); } /* inverse Gaussian log-CCDF for a single quantile * Args: * y: a quantile * mu: positive mean parameter * shape: positive shape parameter * Returns: * log(P(Y > y)) */ real inv_gaussian_lccdf(real y, real mu, real shape) { return log1m(Phi(sqrt(shape) / sqrt(y) * (y / mu - 1)) - exp(2 * shape / mu) * Phi(-sqrt(shape) / sqrt(y) * (y / mu + 1))); } brms/inst/chunks/fun_spd_gp_exponential.stan0000644000176200001440000000222715053072461021114 0ustar liggesusers /* Spectral density function of a Gaussian process with exponential kernel * also known as the Matern 1/2 kernel * Args: * x: array of numeric values of dimension NB x D * sdgp: marginal SD parameter * lscale: vector of length-scale parameters * Returns: * numeric vector of length NB of the SPD evaluated at 'x' */ vector spd_gp_exponential(data array[] vector x, real sdgp, vector lscale) { int NB = dims(x)[1]; int D = dims(x)[2]; int Dls = rows(lscale); real constant = square(sdgp) * (2^D * pi()^(D / 2.0) * tgamma((D + 1.0) / 2)) / sqrt(pi()); real expo = -(D + 1.0) / 2; vector[NB] out; if (Dls == 1) { // one dimensional or isotropic GP real lscale2 = square(lscale[1]); constant = constant * lscale[1]^D; for (m in 1:NB) { out[m] = constant * (1 + lscale2 * dot_self(x[m]))^expo; } } else { // multi-dimensional non-isotropic GP vector[Dls] lscale2 = square(lscale); constant = constant * prod(lscale); for (m in 1:NB) { out[m] = constant * (1 + dot_product(lscale2, square(x[m])))^expo; } } return out; } brms/inst/chunks/fun_student_t_time.stan0000644000176200001440000000767614552264061020300 0ustar liggesusers /* multi-student-t log-PDF for time-series covariance structures * in Cholesky parameterization and assuming homogoneous variances * Args: * y: response vector * nu: degrees of freedom parameter * mu: mean parameter vector * sigma: scale parameter * chol_cor: cholesky factor of the correlation matrix * nobs: number of observations in each group * begin: the first observation in each group * end: the last observation in each group * Returns: * sum of the log-PDF values of all observations */ real student_t_time_hom_lpdf(vector y, real nu, vector mu, real sigma, matrix chol_cor, array[] int nobs, array[] int begin, array[] int end) { int I = size(nobs); vector[I] lp; for (i in 1:I) { matrix[nobs[i], nobs[i]] Cov_i; Cov_i = sigma * chol_cor[1:nobs[i], 1:nobs[i]]; Cov_i = multiply_lower_tri_self_transpose(Cov_i); lp[i] = multi_student_t_lpdf( y[begin[i]:end[i]] | nu, mu[begin[i]:end[i]], Cov_i ); } return sum(lp); } /* multi-student-t log-PDF for time-series covariance structures * in Cholesky parameterization and assuming heterogenous variances * Deviating Args: * sigma: residual scale vector * Returns: * sum of the log-PDF values of all observations */ real student_t_time_het_lpdf(vector y, real nu, vector mu, vector sigma, matrix chol_cor, array[] int nobs, array[] int begin, array[] int end) { int I = size(nobs); vector[I] lp; for (i in 1:I) { matrix[nobs[i], nobs[i]] Cov_i; Cov_i = diag_pre_multiply(sigma[begin[i]:end[i]], chol_cor[1:nobs[i], 1:nobs[i]]); Cov_i = multiply_lower_tri_self_transpose(Cov_i); lp[i] = multi_student_t_lpdf( y[begin[i]:end[i]] | nu, mu[begin[i]:end[i]], Cov_i ); } return sum(lp); } /* multi-student-t log-PDF for time-series covariance structures * in Cholesky parameterization and assuming homogoneous variances * allows for flexible correlation matrix subsets * Deviating Args: * Jtime: array of time indices per group * Returns: * sum of the log-PDF values of all observations */ real student_t_time_hom_flex_lpdf(vector y, real nu, vector mu, real sigma, matrix chol_cor, array[] int nobs, array[] int begin, array[] int end, array[,] int Jtime) { int I = size(nobs); vector[I] lp; matrix[rows(chol_cor), cols(chol_cor)] Cov; Cov = multiply_lower_tri_self_transpose(sigma * chol_cor); for (i in 1:I) { array[nobs[i]] int iobs = Jtime[i, 1:nobs[i]]; matrix[nobs[i], nobs[i]] Cov_i = Cov[iobs, iobs]; lp[i] = multi_student_t_lpdf( y[begin[i]:end[i]] | nu, mu[begin[i]:end[i]], Cov_i ); } return sum(lp); } /* multi-student-t log-PDF for time-series covariance structures * in Cholesky parameterization and assuming heterogenous variances * allows for flexible correlation matrix subsets * Deviating Args: * sigma: scale parameter vector * Jtime: array of time indices per group * Returns: * sum of the log-PDF values of all observations */ real student_t_time_het_flex_lpdf(vector y, real nu, vector mu, vector sigma, matrix chol_cor, array[] int nobs, array[] int begin, array[] int end, array[,] int Jtime) { int I = size(nobs); vector[I] lp; matrix[rows(chol_cor), cols(chol_cor)] Cor; Cor = multiply_lower_tri_self_transpose(chol_cor); for (i in 1:I) { array[nobs[i]] int iobs = Jtime[i, 1:nobs[i]]; matrix[nobs[i], nobs[i]] Cov_i; Cov_i = quad_form_diag(Cor[iobs, iobs], sigma[begin[i]:end[i]]); lp[i] = multi_student_t_lpdf( y[begin[i]:end[i]] | nu, mu[begin[i]:end[i]], Cov_i ); } return sum(lp); } brms/inst/chunks/fun_spd_gp_matern32.stan0000644000176200001440000000220615053072461020216 0ustar liggesusers /* Spectral density function of a Gaussian process with Matern 3/2 kernel * Args: * x: array of numeric values of dimension NB x D * sdgp: marginal SD parameter * lscale: vector of length-scale parameters * Returns: * numeric vector of length NB of the SPD evaluated at 'x' */ vector spd_gp_matern32(data array[] vector x, real sdgp, vector lscale) { int NB = dims(x)[1]; int D = dims(x)[2]; int Dls = rows(lscale); real constant = square(sdgp) * (2^D * pi()^(D / 2.0) * tgamma((D + 3.0) / 2) * 3^(3.0 / 2)) / (0.5 * sqrt(pi())); real expo = -(D + 3.0) / 2; vector[NB] out; if (Dls == 1) { // one dimensional or isotropic GP real lscale2 = square(lscale[1]); constant = constant * lscale[1]^D; for (m in 1:NB) { out[m] = constant * (3 + lscale2 * dot_self(x[m]))^expo; } } else { // multi-dimensional non-isotropic GP vector[Dls] lscale2 = square(lscale); constant = constant * prod(lscale); for (m in 1:NB) { out[m] = constant * (3 + dot_product(lscale2, square(x[m])))^expo; } } return out; } brms/inst/chunks/fun_is_equal.stan0000644000176200001440000000042314527413457017041 0ustar liggesusers // are two 1D integer arrays equal? int is_equal(array[] int a, array[] int b) { int n_a = size(a); int n_b = size(b); if (n_a != n_b) { return 0; } for (i in 1:n_a) { if (a[i] != b[i]) { return 0; } } return 1; } brms/inst/chunks/fun_squareplus.stan0000644000176200001440000000161414572627317017450 0ustar liggesusers /* squareplus inverse link function (squareplus itself) * Args: * x: a scalar in (-Inf, Inf) * Returns: * a positive scalar */ real squareplus(real x) { return (x + sqrt(square(x) + 4)) / 2; } /* squareplus inverse link function (squareplus itself; vectorized) * Args: * x: a vector in (-Inf, Inf) * Returns: * a positive vector */ vector squareplus(vector x) { return (x + sqrt(square(x) + 4)) / 2; } /* squareplus link function (inverse squareplus) * Args: * x: a positive scalar * Returns: * a scalar in (-Inf, Inf) */ real inv_squareplus(real x) { return (square(x) - 1) ./ x; } /* squareplus link function (inverse squareplus; vectorized) * Args: * x: a positive vector * Returns: * a vector in (-Inf, Inf) */ vector inv_squareplus(vector x) { return (square(x) - 1) ./ x; } brms/inst/doc/0000755000176200001440000000000015057753140012746 5ustar liggesusersbrms/inst/doc/brms_threading.R0000644000176200001440000003661315057753130016071 0ustar liggesusersparams <- list(EVAL = TRUE) ## ----SETTINGS-knitr, include=FALSE------------------------------------------------------ stopifnot(require(knitr)) options(width = 90) knit_hooks$set(pngquant = knitr::hook_pngquant) opts_chunk$set( comment = NA, message = FALSE, warning = FALSE, eval = if (isTRUE(exists("params"))) params$EVAL else FALSE, dev = "ragg_png", dpi = 72, fig.retina = 1.5, fig.asp = 0.8, fig.width = 5, out.width = "60%", fig.align = "center", pngquant = "--speed=1 --quality=50" ) library(ggplot2) library(brms) theme_set(theme_default()) ## ----fake-data-sim, include=FALSE, eval=TRUE-------------------------------------------- set.seed(54647) # number of observations N <- 1E4 # number of group levels G <- round(N / 10) # number of predictors P <- 3 # regression coefficients beta <- rnorm(P) # sampled covariates, group means and fake data fake <- matrix(rnorm(N * P), ncol = P) dimnames(fake) <- list(NULL, paste0("x", 1:P)) # fixed effect part and sampled group membership fake <- transform( as.data.frame(fake), theta = fake %*% beta, g = sample.int(G, N, replace=TRUE) ) # add random intercept by group fake <- merge(fake, data.frame(g = 1:G, eta = rnorm(G)), by = "g") # linear predictor fake <- transform(fake, mu = theta + eta) # sample Poisson data fake <- transform(fake, y = rpois(N, exp(mu))) # shuffle order of data rows to ensure even distribution of computational effort fake <- fake[sample.int(N, N),] # drop not needed row names rownames(fake) <- NULL ## ----model-poisson, include=FALSE------------------------------------------------------- model_poisson <- brm( y ~ 1 + x1 + x2 + (1 | g), data = fake, family = poisson(), iter = 500, # short sampling to speedup example chains = 2, prior = prior(normal(0,1), class = b) + prior(constant(1), class = sd, group = g), backend = "cmdstanr", threads = threading(4), save_pars = save_pars(all = TRUE) ) ## ----benchmark, include=FALSE----------------------------------------------------------- # Benchmarks given model with cross-product of tuning parameters CPU # cores, grainsize and iterations. Models are run with either static # or non-static scheduler and initial values are set by default to 0 on the # unconstrained scale. Function returns a data-frame with the # cross-product of the tuning parameters and as result column the # respective runtime. benchmark_threading <- function(model, cores = 1, grainsize = 1, iter = 100, static = FALSE) { winfo <- extract_warmup_info(model) sims <- rstan::extract(model$fit) init <- list(extract_draw(sims, 1)) scaling_model <- update( model, refresh = 0, threads = threading(1, grainsize = grainsize[1], static = static), chains = 1, iter = 2, backend = "cmdstanr" ) run_benchmark <- function(cores, size, iter) { bench_fit <- update( scaling_model, warmup=0, iter = iter, chains = 1, seed = 1234, init = init, refresh = 0, save_warmup=TRUE, threads = threading(cores, grainsize = size, static = static), inv_metric=winfo$inv_metric[[1]], step_size=winfo$step_size[[1]], adapt_engaged=FALSE ) lf <- sum(subset(nuts_params(bench_fit, inc_warmup=TRUE), Parameter=="n_leapfrog__")$Value) elapsed <- sum(colSums(rstan::get_elapsed_time(bench_fit$fit))) c(num_leapfrog=lf, runtime=elapsed) } cases <- expand.grid(cores = cores, grainsize = grainsize, iter = iter) res <- with(cases, mapply(run_benchmark, cores, grainsize, iter)) cbind(cases, as.data.frame(t(res))) } benchmark_reference <- function(model, iter=100, init=0) { winfo <- extract_warmup_info(model) sims <- rstan::extract(model$fit) init <- list(extract_draw(sims, 1)) ref_model <- update( model, refresh = 0, threads = NULL, chains = 1, iter = 2, backend = "cmdstanr" ) run_benchmark_ref <- function(iter_bench) { bench_fit <- update( ref_model, warmup=0, iter = iter_bench, chains = 1, seed = 1234, init = init, refresh = 0, inv_metric=winfo$inv_metric[[1]], step_size=winfo$step_size[[1]], adapt_engaged=FALSE ) lf <- sum(subset(nuts_params(bench_fit, inc_warmup=TRUE), Parameter=="n_leapfrog__")$Value) elapsed <- sum(colSums(rstan::get_elapsed_time(bench_fit$fit))) c(num_leapfrog=lf, runtime=elapsed) } ref <- sapply(iter, run_benchmark_ref) ref <- cbind(as.data.frame(t(ref)), iter=iter) ref } extract_warmup_info <- function(bfit) { adapt <- lapply(rstan::get_adaptation_info(bfit$fit), strsplit, split="\\n") step_size <- lapply(adapt, function(a) as.numeric(strsplit(a[[1]][[1]], " = ")[[1]][2])) inv_metric <- lapply(adapt, function(a) as.numeric(strsplit(sub("^# ", "", a[[1]][[3]]), ", ")[[1]])) list(step_size=step_size, inv_metric=inv_metric) } extract_draw <- function(sims, draw) { lapply(sims, brms:::slice, dim = 1, i = draw, drop = TRUE) } ## ----eval=FALSE------------------------------------------------------------------------- # fit_serial <- brm( # count ~ zAge + zBase * Trt + (1|patient), # data = epilepsy, family = poisson(), # chains = 4, cores = 4, backend = "cmdstanr" # ) ## ----eval=FALSE------------------------------------------------------------------------- # fit_parallel <- update( # fit_serial, chains = 2, cores = 2, # backend = "cmdstanr", threads = threading(2) # ) ## --------------------------------------------------------------------------------------- kable(head(fake, 10), digits = 3) ## ----eval=FALSE------------------------------------------------------------------------- # model_poisson <- brm( # y ~ 1 + x1 + x2 + (1 | g), # data = fake, # family = poisson(), # iter = 500, # short sampling to speedup example # chains = 2, # prior = prior(normal(0,1), class = b) + # prior(constant(1), class = sd, group = g), # backend = "cmdstanr", # threads = threading(4), # save_pars = save_pars(all = TRUE) # ) ## ----chunking-scale, message=FALSE, warning=FALSE, results='hide'----------------------- chunking_bench <- transform( data.frame(chunks = 4^(0:3)), grainsize = ceiling(N / chunks) ) iter_test <- c(10, 20, 40) # very short test runs scaling_chunking <- benchmark_threading( model_poisson, cores = 1, grainsize = chunking_bench$grainsize, # test various grainsizes iter = iter_test, static = TRUE # with static partitioner ) # run as reference the model *without* reduce_sum ref <- benchmark_reference(model_poisson, iter_test) # for additional data munging please refer to the appendix ## ----munge-chunking-scaling, include=FALSE---------------------------------------------- scaling_chunking <- merge(scaling_chunking, chunking_bench, by = "grainsize") single_chunk <- transform( subset(scaling_chunking, chunks == 1), num_leapfrog_single = num_leapfrog, num_leapfrog = NULL, runtime_single = runtime, runtime = NULL, grainsize = NULL, chunks=NULL ) scaling_chunking <- transform( merge(scaling_chunking, single_chunk), slowdown = runtime/runtime_single, iter = factor(iter), runtime_single = NULL ) ref <- transform(ref, iter=factor(iter)) ## --------------------------------------------------------------------------------------- ggplot(scaling_chunking) + aes(chunks, slowdown, colour = iter, shape = iter) + geom_line() + geom_point() + scale_x_log10(breaks = scaling_chunking$chunks) + scale_y_log10(breaks=seq(0.8, 2.5, by=0.1)) + ggtitle("Slowdown with increasing number of chunks") ggplot(scaling_chunking) + aes(chunks, 1E3 * runtime/num_leapfrog, colour = iter, shape=iter) + geom_line() + geom_point() + scale_x_log10(breaks = scaling_chunking$chunks) + scale_y_log10(breaks=seq(0.1, 2.0, by=0.1)) + geom_hline(data=ref, aes(yintercept=1E3 * runtime/num_leapfrog, colour=iter), linetype=I(2)) + ggtitle("Time per leapfrog step vs number of chunks", "Dashed line is reference model without reduce_sum") + ylab("Time per leapfrog step [ms]") ## ----speedup-scale, message=FALSE, warning=FALSE, results='hide'------------------------ num_cpu <- parallel::detectCores(logical = FALSE) num_cpu_logical <- parallel::detectCores(logical = TRUE) grainsize_default <- ceiling(N / (2 * num_cpu)) cores <- c(2^seq(0, floor(log2(num_cpu_logical))), num_cpu, num_cpu_logical) cores <- sort(unique(cores)) grainsize <- c(grainsize_default, grainsize_default/2, grainsize_default/4) grainsize <- round(grainsize) iter_scaling <- 20 scaling_cores <- benchmark_threading( model_poisson, cores = cores, grainsize = grainsize, iter = iter_scaling, static = FALSE ) single_core <- transform( subset(scaling_cores, cores == 1), runtime_single = runtime, num_leapfrog=NULL, runtime=NULL, cores = NULL ) scaling_cores <- transform( merge(scaling_cores, single_core), speedup = runtime_single/runtime, grainsize = factor(grainsize) ) ## --------------------------------------------------------------------------------------- ggplot(scaling_cores) + aes(cores, runtime, shape = grainsize, color = grainsize) + geom_vline(xintercept = num_cpu, linetype = 3) + geom_line() + geom_point() + scale_x_log10(breaks = scaling_cores$cores) + scale_y_log10(breaks=seq(0.1, 1.4, by=0.1)) + theme(legend.position = c(0.85, 0.8)) + geom_hline(data=subset(ref, iter==iter_scaling), aes(yintercept=runtime), linetype=I(2)) + ggtitle("Runtime with varying number of cores", "Dashed line is reference model without reduce_sum") ggplot(scaling_cores) + aes(cores, speedup, shape = grainsize, color = grainsize) + geom_abline(slope = 1, intercept = 0, linetype = 2) + geom_vline(xintercept = num_cpu, linetype = 3) + geom_line() + geom_point() + scale_x_log10(breaks=scaling_cores$cores) + scale_y_log10(breaks=scaling_cores$cores) + theme(aspect.ratio = 1) + coord_fixed(xlim = c(1, num_cpu_logical), ylim = c(1, num_cpu_logical)) + ggtitle("Relative speedup vs 1 core") ## --------------------------------------------------------------------------------------- kable(scaling_cores, digits = 2) ## ----eval=FALSE------------------------------------------------------------------------- # set.seed(54647) # # number of observations # N <- 1E4 # # number of group levels # G <- round(N / 10) # # number of predictors # P <- 3 # # regression coefficients # beta <- rnorm(P) # # # sampled covariates, group means and fake data # fake <- matrix(rnorm(N * P), ncol = P) # dimnames(fake) <- list(NULL, paste0("x", 1:P)) # # # fixed effect part and sampled group membership # fake <- transform( # as.data.frame(fake), # theta = fake %*% beta, # g = sample.int(G, N, replace=TRUE) # ) # # # add random intercept by group # fake <- merge(fake, data.frame(g = 1:G, eta = rnorm(G)), by = "g") # # # linear predictor # fake <- transform(fake, mu = theta + eta) # # # sample Poisson data # fake <- transform(fake, y = rpois(N, exp(mu))) # # # shuffle order of data rows to ensure even distribution of computational effort # fake <- fake[sample.int(N, N),] # # # drop not needed row names # rownames(fake) <- NULL ## ----eval=FALSE------------------------------------------------------------------------- # model_poisson <- brm( # y ~ 1 + x1 + x2 + (1 | g), # data = fake, # family = poisson(), # iter = 500, # short sampling to speedup example # chains = 2, # prior = prior(normal(0,1), class = b) + # prior(constant(1), class = sd, group = g), # backend = "cmdstanr", # threads = threading(4), # save_pars = save_pars(all = TRUE) # ) ## ----eval=FALSE------------------------------------------------------------------------- # # Benchmarks given model with cross-product of tuning parameters CPU # # cores, grainsize and iterations. Models are run with either static # # or non-static scheduler and initial values are set by default to 0 on the # # unconstrained scale. Function returns a data-frame with the # # cross-product of the tuning parameters and as result column the # # respective runtime. # benchmark_threading <- function(model, cores = 1, grainsize = 1, iter = 100, # static = FALSE) { # # winfo <- extract_warmup_info(model) # sims <- rstan::extract(model$fit) # init <- list(extract_draw(sims, 1)) # # scaling_model <- update( # model, refresh = 0, # threads = threading(1, grainsize = grainsize[1], static = static), # chains = 1, iter = 2, backend = "cmdstanr" # ) # # run_benchmark <- function(cores, size, iter) { # bench_fit <- update( # scaling_model, warmup=0, iter = iter, # chains = 1, seed = 1234, init = init, refresh = 0, save_warmup=TRUE, # threads = threading(cores, grainsize = size, static = static), # inv_metric=winfo$inv_metric[[1]], # step_size=winfo$step_size[[1]], # adapt_engaged=FALSE # ) # lf <- sum(subset(nuts_params(bench_fit, inc_warmup=TRUE), Parameter=="n_leapfrog__")$Value) # elapsed <- sum(colSums(rstan::get_elapsed_time(bench_fit$fit))) # # c(num_leapfrog=lf, runtime=elapsed) # } # # cases <- expand.grid(cores = cores, grainsize = grainsize, iter = iter) # res <- with(cases, mapply(run_benchmark, cores, grainsize, iter)) # cbind(cases, as.data.frame(t(res))) # } # # benchmark_reference <- function(model, iter=100, init=0) { # winfo <- extract_warmup_info(model) # sims <- rstan::extract(model$fit) # init <- list(extract_draw(sims, 1)) # # ref_model <- update( # model, refresh = 0, threads = NULL, # chains = 1, iter = 2, backend = "cmdstanr" # ) # # run_benchmark_ref <- function(iter_bench) { # bench_fit <- update( # ref_model, warmup=0, iter = iter_bench, # chains = 1, seed = 1234, init = init, refresh = 0, # inv_metric=winfo$inv_metric[[1]], # step_size=winfo$step_size[[1]], # adapt_engaged=FALSE # ) # # lf <- sum(subset(nuts_params(bench_fit, inc_warmup=TRUE), Parameter=="n_leapfrog__")$Value) # elapsed <- sum(colSums(rstan::get_elapsed_time(bench_fit$fit))) # # c(num_leapfrog=lf, runtime=elapsed) # } # # ref <- sapply(iter, run_benchmark_ref) # ref <- cbind(as.data.frame(t(ref)), iter=iter) # ref # } # # extract_warmup_info <- function(bfit) { # adapt <- lapply(rstan::get_adaptation_info(bfit$fit), strsplit, split="\\n") # step_size <- lapply(adapt, function(a) as.numeric(strsplit(a[[1]][[1]], " = ")[[1]][2])) # inv_metric <- lapply(adapt, function(a) as.numeric(strsplit(sub("^# ", "", a[[1]][[3]]), ", ")[[1]])) # list(step_size=step_size, inv_metric=inv_metric) # } # # extract_draw <- function(sims, draw) { # lapply(sims, brms:::slice, dim = 1, i = draw, drop = TRUE) # } ## ----eval=FALSE------------------------------------------------------------------------- # scaling_chunking <- merge(scaling_chunking, chunking_bench, by = "grainsize") # # single_chunk <- transform( # subset(scaling_chunking, chunks == 1), # num_leapfrog_single = num_leapfrog, num_leapfrog = NULL, # runtime_single = runtime, runtime = NULL, # grainsize = NULL, chunks=NULL # ) # # scaling_chunking <- transform( # merge(scaling_chunking, single_chunk), # slowdown = runtime/runtime_single, # iter = factor(iter), # runtime_single = NULL # ) # # ref <- transform(ref, iter=factor(iter)) brms/inst/doc/brms_phylogenetics.html0000644000176200001440000152311715057753012017544 0ustar liggesusers Estimating Phylogenetic Multilevel Models with brms

Estimating Phylogenetic Multilevel Models with brms

Paul Bürkner

2025-09-09

Introduction

In the present vignette, we want to discuss how to specify phylogenetic multilevel models using brms. These models are relevant in evolutionary biology when data of many species are analyzed at the same time. The usual approach would be to model species as a grouping factor in a multilevel model and estimate varying intercepts (and possibly also varying slopes) over species. However, species are not independent as they come from the same phylogenetic tree and we thus have to adjust our model to incorporate this dependency. The examples discussed here are from chapter 11 of the book Modern Phylogenetic Comparative Methods and the application in Evolutionary Biology (de Villemeruil & Nakagawa, 2014). The necessary data can be downloaded from the corresponding website (https://www.mpcm-evolution.com/). Some of these models may take a few minutes to fit.

A Simple Phylogenetic Model

Assume we have measurements of a phenotype, phen (say the body size), and a cofactor variable (say the temperature of the environment). We prepare the data using the following code.

phylo <- ape::read.nexus("https://paul-buerkner.github.io/data/phylo.nex")
data_simple <- read.table(
  "https://paul-buerkner.github.io/data/data_simple.txt",
  header = TRUE
)
head(data_simple)
       phen  cofactor phylo
1 107.06595 10.309588  sp_1
2  79.61086  9.690507  sp_2
3 116.38186 15.007825  sp_3
4 143.28705 19.087673  sp_4
5 139.60993 15.658404  sp_5
6  68.50657  6.005236  sp_6

The phylo object contains information on the relationship between species. Using this information, we can construct a covariance matrix of species (Hadfield & Nakagawa, 2010).

A <- ape::vcv.phylo(phylo)

Now we are ready to fit our first phylogenetic multilevel model:

model_simple <- brm(
  phen ~ cofactor + (1|gr(phylo, cov = A)),
  data = data_simple,
  family = gaussian(),
  data2 = list(A = A),
  prior = c(
    prior(normal(0, 10), "b"),
    prior(normal(0, 50), "Intercept"),
    prior(student_t(3, 0, 20), "sd"),
    prior(student_t(3, 0, 20), "sigma")
  )
)

With the exception of (1|gr(phylo, cov = A)) instead of (1|phylo) this is a basic multilevel model with a varying intercept over species (phylo is an indicator of species in this data set). However, by using cov = A in the gr function, we make sure that species are correlated as specified by the covariance matrix A. We pass A itself via the data2 argument which can be used for any kinds of data that does not fit into the regular structure of the data argument. Setting priors is not required for achieving good convergence for this model, but it improves sampling speed a bit. After fitting, the results can be investigated in detail.

summary(model_simple)
 Family: gaussian 
  Links: mu = identity 
Formula: phen ~ cofactor + (1 | gr(phylo, cov = A)) 
   Data: data_simple (Number of observations: 200) 
  Draws: 4 chains, each with iter = 2000; warmup = 1000; thin = 1;
         total post-warmup draws = 4000

Multilevel Hyperparameters:
~phylo (Number of levels: 200) 
              Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
sd(Intercept)    14.38      2.10    10.43    18.62 1.00      987     1754

Regression Coefficients:
          Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
Intercept    38.38      6.92    24.09    51.70 1.00     2085     2633
cofactor      5.17      0.14     4.90     5.45 1.00     6236     3311

Further Distributional Parameters:
      Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
sigma     9.24      0.72     7.91    10.71 1.00     1364     2240

Draws were sampled using sampling(NUTS). For each parameter, Bulk_ESS
and Tail_ESS are effective sample size measures, and Rhat is the potential
scale reduction factor on split chains (at convergence, Rhat = 1).
plot(model_simple, N = 2, ask = FALSE)

plot(conditional_effects(model_simple), points = TRUE)

The so called phylogenetic signal (often symbolize by \(\lambda\)) can be computed with the hypothesis method and is roughly \(\lambda = 0.7\) for this example.

hyp <- "sd_phylo__Intercept^2 / (sd_phylo__Intercept^2 + sigma^2) = 0"
(hyp <- hypothesis(model_simple, hyp, class = NULL))
Hypothesis Tests for class :
                Hypothesis Estimate Est.Error CI.Lower CI.Upper Evid.Ratio Post.Prob Star
1 (sd_phylo__Interc... = 0      0.7      0.08     0.51     0.83         NA        NA    *
---
'CI': 90%-CI for one-sided and 95%-CI for two-sided hypotheses.
'*': For one-sided hypotheses, the posterior probability exceeds 95%;
for two-sided hypotheses, the value tested against lies outside the 95%-CI.
Posterior probabilities of point hypotheses assume equal prior probabilities.
plot(hyp)

Note that the phylogenetic signal is just a synonym of the intra-class correlation (ICC) used in the context phylogenetic analysis.

A Phylogenetic Model with Repeated Measurements

Often, we have multiple observations per species and this allows to fit more complicated phylogenetic models.

data_repeat <- read.table(
  "https://paul-buerkner.github.io/data/data_repeat.txt",
  header = TRUE
)
data_repeat$spec_mean_cf <-
  with(data_repeat, sapply(split(cofactor, phylo), mean)[phylo])
head(data_repeat)
       phen  cofactor species phylo spec_mean_cf
1 107.41919 11.223724    sp_1  sp_1    10.309588
2 109.16403  9.805934    sp_1  sp_1    10.309588
3  91.88672 10.308423    sp_1  sp_1    10.309588
4 121.54341  8.355349    sp_1  sp_1    10.309588
5 105.31638 11.854510    sp_1  sp_1    10.309588
6  64.99859  4.314015    sp_2  sp_2     3.673914

The variable spec_mean_cf just contains the mean of the cofactor for each species. The code for the repeated measurement phylogenetic model looks as follows:

model_repeat1 <- brm(
  phen ~ spec_mean_cf + (1|gr(phylo, cov = A)) + (1|species),
  data = data_repeat,
  family = gaussian(),
  data2 = list(A = A),
  prior = c(
    prior(normal(0,10), "b"),
    prior(normal(0,50), "Intercept"),
    prior(student_t(3,0,20), "sd"),
    prior(student_t(3,0,20), "sigma")
  ),
  sample_prior = TRUE, chains = 2, cores = 2,
  iter = 4000, warmup = 1000
)

The variables phylo and species are identical as they are both identifiers of the species. However, we model the phylogenetic covariance only for phylo and thus the species variable accounts for any specific effect that would be independent of the phylogenetic relationship between species (e.g., environmental or niche effects). Again we can obtain model summaries as well as estimates of the phylogenetic signal.

summary(model_repeat1)
 Family: gaussian 
  Links: mu = identity 
Formula: phen ~ spec_mean_cf + (1 | gr(phylo, cov = A)) + (1 | species) 
   Data: data_repeat (Number of observations: 1000) 
  Draws: 2 chains, each with iter = 4000; warmup = 1000; thin = 1;
         total post-warmup draws = 6000

Multilevel Hyperparameters:
~phylo (Number of levels: 200) 
              Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
sd(Intercept)    16.48      1.93    12.89    20.54 1.00     1209     1927

~species (Number of levels: 200) 
              Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
sd(Intercept)     4.96      0.86     3.18     6.56 1.00      993     1293

Regression Coefficients:
             Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
Intercept       35.94      7.92    20.59    51.41 1.00     3262     3487
spec_mean_cf     5.10      0.11     4.89     5.31 1.00     6767     4285

Further Distributional Parameters:
      Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
sigma     8.11      0.20     7.72     8.52 1.00     5406     3733

Draws were sampled using sampling(NUTS). For each parameter, Bulk_ESS
and Tail_ESS are effective sample size measures, and Rhat is the potential
scale reduction factor on split chains (at convergence, Rhat = 1).
hyp <- paste(
  "sd_phylo__Intercept^2 /",
  "(sd_phylo__Intercept^2 + sd_species__Intercept^2 + sigma^2) = 0"
)
(hyp <- hypothesis(model_repeat1, hyp, class = NULL))
Hypothesis Tests for class :
                Hypothesis Estimate Est.Error CI.Lower CI.Upper Evid.Ratio Post.Prob Star
1 (sd_phylo__Interc... = 0     0.74      0.06     0.62     0.84          0         0    *
---
'CI': 90%-CI for one-sided and 95%-CI for two-sided hypotheses.
'*': For one-sided hypotheses, the posterior probability exceeds 95%;
for two-sided hypotheses, the value tested against lies outside the 95%-CI.
Posterior probabilities of point hypotheses assume equal prior probabilities.
plot(hyp)

So far, we have completely ignored the variability of the cofactor within species. To incorporate this into the model, we define

data_repeat$within_spec_cf <- data_repeat$cofactor - data_repeat$spec_mean_cf

and then fit it again using within_spec_cf as an additional predictor.

model_repeat2 <- update(
  model_repeat1, formula = ~ . + within_spec_cf,
  newdata = data_repeat, chains = 2, cores = 2,
  iter = 4000, warmup = 1000
)

The results are almost unchanged, with apparently no relationship between the phenotype and the within species variance of cofactor.

summary(model_repeat2)
 Family: gaussian 
  Links: mu = identity 
Formula: phen ~ spec_mean_cf + (1 | gr(phylo, cov = A)) + (1 | species) + within_spec_cf 
   Data: data_repeat (Number of observations: 1000) 
  Draws: 2 chains, each with iter = 4000; warmup = 1000; thin = 1;
         total post-warmup draws = 6000

Multilevel Hyperparameters:
~phylo (Number of levels: 200) 
              Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
sd(Intercept)    16.38      1.86    12.99    20.21 1.00     1114     2039

~species (Number of levels: 200) 
              Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
sd(Intercept)     4.98      0.83     3.36     6.67 1.00      967     1608

Regression Coefficients:
               Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
Intercept         36.13      7.89    20.64    51.62 1.00     2595     3088
spec_mean_cf       5.10      0.10     4.89     5.31 1.00     5425     4374
within_spec_cf    -0.06      0.19    -0.43     0.30 1.00    11877     4202

Further Distributional Parameters:
      Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
sigma     8.11      0.20     7.73     8.53 1.00     6005     4372

Draws were sampled using sampling(NUTS). For each parameter, Bulk_ESS
and Tail_ESS are effective sample size measures, and Rhat is the potential
scale reduction factor on split chains (at convergence, Rhat = 1).

Also, the phylogenetic signal remains more or less the same.

hyp <- paste(
  "sd_phylo__Intercept^2 /",
  "(sd_phylo__Intercept^2 + sd_species__Intercept^2 + sigma^2) = 0"
)
(hyp <- hypothesis(model_repeat2, hyp, class = NULL))
Hypothesis Tests for class :
                Hypothesis Estimate Est.Error CI.Lower CI.Upper Evid.Ratio Post.Prob Star
1 (sd_phylo__Interc... = 0     0.74      0.06     0.62     0.83          0         0    *
---
'CI': 90%-CI for one-sided and 95%-CI for two-sided hypotheses.
'*': For one-sided hypotheses, the posterior probability exceeds 95%;
for two-sided hypotheses, the value tested against lies outside the 95%-CI.
Posterior probabilities of point hypotheses assume equal prior probabilities.

A Phylogenetic Meta-Analysis

Let’s say we have Fisher’s z-transformed correlation coefficients \(Zr\) per species along with corresponding sample sizes (e.g., correlations between male coloration and reproductive success):

data_fisher <- read.table(
  "https://paul-buerkner.github.io/data/data_effect.txt",
  header = TRUE
)
data_fisher$obs <- 1:nrow(data_fisher)
head(data_fisher)
          Zr  N phylo obs
1 0.28917549 13  sp_1   1
2 0.02415579 40  sp_2   2
3 0.19513651 39  sp_3   3
4 0.09831239 40  sp_4   4
5 0.13780152 66  sp_5   5
6 0.13710587 41  sp_6   6

We assume the sampling variance to be known and as \(V(Zr) = \frac{1}{N - 3}\) for Fisher’s values, where \(N\) is the sample size per species. Incorporating the known sampling variance into the model is straight forward. One has to keep in mind though, that brms requires the sampling standard deviation (square root of the variance) as input instead of the variance itself. The group-level effect of obs represents the residual variance, which we have to model explicitly in a meta-analytic model.

model_fisher <- brm(
  Zr | se(sqrt(1 / (N - 3))) ~ 1 + (1|gr(phylo, cov = A)) + (1|obs),
  data = data_fisher, family = gaussian(),
  data2 = list(A = A),
  prior = c(
    prior(normal(0, 10), "Intercept"),
    prior(student_t(3, 0, 10), "sd")
  ),
  control = list(adapt_delta = 0.95),
  chains = 2, cores = 2, iter = 4000, warmup = 1000
)

A summary of the fitted model is obtained via

summary(model_fisher)
 Family: gaussian 
  Links: mu = identity 
Formula: Zr | se(sqrt(1/(N - 3))) ~ 1 + (1 | gr(phylo, cov = A)) + (1 | obs) 
   Data: data_fisher (Number of observations: 200) 
  Draws: 2 chains, each with iter = 4000; warmup = 1000; thin = 1;
         total post-warmup draws = 6000

Multilevel Hyperparameters:
~obs (Number of levels: 200) 
              Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
sd(Intercept)     0.05      0.03     0.00     0.10 1.00      751     1293

~phylo (Number of levels: 200) 
              Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
sd(Intercept)     0.07      0.04     0.00     0.15 1.00      751     1498

Regression Coefficients:
          Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
Intercept     0.16      0.04     0.08     0.25 1.00     2692     2344

Further Distributional Parameters:
      Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
sigma     0.00      0.00     0.00     0.00   NA       NA       NA

Draws were sampled using sampling(NUTS). For each parameter, Bulk_ESS
and Tail_ESS are effective sample size measures, and Rhat is the potential
scale reduction factor on split chains (at convergence, Rhat = 1).
plot(model_fisher)

The meta-analytic mean (i.e., the model intercept) is \(0.16\) with a credible interval of \([0.08, 0.25]\). Thus the mean correlation across species is positive according to the model.

A phylogenetic count-data model

Suppose that we analyze a phenotype that consists of counts instead of being a continuous variable. In such a case, the normality assumption will likely not be justified and it is recommended to use a distribution explicitly suited for count data, for instance the Poisson distribution. The following data set (again retrieved from mpcm-evolution.org) provides an example.

data_pois <- read.table(
  "https://paul-buerkner.github.io/data/data_pois.txt",
  header = TRUE
)
data_pois$obs <- 1:nrow(data_pois)
head(data_pois)
  phen_pois   cofactor phylo obs
1         1  7.8702830  sp_1   1
2         0  3.4690529  sp_2   2
3         1  2.5478774  sp_3   3
4        14 18.2286628  sp_4   4
5         1  2.5302806  sp_5   5
6         1  0.5145559  sp_6   6

As the Poisson distribution does not have a natural overdispersion parameter, we model the residual variance via the group-level effects of obs (e.g., see Lawless, 1987).

model_pois <- brm(
  phen_pois ~ cofactor + (1|gr(phylo, cov = A)) + (1|obs),
  data = data_pois, family = poisson("log"),
  data2 = list(A = A),
  chains = 2, cores = 2, iter = 4000,
  control = list(adapt_delta = 0.95)
)

Again, we obtain a summary of the fitted model via

summary(model_pois)
 Family: poisson 
  Links: mu = log 
Formula: phen_pois ~ cofactor + (1 | gr(phylo, cov = A)) + (1 | obs) 
   Data: data_pois (Number of observations: 200) 
  Draws: 2 chains, each with iter = 4000; warmup = 2000; thin = 1;
         total post-warmup draws = 4000

Multilevel Hyperparameters:
~obs (Number of levels: 200) 
              Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
sd(Intercept)     0.19      0.08     0.02     0.34 1.00      513      509

~phylo (Number of levels: 200) 
              Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
sd(Intercept)     0.18      0.10     0.02     0.42 1.01      584     1188

Regression Coefficients:
          Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
Intercept    -2.09      0.20    -2.49    -1.70 1.00     2157     2357
cofactor      0.25      0.01     0.23     0.27 1.00     3466     3038

Draws were sampled using sampling(NUTS). For each parameter, Bulk_ESS
and Tail_ESS are effective sample size measures, and Rhat is the potential
scale reduction factor on split chains (at convergence, Rhat = 1).
plot(conditional_effects(model_pois), points = TRUE)

Now, assume we ignore the fact that the phenotype is count data and fit a linear normal model instead.

model_normal <- brm(
  phen_pois ~ cofactor + (1|gr(phylo, cov = A)),
  data = data_pois, family = gaussian(),
  data2 = list(A = A),
  chains = 2, cores = 2, iter = 4000,
  control = list(adapt_delta = 0.95)
)
summary(model_normal)
 Family: gaussian 
  Links: mu = identity 
Formula: phen_pois ~ cofactor + (1 | gr(phylo, cov = A)) 
   Data: data_pois (Number of observations: 200) 
  Draws: 2 chains, each with iter = 4000; warmup = 2000; thin = 1;
         total post-warmup draws = 4000

Multilevel Hyperparameters:
~phylo (Number of levels: 200) 
              Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
sd(Intercept)     0.67      0.48     0.03     1.78 1.00     1264     2013

Regression Coefficients:
          Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
Intercept    -3.05      0.61    -4.31    -1.88 1.00     4559     2783
cofactor      0.68      0.04     0.60     0.76 1.00     7806     2528

Further Distributional Parameters:
      Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
sigma     3.44      0.18     3.11     3.81 1.00     5621     2727

Draws were sampled using sampling(NUTS). For each parameter, Bulk_ESS
and Tail_ESS are effective sample size measures, and Rhat is the potential
scale reduction factor on split chains (at convergence, Rhat = 1).

We see that cofactor has a positive relationship with the phenotype in both models. One should keep in mind, though, that the estimates of the Poisson model are on the log-scale, as we applied the canonical log-link function in this example. Therefore, estimates are not comparable to a linear normal model even if applied to the same data. What we can compare, however, is the model fit, for instance graphically via posterior predictive checks.

pp_check(model_pois)

pp_check(model_normal)

Apparently, the distribution of the phenotype predicted by the Poisson model resembles the original distribution of the phenotype pretty closely, while the normal models fails to do so. We can also apply leave-one-out cross-validation for direct numerical comparison of model fit.

loo(model_pois, model_normal)
Output of model 'model_pois':

Computed from 4000 by 200 log-likelihood matrix.

         Estimate   SE
elpd_loo   -348.1 17.0
p_loo        30.7  3.5
looic       696.2 33.9
------
MCSE of elpd_loo is NA.
MCSE and ESS estimates assume MCMC draws (r_eff in [0.4, 1.4]).

Pareto k diagnostic values:
                         Count Pct.    Min. ESS
(-Inf, 0.7]   (good)     195   97.5%   253     
   (0.7, 1]   (bad)        5    2.5%   <NA>    
   (1, Inf)   (very bad)   0    0.0%   <NA>    
See help('pareto-k-diagnostic') for details.

Output of model 'model_normal':

Computed from 4000 by 200 log-likelihood matrix.

         Estimate   SE
elpd_loo   -535.9 15.9
p_loo         9.8  2.2
looic      1071.9 31.7
------
MCSE of elpd_loo is 0.1.
MCSE and ESS estimates assume MCMC draws (r_eff in [0.6, 1.8]).

All Pareto k estimates are good (k < 0.7).
See help('pareto-k-diagnostic') for details.

Model comparisons:
             elpd_diff se_diff
model_pois      0.0       0.0 
model_normal -187.8      18.0

Since smaller values of loo indicate better fit, it is again evident that the Poisson model fits the data better than the normal model. Of course, the Poisson model is not the only reasonable option here. For instance, you could use a negative binomial model (via family negative_binomial), which already contains an overdispersion parameter so that modeling a varying intercept of obs becomes obsolete.

Phylogenetic models with multiple group-level effects

In the above examples, we have only used a single group-level effect (i.e., a varying intercept) for the phylogenetic grouping factors. In brms, it is also possible to estimate multiple group-level effects (e.g., a varying intercept and a varying slope) for these grouping factors. However, it requires repeatedly computing Kronecker products of covariance matrices while fitting the model. This will be very slow especially when the grouping factors have many levels and matrices are thus large.

References

de Villemeruil P. & Nakagawa, S. (2014) General quantitative genetic methods for comparative biology. In: Modern phylogenetic comparative methods and their application in evolutionary biology: concepts and practice (ed. Garamszegi L.) Springer, New York. pp. 287-303.

Hadfield, J. D. & Nakagawa, S. (2010) General quantitative genetic methods for comparative biology: phylogenies, taxonomies, and multi-trait models for continuous and categorical characters. Journal of Evolutionary Biology. 23. 494-508.

Lawless, J. F. (1987). Negative binomial and mixed Poisson regression. Canadian Journal of Statistics, 15(3), 209-225.

brms/inst/doc/brms_nonlinear.R0000644000176200001440000001050215057752401016076 0ustar liggesusersparams <- list(EVAL = TRUE) ## ----SETTINGS-knitr, include=FALSE------------------------------------------------------ stopifnot(require(knitr)) options(width = 90) knit_hooks$set(pngquant = knitr::hook_pngquant) opts_chunk$set( comment = NA, message = FALSE, warning = FALSE, eval = if (isTRUE(exists("params"))) params$EVAL else FALSE, dev = "ragg_png", dpi = 72, fig.retina = 1.5, fig.asp = 0.8, fig.width = 5, out.width = "60%", fig.align = "center", pngquant = "--speed=1 --quality=50" ) library(brms) ggplot2::theme_set(theme_default()) ## --------------------------------------------------------------------------------------- b <- c(2, 0.75) x <- rnorm(100) y <- rnorm(100, mean = b[1] * exp(b[2] * x)) dat1 <- data.frame(x, y) ## ----results='hide'--------------------------------------------------------------------- prior1 <- prior(normal(1, 2), nlpar = "b1") + prior(normal(0, 2), nlpar = "b2") fit1 <- brm(bf(y ~ b1 * exp(b2 * x), b1 + b2 ~ 1, nl = TRUE), data = dat1, prior = prior1) ## --------------------------------------------------------------------------------------- summary(fit1) plot(fit1) plot(conditional_effects(fit1), points = TRUE) ## ----results='hide'--------------------------------------------------------------------- fit2 <- brm(y ~ x, data = dat1) ## --------------------------------------------------------------------------------------- summary(fit2) ## --------------------------------------------------------------------------------------- pp_check(fit1) pp_check(fit2) ## --------------------------------------------------------------------------------------- loo(fit1, fit2) ## --------------------------------------------------------------------------------------- data(loss) head(loss) ## ----results='hide'--------------------------------------------------------------------- fit_loss <- brm( bf(cum ~ ult * (1 - exp(-(dev/theta)^omega)), ult ~ 1 + (1|AY), omega ~ 1, theta ~ 1, nl = TRUE), data = loss, family = gaussian(), prior = c( prior(normal(5000, 1000), nlpar = "ult"), prior(normal(1, 2), nlpar = "omega"), prior(normal(45, 10), nlpar = "theta") ), control = list(adapt_delta = 0.9) ) ## --------------------------------------------------------------------------------------- summary(fit_loss) plot(fit_loss, N = 3, ask = FALSE) conditional_effects(fit_loss) ## --------------------------------------------------------------------------------------- conditions <- data.frame(AY = unique(loss$AY)) rownames(conditions) <- unique(loss$AY) me_loss <- conditional_effects( fit_loss, conditions = conditions, re_formula = NULL, method = "predict" ) plot(me_loss, ncol = 5, points = TRUE) ## --------------------------------------------------------------------------------------- inv_logit <- function(x) 1 / (1 + exp(-x)) ability <- rnorm(300) p <- 0.33 + 0.67 * inv_logit(ability) answer <- ifelse(runif(300, 0, 1) < p, 1, 0) dat_ir <- data.frame(ability, answer) ## ----results='hide'--------------------------------------------------------------------- fit_ir1 <- brm(answer ~ ability, data = dat_ir, family = bernoulli()) ## --------------------------------------------------------------------------------------- summary(fit_ir1) plot(conditional_effects(fit_ir1), points = TRUE) ## ----results='hide'--------------------------------------------------------------------- fit_ir2 <- brm( bf(answer ~ 0.33 + 0.67 * inv_logit(eta), eta ~ ability, nl = TRUE), data = dat_ir, family = bernoulli("identity"), prior = prior(normal(0, 5), nlpar = "eta") ) ## --------------------------------------------------------------------------------------- summary(fit_ir2) plot(conditional_effects(fit_ir2), points = TRUE) ## --------------------------------------------------------------------------------------- loo(fit_ir1, fit_ir2) ## ----results='hide'--------------------------------------------------------------------- fit_ir3 <- brm( bf(answer ~ guess + (1 - guess) * inv_logit(eta), eta ~ 0 + ability, guess ~ 1, nl = TRUE), data = dat_ir, family = bernoulli("identity"), prior = c( prior(normal(0, 5), nlpar = "eta"), prior(beta(1, 1), nlpar = "guess", lb = 0, ub = 1) ) ) ## --------------------------------------------------------------------------------------- summary(fit_ir3) plot(fit_ir3) plot(conditional_effects(fit_ir3), points = TRUE) brms/inst/doc/brms_missings.Rmd0000644000176200001440000002521115053072461016266 0ustar liggesusers--- title: "Handle Missing Values with brms" author: "Paul Bürkner" date: "`r Sys.Date()`" output: rmarkdown::html_vignette: toc: yes vignette: > %\VignetteIndexEntry{Handle Missing Values with brms} \usepackage[utf8]{inputenc} %\VignetteEngine{knitr::rmarkdown} params: EVAL: !r identical(Sys.getenv("NOT_CRAN"), "true") --- ```{r, SETTINGS-knitr, include=FALSE} stopifnot(require(knitr)) options(width = 90) knit_hooks$set(pngquant = knitr::hook_pngquant) opts_chunk$set( comment = NA, message = FALSE, warning = FALSE, eval = if (isTRUE(exists("params"))) params$EVAL else FALSE, dev = "ragg_png", dpi = 72, fig.retina = 1.5, fig.asp = 0.8, fig.width = 5, out.width = "60%", fig.align = "center", pngquant = "--speed=1 --quality=50" ) library(brms) ggplot2::theme_set(theme_default()) ``` ## Introduction Many real world data sets contain missing values for various reasons. Generally, we have quite a few options to handle those missing values. The easiest solution is to remove all rows from the data set, where one or more variables are missing. However, if values are not missing completely at random, this will likely lead to bias in our analysis. Accordingly, we usually want to impute missing values in one way or the other. Here, we will consider two very general approaches using **brms**: (1) Impute missing values *before* the model fitting with multiple imputation, and (2) impute missing values on the fly *during* model fitting[^1]. As a simple example, we will use the `nhanes` data set, which contains information on participants' `age`, `bmi` (body mass index), `hyp` (hypertensive), and `chl` (total serum cholesterol). For the purpose of the present vignette, we are primarily interested in predicting `bmi` by `age` and `chl`. ```{r} data("nhanes", package = "mice") head(nhanes) ``` ## Imputation before model fitting There are many approaches allowing us to impute missing data before the actual model fitting takes place. From a statistical perspective, multiple imputation is one of the best solutions. Each missing value is not imputed once but `m` times leading to a total of `m` fully imputed data sets. The model can then be fitted to each of those data sets separately and results are pooled across models, afterwards. One widely applied package for multiple imputation is **mice** (Buuren & Groothuis-Oudshoorn, 2010) and we will use it in the following in combination with **brms**. Here, we apply the default settings of **mice**, which means that all variables will be used to impute missing values in all other variables and imputation functions automatically chosen based on the variables' characteristics. ```{r} library(mice) m <- 5 imp <- mice(nhanes, m = m, print = FALSE) ``` Now, we have `m = 5` imputed data sets stored within the `imp` object. In practice, we will likely need more than `5` of those to accurately account for the uncertainty induced by the missingness, perhaps even in the area of `100` imputed data sets (Zhou & Reiter, 2010). Of course, this increases the computational burden by a lot and so we stick to `m = 5` for the purpose of this vignette. Regardless of the value of `m`, we can either extract those data sets and then pass them to the actual model fitting function as a list of data frames, or pass `imp` directly. The latter works because **brms** offers special support for data imputed by **mice**. We will go with the latter approach, since it is less typing. Fitting our model of interest with **brms** to the multiple imputed data sets is straightforward. ```{r, results = 'hide', message = FALSE} fit_imp1 <- brm_multiple(bmi ~ age*chl, data = imp, chains = 2) ``` The returned fitted model is an ordinary `brmsfit` object containing the posterior draws of all `m` submodels. While pooling across models is not necessarily straightforward in classical statistics, it is trivial in a Bayesian framework. Here, pooling results of multiple imputed data sets is simply achieved by combining the posterior draws of the submodels. Accordingly, all post-processing methods can be used out of the box without having to worry about pooling at all. ```{r} summary(fit_imp1) ``` In the summary output, we notice that some `Rhat` values are higher than $1.1$ indicating possible convergence problems. For models based on multiple imputed data sets, this is often a **false positive**: Chains of different submodels may not overlay each other exactly, since there were fitted to different data. We can see the chains on the right-hand side of ```{r} plot(fit_imp1, variable = "^b", regex = TRUE) ``` Such non-overlaying chains imply high `Rhat` values without there actually being any convergence issue. Accordingly, we have to investigate the convergence of the submodels separately, which we can do for example via: ```{r} library(posterior) draws <- as_draws_array(fit_imp1) # every dataset has nc = 2 chains in this example nc <- nchains(fit_imp1) / m draws_per_dat <- lapply(1:m, \(i) subset_draws(draws, chain = ((i-1)*nc+1):(i*nc)) ) lapply(draws_per_dat, summarise_draws, default_convergence_measures()) ``` The convergence of each of the submodels looks good. Accordingly, we can proceed with further post-processing and interpretation of the results. For instance, we could investigate the combined effect of `age` and `chl`. ```{r} conditional_effects(fit_imp1, "age:chl") ``` To summarize, the advantages of multiple imputation are obvious: One can apply it to all kinds of models, since model fitting functions do not need to know that the data sets were imputed, beforehand. Also, we do not need to worry about pooling across submodels when using fully Bayesian methods. The only drawback is the amount of time required for model fitting. Estimating Bayesian models is already quite slow with just a single data set and it only gets worse when working with multiple imputation. ### Compatibility with other multiple imputation packages **brms** offers built-in support for **mice** mainly because I use the latter in some of my own research projects. Nevertheless, `brm_multiple` supports all kinds of multiple imputation packages as it also accepts a *list* of data frames as input for its `data` argument. Thus, you just need to extract the imputed data frames in the form of a list, which can then be passed to `brm_multiple`. Most multiple imputation packages have some built-in functionality for this task. When using the **mi** package, for instance, you simply need to call the `mi::complete` function to get the desired output. ## Imputation during model fitting Imputation during model fitting is generally thought to be more complex than imputation before model fitting, because one has to take care of everything within one step. This remains true when imputing missing values with **brms**, but possibly to a somewhat smaller degree. Consider again the `nhanes` data with the goal to predict `bmi` by `age`, and `chl`. Since `age` contains no missing values, we only have to take special care of `bmi` and `chl`. We need to tell the model two things. (1) Which variables contain missing values and how they should be predicted, as well as (2) which of these imputed variables should be used as predictors. In **brms** we can do this as follows: ```{r, results = 'hide', message = FALSE} bform <- bf(bmi | mi() ~ age * mi(chl)) + bf(chl | mi() ~ age) + set_rescor(FALSE) fit_imp2 <- brm(bform, data = nhanes) ``` The model has become multivariate, as we no longer only predict `bmi` but also `chl` (see `vignette("brms_multivariate")` for details about the multivariate syntax of **brms**). We ensure that missings in both variables will be modeled rather than excluded by adding `| mi()` on the left-hand side of the formulas[^2]. We write `mi(chl)` on the right-hand side of the formula for `bmi` to ensure that the estimated missing values of `chl` will be used in the prediction of `bmi`. The summary is a bit more cluttered as we get coefficients for both response variables, but apart from that we can interpret coefficients in the usual way. ```{r} summary(fit_imp2) conditional_effects(fit_imp2, "age:chl", resp = "bmi") ``` The results look pretty similar to those obtained from multiple imputation, but be aware that this may not be generally the case. In multiple imputation, the default is to impute all variables based on all other variables, while in the 'one-step' approach, we have to explicitly specify the variables used in the imputation. Thus, arguably, multiple imputation is easier to apply. An obvious advantage of the 'one-step' approach is that the model needs to be fitted only once instead of `m` times. Also, within the **brms** framework, we can use multilevel structure and complex non-linear relationships for the imputation of missing values, which is not achieved as easily in standard multiple imputation software. On the downside, it is currently not possible to impute discrete variables, because **Stan** (the engine behind **brms**) does not allow estimating discrete parameters. ### Combining measurement error and missing values Missing value terms in **brms** cannot only handle missing values but also measurement error, or arbitrary combinations of the two. In fact, we can think of a missing value as a value with infinite measurement error. Thus, `mi` terms are a natural (and somewhat more verbose) generalization of the now soft deprecated `me` terms. Suppose we had measured the variable `chl` with some known error: ```{r} nhanes$se <- rexp(nrow(nhanes), 2) ``` Then we can go ahead an include this information into the model as follows: ```{r, results = 'hide', message = FALSE, eval = FALSE} bform <- bf(bmi | mi() ~ age * mi(chl)) + bf(chl | mi(se) ~ age) + set_rescor(FALSE) fit_imp3 <- brm(bform, data = nhanes) ``` Summarizing and post-processing the model continues to work as usual. [^1]: Actually, there is a third approach that only applies to missings in response variables. If we want to impute missing responses, we just fit the model using the observed responses and than impute the missings *after* fitting the model by means of posterior prediction. That is, we supply the predictor values corresponding to missing responses to the `predict` method. [^2]: We don't really need this for `bmi`, since `bmi` is not used as a predictor for another variable. Accordingly, we could also -- and equivalently -- impute missing values of `bmi` *after* model fitting by means of posterior prediction. ## References Buuren, S. V. & Groothuis-Oudshoorn, K. (2010). mice: Multivariate imputation by chained equations in R. *Journal of Statistical Software*, 1-68. doi.org/10.18637/jss.v045.i03 Zhou, X. & Reiter, J. P. (2010). A Note on Bayesian Inference After Multiple Imputation. *The American Statistician*, 64(2), 159-163. doi.org/10.1198/tast.2010.09109 brms/inst/doc/brms_distreg.html0000644000176200001440000166535415057751266016353 0ustar liggesusers Estimating Distributional Models with brms

Estimating Distributional Models with brms

Paul Bürkner

2025-09-09

Introduction

This vignette provides an introduction on how to fit distributional regression models with brms. We use the term distributional model to refer to a model, in which we can specify predictor terms for all parameters of the assumed response distribution. In the vast majority of regression model implementations, only the location parameter (usually the mean) of the response distribution depends on the predictors and corresponding regression parameters. Other parameters (e.g., scale or shape parameters) are estimated as auxiliary parameters assuming them to be constant across observations. This assumption is so common that most researchers applying regression models are often (in my experience) not aware of the possibility of relaxing it. This is understandable insofar as relaxing this assumption drastically increase model complexity and thus makes models hard to fit. Fortunately, brms uses Stan on the backend, which is an incredibly flexible and powerful tool for estimating Bayesian models so that model complexity is much less of an issue.

Suppose we have a normally distributed response variable. Then, in basic linear regression, we specify a predictor term \(\eta_{\mu}\) for the mean parameter \(\mu\) of the normal distribution. The second parameter of the normal distribution – the residual standard deviation \(\sigma\) – is assumed to be constant across observations. We estimate \(\sigma\) but do not try to predict it. In a distributional model, however, we do exactly this by specifying a predictor term \(\eta_{\sigma}\) for \(\sigma\) in addition to the predictor term \(\eta_{\mu}\). Ignoring group-level effects for the moment, the linear predictor of a parameter \(\theta\) for observation \(n\) has the form

\[\eta_{\theta n} = \sum_{i = 1}^{K_{\theta}} b_{\theta i} x_{\theta i n}\] where \(x_{\theta i n}\) denotes the value of the \(i\)th predictor of parameter \(\theta\) for observation \(n\) and \(b_{\theta i}\) is the \(i\)th regression coefficient of parameter \(\theta\). A distributional normal model with response variable \(y\) can then be written as

\[y_n \sim \mathcal{N}\left(\eta_{\mu n}, \, \exp(\eta_{\sigma n}) \right)\] We used the exponential function around \(\eta_{\sigma}\) to reflect that \(\sigma\) constitutes a standard deviation and thus only takes on positive values, while a linear predictor can be any real number.

A simple distributional model

Unequal variance models are possibly the most simple, but nevertheless very important application of distributional models. Suppose we have two groups of patients: One group receives a treatment (e.g., an antidepressive drug) and another group receives placebo. Since the treatment may not work equally well for all patients, the symptom variance of the treatment group may be larger than the symptom variance of the placebo group after some weeks of treatment. For simplicity, assume that we only investigate the post-treatment values.

group <- rep(c("treat", "placebo"), each = 30)
symptom_post <- c(rnorm(30, mean = 1, sd = 2), rnorm(30, mean = 0, sd = 1))
dat1 <- data.frame(group, symptom_post)
head(dat1)
  group symptom_post
1 treat    0.7462497
2 treat   -0.9047420
3 treat   -0.1073165
4 treat    0.9364342
5 treat    1.5826182
6 treat    2.5238863

The following model estimates the effect of group on both the mean and the residual standard deviation of the normal response distribution.

fit1 <- brm(bf(symptom_post ~ group, sigma ~ group),
            data = dat1, family = gaussian())

Useful summary statistics and plots can be obtained via

summary(fit1)
plot(fit1, N = 2, ask = FALSE)

plot(conditional_effects(fit1), points = TRUE)

The population-level effect sigma_grouptreat, which is the contrast of the two residual standard deviations on the log-scale, reveals that the variances of both groups are indeed different. This impression is confirmed when looking at the conditional_effects of group. Going one step further, we can compute the residual standard deviations on the original scale using the hypothesis method.

hyp <- c("exp(sigma_Intercept) = 0",
         "exp(sigma_Intercept + sigma_grouptreat) = 0")
hypothesis(fit1, hyp)
Hypothesis Tests for class b:
                Hypothesis Estimate Est.Error CI.Lower CI.Upper Evid.Ratio Post.Prob Star
1 (exp(sigma_Interc... = 0     1.00      0.14     0.77     1.31         NA        NA    *
2 (exp(sigma_Interc... = 0     2.11      0.29     1.64     2.75         NA        NA    *
---
'CI': 90%-CI for one-sided and 95%-CI for two-sided hypotheses.
'*': For one-sided hypotheses, the posterior probability exceeds 95%;
for two-sided hypotheses, the value tested against lies outside the 95%-CI.
Posterior probabilities of point hypotheses assume equal prior probabilities.

We may also directly compare them and plot the posterior distribution of their difference.

hyp <- "exp(sigma_Intercept + sigma_grouptreat) > exp(sigma_Intercept)"
(hyp <- hypothesis(fit1, hyp))
Hypothesis Tests for class b:
                Hypothesis Estimate Est.Error CI.Lower CI.Upper Evid.Ratio Post.Prob Star
1 (exp(sigma_Interc... > 0     1.12      0.32     0.64     1.67       3999         1    *
---
'CI': 90%-CI for one-sided and 95%-CI for two-sided hypotheses.
'*': For one-sided hypotheses, the posterior probability exceeds 95%;
for two-sided hypotheses, the value tested against lies outside the 95%-CI.
Posterior probabilities of point hypotheses assume equal prior probabilities.
plot(hyp, chars = NULL)

Indeed, the residual standard deviation of the treatment group seems to larger than that of the placebo group. Moreover the magnitude of this difference is pretty similar to what we expected due to the values we put into the data simulations.

Zero-Inflated Models

Another important application of the distributional regression framework are so called zero-inflated models. These models are helpful whenever there are more zeros in the response variable than one would naturally expect. For example, if one seeks to predict the number of cigarettes people smoke per day and also includes non-smokers, there will be a huge amount of zeros which, when not modeled appropriately, can seriously distort parameter estimates. Here, we consider an example dealing with the number of fish caught by various groups of people. On the UCLA website (), the data are described as follows: “The state wildlife biologists want to model how many fish are being caught by fishermen at a state park. Visitors are asked how long they stayed, how many people were in the group, were there children in the group and how many fish were caught. Some visitors do not fish, but there is no data on whether a person fished or not. Some visitors who did fish did not catch any fish so there are excess zeros in the data because of the people that did not fish.”

zinb <- read.csv("https://paul-buerkner.github.io/data/fish.csv")
head(zinb)
  nofish livebait camper persons child         xb         zg count
1      1        0      0       1     0 -0.8963146  3.0504048     0
2      0        1      1       1     0 -0.5583450  1.7461489     0
3      0        1      0       1     0 -0.4017310  0.2799389     0
4      0        1      1       2     1 -0.9562981 -0.6015257     0
5      0        1      0       1     0  0.4368910  0.5277091     1
6      0        1      1       4     2  1.3944855 -0.7075348     0

As predictors we choose the number of people per group, the number of children, as well as whether the group consists of campers. Many groups may not even try catching any fish at all (thus leading to many zero responses) and so we fit a zero-inflated Poisson model to the data. For now, we assume a constant zero-inflation probability across observations.

fit_zinb1 <- brm(count ~ persons + child + camper,
                 data = zinb, family = zero_inflated_poisson())

Again, we summarize the results using the usual methods.

summary(fit_zinb1)
 Family: zero_inflated_poisson 
  Links: mu = log 
Formula: count ~ persons + child + camper 
   Data: zinb (Number of observations: 250) 
  Draws: 4 chains, each with iter = 2000; warmup = 1000; thin = 1;
         total post-warmup draws = 4000

Regression Coefficients:
          Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
Intercept    -1.02      0.17    -1.36    -0.68 1.00     2834     2496
persons       0.88      0.04     0.79     0.96 1.00     3101     2528
child        -1.37      0.09    -1.55    -1.19 1.00     2667     2612
camper        0.80      0.09     0.62     0.98 1.00     3490     1934

Further Distributional Parameters:
   Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
zi     0.41      0.04     0.32     0.49 1.00     3073     2603

Draws were sampled using sampling(NUTS). For each parameter, Bulk_ESS
and Tail_ESS are effective sample size measures, and Rhat is the potential
scale reduction factor on split chains (at convergence, Rhat = 1).
plot(conditional_effects(fit_zinb1), ask = FALSE)

According to the parameter estimates, larger groups catch more fish, campers catch more fish than non-campers, and groups with more children catch less fish. The zero-inflation probability zi is pretty large with a mean of 41%. Please note that the probability of catching no fish is actually higher than 41%, but parts of this probability are already modeled by the Poisson distribution itself (hence the name zero-inflation). If you want to treat all zeros as originating from a separate process, you can use hurdle models instead (not shown here).

Now, we try to additionally predict the zero-inflation probability by the number of children. The underlying reasoning is that we expect groups with more children to not even try catching fish. Most children are just terribly bad at waiting for hours until something happens. From a purely statistical perspective, zero-inflated (and hurdle) distributions are a mixture of two processes and predicting both parts of the model is natural and often very reasonable to make full use of the data.

fit_zinb2 <- brm(bf(count ~ persons + child + camper, zi ~ child),
                 data = zinb, family = zero_inflated_poisson())
summary(fit_zinb2)
 Family: zero_inflated_poisson 
  Links: mu = log; zi = logit 
Formula: count ~ persons + child + camper 
         zi ~ child
   Data: zinb (Number of observations: 250) 
  Draws: 4 chains, each with iter = 2000; warmup = 1000; thin = 1;
         total post-warmup draws = 4000

Regression Coefficients:
             Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
Intercept       -1.08      0.18    -1.44    -0.75 1.00     3184     2944
zi_Intercept    -0.95      0.26    -1.49    -0.48 1.00     3832     2687
persons          0.89      0.05     0.80     0.99 1.00     3142     2683
child           -1.18      0.09    -1.36    -0.99 1.00     2866     2700
camper           0.78      0.09     0.59     0.97 1.00     3678     2902
zi_child         1.22      0.28     0.70     1.78 1.00     3692     2779

Draws were sampled using sampling(NUTS). For each parameter, Bulk_ESS
and Tail_ESS are effective sample size measures, and Rhat is the potential
scale reduction factor on split chains (at convergence, Rhat = 1).
plot(conditional_effects(fit_zinb2), ask = FALSE)

To transform the linear predictor of zi into a probability, brms applies the logit-link:

\[logit(zi) = \log\left(\frac{zi}{1-zi}\right) = \eta_{zi}\]

The logit-link takes values within \([0, 1]\) and returns values on the real line. Thus, it allows the transition between probabilities and linear predictors.

According to the model, trying to fish with children not only decreases the overall number fish caught (as implied by the Poisson part of the model) but also drastically increases your change of catching no fish at all (as implied by the zero-inflation part) most likely because groups with more children are not even trying.

Additive Distributional Models

In the examples so far, we did not have multilevel data and thus did not fully use the capabilities of the distributional regression framework of brms. In the example presented below, we will not only show how to deal with multilevel data in distributional models, but also how to incorporate smooth terms (i.e., splines) into the model. In many applications, we have no or only a very vague idea how the relationship between a predictor and the response looks like. A very flexible approach to tackle this problems is to use splines and let them figure out the form of the relationship. For illustration purposes, we simulate some data with the mgcv package, which is also used in brms to prepare smooth terms.

dat_smooth <- mgcv::gamSim(eg = 6, n = 200, scale = 2, verbose = FALSE)
Gu & Wahba 4 term additive model
head(dat_smooth[, 1:6])
          y         x0        x1        x2        x3         f
1  7.092269 0.21392875 0.3713252 0.5479417 0.2588828  9.214844
2 11.207050 0.69299850 0.9572272 0.8296604 0.5135362 15.053219
3 14.898640 0.09990143 0.1231805 0.6086874 0.9154674 14.138140
4 20.203708 0.56684211 0.8287514 0.5477278 0.6136956 22.069150
5  6.268765 0.65996071 0.3475563 0.7694099 0.5046833  8.440538
6 11.347764 0.08677576 0.3743094 0.5366627 0.9892344 11.461799

The data contains the predictors x0 to x3 as well as the grouping factor fac indicating the nested structure of the data. We predict the response variable y using smooth terms of x1 and x2 and a varying intercept of fac. In addition, we assume the residual standard deviation sigma to vary by a smoothing term of x0 and a varying intercept of fac.

fit_smooth1 <- brm(
  bf(y ~ s(x1) + s(x2) + (1|fac), sigma ~ s(x0) + (1|fac)),
  data = dat_smooth, family = gaussian(),
  chains = 2, control = list(adapt_delta = 0.95)
)
summary(fit_smooth1)
 Family: gaussian 
  Links: mu = identity; sigma = log 
Formula: y ~ s(x1) + s(x2) + (1 | fac) 
         sigma ~ s(x0) + (1 | fac)
   Data: dat_smooth (Number of observations: 200) 
  Draws: 2 chains, each with iter = 2000; warmup = 1000; thin = 1;
         total post-warmup draws = 2000

Smoothing Spline Hyperparameters:
                 Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
sds(sx1_1)           1.49      1.46     0.04     5.63 1.00      687      704
sds(sx2_1)          19.75      5.84    11.94    33.82 1.00      611     1071
sds(sigma_sx0_1)     0.42      0.47     0.01     1.62 1.00      841     1153

Multilevel Hyperparameters:
~fac (Number of levels: 4) 
                    Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
sd(Intercept)           4.95      2.28     2.34    10.65 1.00      760     1180
sd(sigma_Intercept)     0.17      0.21     0.00     0.69 1.00      521      670

Regression Coefficients:
                Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
Intercept          15.42      2.35    10.41    20.18 1.00      642      920
sigma_Intercept     0.86      0.13     0.61     1.13 1.00      567      398
sx1_1              10.14      3.97     2.20    19.07 1.00      790      690
sx2_1              31.19     16.78    -0.90    63.43 1.00     1140     1332
sigma_sx0_1         0.01      1.06    -2.20     2.39 1.00      933      671

Draws were sampled using sampling(NUTS). For each parameter, Bulk_ESS
and Tail_ESS are effective sample size measures, and Rhat is the potential
scale reduction factor on split chains (at convergence, Rhat = 1).
plot(conditional_effects(fit_smooth1), points = TRUE, ask = FALSE)

This model is likely an overkill for the data at hand, but nicely demonstrates the ease with which one can specify complex models with brms and to fit them using Stan on the backend.

brms/inst/doc/brms_distreg.Rmd0000644000176200001440000002537415053072461016105 0ustar liggesusers--- title: "Estimating Distributional Models with brms" author: "Paul Bürkner" date: "`r Sys.Date()`" output: rmarkdown::html_vignette: toc: yes vignette: > %\VignetteIndexEntry{Estimating Distributional Models with brms} %\VignetteEngine{knitr::rmarkdown} \usepackage[utf8]{inputenc} params: EVAL: !r identical(Sys.getenv("NOT_CRAN"), "true") --- ```{r, SETTINGS-knitr, include=FALSE} stopifnot(require(knitr)) options(width = 90) knit_hooks$set(pngquant = knitr::hook_pngquant) opts_chunk$set( comment = NA, message = FALSE, warning = FALSE, eval = if (isTRUE(exists("params"))) params$EVAL else FALSE, dev = "ragg_png", dpi = 72, fig.retina = 1.5, fig.asp = 0.8, fig.width = 5, out.width = "60%", fig.align = "center", pngquant = "--speed=1 --quality=50" ) library(brms) ggplot2::theme_set(theme_default()) ``` ## Introduction This vignette provides an introduction on how to fit distributional regression models with **brms**. We use the term *distributional model* to refer to a model, in which we can specify predictor terms for all parameters of the assumed response distribution. In the vast majority of regression model implementations, only the location parameter (usually the mean) of the response distribution depends on the predictors and corresponding regression parameters. Other parameters (e.g., scale or shape parameters) are estimated as auxiliary parameters assuming them to be constant across observations. This assumption is so common that most researchers applying regression models are often (in my experience) not aware of the possibility of relaxing it. This is understandable insofar as relaxing this assumption drastically increase model complexity and thus makes models hard to fit. Fortunately, **brms** uses **Stan** on the backend, which is an incredibly flexible and powerful tool for estimating Bayesian models so that model complexity is much less of an issue. Suppose we have a normally distributed response variable. Then, in basic linear regression, we specify a predictor term $\eta_{\mu}$ for the mean parameter $\mu$ of the normal distribution. The second parameter of the normal distribution -- the residual standard deviation $\sigma$ -- is assumed to be constant across observations. We estimate $\sigma$ but do not try to *predict* it. In a distributional model, however, we do exactly this by specifying a predictor term $\eta_{\sigma}$ for $\sigma$ in addition to the predictor term $\eta_{\mu}$. Ignoring group-level effects for the moment, the linear predictor of a parameter $\theta$ for observation $n$ has the form $$\eta_{\theta n} = \sum_{i = 1}^{K_{\theta}} b_{\theta i} x_{\theta i n}$$ where $x_{\theta i n}$ denotes the value of the $i$th predictor of parameter $\theta$ for observation $n$ and $b_{\theta i}$ is the $i$th regression coefficient of parameter $\theta$. A distributional normal model with response variable $y$ can then be written as $$y_n \sim \mathcal{N}\left(\eta_{\mu n}, \, \exp(\eta_{\sigma n}) \right)$$ We used the exponential function around $\eta_{\sigma}$ to reflect that $\sigma$ constitutes a standard deviation and thus only takes on positive values, while a linear predictor can be any real number. ## A simple distributional model Unequal variance models are possibly the most simple, but nevertheless very important application of distributional models. Suppose we have two groups of patients: One group receives a treatment (e.g., an antidepressive drug) and another group receives placebo. Since the treatment may not work equally well for all patients, the symptom variance of the treatment group may be larger than the symptom variance of the placebo group after some weeks of treatment. For simplicity, assume that we only investigate the post-treatment values. ```{r} group <- rep(c("treat", "placebo"), each = 30) symptom_post <- c(rnorm(30, mean = 1, sd = 2), rnorm(30, mean = 0, sd = 1)) dat1 <- data.frame(group, symptom_post) head(dat1) ``` The following model estimates the effect of `group` on both the mean and the residual standard deviation of the normal response distribution. ```{r, results='hide'} fit1 <- brm(bf(symptom_post ~ group, sigma ~ group), data = dat1, family = gaussian()) ``` Useful summary statistics and plots can be obtained via ```{r, results='hide'} summary(fit1) plot(fit1, N = 2, ask = FALSE) plot(conditional_effects(fit1), points = TRUE) ``` The population-level effect `sigma_grouptreat`, which is the contrast of the two residual standard deviations on the log-scale, reveals that the variances of both groups are indeed different. This impression is confirmed when looking at the `conditional_effects` of `group`. Going one step further, we can compute the residual standard deviations on the original scale using the `hypothesis` method. ```{r} hyp <- c("exp(sigma_Intercept) = 0", "exp(sigma_Intercept + sigma_grouptreat) = 0") hypothesis(fit1, hyp) ``` We may also directly compare them and plot the posterior distribution of their difference. ```{r} hyp <- "exp(sigma_Intercept + sigma_grouptreat) > exp(sigma_Intercept)" (hyp <- hypothesis(fit1, hyp)) plot(hyp, chars = NULL) ``` Indeed, the residual standard deviation of the treatment group seems to larger than that of the placebo group. Moreover the magnitude of this difference is pretty similar to what we expected due to the values we put into the data simulations. ## Zero-Inflated Models Another important application of the distributional regression framework are so called zero-inflated models. These models are helpful whenever there are more zeros in the response variable than one would naturally expect. For example, if one seeks to predict the number of cigarettes people smoke per day and also includes non-smokers, there will be a huge amount of zeros which, when not modeled appropriately, can seriously distort parameter estimates. Here, we consider an example dealing with the number of fish caught by various groups of people. On the UCLA website (\url{https://stats.idre.ucla.edu/stata/dae/zero-inflated-poisson-regression}), the data are described as follows: "The state wildlife biologists want to model how many fish are being caught by fishermen at a state park. Visitors are asked how long they stayed, how many people were in the group, were there children in the group and how many fish were caught. Some visitors do not fish, but there is no data on whether a person fished or not. Some visitors who did fish did not catch any fish so there are excess zeros in the data because of the people that did not fish." ```{r} zinb <- read.csv("https://paul-buerkner.github.io/data/fish.csv") head(zinb) ``` As predictors we choose the number of people per group, the number of children, as well as whether the group consists of campers. Many groups may not even try catching any fish at all (thus leading to many zero responses) and so we fit a zero-inflated Poisson model to the data. For now, we assume a constant zero-inflation probability across observations. ```{r, results='hide'} fit_zinb1 <- brm(count ~ persons + child + camper, data = zinb, family = zero_inflated_poisson()) ``` Again, we summarize the results using the usual methods. ```{r} summary(fit_zinb1) plot(conditional_effects(fit_zinb1), ask = FALSE) ``` According to the parameter estimates, larger groups catch more fish, campers catch more fish than non-campers, and groups with more children catch less fish. The zero-inflation probability `zi` is pretty large with a mean of 41%. Please note that the probability of catching no fish is actually higher than 41%, but parts of this probability are already modeled by the Poisson distribution itself (hence the name zero-*inflation*). If you want to treat all zeros as originating from a separate process, you can use hurdle models instead (not shown here). Now, we try to additionally predict the zero-inflation probability by the number of children. The underlying reasoning is that we expect groups with more children to not even try catching fish. Most children are just terribly bad at waiting for hours until something happens. From a purely statistical perspective, zero-inflated (and hurdle) distributions are a mixture of two processes and predicting both parts of the model is natural and often very reasonable to make full use of the data. ```{r, results='hide'} fit_zinb2 <- brm(bf(count ~ persons + child + camper, zi ~ child), data = zinb, family = zero_inflated_poisson()) ``` ```{r} summary(fit_zinb2) plot(conditional_effects(fit_zinb2), ask = FALSE) ``` To transform the linear predictor of `zi` into a probability, **brms** applies the logit-link: $$logit(zi) = \log\left(\frac{zi}{1-zi}\right) = \eta_{zi}$$ The logit-link takes values within $[0, 1]$ and returns values on the real line. Thus, it allows the transition between probabilities and linear predictors. According to the model, trying to fish with children not only decreases the overall number fish caught (as implied by the Poisson part of the model) but also drastically increases your change of catching no fish at all (as implied by the zero-inflation part) most likely because groups with more children are not even trying. ## Additive Distributional Models In the examples so far, we did not have multilevel data and thus did not fully use the capabilities of the distributional regression framework of **brms**. In the example presented below, we will not only show how to deal with multilevel data in distributional models, but also how to incorporate smooth terms (i.e., splines) into the model. In many applications, we have no or only a very vague idea how the relationship between a predictor and the response looks like. A very flexible approach to tackle this problems is to use splines and let them figure out the form of the relationship. For illustration purposes, we simulate some data with the **mgcv** package, which is also used in **brms** to prepare smooth terms. ```{r} dat_smooth <- mgcv::gamSim(eg = 6, n = 200, scale = 2, verbose = FALSE) head(dat_smooth[, 1:6]) ``` The data contains the predictors `x0` to `x3` as well as the grouping factor `fac` indicating the nested structure of the data. We predict the response variable `y` using smooth terms of `x1` and `x2` and a varying intercept of `fac`. In addition, we assume the residual standard deviation `sigma` to vary by a smoothing term of `x0` and a varying intercept of `fac`. ```{r, results='hide'} fit_smooth1 <- brm( bf(y ~ s(x1) + s(x2) + (1|fac), sigma ~ s(x0) + (1|fac)), data = dat_smooth, family = gaussian(), chains = 2, control = list(adapt_delta = 0.95) ) ``` ```{r} summary(fit_smooth1) plot(conditional_effects(fit_smooth1), points = TRUE, ask = FALSE) ``` This model is likely an overkill for the data at hand, but nicely demonstrates the ease with which one can specify complex models with **brms** and to fit them using **Stan** on the backend. brms/inst/doc/brms_nonlinear.html0000644000176200001440000212721715057752401016657 0ustar liggesusers Estimating Non-Linear Models with brms

Estimating Non-Linear Models with brms

Paul Bürkner

2025-09-09

Introduction

This vignette provides an introduction on how to fit non-linear multilevel models with brms. Non-linear models are incredibly flexible and powerful, but require much more care with respect to model specification and priors than typical generalized linear models. Ignoring group-level effects for the moment, the predictor term \(\eta_n\) of a generalized linear model for observation \(n\) can be written as follows:

\[\eta_n = \sum_{i = 1}^K b_i x_{ni}\]

where \(b_i\) is the regression coefficient of predictor \(i\) and \(x_{ni}\) is the data of predictor \(i\) for observation \(n\). This also comprises interaction terms and various other data transformations. However, the structure of \(\eta_n\) is always linear in the sense that the regression coefficients \(b_i\) are multiplied by some predictor values and then summed up. This implies that the hypothetical predictor term

\[\eta_n = b_1 \exp(b_2 x_n)\]

would not be a linear predictor anymore and we could not fit it using classical techniques of generalized linear models. We thus need a more general model class, which we will call non-linear models. Note that the term ‘non-linear’ does not say anything about the assumed distribution of the response variable. In particular it does not mean ‘not normally distributed’ as we can apply non-linear predictor terms to all kinds of response distributions (for more details on response distributions available in brms see vignette("brms_families")).

A Simple Non-Linear Model

We begin with a simple example using simulated data.

b <- c(2, 0.75)
x <- rnorm(100)
y <- rnorm(100, mean = b[1] * exp(b[2] * x))
dat1 <- data.frame(x, y)

As stated above, we cannot use a generalized linear model to estimate \(b\) so we go ahead an specify a non-linear model.

prior1 <- prior(normal(1, 2), nlpar = "b1") +
  prior(normal(0, 2), nlpar = "b2")
fit1 <- brm(bf(y ~ b1 * exp(b2 * x), b1 + b2 ~ 1, nl = TRUE),
            data = dat1, prior = prior1)

When looking at the above code, the first thing that becomes obvious is that we changed the formula syntax to display the non-linear formula including predictors (i.e., x) and parameters (i.e., b1 and b2) wrapped in a call to bf. This stands in contrast to classical R formulas, where only predictors are given and parameters are implicit. The argument b1 + b2 ~ 1 serves two purposes. First, it provides information, which variables in formula are parameters, and second, it specifies the linear predictor terms for each parameter. In fact, we should think of non-linear parameters as placeholders for linear predictor terms rather than as parameters themselves (see also the following examples). In the present case, we have no further variables to predict b1 and b2 and thus we just fit intercepts that represent our estimates of \(b_1\) and \(b_2\) in the model equation above. The formula b1 + b2 ~ 1 is a short form of b1 ~ 1, b2 ~ 1 that can be used if multiple non-linear parameters share the same formula. Setting nl = TRUE tells brms that the formula should be treated as non-linear.

In contrast to generalized linear models, priors on population-level parameters (i.e., ‘fixed effects’) are often mandatory to identify a non-linear model. Thus, brms requires the user to explicitly specify these priors. In the present example, we used a normal(1, 2) prior on (the population-level intercept of) b1, while we used a normal(0, 2) prior on (the population-level intercept of) b2. Setting priors is a non-trivial task in all kinds of models, especially in non-linear models, so you should always invest some time to think of appropriate priors. Quite often, you may be forced to change your priors after fitting a non-linear model for the first time, when you observe different MCMC chains converging to different posterior regions. This is a clear sign of an identification problem and one solution is to set stronger (i.e., more narrow) priors.

To obtain summaries of the fitted model, we apply

summary(fit1)
 Family: gaussian 
  Links: mu = identity 
Formula: y ~ b1 * exp(b2 * x) 
         b1 ~ 1
         b2 ~ 1
   Data: dat1 (Number of observations: 100) 
  Draws: 4 chains, each with iter = 2000; warmup = 1000; thin = 1;
         total post-warmup draws = 4000

Regression Coefficients:
             Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
b1_Intercept     1.90      0.09     1.72     2.09 1.00     1374     1976
b2_Intercept     0.75      0.03     0.70     0.80 1.00     1474     1858

Further Distributional Parameters:
      Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
sigma     0.94      0.07     0.82     1.08 1.00     2098     1749

Draws were sampled using sampling(NUTS). For each parameter, Bulk_ESS
and Tail_ESS are effective sample size measures, and Rhat is the potential
scale reduction factor on split chains (at convergence, Rhat = 1).
plot(fit1)

plot(conditional_effects(fit1), points = TRUE)

The summary method reveals that we were able to recover the true parameter values pretty nicely. According to the plot method, our MCMC chains have converged well and to the same posterior. The conditional_effects method visualizes the model-implied (non-linear) regression line.

We might be also interested in comparing our non-linear model to a classical linear model.

fit2 <- brm(y ~ x, data = dat1)
summary(fit2)
 Family: gaussian 
  Links: mu = identity 
Formula: y ~ x 
   Data: dat1 (Number of observations: 100) 
  Draws: 4 chains, each with iter = 2000; warmup = 1000; thin = 1;
         total post-warmup draws = 4000

Regression Coefficients:
          Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
Intercept     2.49      0.16     2.17     2.80 1.00     4469     3040
x             2.30      0.16     1.99     2.61 1.00     4784     3164

Further Distributional Parameters:
      Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
sigma     1.53      0.11     1.33     1.76 1.00     3720     2914

Draws were sampled using sampling(NUTS). For each parameter, Bulk_ESS
and Tail_ESS are effective sample size measures, and Rhat is the potential
scale reduction factor on split chains (at convergence, Rhat = 1).

To investigate and compare model fit, we can apply graphical posterior predictive checks, which make use of the bayesplot package on the backend.

pp_check(fit1)

pp_check(fit2)

We can also easily compare model fit using leave-one-out cross-validation.

loo(fit1, fit2)
Output of model 'fit1':

Computed from 4000 by 100 log-likelihood matrix.

         Estimate   SE
elpd_loo   -136.8  7.2
p_loo         2.8  0.8
looic       273.7 14.4
------
MCSE of elpd_loo is NA.
MCSE and ESS estimates assume MCMC draws (r_eff in [0.3, 1.1]).

Pareto k diagnostic values:
                         Count Pct.    Min. ESS
(-Inf, 0.7]   (good)     99    99.0%   1142    
   (0.7, 1]   (bad)       1     1.0%   <NA>    
   (1, Inf)   (very bad)  0     0.0%   <NA>    
See help('pareto-k-diagnostic') for details.

Output of model 'fit2':

Computed from 4000 by 100 log-likelihood matrix.

         Estimate   SE
elpd_loo   -189.4 17.2
p_loo         9.0  5.9
looic       378.7 34.4
------
MCSE of elpd_loo is NA.
MCSE and ESS estimates assume MCMC draws (r_eff in [0.6, 1.3]).

Pareto k diagnostic values:
                         Count Pct.    Min. ESS
(-Inf, 0.7]   (good)     99    99.0%   595     
   (0.7, 1]   (bad)       0     0.0%   <NA>    
   (1, Inf)   (very bad)  1     1.0%   <NA>    
See help('pareto-k-diagnostic') for details.

Model comparisons:
     elpd_diff se_diff
fit1   0.0       0.0  
fit2 -52.5      16.9

Since smaller LOOIC values indicate better model fit, it is immediately evident that the non-linear model fits the data better, which is of course not too surprising since we simulated the data from exactly that model.

A Real-World Non-Linear model

On his blog, Markus Gesmann predicts the growth of cumulative insurance loss payments over time, originated from different origin years (see https://www.magesblog.com/post/2015-11-03-loss-developments-via-growth-curves-and/). We will use a slightly simplified version of his model for demonstration purposes here. It looks as follows:

\[cum_{AY, dev} \sim N(\mu_{AY, dev}, \sigma)\] \[\mu_{AY, dev} = ult_{AY} \left(1 - \exp\left(- \left( \frac{dev}{\theta} \right)^\omega \right) \right)\]

The cumulative insurance payments \(cum\) will grow over time, and we model this dependency using the variable \(dev\). Further, \(ult_{AY}\) is the (to be estimated) ultimate loss of accident each year. It constitutes a non-linear parameter in our framework along with the parameters \(\theta\) and \(\omega\), which are responsible for the growth of the cumulative loss and are assumed to be the same across years. The data is already shipped with brms.

data(loss)
head(loss)
    AY dev      cum premium
1 1991   6  357.848   10000
2 1991  18 1124.788   10000
3 1991  30 1735.330   10000
4 1991  42 2182.708   10000
5 1991  54 2745.596   10000
6 1991  66 3319.994   10000

and translate the proposed model into a non-linear brms model.

fit_loss <- brm(
  bf(cum ~ ult * (1 - exp(-(dev/theta)^omega)),
     ult ~ 1 + (1|AY), omega ~ 1, theta ~ 1,
     nl = TRUE),
  data = loss, family = gaussian(),
  prior = c(
    prior(normal(5000, 1000), nlpar = "ult"),
    prior(normal(1, 2), nlpar = "omega"),
    prior(normal(45, 10), nlpar = "theta")
  ),
  control = list(adapt_delta = 0.9)
)

We estimate a group-level effect of accident year (variable AY) for the ultimate loss ult. This also shows nicely how a non-linear parameter is actually a placeholder for a linear predictor, which in case of ult, contains only an varying intercept over year. Again, priors on population-level effects are required and, for the present model, are actually mandatory to ensure identifiability. We summarize the model using well known methods.

summary(fit_loss)
 Family: gaussian 
  Links: mu = identity 
Formula: cum ~ ult * (1 - exp(-(dev/theta)^omega)) 
         ult ~ 1 + (1 | AY)
         omega ~ 1
         theta ~ 1
   Data: loss (Number of observations: 55) 
  Draws: 4 chains, each with iter = 2000; warmup = 1000; thin = 1;
         total post-warmup draws = 4000

Multilevel Hyperparameters:
~AY (Number of levels: 10) 
                  Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
sd(ult_Intercept)   747.55    240.07   423.46  1381.79 1.00     1090     1644

Regression Coefficients:
                Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
ult_Intercept    5283.29    298.18  4708.31  5916.86 1.00     1110     1746
omega_Intercept     1.34      0.05     1.24     1.43 1.00     2436     2558
theta_Intercept    46.24      2.25    42.50    51.14 1.00     2272     2002

Further Distributional Parameters:
      Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
sigma   140.21     16.06   113.42   176.58 1.00     3289     2676

Draws were sampled using sampling(NUTS). For each parameter, Bulk_ESS
and Tail_ESS are effective sample size measures, and Rhat is the potential
scale reduction factor on split chains (at convergence, Rhat = 1).
plot(fit_loss, N = 3, ask = FALSE)

conditional_effects(fit_loss)

Next, we show marginal effects separately for each year.

conditions <- data.frame(AY = unique(loss$AY))
rownames(conditions) <- unique(loss$AY)
me_loss <- conditional_effects(
  fit_loss, conditions = conditions,
  re_formula = NULL, method = "predict"
)
plot(me_loss, ncol = 5, points = TRUE)

It is evident that there is some variation in cumulative loss across accident years, for instance due to natural disasters happening only in certain years. Further, we see that the uncertainty in the predicted cumulative loss is larger for later years with fewer available data points. For a more detailed discussion of this data set, see Section 4.5 in Gesmann & Morris (2020).

Advanced Item-Response Models

As a third example, we want to show how to model more advanced item-response models using the non-linear model framework of brms. For simplicity, suppose we have a single forced choice item with three alternatives of which only one is correct. Our response variable is whether a person answers the item correctly (1) or not (0). Person are assumed to vary in their ability to answer the item correctly. However, every person has a 33% chance of getting the item right just by guessing. We thus simulate some data to reflect this situation.

inv_logit <- function(x) 1 / (1 + exp(-x))
ability <- rnorm(300)
p <- 0.33 + 0.67 * inv_logit(ability)
answer <- ifelse(runif(300, 0, 1) < p, 1, 0)
dat_ir <- data.frame(ability, answer)

The most basic item-response model is equivalent to a simple logistic regression model.

fit_ir1 <- brm(answer ~ ability, data = dat_ir, family = bernoulli())

However, this model completely ignores the guessing probability and will thus likely come to biased estimates and predictions.

summary(fit_ir1)
 Family: bernoulli 
  Links: mu = logit 
Formula: answer ~ ability 
   Data: dat_ir (Number of observations: 300) 
  Draws: 4 chains, each with iter = 2000; warmup = 1000; thin = 1;
         total post-warmup draws = 4000

Regression Coefficients:
          Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
Intercept     0.74      0.14     0.47     1.01 1.00     2751     2374
ability       0.86      0.16     0.57     1.19 1.00     2477     2175

Draws were sampled using sampling(NUTS). For each parameter, Bulk_ESS
and Tail_ESS are effective sample size measures, and Rhat is the potential
scale reduction factor on split chains (at convergence, Rhat = 1).
plot(conditional_effects(fit_ir1), points = TRUE)

A more sophisticated approach incorporating the guessing probability looks as follows:

fit_ir2 <- brm(
  bf(answer ~ 0.33 + 0.67 * inv_logit(eta),
     eta ~ ability, nl = TRUE),
  data = dat_ir, family = bernoulli("identity"),
  prior = prior(normal(0, 5), nlpar = "eta")
)

It is very important to set the link function of the bernoulli family to identity or else we will apply two link functions. This is because our non-linear predictor term already contains the desired link function (0.33 + 0.67 * inv_logit), but the bernoulli family applies the default logit link on top of it. This will of course lead to strange and uninterpretable results. Thus, please make sure that you set the link function to identity, whenever your non-linear predictor term already contains the desired link function.

summary(fit_ir2)
 Family: bernoulli 
  Links: mu = identity 
Formula: answer ~ 0.33 + 0.67 * inv_logit(eta) 
         eta ~ ability
   Data: dat_ir (Number of observations: 300) 
  Draws: 4 chains, each with iter = 2000; warmup = 1000; thin = 1;
         total post-warmup draws = 4000

Regression Coefficients:
              Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
eta_Intercept    -0.10      0.20    -0.52     0.28 1.00     2120     1779
eta_ability       1.39      0.29     0.86     1.99 1.00     2478     2301

Draws were sampled using sampling(NUTS). For each parameter, Bulk_ESS
and Tail_ESS are effective sample size measures, and Rhat is the potential
scale reduction factor on split chains (at convergence, Rhat = 1).
plot(conditional_effects(fit_ir2), points = TRUE)

Comparing model fit via leave-one-out cross-validation

loo(fit_ir1, fit_ir2)
Output of model 'fit_ir1':

Computed from 4000 by 300 log-likelihood matrix.

         Estimate   SE
elpd_loo   -174.7  7.5
p_loo         2.2  0.2
looic       349.3 15.0
------
MCSE of elpd_loo is 0.0.
MCSE and ESS estimates assume MCMC draws (r_eff in [0.5, 0.9]).

All Pareto k estimates are good (k < 0.7).
See help('pareto-k-diagnostic') for details.

Output of model 'fit_ir2':

Computed from 4000 by 300 log-likelihood matrix.

         Estimate   SE
elpd_loo   -173.2  7.6
p_loo         1.9  0.2
looic       346.5 15.1
------
MCSE of elpd_loo is 0.0.
MCSE and ESS estimates assume MCMC draws (r_eff in [0.4, 1.0]).

All Pareto k estimates are good (k < 0.7).
See help('pareto-k-diagnostic') for details.

Model comparisons:
        elpd_diff se_diff
fit_ir2  0.0       0.0   
fit_ir1 -1.4       1.5

shows that both model fit the data equally well, but remember that predictions of the first model might still be misleading as they may well be below the guessing probability for low ability values. Now, suppose that we don’t know the guessing probability and want to estimate it from the data. This can easily be done changing the previous model just a bit.

fit_ir3 <- brm(
  bf(answer ~ guess + (1 - guess) * inv_logit(eta),
    eta ~ 0 + ability, guess ~ 1, nl = TRUE),
  data = dat_ir, family = bernoulli("identity"),
  prior = c(
    prior(normal(0, 5), nlpar = "eta"),
    prior(beta(1, 1), nlpar = "guess", lb = 0, ub = 1)
  )
)

Here, we model the guessing probability as a non-linear parameter making sure that it cannot exceed the interval \([0, 1]\). We did not estimate an intercept for eta, as this will lead to a bias in the estimated guessing parameter (try it out; this is an excellent example of how careful one has to be in non-linear models).

summary(fit_ir3)
 Family: bernoulli 
  Links: mu = identity 
Formula: answer ~ guess + (1 - guess) * inv_logit(eta) 
         eta ~ 0 + ability
         guess ~ 1
   Data: dat_ir (Number of observations: 300) 
  Draws: 4 chains, each with iter = 2000; warmup = 1000; thin = 1;
         total post-warmup draws = 4000

Regression Coefficients:
                Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
eta_ability         1.32      0.26     0.85     1.87 1.00     2163     1850
guess_Intercept     0.31      0.05     0.21     0.41 1.00     2725     2217

Draws were sampled using sampling(NUTS). For each parameter, Bulk_ESS
and Tail_ESS are effective sample size measures, and Rhat is the potential
scale reduction factor on split chains (at convergence, Rhat = 1).
plot(fit_ir3)

plot(conditional_effects(fit_ir3), points = TRUE)

The results show that we are able to recover the simulated model parameters with this non-linear model. Of course, real item-response data have multiple items so that accounting for item and person variability (e.g., using a multilevel model with varying intercepts) becomes necessary as we have multiple observations per item and person. Luckily, this can all be done within the non-linear framework of brms and I hope that this vignette serves as a good starting point.

References

Gesmann M. & Morris J. (2020). Hierarchical Compartmental Reserving Models. CAS Research Papers.

brms/inst/doc/brms_multivariate.html0000644000176200001440000046047015057752157017407 0ustar liggesusers Estimating Multivariate Models with brms

Estimating Multivariate Models with brms

Paul Bürkner

2025-09-09

Introduction

In the present vignette, we want to discuss how to specify multivariate multilevel models using brms. We call a model multivariate if it contains multiple response variables, each being predicted by its own set of predictors. Consider an example from biology. Hadfield, Nutall, Osorio, and Owens (2007) analyzed data of the Eurasian blue tit (https://en.wikipedia.org/wiki/Eurasian_blue_tit). They predicted the tarsus length as well as the back color of chicks. Half of the brood were put into another fosternest, while the other half stayed in the fosternest of their own dam. This allows to separate genetic from environmental factors. Additionally, we have information about the hatchdate and sex of the chicks (the latter being known for 94% of the animals).

data("BTdata", package = "MCMCglmm")
head(BTdata)
       tarsus       back  animal     dam fosternest  hatchdate  sex
1 -1.89229718  1.1464212 R187142 R187557      F2102 -0.6874021  Fem
2  1.13610981 -0.7596521 R187154 R187559      F1902 -0.6874021 Male
3  0.98468946  0.1449373 R187341 R187568       A602 -0.4279814 Male
4  0.37900806  0.2555847 R046169 R187518      A1302 -1.4656641 Male
5 -0.07525299 -0.3006992 R046161 R187528      A2602 -1.4656641  Fem
6 -1.13519543  1.5577219 R187409 R187945      C2302  0.3502805  Fem

Basic Multivariate Models

We begin with a relatively simple multivariate normal model.

bform1 <- 
  bf(mvbind(tarsus, back) ~ sex + hatchdate + (1|p|fosternest) + (1|q|dam)) +
  set_rescor(TRUE)

fit1 <- brm(bform1, data = BTdata, chains = 2, cores = 2)

As can be seen in the model code, we have used mvbind notation to tell brms that both tarsus and back are separate response variables. The term (1|p|fosternest) indicates a varying intercept over fosternest. By writing |p| in between we indicate that all varying effects of fosternest should be modeled as correlated. This makes sense since we actually have two model parts, one for tarsus and one for back. The indicator p is arbitrary and can be replaced by other symbols that comes into your mind (for details about the multilevel syntax of brms, see help("brmsformula") and vignette("brms_multilevel")). Similarly, the term (1|q|dam) indicates correlated varying effects of the genetic mother of the chicks. Alternatively, we could have also modeled the genetic similarities through pedigrees and corresponding relatedness matrices, but this is not the focus of this vignette (please see vignette("brms_phylogenetics")). The model results are readily summarized via

fit1 <- add_criterion(fit1, "loo")
summary(fit1)
 Family: MV(gaussian, gaussian) 
  Links: mu = identity
         mu = identity 
Formula: tarsus ~ sex + hatchdate + (1 | p | fosternest) + (1 | q | dam) 
         back ~ sex + hatchdate + (1 | p | fosternest) + (1 | q | dam) 
   Data: BTdata (Number of observations: 828) 
  Draws: 2 chains, each with iter = 2000; warmup = 1000; thin = 1;
         total post-warmup draws = 2000

Multilevel Hyperparameters:
~dam (Number of levels: 106) 
                                     Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS
sd(tarsus_Intercept)                     0.48      0.05     0.39     0.59 1.00      793
sd(back_Intercept)                       0.25      0.07     0.12     0.39 1.00      516
cor(tarsus_Intercept,back_Intercept)    -0.52      0.21    -0.91    -0.09 1.00      604
                                     Tail_ESS
sd(tarsus_Intercept)                     1555
sd(back_Intercept)                        854
cor(tarsus_Intercept,back_Intercept)      881

~fosternest (Number of levels: 104) 
                                     Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS
sd(tarsus_Intercept)                     0.26      0.05     0.17     0.38 1.00      890
sd(back_Intercept)                       0.35      0.06     0.23     0.47 1.00      594
cor(tarsus_Intercept,back_Intercept)     0.70      0.20     0.24     0.98 1.00      324
                                     Tail_ESS
sd(tarsus_Intercept)                     1272
sd(back_Intercept)                       1101
cor(tarsus_Intercept,back_Intercept)      595

Regression Coefficients:
                 Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
tarsus_Intercept    -0.41      0.07    -0.55    -0.27 1.00     1706     1252
back_Intercept      -0.01      0.07    -0.14     0.11 1.00     2446     1623
tarsus_sexMale       0.77      0.06     0.66     0.88 1.00     3870     1872
tarsus_sexUNK        0.23      0.13    -0.02     0.48 1.00     3792     1269
tarsus_hatchdate    -0.04      0.06    -0.15     0.07 1.00     1760     1314
back_sexMale         0.01      0.07    -0.13     0.15 1.00     4419     1578
back_sexUNK          0.15      0.15    -0.15     0.44 1.00     3227     1726
back_hatchdate      -0.09      0.05    -0.19     0.01 1.00     2540     1550

Further Distributional Parameters:
             Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
sigma_tarsus     0.76      0.02     0.72     0.80 1.00     2466     1324
sigma_back       0.90      0.02     0.86     0.95 1.00     2507     1576

Residual Correlations: 
                    Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
rescor(tarsus,back)    -0.05      0.04    -0.13     0.02 1.00     3095     1541

Draws were sampled using sampling(NUTS). For each parameter, Bulk_ESS
and Tail_ESS are effective sample size measures, and Rhat is the potential
scale reduction factor on split chains (at convergence, Rhat = 1).

The summary output of multivariate models closely resembles those of univariate models, except that the parameters now have the corresponding response variable as prefix. Across dams, tarsus length and back color seem to be negatively correlated, while across fosternests the opposite is true. This indicates differential effects of genetic and environmental factors on these two characteristics. Further, the small residual correlation rescor(tarsus, back) on the bottom of the output indicates that there is little unmodeled dependency between tarsus length and back color. Although not necessary at this point, we have already computed and stored the LOO information criterion of fit1, which we will use for model comparisons. Next, let’s take a look at some posterior-predictive checks, which give us a first impression of the model fit.

pp_check(fit1, resp = "tarsus")

pp_check(fit1, resp = "back")

This looks pretty solid, but we notice a slight unmodeled left skewness in the distribution of tarsus. We will come back to this later on. Next, we want to investigate how much variation in the response variables can be explained by our model and we use a Bayesian generalization of the \(R^2\) coefficient.

bayes_R2(fit1)
          Estimate  Est.Error      Q2.5     Q97.5
R2tarsus 0.4339423 0.02259243 0.3892020 0.4738335
R2back   0.1988869 0.02761764 0.1457193 0.2539534

Clearly, there is much variation in both animal characteristics that we can not explain, but apparently we can explain more of the variation in tarsus length than in back color.

More Complex Multivariate Models

Now, suppose we only want to control for sex in tarsus but not in back and vice versa for hatchdate. Not that this is particular reasonable for the present example, but it allows us to illustrate how to specify different formulas for different response variables. We can no longer use mvbind syntax and so we have to use a more verbose approach:

bf_tarsus <- bf(tarsus ~ sex + (1|p|fosternest) + (1|q|dam))
bf_back <- bf(back ~ hatchdate + (1|p|fosternest) + (1|q|dam))
fit2 <- brm(bf_tarsus + bf_back + set_rescor(TRUE), 
            data = BTdata, chains = 2, cores = 2)

Note that we have literally added the two model parts via the + operator, which is in this case equivalent to writing mvbf(bf_tarsus, bf_back). See help("brmsformula") and help("mvbrmsformula") for more details about this syntax. Again, we summarize the model first.

fit2 <- add_criterion(fit2, "loo")
summary(fit2)
 Family: MV(gaussian, gaussian) 
  Links: mu = identity
         mu = identity 
Formula: tarsus ~ sex + (1 | p | fosternest) + (1 | q | dam) 
         back ~ hatchdate + (1 | p | fosternest) + (1 | q | dam) 
   Data: BTdata (Number of observations: 828) 
  Draws: 2 chains, each with iter = 2000; warmup = 1000; thin = 1;
         total post-warmup draws = 2000

Multilevel Hyperparameters:
~dam (Number of levels: 106) 
                                     Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS
sd(tarsus_Intercept)                     0.48      0.05     0.39     0.58 1.00      878
sd(back_Intercept)                       0.24      0.08     0.08     0.38 1.00      290
cor(tarsus_Intercept,back_Intercept)    -0.50      0.22    -0.94    -0.07 1.00      518
                                     Tail_ESS
sd(tarsus_Intercept)                     1162
sd(back_Intercept)                        483
cor(tarsus_Intercept,back_Intercept)      623

~fosternest (Number of levels: 104) 
                                     Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS
sd(tarsus_Intercept)                     0.26      0.05     0.16     0.38 1.00      759
sd(back_Intercept)                       0.35      0.06     0.24     0.47 1.00      521
cor(tarsus_Intercept,back_Intercept)     0.66      0.21     0.19     0.97 1.02      311
                                     Tail_ESS
sd(tarsus_Intercept)                     1098
sd(back_Intercept)                        903
cor(tarsus_Intercept,back_Intercept)      479

Regression Coefficients:
                 Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
tarsus_Intercept    -0.41      0.07    -0.54    -0.28 1.00     1578     1207
back_Intercept       0.00      0.05    -0.10     0.10 1.00     1995     1541
tarsus_sexMale       0.77      0.06     0.65     0.89 1.00     4384     1440
tarsus_sexUNK        0.22      0.13    -0.03     0.48 1.01     3221     1534
back_hatchdate      -0.09      0.05    -0.18     0.02 1.00     1787     1210

Further Distributional Parameters:
             Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
sigma_tarsus     0.76      0.02     0.72     0.80 1.00     2188     1082
sigma_back       0.90      0.02     0.85     0.95 1.00     2439     1558

Residual Correlations: 
                    Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
rescor(tarsus,back)    -0.05      0.04    -0.12     0.02 1.00     2721     1528

Draws were sampled using sampling(NUTS). For each parameter, Bulk_ESS
and Tail_ESS are effective sample size measures, and Rhat is the potential
scale reduction factor on split chains (at convergence, Rhat = 1).

Let’s find out, how model fit changed due to excluding certain effects from the initial model:

loo(fit1, fit2)
Output of model 'fit1':

Computed from 2000 by 828 log-likelihood matrix.

         Estimate   SE
elpd_loo  -2127.2 33.7
p_loo       176.6  7.5
looic      4254.3 67.4
------
MCSE of elpd_loo is NA.
MCSE and ESS estimates assume MCMC draws (r_eff in [0.5, 1.8]).

Pareto k diagnostic values:
                         Count Pct.    Min. ESS
(-Inf, 0.7]   (good)     826   99.8%   106     
   (0.7, 1]   (bad)        2    0.2%   <NA>    
   (1, Inf)   (very bad)   0    0.0%   <NA>    
See help('pareto-k-diagnostic') for details.

Output of model 'fit2':

Computed from 2000 by 828 log-likelihood matrix.

         Estimate   SE
elpd_loo  -2124.5 33.6
p_loo       174.0  7.3
looic      4249.1 67.2
------
MCSE of elpd_loo is NA.
MCSE and ESS estimates assume MCMC draws (r_eff in [0.4, 1.7]).

Pareto k diagnostic values:
                         Count Pct.    Min. ESS
(-Inf, 0.7]   (good)     827   99.9%   142     
   (0.7, 1]   (bad)        0    0.0%   <NA>    
   (1, Inf)   (very bad)   1    0.1%   <NA>    
See help('pareto-k-diagnostic') for details.

Model comparisons:
     elpd_diff se_diff
fit2  0.0       0.0   
fit1 -2.6       1.4

Apparently, there is no noteworthy difference in the model fit. Accordingly, we do not really need to model sex and hatchdate for both response variables, but there is also no harm in including them (so I would probably just include them).

To give you a glimpse of the capabilities of brms’ multivariate syntax, we change our model in various directions at the same time. Remember the slight left skewness of tarsus, which we will now model by using the skew_normal family instead of the gaussian family. Since we do not have a multivariate normal (or student-t) model, anymore, estimating residual correlations is no longer possible. We make this explicit using the set_rescor function. Further, we investigate if the relationship of back and hatchdate is really linear as previously assumed by fitting a non-linear spline of hatchdate. On top of it, we model separate residual variances of tarsus for male and female chicks.

bf_tarsus <- bf(tarsus ~ sex + (1|p|fosternest) + (1|q|dam)) +
  lf(sigma ~ 0 + sex) + skew_normal()
bf_back <- bf(back ~ s(hatchdate) + (1|p|fosternest) + (1|q|dam)) +
  gaussian()

fit3 <- brm(
  bf_tarsus + bf_back + set_rescor(FALSE),
  data = BTdata, chains = 2, cores = 2,
  control = list(adapt_delta = 0.95)
)

Again, we summarize the model and look at some posterior-predictive checks.

fit3 <- add_criterion(fit3, "loo")
summary(fit3)
 Family: MV(skew_normal, gaussian) 
  Links: mu = identity; sigma = log
         mu = identity 
Formula: tarsus ~ sex + (1 | p | fosternest) + (1 | q | dam) 
         sigma ~ 0 + sex
         back ~ s(hatchdate) + (1 | p | fosternest) + (1 | q | dam) 
   Data: BTdata (Number of observations: 828) 
  Draws: 2 chains, each with iter = 2000; warmup = 1000; thin = 1;
         total post-warmup draws = 2000

Smoothing Spline Hyperparameters:
                       Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
sds(back_shatchdate_1)     1.90      0.99     0.26     4.20 1.00      368      346

Multilevel Hyperparameters:
~dam (Number of levels: 106) 
                                     Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS
sd(tarsus_Intercept)                     0.47      0.05     0.38     0.58 1.00      763
sd(back_Intercept)                       0.23      0.07     0.09     0.37 1.00      311
cor(tarsus_Intercept,back_Intercept)    -0.52      0.23    -0.93    -0.05 1.00      516
                                     Tail_ESS
sd(tarsus_Intercept)                      979
sd(back_Intercept)                        333
cor(tarsus_Intercept,back_Intercept)      664

~fosternest (Number of levels: 104) 
                                     Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS
sd(tarsus_Intercept)                     0.26      0.06     0.14     0.37 1.02      421
sd(back_Intercept)                       0.31      0.06     0.20     0.42 1.01      555
cor(tarsus_Intercept,back_Intercept)     0.64      0.23     0.13     0.97 1.01      165
                                     Tail_ESS
sd(tarsus_Intercept)                      638
sd(back_Intercept)                        891
cor(tarsus_Intercept,back_Intercept)      612

Regression Coefficients:
                     Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
tarsus_Intercept        -0.41      0.07    -0.55    -0.28 1.00     1045     1482
back_Intercept          -0.00      0.05    -0.11     0.10 1.00     1608     1571
tarsus_sexMale           0.77      0.06     0.65     0.89 1.00     3781     1474
tarsus_sexUNK            0.21      0.12    -0.02     0.44 1.00     1994     1581
sigma_tarsus_sexFem     -0.30      0.04    -0.38    -0.22 1.00     2928     1645
sigma_tarsus_sexMale    -0.25      0.04    -0.32    -0.17 1.00     2784     1529
sigma_tarsus_sexUNK     -0.39      0.13    -0.64    -0.14 1.00     2247     1535
back_shatchdate_1       -0.40      2.99    -5.56     6.41 1.00     1007     1129

Further Distributional Parameters:
             Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
sigma_back       0.90      0.02     0.85     0.95 1.00     2093     1434
alpha_tarsus    -1.24      0.40    -1.89    -0.26 1.00     1693      739

Draws were sampled using sampling(NUTS). For each parameter, Bulk_ESS
and Tail_ESS are effective sample size measures, and Rhat is the potential
scale reduction factor on split chains (at convergence, Rhat = 1).

We see that the (log) residual standard deviation of tarsus is somewhat larger for chicks whose sex could not be identified as compared to male or female chicks. Further, we see from the negative alpha (skewness) parameter of tarsus that the residuals are indeed slightly left-skewed. Lastly, running

conditional_effects(fit3, "hatchdate", resp = "back")

reveals a non-linear relationship of hatchdate on the back color, which seems to change in waves over the course of the hatch dates.

There are many more modeling options for multivariate models, which are not discussed in this vignette. Examples include autocorrelation structures, Gaussian processes, or explicit non-linear predictors (e.g., see help("brmsformula") or vignette("brms_multilevel")). In fact, nearly all the flexibility of univariate models is retained in multivariate models.

References

Hadfield JD, Nutall A, Osorio D, Owens IPF (2007). Testing the phenotypic gambit: phenotypic, genetic and environmental correlations of colour. Journal of Evolutionary Biology, 20(2), 549-557.

brms/inst/doc/brms_overview.pdf0000644000176200001440000275454515057753141016361 0ustar liggesusers%PDF-1.5 % 1 0 obj << /Type /ObjStm /Length 4661 /Filter /FlateDecode /N 89 /First 757 >> stream x\kSGJy~ʺ 8؎-&օH_B7C[BӧϽ{$ ^B_"YPB/ WH.t +B!pҍRxJ ' 4uaF)lma9Qk(ڀFь M+M] RY ϭ()u |n/UP.B"#(tkGqDs8q ܤ !Qg$1 AkqF+1M g@Y @Ӡ,PD4(K<e_ qoDqU(.PV (+eBy5:hAY[tQ`@PGaAJ@jeǁ 6kv,: 7 ]8}怔eRdA\$4 F :Al=DГr `/Qr " 1`u[ A E=xTjϽl.A3tUuVuLxz E`|V<{[ݛIi}zʹ͹Îq.k}s Z^[><ﴗ;I筡ghuRWԓU[O^7yrP8ɤ>>'iڌxCnKDŽvx6Si_˾½^8];³:9mF]՝'bܯcɸ?vڛ4-lJM)pOiud+sg`ldf=.3A7fP&]sk:F-tSTi 㐶IiMyVt]ŭ[?qz>ms;oUn7mrܶɴmIHV3Ѹ;&&ossӹm[ȭJd'3=LOez*ST2=LOez:әt3=m:Gm=3N`M|!j&%ltgxKsqK 9 md;[f^ԟ?{8N+Ô٘yY9ٗyY9ٖy;,&Q1ITLbD$*Yd-yCiCX3ˇ0L-y5E=lzTR2`6ѴCI]ӘQ,⺗.XD,aWDHpU|uw/j=}Gb,{rI$mw%Z=0K(^5g[xAd>Ic<5FWfZ *}txM#t|RS:G &QHbA/sly<`M42t0;G:cf$'H { W'v3ޫ^{LPUfmͪ~SOi3euUZգ~5=gj@nȌ .)RsX>Ew.(8ԧmڛD@m3?q[O .ϧt҈N{єl?'r?+laTtUPQFgvUlvPأ_j4q`f۹IZc{ivXS}Ь J/?ov]>dNWt1*&]܏VA/3vJ.[4k }_jAS{ x䰩,C[d Bz/! G@o7ɂ&ahbONA!]SP%E= e#o0hd^cqFGB#ݮIxYBbTz2(H;gV׸+tŇ^۝\ ~t 'Hsv,ڬp/[Vji9ZIPD:TOo8K3 tI5^|ˆң{ԟa/ܒ4X[)\N&KKe_^  ;ExSosa>s?W}O9F5=w3e#^Td1w :v/m~Wr3[[7/z.<n]bgW\.tRsRݜ[SxY8MlJҳ]v UWuQ{g$%I.tTCZȕԨڜlOʼn,|CeŔ>J8~p1~nBùRyP~\bжvކt5,iJny쪶FjSgj їb5Mk"(S󥢺e0J2w %,rBWa`-3 ~-pr8Kʠ;p18\~iS8KlM #1`CMeiXMDP ࠬN\'ǛM@p7GDкNBa ʣZ،2~:xX9x\N\RM\#yie4 !{hy%ڒ2I06\rMj[JMҊhNZ͙M>KGG˳wz@PSp:50%$ߥ'ZU.#lJl 4ehRؒGM44qfH %hsHi DM4aBL`4lz! .H8md?tIoHO7Â@yʃb^ʘ98/snnxa\8CځSd{#R>:guV0^o4C!PO;pf.#)IXQZ^fT)/@佀[1r"Ԃ&)$$ɿmbcpJI :l*=`[;@/: }!yk.i2Ay֔B9-Vpq Q7)A%0r]g^|n7x*< Vveݜܾnn[dOWd Noxf3.22_+5Dhu{ZA45M 5vi#ZvN ;Tuzͤ7ϛVvy"3z}kzoXw31'J1V릋Ƌ J}! )ť{s'm{1c}h07bPGL{\٘U HS6ۓWhy' ySQLoâ4F5qS'g V9tZ\.nyI/) X%Ҹ{>޻\|56kvw lmV?v-\\mu 70:vkV{7I\jq6TaԐ+UPcYIY KMˣ10BD|Y7m5>#s6fxU.L*J)v!S$:e9X^9cegkB_M7T NƲEd,Gvdэ `d#tݮ/9#Z=JW}wioʳ=D9EelR[RAS CnIKhNO(y]Fa} v"NlRW<m/9t06zI]{ʴrT H%O7WJ*uL~*ţ!;l zjTNI3bQiʎx0E$![zz:+?}$PQ9Tn,~$N9ߥ\㸪ml0b%P *e؂.&{8==^5,^9Nfg[FH` _( ;(E /ilTZZxƥ*Ns ͪAy E  #&ZmrnWE-DtK9='^-7UC/Pԍ{~mhRNxq q6hDZxUHn.4QXv Mendstream endobj 91 0 obj << /Subtype /XML /Type /Metadata /Length 1806 >> stream GPL Ghostscript 10.05.1 Bayesian inference, multilevel model, ordinal data, MCMC, Stan, R 2025-09-09T09:25:21+02:00 2025-09-09T09:25:21+02:00 2025-09-09T09:25:21+02:00 LaTeX with hyperref brms: An R Package for Bayesian Multilevel Models using StanPaul-Christian Bürkner endstream endobj 92 0 obj << /Type /ObjStm /Length 2870 /Filter /FlateDecode /N 85 /First 774 >> stream x[r7}߯cR[@rNMjmWrhr$".z~13aӧ/V*UtDTƠW.Ⳁ|ViJZKO@4*6/ji$&{; OϟwV^7[ N͔/Շ})WŲܨ/ҫߗ?Umbmoyuy]u+NK.bb{Y6jM9#9w|>~"xf<ǣc夎"A_~]>oi&X ^$ 6{8Ew]qb_7`s076P)[ڽ1= Of B# aO_㨹L|v0nuރv;uR.?1I_|Lߕ=^$"kE[ t_h4pOЃr!GXc-ֲ =~~ (LOaanBlr! ׾d7DH :vc&5/Ȩ#8󾕘Z۾ ] 4'˘ "}Z#1k5;Yei =3VKn!+ޕE(w+Vy9yygNi-ݻmCމXi)Dmv\iN)<{ 8k9J h$5|869Xq؉*d k:GҒ}ΆxG4h#Z#G7JK2LkٻsG'ݘ}>ϰ]]t8uy䏻I9&iQf7o-8IvHHx a/E; X9jv5it݉dt!0i~p8qwjUDF)x& rˣo./V_=iP#b:Оzuz%J<=WR5"b1\þ^sgв'~c %Eɍgr2oޞNZ]l5_,/rhoOӵ P֋/:-5^6q Lpar<_'QQf&\“_~,%$396ZjrzQWazzzqY"˭wA?mzl\NN_!*aN6.Lu٭8,d\N#7.<=/0PxY<Å Y,(8aPGp+Z`\+0BI[ x lq Shcs$`M -z lXڎaPl!Ph6X`ސ_3ǀzOa)Q: cݒdUx& u!6U=8C# g,"r),P4F7-B6 <>.z9&r0ĄUԂiSq0:10t22FШ,ve Y|Tp<C$nWqTO\ 4r)["Kx Nv4JÄY<ЂkBSC3>"-!:zyuc鋛 \CSW++Ԝp7 7ؒðBZ[˷0zD> /0}V_Ǭ] |.Ru{ތ˵z ˭`׸s_ǯ:uZ. A% Wʞ,!OXYI``^8y3o+aALETCBA<#=*Ljc%}bsC dGu(l-: 8C=,uhn&]B>p}"8ԛt`B;b)`cPAomI-nznn>=|4w7M fFl3S>{voo9!4?KJkޯimižz u@;f6NRCPavKQGwCȡ,eP. v.3W/CZdzGXg'-8//e R++x 1X#{\pjpXpe&~eS5lX-[|nl2\,>f;]>Or6]wۂ=uZ?/6t68f Dqd Q[si-K&S^0\yɯM|mO5kpòv!5b89endstream endobj 178 0 obj << /Type /ObjStm /Length 4139 /Filter /FlateDecode /N 89 /First 845 >> stream x\io6BXD(6sm$4I,&vw}$8$b04ȇ| τ癔Ȍ(e&rPpBgRHy cqa3i92>SBң)EuϔsDFAfZXT3Й*p* E.3#{ #ѱȬ̬Uf\g)m4.\ڐgz+d %ϼp"Jzwuy `LDA@~qYP*,X'8%5UdnM;M@@˃p3!8 q'0U(Sb>0>0Ї$J>R ͡ԁi =Esz>d@@-o %&W C](Kc#*OӅPpC W-_LhMj-K чԯA` uc3C=S0I>LpsV9kЇ5x" P }8ّ}8KKO}8ʼn ]ج%p@YX~hS>S>R{!R{!R{!R{!R{jOqJJJJJJN4[JZ[%ݍz"^|?H;ƃ3t7:󨀪tv7AUtR^Ɠhc^Dg'7!(/G%.ȰV/T*,g Y`UTCEhî/oj 9SDOl`T٨*>@5 *ѸW=i^zΡ5j jD*wMˇf]$0/Ey~Q߂ I{>;`v^cvz=;exX⋬C9`//+lll<*%,&MؔM4-?]L>ٜbRL)>O3뇌;#4ܫTpzO?= V9~2 ӻA7Q9BENf9> uU %MݬL+ݴ^<z wJbQJQ3BlP3vR3#LKՌդ>II!643ޕ뢗T?^.<+ ھP &Zg3Z(huk27db"d=eXopyI*f=pcgtg1%Nh^̴9˭kWn~ry;+]263js ou k<9+&)M5x#@yZe߼Rȝt͹h>P@ESzC+k2ejQ]y`eLONupZRU_A ^-~lkӉT@jW%P'!rɨj\)J9fZ]O!;f=v`kKʝՙ:kvSe3pq%ΗzꥊŵhW֌[DbG_<|+۾bp#B5>tVhWBȬ$|olIF/VB^7a58msʅ~%pmT"yN"|SploMi+dWi6*Vh㶒4W㎝].:v21qN㻥{{o mZv%5DWbp|׼ yFmllMT~SE=.9)&mXpRZ~6A>{ ωsB ~bBmweh$r !0APE /O-A wΜ6DD*9duq4T BTSѹlRAKT5<XFCtE_5qoԱI_j񚴸6۰b ;d v~eoM!R^J,v"ChIB)檶#4֥.Ɲz&ڐM7|-_A݂Ѱsՙ>1kt< nޭb'8eN{fDV.-M#[]p!S-${H5)} >*oK@I *n)ڻ N/4P 8FʻtD(.[ip\Ci_=(\[p nYĀl9ӎ۹X:DsQ5| sɯ.(I]H"xIn(958Ek^8TU.XX^PF#r 8w𸴭ޥSc,q\o:hQ?tϤ~&3M|pdϱ4 )&vqF67wHrn<\H:>V4e w/2(ww72I^?i*双}1zt<ߗ8ao&ŴMN/|t9?(+Cd5`ݕ טmv{C S! HXeZܖJoM1rv1 !sV| ާt"YQӄt{&@^ dB{jleo>ϋbsFpkb蠠D)a'o u=N ;O3_`t])~˰ykW“:CQr ˠe_=5KLxX<τV:œY-F[ꮎR惖N4Aq[jcY> stream x[Ys7~_1IJJر(Ǜ-YSB|߯1DK 0>Fwr1')3*s"ੳi2l&(2Tl(Pcb@S5Th *tČЌC訨eF >3*213^"3^O &TzԙYEY*̚HM.Rl`f6:j 0AGkBfhZyP0l楤.ZQgPO̼ Y0UcIGD"2GL&E~.+xDdbt9fRH6%P,Q2`,FW%G3>R0W-)(ʡD&RR (Lk!x5PBJZc beiO*}1Q0O H%K94ͩ!YRBeshCm aʤDC9 6EÐp2,ciE)sXA17'Xaż3i-Z*ij4+1IdljG3VO,g|<*zc?ϊgOlHG ^t|=9ͧsI9(&HO$/16?z,%'\4y: xu xꊾ$SO]?MO߱Nwa~:j^iuz^iuZ.M-K[gl=twJkb x0ѫ?G`TJ8?&ut:>+FSFbób2-/ "<ɧOұP N2~rLXczT`4]a) MZQ&mg׻}g)IWUmAr_?k>iQ,G' &399|C>'_|G__+aJȯ0_  Ot8^<1ף|2=Or|2>$DG "6OaTGXj&35upMW^aq7:#,N*IIO:|Nm5p_>ٯ[*)U%u+Jj*_Qn .UNk}V[7 +Ώd.Z֨s ) zU!!(J( V [kUUT &R Fm>KRO Z#׶ Cp<pY7'4Hv0F/3D2&4O \5<U/աj?>2OWc=yd:?*2mNs0(-tJHWM ȑrP>40UstA0!eFҵ0\X[/8\]L[tN0\g\dNpJxfZNͨ \3lmCa+^awe #.,D69#ۥK}h:Y f"d|}pӣsgddhf|YkaeX3.jPEu-:X+8,ܷb ^Q(TYP͌U >%fde/ Mz6D@h l'5 I'"$ćm2`@/:QJҎ Gw+pc 8%om #TXoH38u . l&*f)~Ӎ͒Rʳe {~ڠ@) jA6Tjl2ٚ8{l3 T連RF:})WM`Qײ!kj+<6Y}!?ls pL'}pZQwey57Eyq/JS'yYfI}뗫(!gG 7Z$Ns 1+gBՖ3(g2$nlەVObW04D-8Z UIҒcU!nj$ҵ5Zhjk;*U Pt̚"j*7nJLĺ0 v~%3ӷo?<&zHrk}rݧ :=ڶk_ʇHijϧOQ?+DBnYU?)ߢѰ5tk hLjO-9 nΠݜ)40}:?O lq'5l+Βt.NZ9J%i{цk3ǵիb5&{jAnq ZP!@Xx|cC#(85{۲$$M v ]b]f9;~͓:/Ֆ.E~_b_U[gO5-SłJN1d2b mDldqH#]#~pMWШ..\hՓR2ɗwag %F/]bj:%%v/W۰qEWPU[Mpd4es+4Ƣ'ZW22m(R(eUڻ<(؅KqvZ%l(LkD`dF(q6Bq|g^9Xsz,Nf%.]E(%ӹ+:xl)lVηb`05{3DfUa;eꠘ8 YK^ڍLIwе5y3fmLXyk=6)#SQNCppݧIE_=mqjK7 Ufu}B 6@0&  #nN;4vN{-8\x,l&p X$aS8>6i>=jTo\iZJkK}>~`p~23l;%rQ 0YS*kܩ?༅m7ۃ[7F 짢/VC HXE*RJvew"thpdzzIb[.MA) !wl{ $RJRŝ'chl0mmg 7=)޿'>/+y;>G&#R$}= Tendstream endobj 358 0 obj << /Type /ObjStm /Length 2872 /Filter /FlateDecode /N 89 /First 823 >> stream x[[o~c"yx 8MIvcqpS>H,Y'(xWAqJ#E c@clБ$=0g0 FN+L٫T`Y GI(sV!;@`lHE,">l>#V1<*&F'cNTd)&d6\LF%<|) `S,ϲ-D*GAeQT9bLI1P!`Z/lE<{,,_@@L$#BD<@~)Y1ls$qg@^zQEAdmd:#9,{/E`# MX- b92GO}&'bT,biіu˵}&U3ޮߝlͦ_AH$K|#MNY*ɗg)ZX^x *חf'?U/+ s#hpyc Mͥ^T[[[W[mmmmxTǣ:Gul5CY8gMoo xUb6W0i78SmYbNG )h<ιX #&a= BtJ[q -46~L0yXg{rkCw*>A\IR\!vio^z%|H q*'Bsk;>gM4 -նXmxA~$]8i,]Gf:PRD~VHY83@([v㘵jyD0#Pnё3hT҈b¯Ev@5[lЅQs]GhrH6遉~XRDB`yY Z"eaL9<a%my(wc-+N{e!5I 8 r!^b|{jIGsQMW :P:k=:cDޠ9WߓDxֈ>B1 % v'S. ;]6p/^\d6.p~x7(zr#evjqYKf 6P[y3{(vÄ幐%OM??kf>Hɿf ^-/Eww_L?,A2- ]?y:h ~jvjz1;?Ye@(PHyAUgnٛf:]|nFreLs-[a.8W+₷6J疬 JtL.&d0 UX 1.1c:؛23=E&рL~' $iCVa$ >.m홼D|!"*x$ըM3w3JkA .IGKR$D,8 opLp.R!Zgf-5>4~I|܀ ֟-_[ȝ^R y,Mw&[㏯^=9k\ v:8"tXw++7}E+~o&Mfx,NnFsg7FYgM1H=@g9b Sr fD!-Y{ݚw88`oex>n'L~`0Y\貔ݬ 4y\cw06M)lEFw=цuJ\y=ʤe;Ȥ` ! r(C}.g9ăe D$u5Ͳ Q&C~Zpq`88J9CJݱ}"rRxQgFl>ny6B^ ڀNG"H n$aj,W. Պ9-o~`Cv5lQTiϷ-S)Wl5“[o{"4Ik4tN(Mi\u8:G O-:9|u6Cu5NI[t|p}C36Vct9hBbZñy)(\>\Bpڸ\Pݠc`:]Z'/Um!hkR󚹯o{Znܞ+;)'+ފ!R* s0"J´Tl={nܽ{wwٻ%^6JwX$ ƿYNXl[R>ynpl3p0r R@NAg룸 $O"Ͽ_l Tc[pdrp:H[3& CTVdžH!r!z#r# sHec aa6; ?>5~0B;v\BdA$PzX˥r[ 3Χz?XbG'jSO> stream x\srULArZ%gW֪zu(KH@ߛ?#t|`LOOgϋ /goٿK)^:S‰E-ioŲ*+t1lAr[sF:jTv@| tuMSV(~$*ֺ.v0Ws)[<#•FV*TꢽďUlqK,*jR">-KPR(- ˆ>.] S(TkQ8lnsOĵeh2E_R 62ʠTjSZSJք=0vA~\*m]G| ʹ#&HUb%,t'VB=lVonbVc ^j .︞Y\ߝq{07gU)[lόã)+mnn`\ʕw=+~r fi+alY͕@ y!u(a$a݃ʺlŭ7Rknx>,֪^euC'ٲA-QsV kmV%ct6G~ ,-N`lPdN*HsQ Jo!4U\Nh/\}ӱlliHhk%D*ǐn+Xشidf ,I5sA2t>D$(ڡ4-;6 &,MO8Lkq.ch[躛nwfz\L 3VBCm{Zx8`2xrh ,j`%cvɶPQaRT0 $Gh\ WSnDibalL.gw#41pM4E]_9SS5Īg<o2J"e14s4nP9~<2LBuu0l?mtMh&Еg1(DW/7)S9)ɤh"Ma:Ř<8hL1 JbVZ&u(NN[;||p0 mXcnhNqѦ70Fʆ!܀Vc|Xm G谍~}.ߑJ[7E3qа@wƽ-~&Ӧ%8A\ }~P>}|[Aص'bр+̥f2{-3L[ x" q3pdP㧹#n"ծne(bL^6S_" nA 4 sǹB u֘/i%SZ@lF>v 6S:H/^@[d2.!n0M6Y*`f'J P\(펤v Fap {EI"h 0,ugoM{OM؈چ-) ,(֞wOs#9EEл^Z=P%D&6t?` $v{AURZ%Q(RUBBmFQ6c||Kd eU4{_a-7vQjSQUM&ܒP1؂8X?jzT{RCCx]ҿ[*|em,*PqJS\sC&FzdmnPn)(DBTn [mH{'$@q\*D#+N9kxu7& ۅ2`"`> }]V!(FvM8YYZTy/sKGeK(upBC%/f 9Pwd+}ۭ3 зd?x(U}^AyJJ] 7I>}ޭk'JqI++',ųsv#4-}jΧm+f-8<9 _C3;  FWEu"vB>~LhicD,8B83hD!}!bb,U\{রOlk> =t;F@<S,[4_F23nC.S:L$W+懤jƘ:r"[o>k:JconQ#Q8̒ M0e5C42-cGl݆dJZ3>9}\flhl-(=BʮS [!!$S6<>m.d};o5 x3< ;΁ؓ:ΓE`ՏskyF coY+[|f,L7^^!ƃ%O=Yxz`6"\UJ$_ ~ [f_DG YЄyNBu1ݷ&*15B\.~PEV7':/`V)b~K.C3,q}CS]75 "igx^H&'S9&.ь .i6}w<.xw}sW-<~7B"x%D`=(ؐt.ډnNšJYJm)Ta?&J #Nэ 1\v2'!h"/loJ[h ;"ͷxS2XHBмO2!xIp\l s- a7MM(n JKG#xy5' }Se# 8Ur2Q2uRU^83ޮ, iCu3ty}`8(4aj!xUL̰ӬAX1vG879}Ί/d\ uҟ1"j GB)rr<ᬃ$g+C`#!;6;YuO#d݅LDV浦pD"=G+}U1+v-H[rkbĎ+繧(QULZ!P  MJYnF]< F-j[Z5vl%QYX^DX9}3Wap(^[xx5f<2 ѱBfQz y7 3~FբDYi )Uv"c9@tIζYv} gAū9tEwo]F=) ňWŻ>XraCH}eNXuu? )l{bjQk~,@1.ע`qW{W)I=/9X`.L |9Q@TxMfEH1\i0vbN+by0yYzCkP t&5IJLR'3D J|"=e a3ʐ,ǥ'gv[KFd^P(٬=%4zytmȁH(}I^GL]B^-_zGѯq[6޸å̕3vv߭S2mn8wٔS ISgv<;r~YK>N7,~ż"amha ?`oxe&''|v)Oĩ*0dG15\i~~9e_zM42GqSqhbLGLZw@n:Q9zv XZ_NUKةh5:G~R ïqivtUgl$I%K@ a}o!7]Ys֢4xxQ;(GSV: ^!R/*77H^VU]G*uhtOPk?;fh10>IGHw1 sǝ;?tyqendstream endobj 449 0 obj << /Filter /FlateDecode /Length 6277 >> stream x\Ys#Gr~enmuWYZkޑ7nqڮ;6Zy<ַMMjw"?nOlZ椄NK +z 2FWo/;g +Xwq[T:U,44P_.4 S9~Jkvy 'kQnMu}lU˄gxsWԪ5cо`+ݧ4VZ~F$}4QVNQ.,*JaAyʂhҎ "oކu}j7kP<ڣU WciH`ЄeR5/Q 섇);-@g6g6:8\#Ec[z@*XR`,؍כu4!VxY ~n:nF\@'0?So:/1|Ub3݀2@\<$vƋZCnj _}]}a .x[U8EX}}2տ]ᜎ$ 6= $JTv\%6A3t DZy2S55“jf74j d2GZɣH>АDBI̱o9(EGԳN0},8hd7j$ $ddl@SuvCjw;oF&y>%꽚 4 ?i[`af&[šb޷}a?rz@i5j JN8&=:6ޠjBj|@3 [Il.?V,5f=5ng MmSAHAG)h|P?9 RlXѦ`ݛEpưS !JfI xQlh`ꊵc`haxL߾CD yۿmvDuhثbd"ςXk%pRKKzЉMѶ "Tb.,C726JNpdG^GxX>KGMI=Q].J +;x_ǃ?mIy[J% # nS8i+.eؠM&a=,.$>v;P aw44DUئpZFtu$6ծױ$+r#fiT$*0W \4>ͪiGywy.z<i0KK‚(I.W#ndzM-a,ȯû KD[&3+D+$M3}'r)_n[Hɻ~K~u2(eTR6lLA`(aNbOYq3Oݱj-~ݧG("WsmYv 6ꏳ4[t,xOw9gQ=Zp;39HO鞚s6qqc8cZ6DgpbaDa.ax5`oN*zqy7X7@I ֘Rغ峎?IgFzL̓^e)9b.qv Gh_B1˹0H `mAPSMn~>~Թ%0QA)F_DSG?u ~G/(en+ T=i䭵 \c:KY}F`ϰRLޏfF $^oHkCK{&c7\b_cOI")6*R՛fg:kWǔ׏qۥ@BP и$~hMN4W))$%M]d.?a16}~p:jI ZYCJ$,Z7m6PC. ziáG:9Rfph tcuVyh ~ \z*832BGaGZa,5 P\o^G'g*B!*5Dr r#LmG9\WM4XRn&7yGFR20`]'=0fp;W[Ac#ح1#-O1=̗Ta֍X#?fȄڮ:Ac-BG5d1z]df4+ӤSk;ڢw@wTB}aY,o}F߃f=Cb0@`!9n/FNaX3U 2lCAUO<%^O qB[2!tLmVYO,8(7v7lbQq1w) )"lBJ y. <019x 9H'aS?B? Ci]; >G2jT,SvσۜˣVGŦ2աQC g_sا,=MaLW ZL61@9Զtq1\m2IJE5S!gTt /*Nm*rFpzeJL1<Au~1z-ضXcMW,O6zWlߢ͉sS4=CfGΗYT`dɋ2-6{J !Caf=>!Hla 7~-;`aa;60wrOq)95O%_1+ ’|ZɅ6ux7]>2+]{?>[?4nALզ=y׭P3ZT=%QC[_HL*+2򻾻EXRӪLI-@YJ;L{*>P5^_:W[Y* Dx * Dzp]GhCQ5O afq;eq0ׅb#.VR,?Q1/Gh4@Q$V"|/jEߵ%w( bg8|t)QjVY.GtyH[]d'(EL6Hh|9$q( 7U%Ǣd1RTE9 N}ω)xa vڵݚKEG2(uge9+,ijt)7rܝrԃl3teNVvf2dyZ/=|ۭ5kdcP.v1%X]`cc8*:ӅA; I&BK,ŧD9^|>UB$Ҭ\|vrF ?wc&%~9Yx4t.㑹ێWvw=t7 e<]wygT:va*UCЩ./.dW_B^G89 c7vwbH5E"? [>!}EvOW4di3ߓFƧ\0.YLu7ٷW& ȇ=?u?",>J,>1ZMgy" qW9EQW%#_>(aŔBtHȱ.~ K҈qFش(Lҿ~Ș>Tf-8 @L v`0vs4-S|@Ɍ1/JF9yBV!ftTh xjDY2pދ6 N6/e8^Wj~a*=rE1XbF}PyS<Ⱥdp zdBW b9O~CZE|OZ[M.ڜ=L5@w_հiA,%pYTX u=mYps3~qD p.tEx:"ocd{oDr>I4RL- j6oͦMa8SŌ9:xY8𪶛.?Uzx/nORJXS⿃ǗcH(V>^xG< (}T D>So3UI#`f_/:]2kϗUHV>¼kT&7?9LFr$0LU[Jſ&F|i!EQ#\b+&=Ї$Q=<@ЃhHCd)!*}Yu}yoyLӆ*eQ!,|eY4#̧8,w| \]6MʧMyσ 8pwp/>B \&s\n|,mrHVJc羊aJymoa7f1s-jtKKy'VQc .̬hp>֪rHƊu|Ucy>4\&Η Fȹ~@HJtm{K%rt~endstream endobj 450 0 obj << /Filter /FlateDecode /Length 376 >> stream x]N@D{ N&RMh(@|F.b[&=3bNzogg8\2ra5}/ԧ9zSwCHg>s:>\j|P+zKkӣR5,YCġ*c6]oۧۇguxX486$!؆l]H؇DgI+'TMX9h!$Dߴ 7E0F0Fi5> stream x}Wy\T>0sFEP#vfD S16e+\@U}q؇ 2cvܯ)Ҳn˽.?ǜ>}+a0d 5-[bs[by, tORz{]4J$ݵI)1ig[Fò}B㵙\߹Lgz6QFEnP\VfڧdzOa-MܰL랔Ꝗ**:fMx-cf1әZf3g2f#lb<'cי7ye^dV2 %3bX1iǒ14_z˪H6['R%z -cƾ?nѸX/h]F_ik1cb@@gA͔ GL^`IҰ3ߘ N٠d3cIA,K\Ph58L` =NUQ7Rjq-ͦ/a* "`&o~€5A9rCd ٫UG9wV(Ӱ BE{iX3 #YׄZJd}hk=*I%v܉њTaFqɉS:LǹCsSGr6uEED~-A3Fdq5@IgJSF68o6aK-`#N%eP9HqBW(1N Q&;G@tHGb\3+Śȸƻz>RGl4C#4L9{*2^WrZ<Ms]L% TmS%l.HKO P9t&ybS X Q٦Ka/>XM7߄ЛX_dBF' vែwm 3-EƜ1qڊ=\禣ק< 4L,̒vϢ\*u(%\gԘZ~4#eCtIk|?(vzY2]OEp(깃}GZ ?$oAyİ8-Xڎ6}A"VOY!Y_YP5/ 3dtkؕ95ddG98ctdT2c[V5' -cwDciy^urIleATǛdnQ7ꓒ "DW$0"7)|Ƚc1-u0 8+ |Sndnl\jz S"`-+L4f ٍT,L)K4@<u_a$2A.VOL2yL-LOٞ .́|(3w5EojG61+B|㗅f=Š Do-*+8$Xe6-5l/2ӗ/Ж==`8'i- u[!M-z8>?{KtU-oP sqV|BIVɹ&drȴ4pа|Pb/M:~|2'u"Jt2>v%dNtO^VA >]{S]wzw0.e6&%wvREV90"Z9M)޿#űkM`@bs_Vփ<:$Ȍs3.m>hׅy:pc16V{n_Xn>6t{7Vh?ϗ7ߗJGL+8ژ<+?w ~<< T9(7gqFWԗ_h0J _Ҕմ's`?s^{] #qF=z/ɯ V=OCB>?l{õJF6 =`)ts 뇔TKҐ-ԢS &ݹs@^ɋW?s On=HbݷnȖxH_XU4 (U,x'%Mr6:%g)GG ugwdNl,,w,~|eCex̼Y}X|h4{X~O*bfM9z*VmUl">籎SWѵLMe+\  i|RRDoPjI&y. V~!{T¯Kw޴2{}. P(i&߻tE\&ǩ'C\oa %ȸ#sDth> stream x]n0 w?T\%C 82x,(зN:t8Ÿx>㼺#/KV7qr_9uEݸqlې6$ 2m>ܤ_vQixPU|&.$obUUUMZaQll;6;ŞM^$E&Wܱ Sܳ vYNc>ɐ ,i*B"T<oWzs[fL-ՄvJvᑳ՞ƪ(W*~dendstream endobj 453 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 2222 >> stream xUyPw{0MI@Ԁg4$kb2A!D9GNa 0r 2΀MPxl#kL"l%qY66U[]}=4R(SB KڥO\0E҇1cW>t4c䭄'?Yg%8;1Gnu q ĕIɆ;Ҵ _/˴Ԅx>1F&ڤL2^뗔CC16R [>|v{(S/XhK©TZI(5QOMUÐ'#<`_Q=e1TlƉ\S&OP;UJB|U/h'M,<ɢN3ݦ1!c]ŃJN۷ bajJ\B\]cPmu‹q%s0<=]]=Fؕ`w_b\,W0] _{Oa R;1w^H†(Mrᆱ|i@wtEw.YT=$>+$f x!tTd66܍E<{ q :ؘ !,V0G;E ǰ>!cրn ̓Aڍ\k0)eEK4\|wT6K3 GgU,' a/a.9U"*IEk6ŀ\c+#x5c1+#hrH u<͹`'.<܂=Y79īedg*0')©"J!I)(BͰ!L] Ce7OF[GM^ƙvQ}*,Ijݼ6e[\` l,Zt8rAu'/d^I&``N{Wϡ9BGșձ! |(LOK1X}]9[mw5Q ARPu2wʂxm]D+?3Rsyt/YεPNӨّ:y!es4'^H $tF#C^ ?^3E&~iW"*F92hieRٜ/_E^ N:n~|};vbOFk?!veb> ȼKdJ 89VR[zRnj갵6d}MmS -2P!՗W 3kz}^[sjheb+h@jµK.GrEum]8ԃ(ڱʁyVܺ@[ŋO%dƷ%9GWfdˤzW bW744dF9 }7';.,]~Ycj2%gnJi4lӀ̪̭Ȩ0Wְ::XU"]U}}Eym$+Aҳ2 sJ2| ʿ g ZZ?yִZ(n C18rc(Rc7mpu&QCF KwDrLF*y\w8A0G%9eW'5ICk!BIRa޽"w`S縋VtȆ;C1֑yW~ )ݢ]Hg`E=1_ YrؓibbRSbC΅Rq c@CS| qۦBYZi}5ZSK!=IxicKYYyEzggt}Ue< >pendstream endobj 454 0 obj << /Filter /FlateDecode /Length 649 >> stream x]=n@D{7~dn\$\ S,}fFvCxD|ce=ߺenr^O~έ;toMmvo:<Ж{>O/E? ˩oܮv}_z֡q\>(3\QX*uHUA ֬*{`} UAwSUPݱU.UAc/AXǪ*T(VTcMQQMQQ )2*4*)2*4*SUP'cUP+,4𚘍^kb62xMFfl51 &f#ld6𚘍^kb621mdȀoR0)`Fƍ 62nǵs#K)s :r.AC%tȹ9S!t :\NAK) ;,Z!B0 d2 BCA`2 A d2 Ab  VX Bp+\!Z!B5M| הo7M&\SI߄k7pM&})ߤo5M| DMTT lnw/Ǖ'Íשk[o:KuV> stream xyw\ ;cWE,5XQ齈R=Kua)`&jLbX1Œw˽; Snμ9n5j:+{lد9OzEQ}]?o|. Z8dI0ewl[bvjO{5kG XٸO8iO6}5aXLPө!Jj5ZE}@KR(;j8AS#5(j-5ZGͥPyXj5Gm>ޣP㩅jD-&SK)2}j95ZAMPK7՝zPTOeM,()ՇQ}P%,j %h,"JٓQfT8JTif"Pq0w%K$pYy[]Fu)麲WRu/zNy^{O]Y8Zܑ^DEwp_M?Q?o_?ހ10kwwyNc6Ec0h nC9>ja0a7;bW#9Tؗ m 2MYZ 9IijUB$vnNy#ZmzmV8#c:$ZzہE`p!dnNp94XNא˵~*/Gb ,(^sargZz R{7(p E S Z VtKY,|*sS"NTj+n˅Gp }*G͆-ZKb3lgWc IJWb %2dOHdK62 .^E)(/E0'pBda@z8ujP,4DK'w8Xo Uj,}:E?VZ*G?E.g̣l['2-MVF%)?di|BeK7Lb4]!Ho=} 7毝>Ž%jfϛ-RJ#? lFż'>_(,½Ѩ33$e 샷o`kpN8xd/} \7B[CZdLP**Qq ^gR,KXv#֞BHW#W} N<nl0\:Aid>p., 7Q\XNt%K:E2!-J  XM"`Vu1t}Za ]$s}LL8vkݺ)xv}<@S!b-ph"~^|!!lP*-} Mq#MUIg)M_ Mvv)nc#K@ }U:6I\8@ v$Z1$qX6/'=M_Ӳ,Uʶ(qQw}NYx%h rG Eud}xz!n]Zd@.N4hZ8mCa k/U~mp-}+3,z(hw3ʿ&YJ`e|TӥHrp_0\oWePok3780*o0sW uݦkC繇J؂6h(nBY<.h.Cp,FT N@)P:+O|>#Ȋ7 ꫇V28+:ۣz[c]֢8Ԗ7>DR&xXml09RԠ IŪcb.N";|ߊ`EHFzӐx/b^uγyƪs41DA|: ;Д>~) qCTP$ǿk[ĭ(T!AFN5XtU,.jM/_OËٿj#H ;xynEN^,`2 =O )WHE_QJ# qhYOH ^3ikoEu84CI;9@m52 \%=Qy2./.rhw{'q::]-t9ghS(|E5тV{s%u 㼿d%wC87ZdI|vD-݇& Νx8+oozgx4ʋU}k"FrLuG;lL6iL Cw:NMH,3b>J '(GX 0MJLT Ur  p"8kuD\dU<5RʌLݖg컪) 62Gf>hDfKX.ejG.tghDn +v=ηW!=rB 7lZ~y,VNn_I7%}@E\'*lڙB &8!:!|@I Qq|N2ICh='eF¦TMZ8QVg{" <%R' KMJ# (uF_ r9% ;8rv4O";`G P)=h MVa}F`/شػxGyeaqyvBfHV50Glpש?R/=`-leO.]=P+\xh@Ʌ/c2v̼[68=ԌŝϿU~A!${?@"d~ؗW{iT!A 11q*>.G78F ،(FԂpw(ܞaM8l^Osȑ+!\T#k={suyoXҒcKJң"G%ϒ!VQe9$Ӕ:6iZ!X&dIl7ZN:N[ߩs9yPUs/ӕ9bcwiLJ_ ]IYB:g@Md.nF:uhϱdæ]ۥZھ1u5VI6>[B\<쁑nz"P '@pTz:2r'-8mN 'vdTG $D:]4wCwl 'P`VG7 %rPx V΢>##NغMRB0c12$f&%+?aP;& ^`)XJo%V% ) vR3e,.tL/Hva<7IO$Uj‰$gܒhW`LڇNd\Ҹ**ob C+ˋ v}2C=L^vWnBSepʪU/ſbYM|8m;/XDbgBj6 dWg=,pBiiGRYOOBrm Fb0C0!,E6$ӱKVE8[Fr 7TBzEQ( n$HL#A͒&i"U- Km~Ro4}GeXl\>ڨXL ;iF-HqoTFם:P9 дے*-k8^I$EƝ~ miϏhzUIX)Uk5ƴ &Yŏi{*ψjҀɅ"C/7]pՎ %&X փzpT-1Sw{CEBH\X,e8FF7e&MӌLRꂞȐMœQwx-A$+ÅB( 2gǟб}ADGbSVZ b1=7s$pg_>_yltbx0AUye],j_CKdV3^%{6+_fѨ|wΜJ=0JQMAv*Eg"(.@>'7VYAtЭ*'GV5,p…tgfըӱ۵Uk*W BjL᠚҂Fu0\v>>TQ.v?%@5%D3;r3JY<S2x uf2(Vʽ Uf?a 8~='y`FͲ7_ ٛT [m" Az> Z_-Ӄ> :ޞj y.jJ YQJװE~uW~yCꢧe/m{,㷪A׫h:h{ pntaOv ]pRI3̝l BAb`#D.O$;^MH/3'4(x1-=dI_ I5RjYEPPR]+l{nC Q):}he1V{SqN(%zy.REL%DAhd4˃p9DKkDzM_/5-v$&1YU*"&[c9"w?Ooyɽw]Ըq_xl]Ȗ{ޝƃ]$)`Ő{t)' ,H}OOayMKvMHğnğ8*IȱSj0ַ ]T]ζ_ia)(]JJ. s+>LxGY[z_Hf&puEᯁ~UNx- cM*uAjTO4I: & H.N;%fHmx 艀'>lWU@.Ғst>Efh)#ge6TvWugE&m%۠SJLT!(\l< 0ylW2zah"Ԍ*915'Hz=:e#1b IuyS_Es~i4](aC@͊Fjc6YYHWx@p@IPWh,eтmDL4CN[^Μ?xܾ+5I[%1z*.?e].El&IC3IGi{/ *fTxG:zX,清&Ӣwa<'ٿ1ڪ]ltv/Mbu3}WlݤRi4ħ$d߹߅r#A=}+nDhuNd0nwߙ{sdC7_nˀ MOY,r{ ٜeB1",.\E:BDz(ht-1Wh YU`O`OY`UUYYP}w'mZ}dYĘ5܄(H Rff&gfYsSxSǒ+d*ບp QXMer>tQ-LZBrrlŦl˾ŠrVAЌқż) w?|GN<$̂`Nf ='ዒU_K wi22*cJce~u<5p5hD̆e†L(31?/IOPg+tK')&9^δʋz %LKTr[Oo?Yu?鯼=K sw֘q`"ɫh[sW&pzFnb$B=Gք*7ep~#15"V-P۶{ɂCfCuP[0)WɰZ|gsSӳhkoeAjqyHϑO/f:6:Dh--eJT5P_礪SᚠN3lNTOH>BC\nNfןqszxn1`3'vcjzMրcYG{fD>(dGR2CZlj(;x5'fiE&z[\>zjuaњLHKkhz>'m#5 C҉cBuC2X^uʚT NgUӐ+p<˰?.FoSHݷHFXf3Q*/܅Bva9: 4-oUZO6U.Érv":]q)';-67,fx<+]r dpJ*drid+X1E(j:Zr 1Su.Ma%K~Z8\eL<3~ q-MجU>S`3E?#ae`m;uWyWn(`.\iqylILf=g).6zΪ ; +,M{r =%Q/PdȀO&ŁusBcR֓QC6aO*#c-:P==M>j+u)J+ɩ%f{FPٞ6=-o{ybf"oMؿ*3嚢ҥ3ku|o]İ2΀ Hoxd8}'#qtD⎩b/\7> ByϞ?w?3-,W\q=P_1.5YcB,1°ˌ%gUCesI ?܌msG0v9hJNɉcփYަm[_/;pjnU M{.6K$'Z=M[Qj%Lmp@bԨGmY&*w"O {0yrՃSNdǏڲ-'[}55sIȗR\a1=O%-ZZ)W[]{[֖-[j<iAOO~qaSEuk]^4ntXaBVl0 -<$xn'dgw {I]Ƙ.ޖ/mVF-PUg+?nY~00|RJdq7< A=2ҳ Ri`Z JΞsv@7D4wz9Iԫb&,ҕ:)CqχK2IM֧ ƅfDHO|\2=euVnuIL`}R,in9|_/qt,B*dTڀXuB4iO5]9R[$}Rc 'n=٦nx,Mo$[lPcz`_dےb!# WG j|+~^J5H.׺]Vvl~Ku36Suz>%5[w?Zendstream endobj 456 0 obj << /Filter /FlateDecode /Length 202 >> stream x]P10 C,( ]ZUm?24Dt-2> stream x]mL[eǟ[z;IJhw ~B3l^Xrv[u8%=ʲj;7NLE2Э Ca\$\r]_<99$?H.CAlYif 5fm[ogaLx/֬iXEb||miػ jI]%m斃v 7W/3 L1?ֹ1+.^jڙ.'`kaMdje5fd!D9K5mU!EŨ"RJ 9zDT#;20:.S͑ByLPɮČz虒ޘTrr8FIwVP-a{cWuc#64Lpųx62U⋉m<{/:r\G}8\q5e>j~G¸иGHߥçN+3͒3,OB&O!a鼺3v;wÚ&5-aˤ2wՋb M&_)]q͹Y0JU3wCW|{y< |o|Uk珊,.PZ2I7Sf8;lǺrwpKVO]魐 2/£,W~ ?D-<2.C +$x#uk&1uISm~䞆h>N7yR='V:?w~E)|~)*wA߿D_Dendstream endobj 458 0 obj << /Filter /FlateDecode /Length 554 >> stream x]=n@{7) $ȥAEn"#0rO//rk?yY_?Mle}&]ǷakO߆CV?]?T߷au<ϥ߭8ݟ̟=FtYEEc S Nh+\4-rWľh{c OExbA4F엃C UM+W6jZٸaUƕ V6l^4O&WFWNSʰ#ӮL M&& M&& M&& M&&]&&p.@'t8t:\NŐɠ@I(X( %`Q$T, EPQC&&C&&BBBBBRp)$`.L `0L&RI\ 0 K&p)$`5I*We,@\I}yN| u0a3bYfn|4 endstream endobj 459 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 8111 >> stream xzxe /ETH}CD`)*.- {I&2}^&=B$@(b(X((>3d] L<}b-[w&pƬHܓ}SFce0ݞ_ǂq#OMǚYDAO,شiqY.\<>{E@Dn#Sy)Ql]-_;zo];wg ~y'b5k֥f>kCƜM-[Elkw➤7O7 _Zxɲg͞3"iD1N v3,b1M!s7`b/Gk>bO/ Kb#D,!~Gl![e6b91C$O'  !($FK% F>o4"xMVH3ul4*|];fwǾ>oY2??UߟdBgzFmYg&Fom39hgJss?RwWʛZ2ִLxi3+fޝugss@-\h}s˳S$AZdhAWŖj*S1T q w苍U> uz4ME`rI_3MM5Tc hWyGAAz۽Wp e e0fN}@9Uj# $6kp̔NYBlps WbX .s˳Wiyo"gn^:@I.$*H^Z1k+݊+>]qJRIvNǗRY35ЕVnȊ+ 6\5dB^qV %d]Yu4DKGSUNIIAFi9u2l[qZ#k%Zs%v(>Kj!PsiZeGFy<=j3nvԀHGkFd.F<3i9VZ5_N%. cHfX>ʧ;mmfg T&pC`bNb;4}qM2Lfh&^M_jqyJdvEfV>~a tzv 롔8r)?8J+3Dg;,w!SiRz"U{2}Jo[7nMID0Au}dXv_gK׊I\CyWYO(A<5Hro/ri P.g3]P W&zV609F-NJfc)u@^"0Yh~/zo݁{ipNTt\rzwx"?> x lEb# bmh@3t}'>{^{^v_'.ͫD:l>&lmJ(9-ؽB~^D `3w޿{h YF`gJ8!:yt11ւ_ׂs >f_`Dp\R 9q&j7E>!ސrP li5@#Ș wT3CHYZ-zћ Rw?J`iG!/^>ghԑB]Pϥ9+א7&;ݖz0 3 WB<> |?Yr2+ aC˿C-y:-ˌwu>hW;,O{;-'fD2R&yAңXpXa-ھ ȅ>Gc{Qu4>F3 E./U|O>%e{=~cs3gT3w7<{MhVi"+ǂII*Ig] =}'9d~.Jv3Zjmw9\+TiJa&riimmepuQqxIq7snyEϿ3."/z&FӋ9˟}0.*=} ﲯJ<%^xcp{;-gRT1ϩHf3u9!xnHlqEiJkavEEI¨ݏ*( &lJ^{49N4Uڳ]8 e2Z-%!7?xC\\r~L`jV-aCK`!;t"ۉ }ƉN&sOW<_s,HUTޮDL :C6T [z> o4Ŕ 6|eûY:R_D h_ꋉnJsp@ZgOrJHz gS&ޢZP?V(?L@Ϝ;DPJ B2~oo@oȄg*6o 2+S"cUIQ5獔_@;SLNLLJ.ilnv5S.*:܆ 8(Lop $R_ ΃ӵrU679"ٛ(ZI+u:'5*F_mV;%BVuYCȆXrًV:}>QUMI0kؐ+L*E[)Ga]}@eIhR\nzzɜ&^g>wB[Iz5F(&z(jV[;M&'6,Ae^aX(8EXX-,uMTk!Dq"=@c7Ht.2ћN02cրJQ({4+Sh7+pa}X(SP^Wjinߓqؤ2:ZQ*[͆q糝G_FW.ih9>#(ѳ g+voAIhһ:+ 9BV7щtͳV ;%o^ 74qIwKb%c O'e:lzUa* V/^(OQ+2Gba,9in;N1cSd2J'c8FwAkx?uẃPW4qN4}-{JDԆ QV1eK ^rK8$Jf &t}(Q^&R(^i((13uXjjrmG;-gf.Y6g;Ln z<:X5A34jr]GՃ8cpK9'M'/d;p^'qgP}GM'W2cgM[W[!q'T4Va~|"dEE~"w@lgVYl>"+ etOrn :5͌P&͇TEPBJJjrן]脿qð\ֻ*]oy>]5,wJ1ǤWJJ3 .h 2udEz g^^S)Jscyجq8k3E&213Uj:1"K fYC9TB| 3W]o9eJ{ELYf7JQP9>h;BETZEbDF7%VU)`l^lwnDʩ0UԸpF-bn_W“I^ZR,R(1[f1/k5 2O%emͭVʅE~}hdϵc"0>d) 3E*wgN2Ukhu5W,NDg1&|5]pI<2.d|{ͅF!*.IKJZ*n'KA5VTTYsr5NuW=N3%lCOkCu'ePRy#'N ߝG˿&խ!w>AbŘLe&1z%.+kW1  B1ȉMIUK){Qc@2RA/B,hXNh0їvJnD_Bch ļ^a'Qn\4{bݢ2`4eflLbvClm)plG1f-MGS;hmG]Q OS9 Y[:[R %ШȗS!i`T_l>\8w͌a)]?FAr8U5Ӄ&/3 Wmdrm{&ΏoFv &c9uaQ*yR6omO%Gɣ3gHFnE+@o> stream x[sr|zIJ0%јO{_޲*~69@"E $@в!=34j$1Ә_gl.3]e竳Is})yO/=^ ͮ K+5/]g7lYˬz7pK(3,ofy9)xax~Z,g(+Į6K5,K}򺦯9yVIgʁ/( ]+"xWooR|J~+?$yp_Jϳ"?v^8uSoVGڹz 2VK3 )v:a9ɣ(@ZߧA6ko+\MmXŶkW]^Dž$sWKtQ&(A3 p ;xƔ۔8޵]Ԝw5/ Oy_rNq7; طRi+nT"R̞_J ._[e6^3)X-3qO@~C˝b] h_6J ?B\lw$ 6ޅ`~ߟ9#T։$.RG.H3FYlɬNTu\Y8Q0bZ:WENX1 ;N[+:$dg.ٟ>=A+aa __Texu$*7qqQηh6Ftqr6A|k9/3ʗ}@(L UP"KwA*uK8!O evhyu>lS%J+&Zi84G5jVU@F7?>| &Tl@|o2`{Xpbz1 ;O^!h=1Qϡ#֫TR*KEURU(qۮIT7-!7E'>RSdIj /EXg5XBgRh}b#uT|ek*,"O,OKHNCs&7ZT,~z OV;4aM__JMI.?%K*/&Z?RZ#~ڄ<Ax ڲĕ.w _o]~B;ߤsFljO ߣiMН΍ͻH/ +}˒>b,@-ʹɜ2_XąX*?<˩Hk#-XID*tR!wUv3Ӻe}1 1K7Bi9h tK>5xj7rk\Q2aR%} >u="HkSKrIQSa&q4kTwa A1%Yl~/d(lƬQjo$-:)TSC1\i/VXbkғmXAaMXW:F봦>R.ܡE05INNhWXퟪ;2j!Bэ}4>82:1v: }wʗSH쿾a 1AwFNLJ\|$;ԯb-7߬h 55J |Y XAi73DBy '"ŧY33#)v$dP?42ݎЯNfuv;Dbl|dC9U{[u3 jECV\;s>߹o˾ٔ]9 "8%~[FZƀ~,jxO5pKlz  ss*EH>~D8ν9H|Cx̶͈gm]5`hG^:ķ>ba#Ch8PzaV|QSv(PI8 GR2/ÍSEب| !v6d'K w i407Q?/mm/(tTt*Mw&ƒ P2%Ys SaU(]>8hW}jǪ"};%_Bִ}η"I;@>s&/+MQ2?hH5(2+~^ٟϲ{_L_ 5;W}ow߼zX~^6vX׊_Y՗v|z 04>WԴ1pXOo/GNQ m >U_d)޴̓5<`&/`C(ƌdld\u/=kU,(/.K~Ӂ]BxGA^yI]M'(hK32s!V<dvm(Z"8Dͷh|S `sCbL&\r)QFT+Xʆs7=l/v:m5_lq`}? ?ȍ:5E}€22.Ƨ3D'Π 5Z?&ʚ3T<:d u,OxIAHBVD]x |v-P/+)/ v:_ @Վ'p (r gon{=/Q/ean.?p\c՜U__9z8rdH~܁'$7^ZlG<Nd<}:UX<@K;|S=̦fܴW}4X{Jb2ӅLڨK3;E ygNF`%iEx:ciAM I+/a4{X`q)D-NdC|zNG U6<٫c *pMv܂!]J˓`&&S6)|xzSendstream endobj 461 0 obj << /Filter /FlateDecode /Length 4179 >> stream xZKstJ:U"yZ6ݭ7IIB){ߞC{fTBLu\"R߭>QfUO<˵,xnjzGmUYj3J)[5n?mJ^p+*dF |rT)h3Jj?O%gjI}+]LY%;>ЬYm'S3` wQY] Z ~sE'GN'3]Ra`x 2Z/ VcIJM'nw0il;^,CvBV jk{ ? òByFL%/B㩐 .M!n6x@~7\X̥0_B9}ۀ(9NF(2B=):0MukZ?ckGs4`BՋhҦ`O`+nYzkOԵ ǧ<В?#p:/=X&{JmnǶk&sNGssyL5|rM6 +lڇp6ݨa],V ^Xh#%Fs5bAj,{H:q 3`mF&}\T*A'%U(O)ʎ 0ڧj1'ޱ|QqԮo<8/^Nr\!nOo|%s6or%Umve^K2,vY./S/ zzYZyK~J ^SE.;7즺w/1''@$mПRNJvciyxُJZޥ[vF~ kv~cU>,_s<-{ 79.&s"ĹoRU0o#hkҒVժW_n!?{jlzp(-BpZЯ[>& =@&)Х \~ej,nBzBTsƚ iWɷ'ۼ 2B5.*G+^q_%7co#&-;5=OaIt7)Q-}yr4;[9ЀGEnJIr?|G{{w<>p2 .qX `nZU5N̍J4X_@z]gN8(z1`ԓ=@݁)h J]‡pETݪ?E?\ W4H'.u D`.Vjm@ܢҰÿ́HJH]u8]F g w0y=#yENaĀn| \Ͽw1j Q N/!X`\I:r.uBZN 4"Ӥē`':;B(efd]%z#Fu'GsJ w/aAc.VI#mj ֏/@]TdgU' R*]6BL/SpfdX6qu^m]zK<]=7$&GbŨ\8决{vS.v^Y;k>ˉh~$_Io>i#cyj]& ^ahT/9$R2嫑By)U2pjfL6srJBhX8ۧj3Q*dwOr"?o yA}zAQ4tf*I\Kvv!|4[E]Zsn6@_ r$Jb~p$=NqPZ8ҕCgJcȪC Υ wyl\P:W( n(3%H$DGԘz Z!+f! CZ`ߜ4`?- {V=ĺe '̅K%kLfZ+鈭e}"1}vfw`bD[? ІV/#i"fޫqVd(kT,y/rK{_T͸EKYvz5Jp{BFeB, rgf>|CT߀wr |d"8u t՛`8M\V" e^/K[^W o`k֏΋g@`{h2v7cw-Zg|o]/h&U.-_T0Zut[2&T!go2fH_?16ntLټKlQ 5Z+JW3\럷z0?8 7)4b@ P %:+;y9Z1OHv:^zUxN[\zծHu. o'8Ɵ W* `%UQ<8$eP~.PV{A<3edw#ijz> ]Kv:R8b8 +Y>A?YBRg z&pLOl!"l~g,<7Ib4 |@+x =v]&m{/Py"iA]⟲paI>;X-8KRiT#H&>nUPܥ}c$g8°e ,e4\') ~~\%gDHr`lMRӳjʼn`tJ85P2xc@wp7z-7iց3"cٍd: ."%gmiɳ wPq-MA,MWkN/kwNoOgaï>TʧI@YCI |Z۴ƠίvZ voJQwp--LmT32U`ڥ)r>UL".B)6&nu?.@eJ"n-6/j@xs$JHaE6kWpT0j=e d]2ET:|OzߵΕ#ˆ.)"C>,ǁ^ ^ֱ&g_QaLA EJ-eW] ˔) 2=cͯʏ&01v 7a oI!dHIjPs}eWT;I83Q) aj襻570M \S\ xjj6= ՜WݫϺT`")\}EN7'4Z.@ "^uEW!H:-bǠdjSXG=Vzr5 _֫r24Л<>>J<ǡ퇎ҝ wpOզU0\.@#Cf9EQhgwfK)4dý=׈y G.ayvYRIEl0>SnYk({?YQ?3endstream endobj 462 0 obj << /Filter /FlateDecode /Length 4220 >> stream xZw6=4vo,M{{ddzHNj$ݤfsت@l؞&@㫯q(?;ӯrs|eiK~MBLulJl~f Qd,%v<˵*5{UB43ApiU b]GEV։E"/oAZp3{Zжf-^%lo@OZڰͪ 2G[w A 0۶]k66.t BM$ N^ڏI^HR˰_R/AL6E<ϬR'Bf{Q0t/ -#$yR*׺^[XΒaa]7w’^'}tc ͝׈)GЪߦ^m[]hӖ=ؤ֚ZK%4? Ew'o5IVJ5_}uYjT/㵡0wZjqXa_~ 7y9do5((vsOcʲG/!\V`7 F˙L>w5Ξ[\Bc"ĘbՏ{H Yؿf<J-EA36 GfaWxV%,w[^?lˬr{kzVbDKn~׃vgB1F%*BFy~ wy# U0  Ԭs؏hi(4;ϧGH{uYk3K_<9|:k'7-D~iD:ֆg`v24Lń\@L0!"0Q#ztAq24d%0Y``)gf/ >7lw0w"Z=> uYs va/eX4Wc)U2giK)q mSp#inG:Cr٩[Iܢ <0M4 7CF^|&d8&6nۏw#o!%5*z20pg5_C lx@\[ (1l%"n/`Lm!5] ;[eͪ50aKXc8|K.ҝk &NPXN6LƢ+%p>g}KpIH#yOG䭽?@ I #8Tia( ȭ-Ahwg:tyv[ Yr9uSa"PjnWp֮d|J[B1m6':]{}/rPş#v QS_e}B|#ȴ@ @|t-زC/#$^͓us~>['тWB ^% EOREV閅^d A4 &d{%Ak/k 4u#PB14eOI$Kbsx{QK}޼;q!mVM _\FFxNe|(MRTS!]߯)G1Q~ 6jA^tifS|]+AО19$CM?Ǡؽ4SMMliHnG+9JQPk@&>|p{aܪ@\0S|] 7f x|D]v cILoIʪDt]P@q-BYc6,qMP&0Q~ K3,?0Za)#&+Zl}6 A|U7$s>UտJfmw (̐_l?B@]޷UOZ!~W=vdﺡvU=GUC) f`>/xB48pT0q+ â`0i~Gz)J#BUN?}"o&C, 񢺍|Z((4*1jnk*TGebղop'%WKסaըIO99x(<`qӒ/J?Sp4r1*9D,s|TJƢ I ֫KWv['8~Hi]OB/xC d+ɤvS2r~] lifJ E)bc:si4fS;f=$Q8Hh MMCsj jvUT4"[&xZB2/g^d .Ħ[svejUln5,ZE.w2` )c}陕dx =ujJ? q&,#{&hj1d +̖~xp- b,9ٚZ(5sq[<@ {\.W+;{Fm9yfOyqΪn]7¥DA%U -KJ:6,d) lA qGn 3ur+=Sdn/vJD ] uW?}O<}c3 7 #2wcY/6`1׽gV)- RV%h.]CaISyEQbiAx|1B52M,U?AJIa6i`+v_ם+" V׈}4_tCL\8B}MQH )L('6sDMT7 oEҁI[ @ [I7 1$o>"La㯅&D3t@Y@<֏Ljt$p&Ŏ@='+c#!ET~)sI o3u] bWcĂΌ!s]uaYk\M ~ B* A9- s#w;iAE' ׽]?h:#ț%d>NkHM"CIoV PVT^msHPT'`:u]yp݅ƽ8MLTendstream endobj 463 0 obj << /Filter /FlateDecode /Length 4088 >> stream xZIwF994 ܴXGV& sAЎoLU/@7DHA{U}UU9. z\_?[w_zVǧ//--=tcCԅzu@\3VXͤ,J5--iVbvaTY"Մ 0aQN)iQlj=raY\mPKw:a F2L8U&cN]X%m۸>BS. ?WqZ(N+<("'/ȕ;-J, ;a(H#y>N Xxi&o-(9B3}Xd?XcVd9gLy$lV᭔MVj^\>ԫI.c "ȯ[ZvS aҝe6`׺wݚ4R/u=K(iRL(70" !YfLeaS ),J}oz6yjI50>2hr/T=t!ЬpN*G-R\I<dTV;9> A ZS&KAЪdQSV`<)?*78گJ4nՒWM-,939M}KZTɠ6FR.|/˼_:< #c8-ι&쟗0d)*au[{cڧ47Hr8xjLMaKy_WY !otB{p~˳˳2Svҝm`Ӧ /% 2 86$׬< u0ec^[|W3W[5H8~Ku\mh{ 6nHm&Shqq\*o#x$Dh 6( M8{ `(Bb?)G,Bx6:ߺS:ucm;{R]¥'ӱWf'`# [vnok 1zPl@ӑ8׎~l< K'g! :}mB u EeŐSjCۢۀY&lԵBTR3GBe|vsÑw-U6##Gd1ye=KykX1Luz{-{ڬ@?W{5 XY/w?Gѹ"aChqE| h_qVWP^/7݀:FU"g5qHinUn.M> 9!Ib֓0VCҡ>]޵d"ڧ(KwU%b KLT`H4Q nǙ(~ ; ~ HpN-C'-W`>8Aw3EvHplT߈b`t^[`bQOB LH7=4A,? hHA8dofoЎ1K^ҩa!(r%24ϒ'UYwoVeRЅMV)&`miSZFbKΫ ))RqYGKsy8,M>S'y˂q0gS3 tn{$3o|3J{eR4ZˬɎQtn;r"\QyϠ MT *RW%X3%#K Oܐ<Jtʓa ϳ,=y9Lf,_8gN(jD|IE L,Q9a1?&0`)X+kĥ*RJӧ*C`jQ~"D8`1>kD&LHic,dJM!>m6X-<rsM5_T:+a2,%nxD٘6ؤ(3yU0 ؛<&ϝ$GRT g2\{@G8p }EL&a֛v~\1YMHB/){GQʮuݭE<Ɉ/P>G#F;,& @E]p#CX;(}eRLtT[Kr;6LïĢi ț,XGHnTM8?lE:rX6+T!PQWqϔzG#?'>y j9`8 wy?YOM=KjcvuAoރw J.?M ) Wơa)!F?S {O]n/$e!mGi߀??NZ`/{³'2pm&_t lIU6\ R)$ɣzY>a e+%7K &:$SELl0yLyA}M,?o)mS@,7qĹ~/n>bzB_ֺ,W_ m>Ac#u+/_{ Ig)mL7MJ60B߀h%b6L1P' )XtFfw'T#SX69wSP #*h dYnb.g8hw121 npۙvv!S|te/7龎+.5[NuA}R2ЭJ%\@:1n59dTp(,ր^sK>,،_-x *.῀].v7lz٬fs ЅM'A(?_|)(U6Pά }U/Ca4_p$^gԃՍGTZ=oXc|:a~u.T UddqAC4172TCXwcZHg;CN> cP|yuZ{W$j2K ߏSHtЕYOlbӗKb"Fb:qJrw|Fi_/]晿"i#oq o2/}nfKĸ Z.Q0^'1 sxpTrɝ+OEy%_v1 ax:ݕ Uz-]拡.upkg~ -=/:{\>-諄Sz=> stream x]n@ D|!H/%VU RqȂ9;$=0,xz9q-ei-1KN%\l x:vϜJ|;uT}vG{St.Pv+RjvUר(`Fձ3 9F17lnQ@agp$O%p:; \l1D8H|Q@q ᠽQc4 {c2 qtŏ鮺F"2zfE^ef̊S))S->/W e-K+k1b4{W @j,endstream endobj 465 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 3529 >> stream xWiXg֭lPn!3-j418M 1MMwowa7&"V3w'a2Y4>1Ɛb^-|QT{9W8Nbd2v% _q0zR褴/ϋ2cC Ȉ `3,qƠL7.'!1+9:@K{y߫՚,%͡a )p%ۖ'dЇE jMāиHuBzOjvV%Ϭ2 ƺ͡vE;a<jfdv3{E?YǼ0f#eYlfV02ۘ*9 d3?Z'taudv\yNdi~ӧLMnF='(0`Gw! ]fg_|=VhU@^5X52JR!tʟt2uU*Kt`1k#*N '嘥 9|Yc_l.OÕȹ6rgj(=*ة !7rOX! pd"/,`˗CupArtj>mWbww>WUk6u*^- p̽Yd}zD6_Iիяp!jhpX7~ -II[b*E*YATe,Jb$]7="^* .n=Q nk7nW L}|tp o8Y4_`E.{ >SyGl^rWA5!̒ǐO| ēgY|㽙F0|h(yL< )dA B ͉ פFA$h61tWܰtx[ ǹC^\(\G]?S)6\Sr(4zZ')sB#T F]q7:j.D!~onhON6\,'Sz N8 ʎ޶6tlI'δ0YuiVl !2pPQQqyO{APJ&JگY}&{]*vׁ,2Tuiه43N 5Y"Vw=;"TT\K̯N>` + [Qvpo)I7暊LGJ[?U GYC%su*ž;]/ئ ۋ+!RXTEdJCf6c*KimEI8p!ZS`G8E/D/≞DIfItVQf4@%,f?o^xm}Pͪ{_A9??ܭ<{>39Vv00vi]jD^gu'@IQE\M ~whS[D+ԀZDMDvؗ)y \^cwſ E%6kRpv)q:GGJs.M $܂(%&Le[߮.ݱ) Qzjr7GxA*^d;-] "1%Vj,PduKyRk_{H\ D/*VШ5Zha-W3Q.ӇteNite44;:4Ҿ|e@Ub{5k_䧸FV9UzecZRe{CJO5j,Zq!5۾9oNLt>9,6 S,n}*$&^L8/8A-ΥI.7&*y&*AI>OIf=e gqpѹi6禫"uP%bSrҝ Y ")+M5~ѹ_t*8AE'}Y. 2bxK/z|`| ԋk C9ũSQuɢ{k%+h?A;Ƈt4K.i)Cm(@>Xnl.G{4B T ZdAw5J+Є`:䶢ޢ,=wzjm)n\C%L20dPa@WQ*&Gk2S9D~%mGcM.t?6݂÷BQfh Np-Eч3o | '98Lu_F^L5|5>Q[wȹA'UU[5wGv|n_'uL&\~DMdFƍO z*&&i2 r0MWU$Zg֫8>pW{S'JwJԘ>ߕo]Y"436?#3Þ7蚽Y ൿ(-zϢ#:Ё&GP=3:]ӆcA#G$3jEiD,(rCRW7M- oGO޻Uyax]khOm<9t֦a'%h-N)VX,խAY5Z ⋊s _hCozi13}B! #'ABpq! >4\?Y(a:x~XxDQ>DiCobNvN QT\/8q2JDDkLYailujoWfP[a--"N2UZ0w+gBݽýGJΥY]L>QGt$m"$'I9Lǚ+/ wڈS\"K*$] 0=g $NTƫG>[U` '5r&h, F!mLe2Yd)նU-#Z![жeuxI:D]AWM} zN= ӜRd?6n$GLG,Ӧ3Xendstream endobj 466 0 obj << /Filter /FlateDecode /Length 306 >> stream x]n0 y/ݥMӶL~;|>şt~9i:O|ʸuI Squ)m.k|, oEk{T߇> stream xWyTSW!$>QyMyohTѶ:.h+VD"Z)E] !1A6 Zhi3uԺT鱵ֹ^f L朜{or}-"ׇDVLψg̞5c}RRzZ OO5xQo2Gq(H)}̬a{fi+g&3,Oޚ/OLސZpTGD>*EQlFhRŎՉIkSR"g,j* " TDRLjFͦ©JyjASAGBRf|gOx I䮴nԒQtmјıSƾwsgW{x&Pm?ׂ"tvNUwBT\Y"?VmX5#v>UON_:(D\>8䴄E@^;aѫ=]Ƣ;_f?۳SxРT/~ ֥R @Z29A2a1)!drZGC̩f#-dWV,!g&Jctv2@Lu8/,Hm2zl=<Dh'IJ[Ϣр1Lؒ HβwtЩtǹhґK)%/BPRnvtx*[Epd[A'PL9@"h?M{VuR*Xj `bժ%=Yi8. ' <4?Ѥ7f ,,L[b•qn2x abKȌ FY(t9;/)e[Pho@3oNd4)UlCfmj2T)R{-na[810=&+;_\ՒꊪXYU~qM@>P< 5Uf:[kyP *A5m^K̬S6e7.z ߭ZZZ|"AVᆩd+"0iyJ̲|`6׹-n#4 ޯP[Jx*7tD@f &$ )ӫ٠Z \8Ta9xMREr` F%{Cnމjt]@?`ګ-^~8 2:ˎs"$a:Gcaϯ] <u40 p LѢY9N?fUR;?7]Ba V"9^&gqW1jv+Q lγǘt σUs1UU^֠+le][ayyT1o%deIw4udmyљѱ3uXc+5 K%an=[ǡ7`Kd\f\-LKۤB3ꅅ_*ɮƣ4rqo ߳*sb!kh~!ﭽ^a Pz]=9=MUWZl*ժlbÑdQ#YrrԵ aDŽ!v׶*j{C~uŽ"}:MhmO!Rև@x8kRlEDS4 {HvHS򖰏u*>z0ILy,'}z̑(A#* 1VDQ{#7 KR4_>" XK$Nxڍ?i!x ]Z =wZ~,iOj"Ŏ!Tvb4$ ۶Ee^H&3Jiz=)Z r99:*϶w7o.֕Ƽ!y; X%=h3l ŰRPwӨE+X=5$ (G3DD?\@bނ8.&J0V}&uyȳt R{6 :Yn'w [l~;L}8.a")#uxIL\{ݨn/h.M.%Z֟鮫CP x˱_;{be$uN2>qaZkI$(EoTkV2h&, +ZL3S-I;RrgRS8]dRȷ〾7frئ 1UYn[6[޽mn>XCӡ;a ^c5*V]2W,#}l}ڙ ׵gD҇[62WiU2(!$ Znf+g+]z߲x̄X"ȄXc!&g&Ȑ[?CrNJDZsޝi㌻ )6C{8TCeN 5vG}W_w8cf ]goM¾+,A30v ~=fl,s~~o6X.jwQendstream endobj 468 0 obj << /Filter /FlateDecode /Length 635 >> stream x]MnA=zcoH%04 End0#u>݆yo4yoy tJzNe|6^~_{>ؔ>Z_·q~緾حVmw> stream xY\SWaDEZG]*.@EA@EEA#l[d "EōGP[㬶V;﵇~ p=9=x(=㍱H?;35Xuq*7M݇#Co.2;;qЈ[1FhJsF{{z̛;w}[k=҈_o׀&slI#Eo7w/W?6-o6YkaYc6XH \&2dm027=Q{7xlof3v̜k~3o~삅>Z%% P93]QZZ#W}XDN@~uB3]ހZ$x9lc>W = JpP Or-Lk0f] ie뜽e2VGR0N{7.`zߴX8OQCꕺ'10fkLcY:߿#2ckfnnw7o޹{z.>'W@F>=dZC&1T'LaqBI:rjx}0 KJ`XO4_8^W**R˘MCܐ`a.2-dGeE A;_#SS}(=6اiW6$ 9xl @jCpK '`B$bT5ww8Gy%ɍntăHr5k{== ^pC~ rH0Y6zO64"˃S0da4s.ҕ En ;zSfa!r:Q[-NZ1[Ǎc읖,1mNҜ.1cIN?N*4]PLeȽMpof5p.U ɡա89PZqx.cJk|X=ORy8gǰ]KӸ:jy&- rU |Ȼ U#q%EmA )xe%r)LKd1 !ԢJIϠ5Ğ댼VHEć%A4#$&\ý91G(.P?,ɮdҹxXNRQT*B(,ZRD *ʸ29“ I,l{ 𯎮+m*d̪bT[-kh@oy玞Ӭ̯L Mz!b)|o@X錒&غ: Ŵ\ +aU6=g_^F^E0 ?&f"d*A=q>TK(n&*zpN0 Lpy0j6j'N/p2>mB B(]8uG|ʟd6dQ t</C 0M~#?ՋGKqz~T}Y)izˣ#P8z_?xJHQJ" Wpnб CGche ;0rQp;F { X8*'ΠS++@kImNJCHPGargzLKfx`Td=]oN0Gp;[Leҫyi @) lJl9,Zu3M'TALJyU7ߛ6|9@rlu)R\7*3!_>II>]Am,>#2PػU(&UR@!R6!1H:1<* .#;7; cȳc]k>D5tEIY1(ŕK2jxUs ;ph,^i?GDRp:Y#JrCHpä_'MsUs>?q co, tҀ2ē2[ZYxFC¹xW4HaaRiMXSSM:Ejt$JB?LtX\""vtZp0(fT |IObڷ9H5[h)B$6|`ˤN9{X}2*23*|,R%5y% أhw @7Nυ,5 Bxa\lE! @w?P\VL,/h - `+D0c0 frIT|rZ X 1ksl_{? 'f ;6woV } ߮%h/³79CL'w7zS//p[AJ''-w~ᗴVnlmQ[Yi<޼9bu  ׁ {i<A0<l>vƌj.YnLޭA;fpbpw{uShD+?^Uq,< U.!yJbJ٘C !a-(r/={#SMl"Xvv-f//S P‚DX /*Yr2-Ԣ]$d )qOʍXIHL%ͨLșh eMބ $ݾ*}C:T4U!6(ir/Oڨ:~+rX U]ϼng)I1ɹiXyx!iX'̍IHJE1f "(mm9VQu۵1: GRg+N&LJ-bkz;fiI+'9Wz_^! n .Ebd{y!/2'ȟ^HBtjoGE,LI"n` vT]x](qܖۗ"1Q:r\J f9[ vL*0=doхG=L{GK*R*Xpo11a1),O đQU5y,|2,Aq|V GHlTn c7M gl :ƃ5kY`rk00Ui4R##xJֲԹ\9dYJ\\*1^μ'>ӹ!ْ3yu8ɼ]+FC/Ii_'ߗɤ,N{QS7S`ْEMյMEʼnlӭ]8mr lbՃV i` ȺN z{@jqetQpSdžkvX˫THf[[:& NLP@H)Zxu6ݳt$77:YUphX6j6 ;8k))OIMIfArIE(IC"bP 40/7/mij(+A,+ ?QSYmyUis r( iICݖߛ!(5#6XNȧ \LjuCeo ԣ !~U J O+~^.an,C xJ~$ =X{`?x I 륫7|$]8o>q^shYx_=jT(^,!zgsGӜ/laߋuܜx*M%̐.ϋ3H#3N=׬~ Iߵ~.EPUJ=~usWk(/ۻEE$$Fa2kƫlb"##f6:`6X(VUde3UH*TQr&OX_5d,x ?ZfjjAYfgcpu`m'w|ڼ/V*\e;u ydd( >ۥ2cÛP=ʭ,Űgh:HxPhco$87HYXwbv<9$G/>( *!:T5]ϙ*jFI iH- DV'm++,(a1)SNe9)Z- *MΉ,£bza sP`jUPލE?avŃuHА[_22[U s ir8k 5v,/Sʭ34lϬ> stream x]1n0{?I1Ƹi\8|" S-}g9EY`$.$p> stream x]RmLSW>2+*kf@>S7 ҉ P5,G)RDiP,ph B*Q:AŸ uVNQ揽w;?;_y<{<A $ EF%egy˹E$xÓNa % 5ػv I;r’"uN~6*"":,L8ײ%lL8Pej}5*U'[z!fClFV*?fiY;YeꦔT6>%I#WmINIUC( #%Aa(EUh5 ?$(ˈZb@+#zN~H!oHlG:n$ឆ]$pΣGj+^la:r˟bÚD~@>{ʯp3WٱyWu+B$H@MLN0{Jfߣ-`y6>s|d, ,(~)} T-\K)i*lu֤𶲤Mױ܅GOnR䥂zt΍(=wX\%؇7{L }R> 1ϞϺlH? %"|ikj/{M/kG3P솷$2]ܻw>|/*_EA x;*+ݸ!*Qh <\K‚C; n]m2UݷN|߰;ZZWeekl=gfcG[ < ՅTUUOΖݺ-yƄnhNc`rT< Wex0Mz(SQZ Mx˧a3.C_4;Ox ` 1, h 8=`;PifFA^zk]d2&wFl&I!Gz2 6,Ux@/mucrzhv 2i`c.. vtvѓ.i%s. lVE"1[,ZaZv<Nendstream endobj 472 0 obj << /Filter /FlateDecode /Length 6076 >> stream x\KHr/xv/"|UxmoxَaH<$aGPYjl&ʪǗWM\ݿoWyl ]ө7jє?@?q8dٷ!J􍲡np1ng8yU}fXVWp׹jfovlKg+ge֡ ޓomU_o ěH l!aK‹"i i(c('fbx0IEF !0|Shj8doN W RQ`Ǻ>tm鎷yF?kb TqHǢ?Ehs0NT w:Av;WkAN;?D7i6$xmSi^`K̪z!%'aFvjAbt[zlAhTEbґ 4Q~ؕh o$Nt;|o9dKyG֍ {Hӣ|1os3X奭B٥xЪru8DnPwכ7y]_;[wAG~-'\h;/Q+C}:u 14$ ϑ 1I+3}0B%ϙ}:DHWߜxQI& yEbD0D@K0 :V1Xw:mlC)5c|+3x(7a(K@RpcZ) Y9N~!?PW!-HT +0K2%<`S"2.-btaIg'%^/l1zz})38:EypAyē5Oٰ(MiɥJPXcn8ǧݖ_CPRr c\<#A P ڤwiE#dᐦF'C.n` ec($oU8;{QX;ik盩 c*#ZIaVQ7SHB}™. xLr^@EsuW,л~5 uO\3qW rLeή=RXM&(\3QZ_,8ӊ.j}Z }:SiLfb nCcSI^2/"pL6OncvQI,褊ŵF+?Ix/ST $*sc! YF ]hJ'/";SV"ɵ, ᾥNwC)ҲO׫:9JC儔&ҧ4IrC$;V n'ARmMG: ;kruc8)c-Aw:bJ&, e2]("EMgE+/PeAiax1]^!'9HEqIHo.s@1uhAry*aՆ,ғX"3,7pIX<5S;Se%f :vpq{muWPZM=Oeoj嚩7N2g<Ϩ+rN OLQ{[X<,j2UvFX+V>̔&Rɕ &a l(!alں3ts6FG*9\ĊCLJN'/0Ғ|e?+/Ǹ0} pHcw ~!(SLj1l/wi-CXl|,խuR$ C'uF16@T*rst*ǘwE_ˑOQPZ'i~u~;5A׹2)rKnO?]ckTVAjHƔedוup&31V&pW<ƽP6>7=16±~s(ٳ5](ONN&7:0T=2dˣUQd^1D yC|~T TbeǙePGTȈ+@3 o=$͖4*ȘXkn'R6g m(V6ҚlK)Kc: kʭRYiP-OQ$틺 .TMmJ9\Lps9Ni[M$",hP]l;@HKM'K쏃Jni!Ib ݥtr^i\V_ !m >yc͙O0 l cfC9R mJ/hI窉_9`4W ɑ-GTOS66r~04O0V7v1 /6E]옇'`PfihRw٧C {SLZ ˵&pD=&끘yBBj̈U9F%UjDTjЙ{躳[luk= _@=aHM,&$G: ωPM|b|<ѷtYU> ѯXB( 8K·fmX|QX(ZpBWuKa)x>3Zx) wpg]*Ϳ\oז:݄/NݵJ2+mușpD֚c0 LPl:b^$Vi$Ɗ U©|+Ⳳ BxO:|@5BtZE d-rֿ*ExoD<NvPYוŗ_cKmk1T#cui > stream x]O10 ЅUqP(/ СÝdߝ|p%E cikD&Ǣ8LTgo:?`3绞I>RVBoh )jHJu 6l@Tr48o1Ҵ4CN-S-endstream endobj 474 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 364 >> stream xcd`ab`dd N+64uIf!CO/nn}/}M1<%9(3=DXWHZ*$U*8)x%&ggg*$(x)34R3sBR#B]܃C5P\0000103012_i eO_^Pw*ˋ T\)S^m. =wnw6/ i^O mӺvKc?{oi~}/.cA<_qsg.a][%${z{&>&20}Sendstream endobj 475 0 obj << /Filter /FlateDecode /Length 2540 >> stream xZKsVa֜`3{[3eJ\9Ȓed!ʉ ZI G?zI1|v]MN2XxCݤ"R:xPfzfBY ([ {VW7۪\J)kt׿;c/gs|[8_@"IgU:0f1*t̥eέa;n͵-W:$T[,NW wyt:1ӫ K>;*ac q㦫 ըv %LsNp{_<0y13B.@<&02vh'cqf FcmhΊhj ʮhjD o GU( bb ygف]drL6@ 9G,&S i/[KZH$ Ͱv]T׀oZ MDz3|GQ>Xf9)HT`(Xei$cqD: d&dxekm5+/z$z-Lf)LeT(V]{!͗*$4צKyg&Fmd7ǓLS(D2~R Fb"2 UQL+sc3DI.IF>AR̾  +,Dr@%zU |UA -2aX#pq|}>wŷD(Be"{v3P[3b־ӳk0X}ѨXC1OGZj 3P5Z]7Aתj1 °NO2aDLb۬sZVԩIulfywtarA'd Q]/,U^*Ɵ>^+BR:}v:b9C2&X f[n)* b5+ bP\@ 4 ]" q:Lgԟ;bGA q 0sDKŤ&Ք _gT7C2HB'Jԃ)yX2%>ަ~O&BؗFr;+9}) ~=,g&K+U:W_ }lZu2>ɩc m~Q/ #R?. #dgx jC$ S9ckO3≀X"#:d7f6K+vjW\IfWa8H- iflįaձjxHP4gi{$6?U15l7;U9s0^)|ʶf ;s!D,r|' \NowRtx}?#ݴ#r?Z[KB*%ؓŃ=+L9b~A>Y壎O(۟]de^Q ,{O" >5ʚtGUgP{\sM׏ jI(?ekfnu^nI> stream xZIsF/dR[}-VeI̙T=h1) d^@4PL ^7?i͌ίff?WiIcջY͍2j`` LX]ސ-QGv8EpY0\tRj\p I>/gL״jKUyX !@,N^[z`6q5jTx K܏iG.zkqx[]Ey{ږa_)EQ.GK% i̸5FR90 k{ę ti`qe{i~#j _mg(af+ࡔv)ia##AQ3" 7S*k,#/L U7m`pnpfd>h g|ΐև~*3?Vb_ߐ`ǩ&eCU\al eTJȂ#Ґ~z2͵+$ %OZ˼bH{ Qak㕑Eu'#*!t gh@/ 0^YyH2ky3eMC)=_zcZYnzS = 'FiUTkd:B+8,Hr(vi4>|NbBĸ11qwEY=zWD93An|WBCʶ,1 ADžҘ"*{T@g:eӅY򱌅*%Yƾ9)XIa%6EYj2?^05jU!1KTwuقDz433-< BʴjenL-nٜ{‘k}R5̮˸;+M.h!7ؔl^R\JR^ 4E0¤2DFA,xg38> qU⾠e)"`R#ȺTƣ`M!ݞ$'F8@ $Ď' x'pB9zb'f]0wȜovO}[\#eú\X,p#Dg7MlFwC 8 o>-&je~5v-:%*oʁ< .-3Mxxrz`Mo\̯2Cf>"`)[d3 ȏ/Nr?V}l ٽN@dbr\f6} ySSLCb;mV~ B -W4 򍼒pB(97{\@¿ɢZg$S pS H>QpI$s‡I) "Lys$14cg)0|gZK\14Ǜis:#s8MJRW${iH^պjFn}Fj ftaɃNjWd$e> "-[3b]HiP<׉nƱ#X:.w[{aU3H ˺^%ua)q%A.\Ivُt'gK?p9ͰPƕC4P1gM`qgșǻw0߁<;cn*ze]ް~g@ n:%2J<-f/IEA'Ep^]\|W4[q $DLd4LOPI2hN  d&gZ>O{.ӿXhq Rj`.;8 n+y ֘~Y)kw+M\ vdW٨ zҘ1x`[<2%ʇ4[Hv$R-$6Cel$sX> stream xY[6_P`_,\/06ݠi@ Vud˕嶳= ]95YiWyP jzmTcv`Z%!*,*TJOTzC] %PBZ(V7Uy.OXu{u8]e|:c',׾Ϫ%yO E'3 r]o|1eծ<EuYqM0}h[%QM'js"J U:L@@Fmt.H<*5 ܳ)R~ (жg-h=x\\|bԋoH5 7Uä$tr!蒤n)!>: <ќ^?b0WD0aTބu mRL7!VKWkG<u_0rSgcX)Ն T?Iuߔu4Tܗ %UA`nO]ķcQ'cyt T?p,uPZ5? r0^.2xPk?X{$ rZY8F u"UYt.Jqh09ئ!u%Nf6{H.w?{ +qr.Ø$b,h(۴JC\(,o"NXn. t|=򋋊6 v+>407Ӓd9is޵wOnM`NL8nGT#;ѽU<,Ҿ 5k0Ao鮬LJE5ꘜ)F~M_ZIR;F8 w%dVZ+ԁMx "F!ŨU#(Y Yrv&&!;endstream endobj 478 0 obj << /Filter /FlateDecode /Length 5242 >> stream x\sy)TNfKDov7zc{:(f8P HnR:4=ygg~=ޟyyϿpUo6ЍwZ47Տ? oyTR:=M&y#q'z|@=~y >WbE9FZ_SlTtIDږCzG EYv \.>tՂ!-4 @hZi˕' &V m~ݎ ]}n㎚dp,^*HS i < >lYhK3Q׿_{G Q/%> bY= <{^4h&o՗~QiFy7_ϵ=ȶͣϢo=m31`a_h[(F ? 񀂏{,6`~3"E, {$@G+!oѷ_NWHoH7{5tnm`T[{h 6&Kj%budϮy3A2nwo80{Kޟ a5kP J AUI7Pc4x<Pε4JڵcRT䀓`Lm0@ނ<~Jkgqm՟6-^ѹ8]*L R&?N>j!i5πuNLjS5ҳ kךmI5aÄ};!a~Kb y3nTL8d27=JC 8m cYdxVj ڎSp$7JSxB pUz}m#Bx׏)& ?] R Pt27? "~|ʱ0|I!p(Sr7X/J!R t;a=3+8Q8pG9TD–fH&+KXR+5HGҬ?dLǻEToS1cA[hlÀ)e-DH7Lm`qW=g~#`DTMUbE.GTB.}Vj,2 8?nLus[vt!,N/dEq'"VZu3Ğ&3o׸1n ͡2 S҆Ֆ82NQjVva|QUMƗ<`]t8K !;p;TO1@ƔHPWQ萱dcU\W!m% pHڣ8 GJa4oF$E; XAz|J*HI1"W])*r?5U?_Mx[N9Ӧ\ $ߦYs8U,վ :M/i"1֭)fxYR ltFb)6k@%d,Eh` A u!р.I8tgB)M需˲rƎt]#zdp;/pK= \SR0"&jd.T4i4jV>2!TA>*cXmאEqe$>dyn)X6P xVVZt`e'c=n׵G5mܕxfdCA~\U!^=R1O؃7-a zk)9=44$0%v sUeyk M ΐXSj;(Wɪ;,jY?7u )FM[E AKDMCl͘y5BRq:)L2/vՋK*cz>f8j1aeM|XڳdCp[̊nQe- Ӟo_}`TP rKA}x15x1ƜV#=J!Oa W[ J[1T*ӮX15S#yzdOm*tG7E֮i si96[ y2&yf\j\IR<>Q4@f҃Sb7FP4i}$ӛp>^Ni2c]wY|힐.~a^R],̃uڸ/NMG݁k VrRhZ=YS;C<CZi(}&]¶R׃Vv7SUWhC0@2thOXxmV6ccқmE۴!R 6e)p($σ͵lf}L!?,3ܩb>.-=FhyfPVofg 3{ HgVcW6zC^)ssFdAtۺ [ ϕo`"߿OYͬw_'zu,UY{d`A^yS,Ib]<9`uPrܞDYl|Iox)lb淅=5ɢ+x O)?NŤnڨ1Maqx;Ts?=uds?L.RQp%qal!0-S:hʒ@Qp[EjЏ=F%d> ? a#M+%.ypSW_#yVOV)~bb)\ q]W)$9l-O'v fs ڽ=K=D]:d(20oq-6z0\}#m %pQ菩=%7}zYSu 8< 2f  !d]i ނ!;#ksX/"o+90 ){"1L 46 +Y"{2UȔ=m_j> stream x\IsFv@_#M(GGH-vŌj,.BUMQv{ KfG[V8_|sR^r"􋳓?ᗲqzvy⧈Z:FӳIgfc+P0lusfQQNTMw-NK!&Nb)_ J YoB%YškR N%}^㪚OzVu U-MJan|ɷpxڷ~ iZVӥ2em5;>W[FUe]IOK0Q15 C^l]J-M|N9!ʀ(,Em ?BQ2Vt[mjWȊFmd׳g%imYli =Xu.,b?+6m~wM|t*mþmIЕE3CrH.fHUYfp R= ./s}ŵ)}$ei`v3O P3 ܐ VI><}ʞ~,hJ[S_n`+=iҶ0Yᒳ'$-࠹M(uuM6Qw6U\.R*] lh]*}d9 lbE-+@Y!{E{\dPjS>"s`Qǁ?/PL{o -DH^$}|/N) ZZ:m7R)RthNEJge$`m'YTst4ueFKN\Nv19ݿ)#y l[qB{.~ߝ)J7@s#oU#HaU5xk&w y4ԕ(l] v!YV.稢R?M n9&0KHǎ2c%wq 6V}Lr2٠.j)B~<6c SakK b>C3*D/5O)Zl,6+w1 }39ROB!nx7~-G? n7CS&<\H""#w7ܹ-<~uD?9VKU10LIt^ <#c-xνF\*s/Kv:`cMAH-l՛`]3_hG- }ŀ"Faa;'!(Sf<Ga{(= Hn ~'l .A G aj$ɨCXx sCx^{=z_M > `amئa;/_2vv.iE0L-j5D64po8R@#+^6cU|3ERθGM{S*)A gYb.h9P,$m(qJsE?۰jX 8Sc<cQ7:DdA*.?RY:m; iP 5A+ C7 0+sMa$X'8328ݒIcfި Qx[pG.'NItDUU|p!潉6MTM3nŒ@x oTcrD ! O xodb0y6ɏϘFa!"C8َ7nQt$ڇ!<2$ H gjMs2ɚLE c5w8 80$z:]} ({'P+ҘRLTќ 9@˫_^a2=5(G3b$P~챜V`SOCj\AmWq& mRx!\]UmG``1,RtdBgLU9HkBOGg~~}ӭw?u& tfߖLn u4_6@4Ѽ@x!x̶'4<ϐ%q q+n =~q.}z&q r{ΚK* ײt˾<\J,7̴x d}c"v@-b8hZ|qX{-%q5^  8X(X0%4Os)~2UG2Lv,~>n'313WG.6Wg$%1U; 6bIdk Qq\6\Ω)G]vwg4Gaqm԰]\쑠H V"]gȳAo8}hC ˤ:@hq#çEy'-7A:6%XbΑYHl<@~J_0Iف|hkL9Ao7[x jqAqyBYS e߬tOn֘"&#dxy@v-\|>E -T9Ld i]&/&66io=j4U%wIWMP {AKuaI33#3%L~g*+L>V\H{<=^4Ii$~ ቝk! } 舯G׹nQu]ZqPˣ>bHG(I`Zo@CnJr4uZ lY9S|lջgYp*f"R 蘪-Hq\{8cL僟/*#a$cn#\6WC('!7P#d4,ļO`cZ cgNK}mɈ_6@;Cl#a!aB„$ŵ+x_A8`Z3[E]Jӣ.BP־ⳁ1SE6ܴvx]E>~@|<{ClsLgZ!6ʕsT@vZ?nL& |7b^}LYl ovV>3n"krX6# Ãȱ5).)w<{^N ՘\)Wbn*]WyFg2HW|+ _ `U⾦0{b _x'oyěntі6'[\/V*E`3RbrC ~j*m代#s?BN׈—fHM/^G,\&ZmOfՓ7Oh0:k\Y)MҖ2$BbsKbBy0Qu(c/ȼI/T`ݻv6 cku.R*5^a溬1&s7}N(MF޴XgԪ.2@~@+8 N)}UL]6SiQ봼@ V(%8n GYb3&-}%-PG姃@i}%7,r2C&CH ~yKB}WTl.i|x4b_Q/MF a2fBmnC%umS!4(E~,qiX|2%bdv}w}m&VgHCnb|SjEn졤nĮ;F;Wx34R]uET,”>{㟴yvVm&C:nZWI""6QhVJ,Iy7p*t[ !\C_g}MfyO &,| I1uD/\W> (Ek((259ʧYfMNW` [ %6eQ|c7#~9=m a#s<ɱr>ƠXc›8$ﰭQ /x_&#(,C{V0}LyimxXcM]*cewؐUt-_Y'yaB[0w0 _jZY/[[E<hWϼw]Y8uSIA<=ݜH)r7>yul*AByrz "8A=V-&Lӥ*jH}ƿ߶k ز>fR,^^x}o#KjaZR`w_ p1|s)-Bb+wV0h0Cb_[~CY\>yr]P]> tڼίjOtΉjaŮ(@`c Nvendstream endobj 480 0 obj << /Filter /FlateDecode /Length 6591 >> stream x\KsF/c1whԻ`qӭ]Oz`$dla3T[ DBVV>|~_9[_nϊg~]g/ߖ~ˢd37-TraK۳_(EVE^(aXQf[Jimv˕nnF^-W2a(vL7:ׂUL-q+r5^5;Ǔջ@gin˲m}oP<[dfnɑ#FeȮnp -2Z_v6@-㌏909IK7$Y~5\&CtY_0<}~YZ7/tG#,Eau Fcuߖ"8<ֻ2Úkz UV.lU.Ú]4 =1)K<:#dFg7/-`Ddɝݵrʼn,O5!H4 @5}= m;Mlƣ6уp+:&$_$G)l-"Bri0Efp 2DmM fP6j=VF܎_ߜLra4ڐX;[w<{c&j{I?Tq.ŲzO챦 ObBao_q`7`2)[lo)߲Hin,jdwXbbHmQݘ;%h!j}mf0<xEM 3W; lu[vQ]:,q$q#zc-gq&f1"G_8Fz `Y[XEzVdHH< !iK5(.P&N/ƪjv1#IK6r*'=~ {~nvx --% d.pXj$dQН1vkM<2pbE^hg,ٷKb ^ 7{ u( g)bm f*zA nJdHl2D.mb_bWo!˵-slQQt bPȭ?nIaUS붹/YF1opb`CLdk9OL%"|i/\(RQdXc GBF4tBpO &!& y̎,#mjÈ2'qʆa ]YmIĘdNYhwo\BabӠ#*TTk\l*hJ&( T s'p,N%qTh?E8$EI1u黰@,Aׄ ]84'$$Y`/A #}!\R:B;u ,7 GO}_ P2p~ɍ1KK;n])'UŒj VM'Zܐ$6)>,a+c٪^9T8O_=GA"iV$5[H~PQ 猻8I8γc;Z% &Xo'Ũf_=J3$-}H:V=OL0"20f<({Z@R*ހ=ROJ?2,/s&[W04ˏ#+!Ks,wf?Q뿪Hq}ZC؄!gODP$%w2;)y ^`F'|7´\8bȍؠz|DMcdj ,01vPH͐R= wu>+CX 8e wUq]O9\#DcLa;,fI:$4$6=~b w .Y7/J\ g祋i~"\?֏æjyd s?Ѿ_&Y-zJ#b[ C.6;m5Fbt?=`iݓ,D 0* EeJ<S[g(iu``<}qǒ A,{g,Pʩ3&?s(E{Hϩ|3" j򿟏cv1Gy3ޞ4dAO\g^LU $9剻%P> *e[\Гbպ>I}·4lL4qȚED Bpn0p@C 9<4MhZL:ݣYKkrLL?! %cͩ>A0ŵtt,X".0jS4 \$BHRHyf9⠎7RUIGB>*;_x6iO%i>^jB;ׇ]DK=&0׏?7H|7d?{ /LIԔ>P3'O=9Ch,]BOҼ0aЩ/$#` B.nmM3 ʍJhY%{$Ŝ *y ?%7J3q#53 .O1mv/qy@뷯䨔 gYqL. s߲?]rfHd9bBUD ۹I˞q9ynjz3]QڦzOt|8R&j3``kFȣϴ:\m4R/2;\@Ĝ2HPګv@t">tM8\DUpվ]/OͧE}Z,wl޸:# !K)Lhvy?>|5}ԑ@,/fH,㐴o%e~:043V$]}||һ3c}͂edj=\̵]8[NIL[ca,($"9i(l8Kh'ڴM/v]3+#C[l)L*brhCoLwh /zrn1XifۺBmnj;6t>1y`z<6Hc|kpM_&%Xnhp&,N''9QvMiZI _A6xG=.\y<%',+fZ/qQׇ\Ql?%f^"9 م+ŽD;C(.d?>E`̢Nof=x"g %S1Ї p FCa2g}_`dn` \ng&O2WvăSe'p!SeJLl1vMGPU{`)4$t>Ghyx0r i:?CпM7<h$]I?ŭ30uv? L @TvŠBuʹu?'+O^3{;-5){(,rzJ/MMM1kO0: Ʃ\гJߺHtF^D]R.@ϧ){ѵD;څdiiQެU3Q:J+%yb!}+.=&}P]Sg|FRRMƷ(JflR"t yG]is )\~ۮL徫v+TNW ?l34U~.^Ђ .8`O+Kr>\.]qg?+<t7Wd#&FG+#ĴMSL ^+Wamb4Ga6b}U^rH2u`\T$aSCk)9YfXM=c)RG O6=NPz:ΚC碜7͵Xַc*)~/+1~sWrdA`rHw_ fٕ뱔ULz$ͭ#΍|Q<6FE{WqU WlkGsֲ91Ut2 @ dlwGɌp`+Ad:3{RPݎɫM"/:c?l9eud.ڠ ǜr8I wIJzZ@u7瘅E_b_?>)mK݋&yyP\52> MkZ\"vԾASD!4B1[/ޏp΋W1܎:rr<~\U{\{;M݋ pګa\]zdz]> stream x]1nPD{7%-g-@ݸ$E},L\)RFZb Otk?ޚq/k}~Cmu7}sۗ9f_]jÁ:KV? K}_Z7-q,:_+y_ն> stream xX XW(]D1GA6\AC첈l"K#Ҩ$K̸E7k':zJ/̘Lf뮮{1d~, 7~̬MҩᢽL|8H{`ej5{\&<;d[t]\&COqv5aƀȰM .qH$=02$gwCÊ͞+.ww|J7Qc_>1 23xVmsB]v/޸d;n[o  3v  3Y aܘ2fΌ`V0+Ux2lf 3x1sWf3,`&0 "f1ye1 d c˨;^fɌd̘xl׼^)GfO7m~Wet΂Kg⪥j>)}g֯߳&X0 p@`}w H駬Ccȗ0I\){fc͒W}](IjKU.Ѕ$C8p!Ppt  Cz;ڨDq(j 3T8rd{1ҕFS((+|Bz^7_c/\^ȄMj򥫆-3\ރ+ dn_:Z6] >'L2[|W*(HlZy.LM& h^tv8jDON5s7&2 pYɴrbhEY^LbQVVVrChG&MBl18'= b #JbI^(m:~~[Q-^R0L "1,#M (6_a(1uw\hB<M`!L8~ѯ! ?8yҭ9p w5cφƝƢc1*UK Cс9BtScy#Gʀ 8 SVa0K݌ފY{7'* P1+"hmgN5\-kQVBvc:9rB+wu'pCMX6  2 PxP8T|438 (RaMi3ʼO-!Z`e (8p)|Q&`5Gzm(~M2ѸMNą]jьyŜ# Z X[1]b?@Lϙa:7Pl}1i9aNvѫ γ8s@ftzB)Rd|T/HavѮ22P},JL](-UU bC$S8 d̺@݉E$ꪒ;scv9w),O&l r"斃j4%YP&[9fRt㉿ S>Zw)7lLsY2 5ȡ]{`gbu-.$tꉣFb7i N.d9{&;C>)*b_&!3KQNͽ5rT$^uUڶqe̕Tԡ[EyL 7Xa+-*.*.<ضꌶj>IUn=, ZuO)'#4c uw&Zx$+E7VIIIԧHGbD0JI.J^bqI簤=Iv\B2Ă6ÐZ 1$(0,mwOl9(蝑u )me KC G!B.>6IH6ߙ#Sm3@))1!YQҰ]f$sieɻ;W\&oňsDyDE#SBzh]>EMWnSϤXr6# #g_.VJ*)b ԋ!S'Qz+:k\X-*svq%Qh fE-(tZ~]d6DKENJi͐l/(-"lx*W'2bcڃg4+?bOW5)mPל=QǠ%ڸAlR*^%3 <$S< vC.}JL}/0=ڟUi Nڻ}2È5qx{_NIc%ŵGJM)WKΣ1(C珐W<Dž7N6Ss&b}~Иk2q;!X}GtlxVqJdF? Sf6POPES{LMm$,5Z0e^O$jq[6κ8E][cfq<[!LϦlO{"hn`OzgTUxMo.Qdw.ӷ*4O*_ 6@R&3hVjAg@Ҏ3->6G]UX^dHI?ȏ:t(D ug1ډpCp]oQ -Qm9p"Qe0=_kIGůs`b&mwꮾjR+UO$SRҦIgrԴ}Cv-_6%{,|$[%j71>[7656JMфM qcx*ῗ<& 2F54:sm!-=ݺ_B>.^Ь -YDqqD6~m)Éw< ӕF쏩 ON!1@8|?io[KMrsWT|nd]xa]* ^̗QP+9]Q1xa_B귗m [v!N='G= p $f> שLHЦIKN擩BrrI`.|a;P啧MNL,$E _~"gϗTµ/=}R^I}PW;mB{TDtG+5K)(Q*᫞zbZq[C?[aud)b6|]® {$‹[SU9uhi)mݿC]: 2h3Sڧ&B\@F%CGV>"`Ϳ+Z'cu屭56m 166kf].EpH:1 U:f."r釕(Mg4:KZ*yhЮ$;vUHHp7a=YAUvhQsEWvԗh, LNeifh$DSmSvԈZi#>tl^Qsq> 8WDM̦}qס#'f ǮBp5((y]zvf]>RKLHvfPҪ@3  Km.u},Gfx{;?]I)Mzi~ƒlVژParghHGRs % "'*uĈG M pZV_|y52'0UbN}'?$6z 8͘uP`˙r8_)>u3 /VwR_iߵn~9x-J0RjBER{0ǐ%׷<0gwq95o*ULJߠk'~3 -axo6x-KGUTnDޖMQMb(TǴ O65^>|F5S#aE=F k?u':##hQK!r,~+lQ$/pފYq.PP7+͍p` 7 *gf 8&.B'ΡȽɂ^v6~~[N^O= _sϜ[͙rM1_ txx*6R_+'Z|+qFRFABir#ۿqDk‡(Sx"Dܿji7Qצ~Mp˵bc8d/&OY:`Z4Cd9V UpYÙ 8&pڻeq'G=A5n7z?5o;W#rDVTs&OGn+y[6n80YR0[bջ*-5--Ր{ʪ9D>Cvf!;ݪ/)gendstream endobj 483 0 obj << /Filter /FlateDecode /Length 301 >> stream x]An0 E"7 if`F,& Y6.!<_/@C A>!8Bc4*HTĐ bFw,[}3鹮7].Uv9e/y.?yendstream endobj 484 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 3368 >> stream xW pW-0$!A"mb6CB66L G8ca˶|˖uYn_je[[6OCL#$n2d*Clnid[LTTmUj=iP8oMru:LEeW?M?&L/^(jʾ= 9"9w梛aAPlw{@)J_,*V>|K宗VjkJ6-\*s=(V澩؝c۶Ǝ-۟Zb!Z^(SZFYT?K v~stK^3y @XCSDWsZzFlCB+ )_H  @'D9~-z:zvQ=?tJgfVΒ28絜*7{ʯ3)NWKТQ3\3@2xD;@\4qm`Z;1*@{P$^-i^׃^B( 0}B cާ;9)1{r̦e=hVGOH6pY=ى|bg0% T]q2 Ɉ zNBk6 d؊p+$5ܐzlǰΣ9O[UYt)+D+ Qz$HUOuke'CD'PaNѩ(mY+j kDC 6V:gI!j&o0`L\0Oj6^lɵWf4vBT9EP,!~@EE|a-5ru6^8܁˹$||Ł,â/`K&.tjmgy=7[+4E#>rLa<4hQ ѱ/|)J7UiWwLlM: mz>ғM?q4 >O'i-Vu\Vg[W* J$ͨ]V6/S>' BN:X# 436:Mn-#oww4 x(LW5hǷB^#%ʪ/3ah׊()!q#>F3Ͼ7%]5m55m5]]mm]ϸ(4DiS`E^iEA"1n7SgisI3L1Og,0·( Dm:҆ _`flq;f9۝̌5Ba!*6Ɏ?NvU2wfDi*^Ӡ ,3K!:57pnޣY$,Y*M#!m Whhd {;*FCKVyrn[-6?:[ObçDZuĴ6XQu;כ|M)b9{OMY?t7#eԹ NUWUVթ (9ث&pȌSsO+Be"'6=gTnMd6†o.K?nʳW9y9 qQ$< )z-&? MZrAi@s}b-ʷX!?O|ZTwerh%3>G_eU g̶R?__B5k{Vr4pbL4qvf ֵB]`KreG]*hZdz } U`QΨV,N9iJ26Ew?6j?ZϟthB 0eS_:yb|Mqo7'//g@0gwendstream endobj 485 0 obj << /Filter /FlateDecode /Length 176 >> stream x]=0 "7H Te)K"\ ?NI'q[gg޻L#L&*'́FX$#a +yj.jV(5$G -碵Vot\ n@q^jA)PeE%P^}p'zI |?0g<^!V-"_iZendstream endobj 486 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 749 >> stream xm]HSqq+NFvvʂ &V7E7Xh&ٚ:rSk6Ïmg.֖V8J0$PK y_x~ C\MH%s|\ܮa)aV&!8,a/m;^yĂTЪ$jLIY>?1T QK[eM vR.ÄBچ۰:q#V_[bWյEEDŽ % t ت!\g~Ò4d12E7Z)f"q4wu 6ъ/" hxlJkoLrDOlph2Nn[6ˍ#zc7OqYQl2Yg6H\4FYd ʴƘ/[HuZbNg`ORX%2^8#-kVnzH K;&AF&(@ZWPuS9R]~ 03EnZff(CQfxTX*LzW E@uXo7@4P4O> stream x]OA  ~@YcԤR/=h Ká@(={Zc<&3a]MݢWLX#~ 連uVSM2]dxfW9!_EkTM#ZcANU0"S)*NLQTTutŸDQĈ.5gg~f7%aYendstream endobj 488 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 559 >> stream xuOhaǟgl g4ɍm&[4ӗAƒ#͚Edˆb9 ˆEбkgPZ.@Փ I]7ϘN60{b=6*>[: VHwar(!!T8h: tl>g4vyMq{|sd|CM 9"n!}$lϢ,N#Ӆ.9N|<\Oǹ3@jĿuwp> stream x]1n0 EwB7lN\%Cd]Η4(KLsˣ6#_T5sX5|ӛ? .qٷ5[SX"߳\|ruDS3lX ݓ݋HDGR#a`-*!ڈ:RNCr2 @)Н(Vp5\$'ZT(6tN)ۆAy#1R5Q UBϕ,]Tendstream endobj 490 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 2038 >> stream xeU Pg9n(Y7*‚gpT (Hk4$a FWHV^k?[n$lz_ !a1ina)1#~#̚eV`-kJT(m#DA"?}O^fRb|])ߕ'sMNWf%'cC+`5=M+^ OOo,_. p7@<<.[bծXL kžp f G‰p&$>&|,e^"VEe(Ծϛ(]}MI"c"K>R$ٻp{p\Mu= 'hԖ5b8P)q61[)6v 7oN))WqP+%Rm&;J(=`K tWCwP)@E2xPfnBVvR**PݞǼrN;+jPSuUڦ"z  |GM:$ aPDnd@R g&(vhaI [hdBdK;t06:[ov >E "n'ʇ+[c 2v'X:ϓZ5< S/oP+xK n8`ț( ܀hƽF`8ݵ)!o#kOi]|1Tz2tH$$|O(A2Q]I'ORx{2IdGwMAܟw?q[ѧoHy]\4;{>3cmPH7uBgqƌL$ufMyMV kT5PJC}J7p!aڎ>mWJNP={:Ҳvx<_ӷ0!E(JG׼J?gsƖF1G,;.EЌo0ug"F0]Z~#FR,ۢ\ THBtr OByϒyPRau0膼MDBb2_>>5,[s1 hFQo'tnѧ}q;>()C%Xy" vW$X؞Uo=^ga,Q$z912 Qѕ{!RV;xi1҇`3l&{|_< WI T7WSxA¶6~|^B,Kh^5!Ք!>'hv7S2g$kऌ|,y܄dJ~)ȯy=d& #d "`*3K7Л`9Ulx}P:m(MKo͠7[Ojj5zfmm8j5ZekgĿh!Bendstream endobj 491 0 obj << /Filter /FlateDecode /Length 230 >> stream x]=n0 FwB7_,'@%Y24(^@@CdAq>CG$h}t<;4Ϗ^iZ;ưLklÇ?-xZo\}Y<=ŧ+}]~ppK7.kèPרІh#ڒmE;RF'ڋ:RNt :nInEw@wPӮ#BW_(QQ EԼ$/> stream xmPSW_JBކ ڗhq+]`-+,?P*?T, BLBBP0`!~ Te?W.euU>9ƙ3sg{|{0;6bBB+<'&g' Y"61TM\puNhG(X;kidRӶkA^Mq uFj8NW+KE%Srq|$N$V$w#moE0wU5w0A)]\ "` c$L9cB[blavn!+ea{88쾱{-},߱N.y#4 r "čBfnaQNJd! OB7x{Ok=(a|ݶxs$z6o 6I,r~"$h@ӫf}s0r`B4i8ǡO}-Ɖ"2޾Q?:QljҾ]o\;/+? `y"8sb]iWM7D|e˂/#Fg XZs<|'rꛫj[SOdPoOA'ɔ[d{ *)+u91NI Pgj-"b`65M<Ђ_Qs̑B۠sh=Xӑx y36+Eluk(܌Mϵ(5V=<"`yr}~qzHpEm)jnJHݷ+_0IIP^~=40_~RIVW4"׀x*3]},20B!B/A `s*A댆bWsVyZ7EX^ GќvGjwM{ i!i}oX M1{+qfz2TAV$tľS'K.ŜaDbƅ1 EzlwC³@;!V?ZH~eVv_6[֦$sNژ"iMX]=t8j8 d&+4()- P\r1kD;eT/?}\B! Mom,Ҭ5mhUHm0p932Pb w6\v}ـAI)urRu4ǽY82l A,{-&jqw!o+3O^muT[`ݫ(7`dr|pxEU|ݗ _,<3i7k4IMޤ3cx"Og/8gm4|uh9ڤu-BRwS=L${tal;RuAcpuT@MWUkMHqg W8|`.x KFSbcaQѷ05bendstream endobj 493 0 obj << /Filter /FlateDecode /Length 204 >> stream x]M ac7.4m/8"A]EoI9f˼ :f|zU=)ϒcojQg:JwX5B WЛrKD%IYUE*IB`E,$ @,%DZLI?P1ޑ-p+2hoM~QCfendstream endobj 494 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 1102 >> stream xU}LSg ئne@8 I"~Tʇp[NB+nsԡF@qa,Q K68Lf\–ffⲸ?ν{܅}$$9eeطmYm9ʫ"5Q-Dk :rCK,\hYvw9^{΢ui7ߩZ\]YgeFgߛülbl' D2l3\Ts/!:C-q[#d qlQ#'PU!_WwKMh7`mӾL5qagS$F(Fg&9Jc8y:N!ZiܨE"KP2ڸ/dž@.,L,2D1~2*$QnDZBrəK7go2h 5[[-:'ALP@>Se閑ʋ@9e72!_`^m*ej'O&Dc(^#:?m!\ h'Zl>Փ&4oНWtI;$L0D($K"wأ\E;qbh&:Z Bb+$F/cendstream endobj 495 0 obj << /Filter /FlateDecode /Length 278 >> stream x]An@ Es,$MɢUd0 Eoo'颋38.y']|I74~y|q7!CWW!Cה!;q;Zhm@ٴښ&qXFŁ(Su "$Kd4bo֊@(^$cVyed/{䵂yblSֿ.b"Zendstream endobj 496 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 2612 >> stream xVyp_YH85QBvh2idRC|` C/ɲçuٲ- d|m2&9J04IteLR2͌fg+{Da,IUm(.\D=͢FQϰ[39Æ9 c1(f $RL, V\f2{^ q`cvNDQV(d 6.OZ.H(bI`o((_ e &x#u˶iK?O1 {D"^V^!V SE al+atlmzuMl K’b,1csTT"{><'jNg)Wĝz4Mym;ɩ 3vMy`MV,]xnrȎ{ni|+Io w摢,(R|26 [<>-@4 Jꔦ S Hj &~.Z9dmh;GaGetLNR+3iA:T<| -un(j5ΰ)}t,G?K/w}bQz-"6 `O)L߻>S&<[wqEu"g&:x+d^KgDЊ"Ģ<ϦL0 o޾Io$Džm⇚On&i"!j (u.K}GNDohRh\ch3Xh.ZH:WRx&8lC)C箝~_0?#ML?&c`{-MUP7\̞f MI\@~Gz: T ->"b "h|ú&UkG28>T7r+Ը$4f0oiE]2U9 G,C{|ꠊ4ps O /:ZReդEQ{gwix5`fx[c"V^%.3e> Ye.'-5`3>Fp ~铣3(X6gS<]>i #xGūy,`ծP533%=*hGmO0zq}/jMy>gT\ V嘸Q |EϥыVm8<12@G4NJMc ءK/]nio9^iȯ҉2R/'zT>Oeo wP.{'~MƢ;CO~'~>z J\]W 'Ϡ ' (uW mT**tjAOwq'g PBAEDR"Wd<ᓳn0܁1Mz008Mfm-.TD[lAmU'kZ+pƎ՘,n,Z=ўPt/ޭỶs;n<|6!LowA ,99r(a_}E|2U(@/ׅO' \FЯ> I?˨O?u_"}o΀>x PEu\w }t-f8 K)ⵞp8~B]C?-%K9 'n͵; |]Q.!@f ƃ5J"~P]^*/:$"h}uP$DQ$3l%m*W1AA YV(b74yQu72or>1oN$&:,{{l11ݶV&"lM6g 'SYendstream endobj 497 0 obj << /Filter /FlateDecode /Length 162 >> stream x]O10 )Pu)K>:NNI[;ɾ;,ڱK X&= Eu0mSau@vz$</eU!􆦠DTS[b'mns(pJM9FT&c=|)X `4Sendstream endobj 498 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 405 >> stream xcd`ab`dd M̳uIf!C'O/nn}߿ }M1<%9(3=DXWHZ*$U*8)x%&ggg*$(x)34R3sBR#B]܃C5P\0000f300012,?S[C/~\;w9Zs &=~o>Μ:ynݑ1)U!}쳺:[V.W3k8I)6{[ս{k}==;o6ɖfp}swMm}{u_Ӿϝ:m?w>n9.|M}=}'89 &Θ?sendstream endobj 499 0 obj << /Filter /FlateDecode /Length 214 >> stream x]10 = BB MPnÏZ[J~)N:_p!c|u~pYUۃWFMf݀չ;d%?cqjc lBeͼq цF9I !Zf bl@Bl $Ė q\bAB\3;;.vퟥ`1i 1󖦨7nendstream endobj 500 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 1514 >> stream x]mPTe%iYhw7E0eP)4V`Eyi].;""ۺ e4t-FM{a4rug:EgbJ$)^OJ64ٺI2*⧉g$P_{'? &c@4% ˊru7̉|uV:!RB!߸8?W)ЪWD&EW\,c:+{F6fSS&WIy>EM37:ŗbͧ(@)CM * & Q>FhsqxHR&],z&%BݢQ<7*OsA đh R/.ّHl+)|>o\)i_%yqK[pPhr aZ+wpҏ<fjem'a8o/vB'B ~]ɑ+oY*&e8Cw].WF^%!vvZwe<%wTjb}0(Seʓsч1%Iߋ2p5z{F#ѩ3=mC]KZ mɳ?B#gq*3ki孪Bs꺪:N}0"^PzgymY(NA%uWv2*8^ES#~̼%cI](hemh+σ=8!N:/x=5]NhܺܵRiHsuiWX]EZ xR﫶&+\EɷAekcmO{9 4y!_+%/K^W `ّ ,9x>TڡѼu;O{xO屙pA*L:MUvRH宱t]k S1vӛZK\Jka$$PA/n7w~gNe ņ YxVwϺJ;TN-7gDTWm:M[} Z*h 7L\ͬS5AM`'7q›߇}'"loښԵ};Cg#g$d+b{ʯE!xi F 1xEqY :-i!]w=|-3xϼ*"_}TоǕOlzml׃c.@xAw 20"ANMdU ',[]H6Cj!P CeVy0ްu~7*Tc*gf1I2xx\ OxjR_҂Ʀ=v7ad";gmZ-uπ֣6bk6=EQendstream endobj 501 0 obj << /Filter /FlateDecode /Length 471 >> stream x]n@D{}@75N"A(h0ErNb ٷ?=}^.ncڭ/˴6^.pxp~ú?}ֱw}xm:?S{[mv}_2S_j=բ}E;Nբd[h퉩RI{AX-ڣlm Cpq8Nբ=FhCDŽ jBpa`.  …C1W{,)&*"*l6 [(nܢܒբMYf催0/ ¼/AA`0/ f¹P. B :-mmE{$i@nnpNY%甞UjVI4` 0 L&Ҁ)$\0Kpi`. L¥SI4` 0jއ?VCKSmmyiZ-z]UGendstream endobj 502 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 5730 >> stream xX XڞɌJQABE{]bV*(( @$ "`{[mb.z=3moep27%H-_J6k*Oe2)`߫;ӬF 6}6lz<e@o WU=280(i ,'N&:- QE;muZ6qDq`0'_ U:jūTd('Zfa@V!{Lט}￴.6E6^J" 6p A-}-U<>>Ӿ!ʡCQrd9@6 qh{!^T3~g"$.33tQlgT>c*;AJ(0rۑ\elp@Er~膵2d;B:;zH +hT6eI?xZE_.XU& Ai7TfP?c Qe4[_O\|dJ'p/V?K vhH(G,9-Cǫai1|TūC%Vp]Vv͠ Pv:<.Ze)c#{* |%8<eɚ =<8w%rH+duJTަY+󖒬HrҘ-cMƛaS<Nx0t4ǏnZM|`GO·YY8R\듽|-iI.A|6*TtKebt MOQÙ|.:ֵf @o 2v}J+(W5!k7 b;|Eh]-\v$F'ms!/dHsx-[ DXu<OS'# $k4ބ:BUTsӁmكTrd7o_">ãE]ܢ S͢#} ꏬ#4{,s:ۿ~o\dP8{tU/MƔҶ(߲x$ AhVCh8ܕ{.rs]NF`Bw[e0Z;f}H]MTxs!`nr& R~X2;`hԷxCJzO!XfI1zˁGv'd 0 sk_)bu焛Axq, f5`exR+Ov˔ʻb4UeRTc(`Cd yu9vb25UZodgq*AfʳoXwK_@&>>+9S؜4dEJ4>X^A2NO)ńW'Vז5qdWŽ HNQf4lNڲA޽y % ]\: =( S隐d[;&ȓÖPP}8J>.`9k 4"wQ ev׶ATHX_+R9.--SQmڐ҈ej_㩻tS<3S!iT7R8PLoWtegWVp9yE%mGx!̀C~Dp!i8箊}ϪW UK 5Qicy&f?eϗ'9ꣽ( j&s@;DYjVC5Vy\m$'(Lrfgș3p[@".}E6u F薖Luo:š{s )JheiF\z>O-PI|c.Z Ʉt;Ie#E^N `!TT[7Y;gu ! ěҗC2IبpF `t dM/3*2i8~7T鋒 4%~kpxTYF9DZa2FU4Q5]q0)2('hG''5GSe`,)$uFnۋMh]4ޖ3jOZh9\il([̌>o*y炲hA#0OUnWhxjf=}ͥ'1PŲJ脜5]yw?< !yB!ƌlEF)ΝBsslma|8)?jJI47_S}Q3Zq.BMn[AwG,W}׭\RF$a73BrfeuB}麳2t (1|{hcBL&&yvHPvAcAQ1nu5ӭO-k"bB|UkZ![t4gvQyc Do1Cxino|X$l݀y׆ɔ9w݂,w?+^FY9 `WM7leW7Cx$ƴ#:,df;42b87Ca)*rڇRWtъH5an1Jx>ޙm<><:r{bw[wCoXWd 9Mrfr,!a]e>//]B&#b-0o:Abˍs%tج$c"w sƒ(w bkX&UX"FW-tAQ7?R!iLk,IE+&Gv1id)H,welS 5&hCif#WX\Ksv{5 ' 6'E[0^,fP=楥Yz.x ێAjrGI`3a~z"cjnhg Ďr3s>x[f1_G?vnG< M+5 fB[rASfnTaTgg!ųݏ b-,!pWvmvŪV'Ǟ;%_S]ǟIrG4;αÇ8vx! Id"***瑑3(xiܒ)4VrSVFP2&;=GcNAsh}({oVx6G,u_fϼ{{2ۀ_р2D]K>]k>,YWI_&0 ZxW6Pt B {_6/`BрN^;N@mO5 ay Ce%Da颿cR偖v(-&?0%9k ͻeU ef`:`lIy8vfT~'ۍg+w樗'hη9_ Tݗ~/;/ڞ!6f֚PYβJf✗ 2 g鰡:(';3).44**4.DsZ@h;i<,K?_BS.9w.ZV6Z1*|tH~bs)gwge҄`gJ^%o/,P` ;e ZZ_e|nO0{/pJW /;0)4 ^MAzq~vvq>WRąSѳgʞxD]'ӲVGZeq8d)UՈ+k$ԪN%" ù*YYuE%bhx^kVTj_.1]}屰δ?#&dtqSGvh1 tzk `qgPU]ƌrIc^n)aZQ}`i;SN>4> _lVU|^#-0okeu~śzZfX?׃D}[+66X Ȧ؁.!)rQ_ Ѡe2KWϴXN>?gp8],:qrQ9-Yy!;03yP煬0(*+WK1C>(n'D1n QM|I;?Dd{Bz.ɯg b +z{k 0 2!ݗ9]ܦ8ۘ.VW#uT6+'/;;=Ѵ3Xcͳyq endstream endobj 503 0 obj << /Filter /FlateDecode /Length 2684 >> stream xYMs|m)|),;vIĵ+S)H$A!<3啳)nnJvgnv|9R9$EZnλΒBpaBBEH apnzij`r M1΋WJ'ijQO`\*v9qɦ>lSVf v [41'Kxҗ0X5[(Xi?n 6 ֌on)W7`fؕSbʒ4Ϻ}wͅ`tlaH* oV! ݇lPtX.[~dK`pV2EMu^7~5-qv{Q "cuSQlXu럕aom̹ЬZ5ղqnՖg4g2qpo̪&6+Æh媾8尢2Ѫ.8A&Rg9gQxI5/B>xGs/=nʘce1pLj:(W=h-őRLN^>B/5N 6b?e]؋~]Hyx[`:'/X4E3L˲d-|rڭRPMɃ3˷A+Peބ,7sW]r[c͸.P2"Ҹ@izz?qʟpDn_.6ϝ4V I+VIr's5$jr4g_~M6Hd\-˛rL'ϦztkC>.`DQg`n9aUgw^ 1k\qknbwDrc%}/Jet7)q}1HQ9F2H^qG"]pbǻ P DzY$RDϩJ}mK.UuIF_D2 ;P[sn T2Bso&.\ɇ5:% Ij,t1`uoag#ԉ9DQt[3"7X[ XV1]@#`gSB5uՎ(kRUMri2_`c_ !?Q.mP$+>ґH)(un^29W6T^G߻g#N@-Q&5nYvpޫQ?!_zUfNUJ,ʹӷT" 4gf6/],EKlpTo1H^ٖᷳ]JpUtmozAV?&פx\dCׁ )_Qwn-iW^ҳQyZHd] |!RovվBiXM7mX5{U~.ko^i~`nR6q|E FB.dmdy=#l]&I^L?ypMhU5i=-}rE[FLiu4-@\)k@/MѼenq" ?e#tâuDː=tp1v?.[VvU;/GY}0y׹azrfN&I196@'ln;V]+L&Wq"Aso63endstream endobj 504 0 obj << /Filter /FlateDecode /Length 4695 >> stream x[ݏ8noO=ӎ-_&A.6L<]sUl!%J\`,QEHV]+Vnp+zWvk=mbus+g\+]5v} u5Vo6W|\wmg]LoX>EVOSڴ]gZz[_#M/qkp%>嶧q0uZZLݽ:k\Oؾ0#M|gbo~f! Pj_ -ZZ[es%9}hkAj.5\Cza4뛛G Q3?LD:.[h-4S4w;a!NTj{L0v8fŮlI50+.4UcԎǍu WV*0z"|sϟJZ weωZ(J'N`k,ڙʊ{v|4"Q8nڽÑS81%yI.S뭪L Jkc lIռӢ*n>>*8-n j%/"BAL-ȴC # 3;mx q G2b7L& | p$Qr<¼&2*a0,>i 2lVUe2!ϫGkh:vAzfRU]FU޷wY*͹ (i~ a*w$l +]Gl5c=!RQZǠ%F~A(u!v#_o~YMo@pc_YZq!%D/qӃ׊5MtjTǯѸ: NDf17b-}uځX7~!p9Y 70oind "E 究@pպ&y JAoI0/s!?P܅8htL*8U`SR6Ac+ܿV`65Ĕ*i/ãa'j7{N~;N %RG*ęQ4?G>}?Urk>O7 |=LpaJ+EJ~[54~~NpgG| yZȃ#>%b)Ad*u@FCg)BPtn#;N0KAzfj!1/ 0‰qGS\s˘'Lۅأv?֥|fz1^_@sP=.Cq1u%aУ @jl40>p.IJRb0 9P;% C"YT>=WrFAwoxo_2 !tNtgw)G>aRU]y-D\rk6"XШ&.h %VumPX1RJ*i%r\δ*Gk ?~(Ou !)瑢'Hz8B,%3 _0JeAyVW+( ?^)g| h]퀌8=l"M]zn v^q 4RUitWmz!ِGFD3 !ζ'izduwW?_LMd)pH @pT# CE|[;jA4Gi T΅4Ղq>.MB~Qׂt$@Y(wa8XMrtRGg\߁-P-zP:rGc_{ga8x*Bzf& 99I8cv.ֶZ* /0lOY4^p{bG}i+1 7;z!KR0cDmA=1f y&76De -lHϭ\oM-ӳ)W:'/tI~+Go;dT)IPܧʴl߾s.;?B"t{-npծ'*-w"8vAZ[]H5PCO+0Vd' ؤɛ WieĐAw 4.-V|,`ƿlMWWlB {dI|Uy_jP&!'ٕ!"D۠N1P0ND"͌!,BA#AWq -|g,8в_L yW2@3k5|ME+TI38]ɇDԃ@9AY+j-9ʩ!=p: W܁Up8坬Xw6XRBĈExdCn֕++l@FK"V TqF Ðh C h:FTuBD$p$#"Q3#('$ 2~^G"c{LQC"i X[ o8Iq+D@Q#B4sVehD14"3M\Ѻ_G=&,1~bG x8DE*+ b>!z>W,V2xû|_u6bMT*BpB] pBu#u<: Lw=5Sv.&zgS5i ;0)𴅿3+#f<>!^,y ,0 ^6`+)xCn x`aDZ5 फ़x'WY> x#hosypK~eP}1]C Ba%FkX +uGͳSƆ\EтA|Xq07JY3 -l+?)&?Y.ҪRc8/’fxx.3MLZ^M?‹rHS%dssTYHuIrxQd (FUzPOY6ӠK=ӤQ U,ŕ򗌈g5 B2i_y|h YMmM0b˝j,U>G[<(z-D+A1gܥ[K_K- |3"xS8H!e {^´Θˡ^/@"|ܩ\ޥY}Sd~Cv 2Yo_.]x\y ɕ> CrbBr`""46#+@,C2" yj&$˂BXL&73 bͿ?{K?PP^ߖiS44T4M:TZ 鱐欔+mr˼FL/k $wkMJRXߴZO xZ҂4L+;?СZ:Tq``~`l"[X|w u]>묺.[C,yCUi9*}?ë밄sӱ#L0uYr{V|fJ*U :0YYLը8^M0.3"cYu^;(d4$~u\.{= qVꞌ%} qn$cr]]Gޘ6\.Dhbo/-i;.+8nE6y5F1OR髁[*:h>4%ߦU){ `pR)o6~BJJ)a>3+%u fuT]T\S} uzEi>i )}j\UJEiT.W)1F;'~X܎azuRN>ǛяwCwTP,BQNh^y$Zms̱@z80JKڟJ9tw<%FK)BA|sDgČǻu^v ؅ ?qV`4 J)Ln3V|2-,3J|yi#+)a k aEꜰ@}oendstream endobj 505 0 obj << /Filter /FlateDecode /Length 5306 >> stream x[Yo8v~/ЍO".2H^zг u0]e[}kqnyb ;Ye׊Ewxㅠ_/ÿw7/ＸyWĥ}m/oWpڮWVtY]n{kv0kk4}$mWx3 HtFҚ( Y\4懋k9LZ3|n;)a7wԳuYqx[]08\ nt]}.{ `}sFjxboCd/ܧ7J]g۬Y쬗2Gf8&ܘ7mO0nӖ•ҷ f-5kh]Ypá+KL6C}޴ yg_4$S3#֠_ eЁ񉎅ж9\]KסF1e[7TOzB-7mS_Uay*x{5qkg=.$(Y}|'/;8M2>4OЭGOW}G}\WuRG5xrs*jդx(j8ȨL`\ f2RYNQF!Xy ;A(H7@& ZR%A$c30w>*6Sq*ߙ~{|f}-&gm1þ:kR/d-Rl&<3LE'wS7ΏL\}Iĥ{I[p;}y7V*\Pa< S\o1f\a( 41ec[ Za1wrCWNO?kA`>n]ex8&N8?k@~`Rq:G?ŁE F&˸Z;Г ~~NY PPN:9]w$οG2k2};y^W#5o Ve1yER>KG 3񞼠ia<`1,} ph=o{< CD.΄]R̓85>U4Z*ru2T `^g;Ijh)4لw-x׸yu6g/1cѓ'ǙPK'`LѠ& Atjax҇+o MT=Ex=_@ɱ.,Cb*#nR+8Ugg?s6n"Ϗ(~`ƩHṷDUlwtJ-p[E؏sFIs"#E)Qx`),!Cz1cӃⰋ&FXvdFOǮ4=ò&cƤ3ֆ,B2@0usrB1ɣ;#gK9XݙV ḹm~ fz 鰦m\/bz7]/d':Yܖ(e8`|7y,/{sI_04N`sW~6 ٭%ʿ<8픣.B$h-ՙ5KܩY`3DݦII#vVS gFpe,Z”,s]um $ <Fe"*^-d:;^59Mnnsv&XWt,]Beԓ/r so@ dMvS)fZsX7'L8 g37 -^ݑ^RݡT쐩ɐaJ)YKTwPoD9p#G|{|lֹyh)1L3EeU&’$>-Q9ѵp'Zwfv(ML$mwcHC˿Ws5H4GS9/vh\`y}x 7,@@+Ɍu=6U>+|hRSN8/P=Z.9?r.x>SOg\|Eւup%7{ O;K-ᐲŹ|`Hyn`VŒyagC^!4pp2aQVz7_N~&4K,a UY =@̸ N=`"e>5,>;^;{.C/WoRSaV6#}Tw/U*)|}Bp!'i?|7yB(ga ɟ?uί])&iêzk{'ǛݸٮG!di$\cљK8DꎕZcܬ/ݞ8LS 1loK8,@|u"Stxqe3c6r~c/ ޟG}ʆvBw2A0k_eqďx‡(arw]iIVV1?a K =ꦜ jh =?<&c%3#γĜF`L)>ؕC#=_wL<}b]ΗXY / Yo)KzZt7WYZ2kn_^O|1l$%5M$~ufP;رST94> N*8$)MVI5caN^W'ٜH=!Ī  B5PF곱UG4Z"Ja:Y䘵㜌X*85nCec,89$!g3b9!f `P]ۼaHm0,d4s{rPVO_ 4eT`N}~ytV0bJ _DDPH ڗE}* ;oJü8/ fqr]‰RH\/doᙝ~Y]|v@)5iVƕ- /AE(mEY:u~O.SqȖ,=ŖTʸ..]G9Rպ6a𣓈uX:Zj]IX26;E4(X/Li c,&).=>xy*՞ދf!x', /7֚`T N%hq½_Ƹ:*Br_ېFqX$ET [JR>}W OEu0.q #a1}cZz@)'%WBM AxF\tsiLYJCl<OFvr;endstream endobj 506 0 obj << /Filter /FlateDecode /Length 6088 >> stream x\[Fv~-@K4únfpIv0ZbF53m\*jx`$^KEEWbFۅg_|{wKxWE%w7\E,Jp2MV.V:)+\nw7ow"/rn\ݿcW:BYjmٷRBRNl6KQ2;6ayQ?NQw-qEVZu&}  [O*{L}h?^k.C-k~+ȭR[eZ^i2Ѱ4V%-1wEc!W(Ls\&еFi3 y/+=0rqsDmYTqAU~d[C"t~[*C3ȁl|ןnzG,GBvU] e\r@ Yҹx.|{Ĕ:hN&V,9(et noRf!ia,;oO%$Dyl6[nNQ(@+.krY5?þ*7.{vӮfHgU^ SPs0D#C\ Wa]JKjX|˅$RD $b$~<^^%'NۅtȊCmN㧎ѵt*QL4#M\SjLy9$jkFqLD<1ʾف'mh Up)9'yqMvֻ&%c~ThI48d0 TdS}>Ȫ*KTKTsL@$&23VEOC\^"*B teYr Җ#޳L2W|ši\)ڟ-IQFfZ ޣ}}6̃ihf3} z,enf^&Rˈ 1_e'H#)y,ъ^ٟo~6pb9ρeXyݱOG2|Mx q8K#2ҟև~5KY 6{v|貃o6H5>h*~Ve&~M9WZYRmvz6]"Dȡ&Z> z&"k;XЉyHM 410㑆!J]أ%d ؋5՟]csx[?{\+I(h93纋>%6՚65[ o!VVaކkVO]|dx+;~x_)Y -i !:Z%+H P8 h `9(r5V"eMUNbS!]A4 =p0aK1{MdHb6=>Hmlv&ԑN߿ UdP:>@M?<ȉk{r6F{ϫ&Kx}oV ߓL$3=Z!|ɩk{ifOA1i0jjQ1ˉ/PJ[Oyrp*BM˝S15>ɗ(_'RуفSh>ִ2- [%ӈxԌSq,au"bv F"^SLAw@|72nJrgޝ)Uay),sBM4~#9_Jvb*T%{N.!'BoE똩%<~8I?@Lk1Dfc#RF4D:ic&Toi\GX/Z11z;F,*eC /_Td3ϗvC K="qW `VI*Z+O:.Uw 43:Osrڡ& Mr}SN P]0 %O2s28<ζt,X!΢1 qB\%$,w b^\-(.4&$z6!6LG2 jA^(C|A.D@֐U9l /b0,h%La{CcMb8 8*-Q4q=R}6dNlu H_oY7`vqHͻ$).%c=KcưO}&0CyD_>A`$[xlw$}CJD \6OYbMz☳9NĞexeQ0ۺ80(MJu9Zr!uy!eCaRai7`vp‰4Hz?YN3j_$ BL d.9H@c^ϔFxqjZ@+P!aY\bpU_b)IVm3LQ/a2K7~'SU!:%)*t >Id4 {cGICqqڝ.@=Ri Jhr۽|ۀW1 C#l斆}$(35虜zLΥD%O\\j#,A\=ʳd|KKQ<p_gH1C}HEoNx_qo1~V"+2] sR < y|y-T!}V1NߙCP՞mz&EK- y#DWFY˧D^*VT{o#H^AU28Ѹ<K ;;Tܶ.ɗm6YE }Nk &ZڅˌG0ѸKu7*K1 %B5cVj^~WZqK}W|s'7Y&p역4xSL%ʂ_;R0Jxlt33~X"9G~ާJ`j@w+0QobC) ynvGߝɤ`X,YPk_ǢUbDPWÀNOZb{PY(tAka#*CXݠ-·2D*AG$Oj+h\ &}N}*¿Ta Yl7tS懲,7jn~r9!HVN@ pC+EXMN\=Ry9P)AOd+XIYa::@W{zpWhlҔ)~=۱D1&YP^Q )r+_~mUFڨuX.FDJy'[X5zԁ[,-xY2i *_)q\֡fAsFЂNQi#Q9kb G1+Eo>˄̘9g.84I\B{̢-TH*7@,!՘RoW"P1h}%+pBcA5 XH$6<]4>Ӝc8 Dq`Fg˚L3[7ÖFmF؆K |V8S'V'k !S Fj&mkoȉ^ `8`kAMVH9xh%EAkҥgc(J ;k̮+A0> r~3;vQP[:;ij~B[v!9"<?w>g6%"~Cp?o7m4F_]*~}4f}CPVb"x71w:{<COLu\6i8zxA#_Vz 79endstream endobj 507 0 obj << /Filter /FlateDecode /Length 6431 >> stream x\[sFv~Sוb˂!lgxJY)$RvHB R3{r. tf<@O;U)..^^7~) "RRYpƕ2O-e]VQE('خG.pr'Ir-T\aDH:[Z%aT닢Y^b5)kkOōoi M\q\ѸW}*ԢH]2mчf(`}Co6+Z6iRڲ 椔r'Mi7Ӈk7edp*A$5¢*mq6w7vsLlKX5ő;Z쐏e|pZ%5l#Юxi0 ΋Ȥ[ ,.(CWś~8lW7OPhUOE\9Alqy?Y1TzT2,˳@y> 6*t 'V4,=BƿR%-++lM: &qn5ѪÈi]y(M#Fr"4TkmϧFJfI6~H=|bE]<09Z4 {?&OӲO vTcas*6 y׀ͽ4u#`:< aO5 Uƅp"V:V$05rD[xڳKMfkO"$(^+pnvøE]~\:]FoCA@w}A=6V?"n|i#ҳxE4“Up~5-thjڶv{b_?;CHI Tji]*7b ۢ]ƽ5.fɛ|ΚC6y|Fy4 R#Mh[E4*CG UՈr2rP̀$}VN&.dU5زE׏TWtp>ӑ#SNjY1ổe-1񧖁[! Gnt.$۵0w!e2:q&hS+U k:2d]+K XDužTm±=RCHavA$w}:>Ϙ=ޢz΢ }PdQTiN, rּ2Fz:g^IϢZ*U2U9GJNpuUJ 2mW"(kߪ 2:=)@hqfjƛʱ( w۵HU[sb[> $*YMhcPuGS& b{sD6!og%®T:89K]YdUJU("J +gP@:<$(2~Ql>jChWۖ z2ڟR_')Q,BCşl2nn17xMw #C2N}υ[EP?Q [);#.('i"2E̷u ( Tq A>'qbq.ܡGMi~ -(]~:P`=o}k`jiH:x->T#NaH`r-/{~N'@Tg܄4wH `qdJY녱M,{JVu6w-f.m=r mcDL#b7nU 2_M$u5'U0͑V9 m"˝& EzB0~QX=7WXpM%Yas]YGH:r_O8SV|`sS˳Wn3\[^/QRИV cl)(#%HR/ &~ks@6U-.1;_Lt (KhfD'UuNiUgϯRNJrK]^L>]T6R69R`TLX,[ßE?SUe h x_Ok7%dHz=8'4mW ͓)Y% 7遒: ~iwi,">Ah{f"f|N8Gݐ)AcX1q4Xw#> ?.v f.)3-.iU[4yh`ѸT,^hȄ"+}UMZ> 0sLSN9 %qBت6$怜Pojk$7p 氞 YzbUY3}Pƣ܀;E0E!/y/yGazu h`'p&u nL")]OV9|r̻JfyW=cŻRDvsy@g}'4:fM|9/0ؑې|6g `ʹR&t?ѧaIP^-ܩi|MJ@l]ØhrFd MJ}$<&up쮌]UNBN v8]1ћ00~ϤH>/R%:#$Uc?Zg ;VA kwza&@GGa@1n!tP(qDSEw‚QzN{{ϲR\0K{ !)L=-K,T6ehk)[Qִy& Hp>~vt>aD+vSezpv>7s& cE׺֜{&djej,kn)"-^>fy)l2Ad:B.pE}0Ɇvni(ty_`ix*D"rԳLVpBL>I"KQlSL7,C>i.o%ʔJެQW^>/ǀ>2gaNit= $k(OVtM8$Yc|z! &SM@e:K~Mq&XM* +P h،׵l>1AZ1FiV`& iz` gXbFmɈM6_QK} H͝# :(aLP;3B!|vN_3s#s+4u'6chh&&LhtN;J%z=XlɯKϧ SR$Y($@Sή"\|9|k2u3O.+V[^au'ي3x$r8H3-ײ^.0j={GvQ't/;TDu`snƫ($-28>2:T$Q 5 b8ewŗ&snGe 4Q޲ժ>239_[%N#?RǶ2!SX&\b8|q,8 ?av$b!5^}D >: S<MޤG%>]%12NO8(o[d6#V|Mj00F (љy"cR0!jro!{_GaX>Kwv\V?g2?NˬsT*q "g#NP::IEsaQoڜ49e2O݌~> SG^"o5 '$]HJ>f'!䶏#3~A} /eƣ emq@=Fҥ-B0ihnǡz4q:ƅ CC,_4e -0( 9NS636~s|IRXa7-uT5=X4}E%a|1 tfxS`UY[@QjY)$ձM%CXxŊ(a5,y 6jֆ_&GqZ)U3(I֓aѧ 1?IM ;SɻP$ 5jM/};+y4T3)dt1谇uF?HY.PS->%E *X8i\e{ +W-@];gv6(ޅ0ԓ`yZ T^TYWu %E%p!t#㧁o<#*Ji>Bh݀Qjwr2pZOw`0A3%tl'0ԾmwxL2v {vC@m{ 0sא-*G+~Ozz{1hOĎ#s,o;LQNPf>^E+x+(:  Qw4Bw3(̇p3tneܸ|b Cl]IPalx >eZoMݚ7C^aJDXN ,~\%Ɵ UZH''v9M,X Y04JB@sgb&?SE}}߄9TuX|T9Ee(Ўoq3$x^iԡ(#@6'xWl߄%%A灊wA,6D'ă&M: y"a   si_{ ZNJ㟽7'lο n 7 W-ޯ3 0ݺ͑9aM\endstream endobj 508 0 obj << /Filter /FlateDecode /Length 503 >> stream x]n@D{}@nkE PPa""[7?<,[]_͗ecnew8ve}:Ƿa퟾ ?k6Tx:m׶;}=sݵe__ϟ{~iE X-G١ZZgٱZT-IUբeSbc=T ˂%JT-$EeKh,'#$!$OFHBH9sbI&wNꜙ XXoq΅EɅ'OGAQ$i@Sd(LdZjц,7o>BA7o>CIBO$B͇~5 yCA0o7 Yü! k7d xao5 ҄BDa~uZ_7+ӽ~g7~l[[n>jnw^W_Vendstream endobj 509 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 5319 >> stream xX \SWy>qAxF|]Ժj괥 F&[$pB ;S\uR5VJmj3^t~s?PGQ...S$%&mߙ9"w8L.3?̟Fσ0~g"wG$EGi }VoX)hsm)Z7yeJjZH3c{"EFEo Y eޫ r^[ƛ3(jD6PӨT0LͤBwjJVRyjj G-?Q "* ܨqxj5r|IImXj2N)+5RRKT=ȥfQ?M1/Ä2=wk5.k 3&X=iWYqPZ=Aet94:lM+6]p ;)cnCĔ{11g>/3T3;ElQ:y]ItP]@`6Ѡ(w1؋DȍB8M5E8B4Rѱۗ ]{tA 4Vy <KIpE5N7gm90=%qۄs`o"klIF$'].N)-._g/6M5bnɭyឺWYIA(R2E.h,33FL;!_\';?Ԛ"k6tubF+9î Msra?Q#BVf8|ea:>\xPUU\adSjt!;.3!\MHm(7iaITtHHĸX?z$i\=D(@P̂$(:p/y--Ce_b7‹+3mhp\Xmj_R(?]}_PǰN%p?3 ^?wo^/6"7y"=kv JCB,9Kw]rfoy>{Y>,p<Re8555kgQtBzdr6J>_ 8JppM5kDd3̤m֤NGhR|}BB*(:O(&"fFv/KRҤL*!@!Y PQ"+ɩu涭P5@˔A==z #F"oD"$ľ KF-R9d"@&x# fЬH6FШ6ZHC6+D=+ -Ql(qZOk*0,GA/t,g/{}bRe5,SB=Ktd jt̅>+ʁ 燋p@+Q31XIZzu]u߾LV>Dـ]Y"20}c>px> stream x]1n@E{N ؒ5ӸH%,KDa@}|)Rt~9O?Ӗԯ:֘.}S~ۃKd]~4 {sKN);4~V{c+` l;cc4Θ w{+0 1@XeKIe r֎(#,%^JcG5x k@]//P \⾒&G/TWP*}}++++|ITYgE&@> stream x}V TSW~1 H}nTq"Xe` !,a ,oJLhycV2Աq9sC"әrr8y~DyX>m<'b crBN@;h|:^?vcK4vbY8W,q.\ɑ/]Hh\JNH|&BNP?:3^&]{ƕuiw>QڴKl E E73Kd4#PUQ ֐-8F|@^^tĐuP3L_aU,,eM5bW~,У2hC褎~1_yfpP"NX˰BJI:DG$@3_ vRr+:`P0Zl(6?^uMO-} gn;!.1 =Yu 510."'kAb0Yi%}-~p% X#ɷLJn2>1h<cЄP z4 lFi**aRY=Y7u3n .6fb#McJ$w4JJ- H1w;NEԁ)wlD'y#T!\UM 8v MUEiC~ (Խs71hE.r )Q ;Ǒ5)&nB T >\Cړ} N k?$t3tI4.<8]p\3M~ڧ&mVOP#@nُ ș{Q7Y61,odvRTx?nF67MܦI4"$5( S9.e90բ3Ϫ@Q2PIa Mo'cL(וoAs RSZ܎D@){/] \UjTEoaS>'T׆7nwwGQx$T:9 B[%bQ{W #vp˻ ,",eʊH}ɺ#l\z|~f0_4p~npf~ppE$qujO\B+jdeR@yxy/ct1 +rׅZj+(NC!E3A*OAGQP KV@=3MgH:4WUb3+⪭ib/ sB@kΜ}̅| y`vҟ=qWklzk]E3l`>=7F4UBR)*`^ 7‰wz1)eJOaY*j>8qXdss?SÉ(RD?+e4f :lrvE9 VVa|k]ɻ0Q&l tHsxU(KhqEجj4Ƈrs[ޑMf[ s ݱ?SCԀ)N@*z9wh:70S~_6#z σ?g:34$3Ӏgpఐ tE͍.?]#pӤϭhA>Ġ.Hv>]qyEc9V"ZmFsPYztH@ӯ逫FVVU&T&וҐȍ= @:4fsO5iw52܆87m>+4ѐ!@$HA0 '2Dvvrlia:,]p'$"~IXϣsԉAIC@Mi+k~FVm-.,*eTivRdI X_1os{W?mQ])3>[]?דсۦpUU+Wqtl/,ȫҗAqAr4endstream endobj 512 0 obj << /Filter /FlateDecode /Length 161 >> stream x]O10  ЅUqP(/ СÝdߝ|p%E cikD&Ǣ8LTgo:?`3绞I>RVBoh )jHJu 6l@Tr48o1Ҵ4CN0CS1endstream endobj 513 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 329 >> stream xcd`ab`dd N+ JM/I,f!CǗ^<<,{/݇3#cxZs~AeQfzF.THTpSJL//THKQS/ f*h)$f$))F(+k꡹ e``` b`0f`bdd? ʾ?}17/w<~$.S@w_>.|ԧ+Mؾ>Z_7o}8,WG .d;[%$s쾞޾ S3endstream endobj 514 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 3022 >> stream xWitSi+*wQwS P eP씦 چ4NҴtJҤSZRZ(P( 8񪈊ŇhDOIk/Y䞳}{{GQ<O|O&|㤛͇e]GƠP-(Qd(SԑϜ.&3fϞ5-gGΗIDyDuD&75 qDX2'M|dzeh2uiDEH!WGHI"@,S(#+%J9EQLJْ$^,IIM[V*=zZER:j=Z@P/PBj"ZB=I-^fR˩ ¨ AT0UF3n}VΐCBA=nf0)QޛuoЇBC}0_?x|!=g8 :$g {QbŜ04A#kWϞ8-v5A VaUhm}yxsŸ&#oC+*vɣ#{) 9<<E6\H7<-t@M*s%hSE t&l }ڡop5Hk5ZXlPR^jC󭳂Tv :K'AgT<\b\/wP/("ȑ%PTsAɨkZΔu ^9OjCjI h47gC uǟ+Ey)VW64K4mޮ,P+Ąf&Rhw) \9sfs[ABI/B[UPSQ_P[ЖKJK4D/Z4/)qooɀ4F8LJ^9L̵( ~|Gޱ ܺUL Pd\D(|}tѱu,)B03SD@.nw> < ~eA?ݝaj<{7L(也m+*ihJgI|EgdU<-|'q;G[r6Peg{w] Hߗ RX KA-N}C Ϛw-_ E&%;]GDW֓l -(F  ,u#4_H uдDo (c۔T4mIyʧ l.?')H:pKjK{i̱+9YO(N{7[T.\]#]@;y^7*-$؊5!n4=uD CZP3t{K%?! Ԋa^ԕH^٠:cɸ†y$|px){w |71λ/l?N ,r-ΐΐې@%E.=.PY~7w2||n3^47B!kCiP۹$Nۘ7̏n< >^8ֱ?Bh~7Uⴜ̬LoM 2 ͦ+7t:JYO?E4I!φdOUt7*x}=/b(2endstream endobj 515 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 1403 >> stream xT}Lgk&(aulN|9]"uQg-TtJUg T%2E\umZ>e,ݛc<8?N,y^pW euA/|?(3`/OǸ8n*l1JB'(,} GE- FE c2V!:L-չ*a&C)G>Y, 5 "Z+ҰASȴ2V/&jrtRL8U4ӨdPɔ9hXN)VcX2IX,c X" [Mu xX1rZ\g^W4Wpn %N.u4 :0@> ;mU@c LLL N]$Ȑ;?L ;?|w;uɡJg~C<E3593H b>uݛIa"qt 3>S W ]{a u5k\ҸJP-o4fU@K'Nfqq~wpC%x@k(g+r8NǚTsiK&@k-Z[ZN|@OtQ2S{_޼9+lcYz҃T7v; #t00 c-pr!"0k}G?GAIG- T3."o`Udлkt\.ۘp;^987 BzYP} ufiQEy1U;kFs6XT_PfvO[P .%Bg'Hm{{{nK@FyA*(8a ; zumY4:~}0}k є]zx>CFDykW;o]]Q֛N6C\АJLEet1\a4XG Yo=|Q,A ="丄/ KLkI('k6 <8QhytsN0OI\|gyϭɘp-)Q/ѻ;#䋦 pVcGxW&o /낪kWzeV!dz8tqw$/{NJ0i F( VDo 7LJh½}z c0p: 5ل9׍l'͗vӣQ=3pm?]UA ޿d'@"B5SC[4GI du6FO5>`?endstream endobj 516 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 1085 >> stream xmL[Uꜛu1D:n`:Cځ-[ZXc@O[:^R؀v(Hv,PL‹nH0% 1~;F-]0fhs5ir>M|{]e7iT1UQJ2OC3q"csŪXJGJ4JJG#:=#W)B>@ÈُGDxG?F=q;!۞!?A>̆|5%aX%i R-`cr(R= ݼ캐Ipc2:g zD|j"a2a0| @X,g+q;xpTzJ@X{OYgluQan+PU-o16htSgRK8ElseH2s=h -vql9H8:{f\8L/k'>UOVv)eŽlZuWg#f[ #1,Jf_h ԆA=` *I!. l  pȣߍ@ܖ Ve6`C=0[?rRm(2Mx^ÀJ;mW0*=&ps[%k‹צfD 1w9뜭*Ap aVV00>EoE׻O܎ÓpK]$_ks}`o.0JfJtD8y=? |I9ARPj̪jipԸUS:zg 06#lBUN8qfrBwX((/]a(R#\8$A0lP͏QZ Ͻ}+ܴ`}&Ut:U}? vnnrq7F!Wp#6Dl9"U % rFleoZ;endstream endobj 517 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 465 >> stream x%?hQ]. Ś<6H(XI;rzJ@Ax8sYY$K'][CU*S0 /_1岮E||nFX\bqu#`a$aӂS_v#Ze(:jZ\kU)Im=Rv*W.W05~ư302A|3<]N# }+8vG]Rtԭ!YTtő|.{ο~,U,&T΀ _@ɭ]:|3Ӛcc(N MY8(n@tb0:;ߖx߯>m/S)؄%IhFivv$FS/;փ7!摞'a% Jfa`ʹXF3%m6Y!)MCRԨ ) endstream endobj 518 0 obj << /Filter /FlateDecode /Length 234 >> stream x]=n0 FwB70$KE 8x,(#t5)ΡB[R@ tI @(eH M(8 mH6)N'ڋb*K}%WP?Ji$f*zendstream endobj 519 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 1383 >> stream x}S{LSW>-RFLͶ eGtÁ[' T[jk!DzJmeRCu["NwYS302_rnr\-.[rsr'}j5cJ \)^ r5JT48x G(3xDF_a(/018Z[A'DIYŌySq!ˡQ _dLNO@J4)oE8D 1zєUWXR @2H+A*H,*`Ԁ!A0T@5Дܲ]ˮb<(B~*z`5E[Ʃ6WR5ZFTA*cWYDk7}Ԣe{{$R>y~epDbAt;##w!9S^rw .E1,<.a/!+E Z 5Q}73ys"SP7%O"RJJtIޭA꺘~jhsMGMvEz{ZpN8ն#Mij&W ]x?vuBoi7/޲;No %eYdh>orpŽbhLY55F(yv*D8 *. *.V\ ۉN>yDMp5L"R<2_ ()wG Ӈڝ$S&'\>a=ceFG5t+8,k6PnTIO<>O]l83?7k% nK(p|,\\+?rzmz ,$9"8 ^TXmkz%EGk!!|²*Ɛ.!S6c f4TUs)r}x)lMh }=hv-1DEkQu$6^$F!=,ʝ V fYPBws>ni^eóTIЌ/)ryt#{;8m#|i{eɗ9ȋ}%$]lqZoԍrTp;WtSg/b"{8G0REFc%ש2; `pή\-/qp,g/{Ze~N!$BcK( H4pKc:%$Ͱ"t +.6sQb́_o*ȠprBOE)%ŭ6+NLKFj:RԸY?@|endstream endobj 520 0 obj << /Filter /FlateDecode /Length 162 >> stream x]O10 MR>:NNI[t;,.|D/J`H#480mLu@vw=|Boh )jH4U6ֶI[Sۂ>`JM9FT&c=|)X >>Sdendstream endobj 521 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 352 >> stream xcd`ab`ddM,M) JM/I,If!Cgnn=߯ }=M1<9(3=DXWHZ*$U*8)x%&ggg*$(x)34R3sBR#B]܃C5 U837`F .&FFk3'0|9]8㑕?YV2DtFº.REI݁17^yʹO]-Gw ??B7w_5N> stream x[oȑ! 8N<ݛKdqq2d$z)j<_=nw`,C?R*.ŏŸ^;xRʋO+'VKzwQ0l5L^_ʨZTwob)RBx|qy)_56tJ.gB+\ g]qhR Ȓvۡ^ SW.RZX6-/T X:Y3`tCO|.y:4\g:BO~9R4GdmƲ>.]`]hǽԮh@IsLȕ8EzTv{h[JQP(޳Th."+jWC$.ZM7z)ڃ* 3 |*:Pw-=:L8J5`o;tYJF@ p"ELK' ă} IA旴ݵf؄5B#zfWAh_kPA';Xɳka\2tzoury=ZYGŪHcFjz4g(Hb-BȌ9fvvhL#MmCdvbIǷMܰpo(nk64>jS Sg,g.0T ^ 1i4⇇?C [w9.[lyG L{QTMe .`)|Ӥ xނ1Fe h*~3}ܶ}vN4J`eB8)_>5_JNg6w]⭬`d=nIX]fQ1gkUR)K*0^& G*x=nD0\0z` 9"ZWkαLM >wǾDRet8'g0.M 䎕B:53+h+etrhRl¦5t^+^I3{OCN H2LgGMxBPSNk?qf0`U*Tk2wDŽ|j FJ~MʋA-NbNmkch-ZtcMHɷ R&#N31J=_= '2bN8t8aE;QdWK*͒fNRlCA 9ăAA8Z2gǓ0E3ϧ&3*`1Jq!(jU([1!@94zVJ3|rE! `n84xLWȁ kfi-ћÏb >0% YP ШJƖ+6%8ɔ N_"<`_'1K27ç1WpWDʶC{M%.fA` |" x_iڋ^+\zM3rfeX(E5)hy3PbxNf!#W>qՑr3(Z~N0Q{N.ث1Kv{QQ>3&L 'LYyl.+2GIt`7#8u@lȞrS$BKf1tTƞ_ {o j8`_ -+;TW-\PRI" M-ɏB6Ձ2/r&AoBLk})|.C!RyO-y6!(zw<>rf(ɬSA{_jz&3`v"`‡H\Ȭc%gc'3Ŷg]?7F(+(N)RIdGI.ZXb-)iṮ$Bbg#[`H_ҚȻvX ?ri%]('*m. V%ٳvDVh;nE I76^$u3-O,[}0P?3rZﲤxF6=-Ensn14x9[VfX:$Msu^ZӼ',7:s?W&fv-.,xցkd!! gp۳e/\a6|eYTvUVYF@;#FK*/SZ*,J<@S'K'9}߱#O3Kn:\.>h?\gb]0j fL_v4kuH Jv viaf54sh*>x_Q2F@#ʁB`prI9Ivyr&L92iRێ+3!:ıA> G6d'kEQ ٮ36,B5Vmb;3Bj^z/BӉ=Fנ)s/Ŧt83 7Sl5b\k="OڟRNh\/ߦE x_\y,{U9jbqlǙ! twMa a\@BB )pZ~ $s Br `b/r<&L#bw$i'ԑDIguUZS:x)*ΰbrp$>9^^qYUkOiJq@YGENžx ^X&İb>ÿ˖~K?wJ&"f*P[fc3uŚ?S?%imM*DVO(!o!tgZ|uvVIi-k!1{q"M4@ǡeZC,g-a[}C)uD6W)}qjκ} ET+v#8j>Sq]y2^8IR6x̄խ>j|ep~MY Ch]I4[h}?ˌmectkc9PEDBvz @L.].s109 _0ǹ u4JbnC5X(Nו*qQR9Y]G2?x -g O5,_jҊwZ5n._vhps9d=Y&Se/[P)_"Ve (&%WX1I4]]~ֳX mY%Ճ hvKTFcJ ^Y\xz`6;'~p*1p.쀁f4tOYe*JpRU*[J~ːJҀj\b\0mݮ/Ye&C A ^V4$NOQ]2VLokD$ΛpԴSyRѾoyWeYK 埾Hw6]oC;| k_keaq|1H迦hs0)b/iA}!1=?3c!ə=jf\v|:nƞ~ln kٛm7(9$ ?pyHTd>LlJֆ_)=B1qҖuk: !pAxwq`t ϵw 5<9_]@7AN;jLrxNppTE 7+Oʷ}n}7i+8V.cLK'\8/Y0zwd{M->%)Dd$N+Wzk52;uJW(Kin>P!V{N4>vX`Fn)r:> stream x\[6vs?x(K)ESI؋M@xnVUyF_ "Y LIsEӬŬ¿wfpӕz?|ZSM+f7WImjeWnW?Tq-}ݨVUhj5#]V{_ wR ޵՗ n9^x-x7iR$@G#fBԭ1̵`'sejo-ҵ禁Y}CKYFU[Z,W~ӭQ-C7MXS{ t;^;/pUj% x]I=w6 h'. \Pqsw'ۡXۧ8>}t^G8wX^ieU0QSKޭq7u40!3#Ȉvɘ_/+.[e@ڀ3ߦ2L`|#Pݒk/úL< X_F JV|u, mz ~x¹ƃhַDp8hW$5W7Wbbfe[?jݪβ- ~(L]!J j!{1=v>vʪZzS=zu+6%39\^ VO M(]<\KFGd@`0֟´%0pyU򆧁3G< !F/=[~"堡Q5;*|- [bx?ɟy9JDNzr #{Q(%thP7`7xPIiUcvFjU;C"3kK~&BQv=nJljȜ81p=a53w[oĽ!^TpU1iA`rǂ%!ЁX6a[˰|y JT]ǒa'0-Xx4{hXq;U7A\<:mo38pl)h<7Idt]Y_ 5OΡrEyQ&5cXM0C&L1 4'$&ƃK9Lt|#0ePgÂ9.5#hݐ"g!hBț} PV4Ԡ~wYkD#$FկdGH"V1̌>2(lGM܆ob}&Y!k)EQ/ύvd]W_XjH Z=]{;䃤+1ׂAtXi\c&KL% ̥aKd\08Gdܒ顕49Yx0'XAMjLMʢ`qxRjIp3*i jO,^ k9蟯 )Lb({ tM#MÉKIJoBIMYͿOV!kouU*҇QP |Z34VCNpع?ئx&ݞFk;NGV'+(UWVc  g8Gd1aQv,GE%!, += Yi!V Mvx:ކڵ05_Z^DY=ezF^syC_x ?‘7h*QN1f͖"0I&8\zM%'ÈMq_`Qs;n&!5 5a`F:>O-F`yأnhU %V0®C+{u!$F3Dנˤ~|=⻑ ) a9)5 ݅v4΁”!%G}JaCn>96Êm(>9@"K@f;NMX~:^Jފ zCKK,&KWlc1͹+p"ۗOQeM׎l8E}a3'[!r(@f=qR$E0۔[] P6G~KhtD)Sp&' VmM"16mo'z%Y)#9=aeo]vXk(Ιb_uiSQҴ-48Y}( ǩPL5drնI{z@)qi"jKZ:*y%tnc2)>DL(z2{;#0=l/{)ՙ—5}(*, 9IRvsei{;$kafyX[XD9<[]iQn[ 6:(q%#QAJx!@3j0 }|_jh7XhvJE E< q > eubGfTG䅰bI% p*NUd0jm ejGv 0!GccbتE 1-Rzpwɩ!j~_/gݎ4 mBEEX۬3xefI~T6-6ycban->lǷLKtD~p)YD@_&x 9 މȮa.ݹ*:q\k'JkpS K_BJ)]kTeU_ oOKbιOb58ymU-lEUkQ1T&FqRqT f<N:rJt%TV,zy>".3.GjX5FSlv:47"&f )m@˟fwE,x'37n v [PfHe,W7bTs.̐=t|?UNlEclcHYWCfa|c O X Bm%h6\CHGz}x%/'>lm}֌7i7"_ <,tVOb))˭羅;RUWݙ.:cyngW4/V0D1&BOn9> 5Ws1>l=01{.W\~of+iBiT/I75W÷An=k&R݋oo z.Ӆ2Ğ؊| gbR"vLЎ O={LvQKfQ},7&nU*Pu+QWFn QG"m/y՜I|O$ |WIkA A ɹ>;]XDfM,lm;g!$%掍@XP$_{&{p(OZQq]eu\.?D}uq{GDȃ?# 6>gMXǿ7 _s8iۜ{*µ$78JN:=e fM|ӟCendstream endobj 524 0 obj << /Filter /FlateDecode /Length 6219 >> stream x\IsFr/&7F'=!<p[(n\ɦ}h֬\\ V:_:>Dѯwo/N/e[ wQںx{Zl;؝-L7eeZStgUY9S-onѵinvnÇ}xx+M"] ؜ʝ]Zh+?7lWo˳s m|jg6]:8aMY 7}!ڏgqODf > ht.E@- i؛.M)lyvnU 7K?ok-Wc^ṔLܥq>JeGi\;ъxiYmu[YZ^ hLŮ~=?)S:ӋN.méݿ?-yj=S]lA2Ȁn4P#WdTNt\S7"klB TH]մHt捂߅#o[ކ\*g'$>hȀ,J* 벩|qF\.-y[tC$M}} +lj$e->ynz>\..TUaM1Dr4$a%rqƒiUy0Ui,+{ odw9 tџ) k h~TuX=UkZЪ=bRi0^X'ٝu_\]*a8UbcCwq~Cw(KZ1pި$@AR/l8vX('qwۮcFtT\%dk@D)jj]sZ+;Ӥ!j 7=l"jN8 U?5f['C-PD< ]*[ik-!ÏB1S@XLO~ vV'w"ci \p(8^.&~EՀuRtAFu+;Ygx7@C Db!AOx: @0 PN k H(2T9U6GL]utNy݄EݔK%H Cu[zK0ɉ*FyR9]n"s\\ .C"pEi9U^\.Xg>Miة77yry!Ѱ%zPpF &dVaeD{0li~ tԨSR]D); И[\8Hg!Bu2 VI G !< ~ $p?v,BgZQ@!͏Q!r.USG]UQ]V/';;3cyU֪M.D`еPNUYdDU,\hu/ݏE(ϯg(*T.cW5-8\.&|nvkTUq6 o⯝p:Pc!Y_HNe[Dr%}Z C1 ~۩v62$̢_>>]3x\ Fz55Pؑ[gwd4&Cѥvgpb b,coPd~51(Vw *9Pdg0KFvS0by,)uZxQD[)I3U܆nhnحwJ_էGVjD&H3If_;479ɞ#,PZt*f\5+ Gp5$T# WpiZPM(_y<ޕ91?O܉h甤($ž@ b@!k^U%9X!wXpOmZ% +-`􂱷kɩьEmYH>}* Q -Lٹ"j鈛4㘁df|\WsUf@=SK~E{nr0$5 D P}Ly ]]4`!EzĿ?J>85g(NG!O(7MdcTo n36XɄR8Gsf5gF-m!'Q}T8ʺWAoÔGUڛXǿA1ɥvD> SmZN;]XkcXr418c®FݖS9MX1S8"ʷs P(HdoA ܚkTi*AïIP'$b3O(+d;v U]֫Ⱦ? A =`pdO8~%IRt/NUec%oCU[T,x4(V| Wg1=OgG87.)Ǡ%6{І/]L[]î'zg$ripcZa%/E&L?=qR}Ǔ~c jjCˆ QT r84cʀOU4h:f؞>S?C(`-Gd+xBz"T(|b]CtߨC ՞({B+(L|Cs"bujtxr4z=$Ŭ4(FQhQ4 ̱! 7i k?m\06 \5SHD=#b˘fE= `h^n1d:UzLVzT҇G!NEwSIJB>+ 8D0SwWqGМDK$'U ~QʔKY1ωs큨tv:ւ{P/w܎ͤU$b+pjyB;'= Z& za;_JrT>},|qK%&X\U uH.]).sX$4UWG<RtS˔׶{D*-^3JlZDd{?!")"! 7@:ŸZx[d0jA &,Vʈ|>=̲2{7ٰgd&>T:!@l]r(ACK3@#xxR2.TClW]BoG׷V鸋QFoIYå2#@zOqQMi\+uŤ[dȲ| 闺NP<9nd1~Kh*0Jk܂uO e(ԝ#[_4.L ԩS)z?ќ6tٿV?6Q+=_C7tm/zAsoy@]q1i2 eXXX)e\˳0˩1HRKZY`ny-4w3O|1T% TB^$Ok Z \oi~Ag'zq&ަi51_C`z:Y dnRmG\Ftl3">*7sT7:Ij;=ƥ4I.7!4i?/ׁWq:Z*_>5ڔci :{ύKbs '*Gz CſTIR+l5:mwE,]4>3)5PyMi)+7?M9~oiGH+Ԝ'<O%R[{eӐ=H SbXqU؂1Q@U=ljQI=EyY4 4\L59\>K"w愥JwjBI\ P;f66< ,u}g2:NoZ,?;ߋ>@MzftD[y-آl[{"h:гC<W˻N8SjWrQ$(2}Ey)YSv>fc),j6w*Ol^$OKK׮MOV!ϊRj2S^u oW eEM&*a?@>Ā]qq8Syvۏ܂cH+9S2͞\ͣ1TS#y3Vq#`kl1hY Z؉`mmVР{ߊ>WZ6mϠYߧ%ߑ1uwwX|fn;=\ JƅGq7o1N2Da@}?)-}|xJAT|n767ޠڧhTVwjsEVS9xv(LҼ\=d,q8Qp76Y *1A*i(o>l潻i4-C3\܆1i=VLvcc*--[Vn7DeJn~ J=V9dw'pzݍ@VO4LÀ^sp$S~"T/NbR%_߄Kn/QH-+N~Cpκz=نnӯpL\Ϟ?E/[GJ|**c87ɮÍڸ+1Iu{[ ׸.3\$CHҗf+GJ {mZ, m%$Y%s5Y[:ͮOЏxu[W?҇_J֔ϯsq@IK0*f0ʔ\gJ+ /UNү"Ok/&N<%j1LUjZ5Tfեm?\E&0gD[`4OwFk _AWu *oXĬ-P}#(`8[fнmR;1ToGF/Kr+R ,5 =!3ł=|7- s;`zF9GƮOࢇ0Hş͋Wֳ"u4aJ؅~s=!6+4e9W3 tI4Wu‘oIK9^,26Rck%~fvNjyKA,3n1&E),^>sՆ&czu/K9ڭy/?ND UVW#.̷ 45}+`6 P0` E=̛o;UL+K Q=Z`^Xc i|ṭe9Y)`Ώendstream endobj 525 0 obj << /Filter /FlateDecode /Length 4395 >> stream xˎ񾿐KNoA؊(q +3egesHUu7Er@ z" 7Aoow7}WYxWE%nnq+ɕշθRnCBy*՗EF9QTnM2ksԇR){m폇dfćR6.y'H)F* Xݭo2!w5RoׇnӮ6b4Y$RZ󪄧B Ou&NQLBFW뛻)uQX9)dx*ؓ ձMhyΑEEBY<;@/eObl8 W㓤bOѷeWwz!^=@ [t'Xgw_?nX#uA.-s xܡ}DƒP Y#!Ҫ}xE .6Wf ➃$" p" $HI=zD$UpRͤ%9 gSL $t V:y@~ [LjC&9N{Oע`8:yƗ/C (ʴ;$z{WpN(+Jb.`}(ao˓w&@gm&%蛵ubQP-`4T YZ1YUqI c2{hG1:B6sh|HmbQJ17M%I5ڇo7~ܶgl Q9-cבkhTE!.c{}Ǣ¼2#{:iG*V@N ,HS݁JPaYjPq+˝͝}rjnGÌѴ=ud[JʴC|d"JMlOPϾ8ȕ TeeC20_` |> FQq0:bFɒfn$>Uw0ñ !w&Y7Sʬ x`ɚW*w)>Ln<ʉ>&c)©'Zb; Мrt*H8x!e\F9';e;1 jTJ8J^bC'/wx_SPۨ ._RO"aZmɌ sJLopY|m3o^!VKcn5]~@?{jic\Ŝvkb NgxA?A &'uo2>BKգwxCS+*pj v. CK`|'b`%/!&BvR8x`%xΰ=:5OzdLʫI2ɁyAUS̨=bBkȧ>Ԍy.ODwu[!Vļ{Lݾ,U1QUy)1sm|OLD5jC!Z03@a$fy p?ebI&'1ȹ<l`Wg1P*F^9[rDfTy2fIM n(-xlG] o5xn0pk^wQ]-7hAơ]{XpRo䏄H)Dwr)Wq4dk)(o%/SW39\=Rc ]}yA.1gcc9maEX2̅shz{)챉I:s@V1D-*뀔tnfY.e(l~njFJQYvFBocY˰ NCeu凾t3gy[;"*7 -Yޫg<[|6iɕi|ʜCG"~h4q E< @rREֻ|UNU&I쮖L-uw9BڇWP%|ӆ͈͡!X혘Ol%VN[!\JTP@ϕu=Ñ'q2WOA[9WPa};֣dO> ,IMIw&E rI0*燡$%ZiAjktWIl` aWIbJno7 d7@endstream endobj 526 0 obj << /Filter /FlateDecode /Length 278984 >> stream xKmMiV5Y+/5BHna$e/2?OcDD2_{]挙1bϯwy??Oژ?y}o3_xoS~R~s?D㩟Twm?_/_῭/>ߟk}Ok~i?v_Yezm/n}k׿닿q8u?Eޟ^I3e W/;cwd|Hy~^ m?ɍ^?z9i5usidy~ۺ iv2/Xp[ x~I^WxsI'A]K'sϟ6AL|{8Nî}LjAEŏ?B{ úxyH/2_Aa8L\ ]+׏?!y@NtN1q0I֪@v\;Zgǵ.k'x=lߝxõ/^g- ZQo'V˛֒:Iy֒:l^A׊ڝJ6yJ/ҸoGH^_ `ZP}-+vDzHK.Dpö$VNJ9 m.Y7 G~Wǂ־?YW1{WoS վ>Uwr1pzE$u7F/0u ¤urk9Mb/4p!&Y$y'Zxt=N{\Fk#BLOktr`8Y ^g-XzpkQ| ۝t.@c- I=+".'wti%jGw57gc/o\_DzI#[\ 5X_p~} ?&!zzIcX7netumY عи-ݲ֕l - L}W̧򺞶E^Ls-B:tgLK\ [_mr^]W둷;Vmsq'C_zT'J: Z,2f`%VDyHܞ;kz5niky]AH z,-Ówz;\u /'Z+Z]E #9}kUfzwg=ogrr8?Fż\̶u8ɋWu}ÕsǶ$'g^5']d) EEn{V\kQHZWoǐ{=+p7?q-^p≃v'-yN/lNCb%fPZVXdrȗ " ֽ/y ;Ip-O hoܖe7`W߹+?7Vͅ^&F/TiČZW 2XȗEbi;"8?xkibF-A6AXֈ˃/ UEmY ޫRV"͐mkyCBYbuȺ8_L=LU^ZB|u#Q۵L( ,2Q W/CK~뭡6us'[Bmj0?(Cܝ׫ۑrW^!/עu`q!.Tj}-h^Z{KZ!.V"[_KKת)yQZqmQ+UHKu=0.Vj"/Sv{Y8W+|qgm/ HoG,2,Bcۉ#/|/t0.nm&:@uJETceqjȅP vu#ke}H^g7c[@q1y\E\ƺJ^Z7_w |u+gha\+=.l#EtKSb=aLC FK~e͵~XB@kfE΂W6~-e_61؏XdFK""hsbeEZ*xxm7b\߹K!@k"Otp U—ZѨݱ6:6;h /A.qm%8mx^keH\ke"6^ke$U?l@bý_qu5еohs\b)e m 5YyI֚rfmVB:B;;N^1X 7B""| r$߆s/I9D!9D\=+Ax[x'=>@qp[x'$x X_Fm ! yC ?{E!l'y?! ! yCĥx> {E!WuzkAde9zyDD<#(FAXcMg'/J#c=d$쏵QY Er,5Gv[Wِ@&%ξr=D&u㭕Rg7~>k؃!+"(db˸b퓃H"cc;d\$yw4E\ ?og$Y畤<"zhaG-0Ab Ju*ֲ %њ$$\DxAb?HҎ}%$ڟ{aI}7Iߟؼp{O Hd II$Q$2$ZDfDOeHA"JL+HdcI%QV'_~FfIe&Q&$$X2 qeA"N,<2 'QD<6$@ǎ<KyETRAU<"mIt+B>GP)44ZOTDBx8Nt!8'a_<"JIT^(%B>ǾJFm&T )`DTTR@;N!%Q~Qn*d[FUH?҉(r[FڒW8҉(%Q鯐vE G:u Q,a5BND4꫅#:m!H'ޛD5BƑNDi9υ#6]8҉('QɼvQz/dD_H?b#S!#F@ iBёIM!'S8"%Q~lѰ*d_9~DlGdYWz? #`p#'؄C G Uy;+~lndA&q%h$odѕgq}723[腰˾vod[@~ldAAB%2l%@5{>Fxly&"ǦAI%l -!L%l 9{B!aO%ld DD@hDžJ{B!S%Fmq!FPHU \{B!]FPH_V5h{B!-[%лmۆds{B!]%mAFT VUFPH'8VFQHMk(ʬ͍#4-*э}t#c5%Z֍#4(걁GJ6ЎdFƱq¥Lli62|C9`pg#'8y$FG>B8شv62|sV`k# tmdg*FOpm#'8Vf G>sI4_WH;b# Glļ_ҎM#F G>#I4XH?b#! G>SI4yYH?,d E&8r͘8MBڑPpk!㈍MABud:!ϕ <yqxT`n_I#m;rF4j?<olGl<:$i$8HAm"XG`o!:` F:-yPp}m{P0B5ƗsEQ0b&=} b#pSAk>( ;KFneZ*SUf)]F:$6ð67afѳW>#8U'pPUq/-DTy Fhr hI&@a%tXj]jX-zBĪ+Q G9W~- Y+g MPE"GQz!_G_&tAFŇ Ãs|Uk "o)U`JiZjSC`@=;c'fcDjtba YBA1 70)B䍿_2Bhþ˰ILfh: -gh\M3]rb#V+[MSQUׇ=-S7}qM{cõ1}f -6.6 7BVxl獧syTo]AMUC[߰H8^GVN{ a^-o%UOĬwÆ}}+2lr6젋F#)kuDnn@O;)?ɴ>oR_|<}Q#``<@LN#!gUId &N3/myI;w fMK,Jai'I1Us#*C%3Gl'&S>ҠKƨҩpܔ\Vlib%\Syf]Czثљ7CcuP3CI3 l5Cs,gXOϗi4LF0c'L J e;32";h`Y+#o5Yˇ-#x+(g8P6e)@Gf fF 9 _ I|xYKfӏ8# XmHfgB%^ 5孩 ,Փ M{D㔪ƇzG8HisMZ}m(y˗AM ~0eJBRO{.XPZHFadp~hS{1Jm ׮ZJ :A"_m%ᅢ>vs44|zlc -|NY!־7#iM(| o iClMKhg8!HO$C)?}Ud&l#IO;5ccI+13x/9\CCVL7`5|dG,zp@i͜'i1dg9pjFSMK s1Q5ESWvɬ8Z?$.V)MA1;0ÅKdvT{HA8fgul%Yf$h#@h TaF`~H4,P+< 1B@|Ar D:k)[$o Ik"ycIʽ")A&(:"csDO=`AxCDjxOR$m_8hq  P-RI. h&Gl$$ZēhAvFn*I$(D &FDipy];DrD D%A"IBu3I$ԇDS!-C$ <8 $B7ܲIҏ.r$ʇ iQ^]H-'fԤy~ Yx(MBqIQ!= q*dAG$:_!#(XH qى|BGn!<'љyE|^It/dA$*)ªC!cP񢀶g*0l"(IXh)OYk InDBNDylQJzV!H'(VulQ\K\!H'DžBQ4,dDD}~E9 G:$*ҏt"J#o G:$*9ҎP麒q*2y%H'Tnd_I?bC-JP[#P?<*i֡I% ` avT2|B]BY[T#Pv*GdV<"C$U2~A>G>Na%'qde#ˮgV0P{`+ǾVn% a׸q>u%-$tW23:IUcP*G>!9A%  t~@BD%m j-*{>AFTtTҎ=P!TUR%cO(BTP=.BSUfBV%}O(BV%䬒'!]+JھmL'+JU2ؐ>j+{BZJPHXU=d%מQ *5+GhHDJھy皩QM"k!2]mio {FBQ8…=Hq) i{F BI'-B]<"I.)E GT ==H{ iGTql4I/)E2s]$A!}O)ryl1 $% {Jc\g(`lD$IC)d[̳$K!}'rvy1Ds:#yBgP2|"FS!*dDU%U!*dD %ѰX!'b謐y1Dn#A$+Cy#6b/ iǦ#$1IOeLҏ'.5#ȩ 1dfN)$H(r58b#bl~l9dfo~F 'GlqON22  ES'юsn'h{B<"ǃČy~l9dQQgIXH?:^/rQQI 8j@r7cb> 2{w~$a畩W &x+]؈ߩݬwE <*+p xWa#Tj#mJoJlRT]mUt#o b] 7F|FFof`ۈo`܈o 8{tW;}&xPR0؈& })3SJmS%-̥ꏞkm1k$˙wIM|9fLg7)-- uvg%N` <]x&N:N/_pjpy}:iKI^:N`SYO:N`Ӑ'cd!8eg bEnFN42u' Bm l9yI2M2*5jU8yIWB9CxF R9g0xj״ &Ys V͜L)o|( ?V[g"0GoX1trW'E:; ԰89D0\Hg٬N:tjxq YŇ>.rUg o*ҝ9_>/~dP^D*e;tmvH%lkKӺ}|wӅ 48]jP_Dߛ~'X X :pI]i,B6'u,/|?2bcO&!:4, (Sᬣz.fwei4i=`{? ggZ[v.'4|5N6|0WjA;k Ζ"C?hM[g\L^[ ZpӦpaئ޳&V"k5} f%Řep 8uWh?NNN>; mEWY:uox;tG@hNÉ]iWљ&} Ah|5&!xa(DBO8I OB b>@NG!W7ݓ@;DFl WzƠCSdc^7&}F#_rkq>a2i>1.=է#<ɲ0N_:&O2VO׌$dZp}bX^R4#/^r5 a_OLKf Sy6O׸$vF0$.6t ȃKCşP#堑u UG-qv*"5I~ʼ_ltfaYOH iA-NE^zOK VQ-i?WQڃ^񂧒P= cU"\{^@k MymѠm (ö@NJϗ9o?~ -}x%du7Mbg[BaI$A-χLJVjE{љI_Bo+h1o'{`<}[Hw.Z A> }_H ޷Q</:؍a} }bHq|QhtK!i 8H0mdם`m@8Z4H *!28ԧz,9L!EhMA˽l0"|pF>>5gC<ȴ:xZs(ଊǽx MϼLOJL,t2|'fLKnZhY?b X8us&ȏ*̘EhKZR1a 4g4=P~buW sU80{_ Y~8l4iN IO 17f7i2j¼nΉ8jf͏Ȉcε1+ gߜRq>9;?꧃? zYLWn:LV"4@Mb~+XM9c2ҪJ'̘g 0E:x橎:N`fHc^cG(yYbF#Np+86%/,-uLf-MNhAC()| G 6Ku:^|N<5WG'ƘFqb_2v2I:˿8O ' ,k2et1.Zmr:њΒ&Qֆ'  N|G-\CQ-x5[Ew͟ga^3Y{5=ãMpćS?{=ZxYϾϷzc4`zdF>ٹ@vwG%< $_'ZXi],Y(dK6 Cvdא]5Y:d/Nٯ5Dvd- v eCɈ`Rv"{ŨtEv3* J`ӱc+G v+R NRAg[+ؠT0C@2"R =Y*Aq#e@GLDgn m6pI@P:Lj:MCFU||p \N$Z%)_d-HJd(d hLm$|HNY$vCN-"dCDXXh1  fyF.AbqN< $iGl䆒D{NKANS߂DdCU6$}bN-=v $QA]Ur$#<"Dڔj$$3G"ߐ'1L/I?#3$*( i~,tL8IU`%N2v5ỸDʵ<$)!GPęYevyMsn!=d$:/2sw K%yE Pk|}CڞMQس($avrAb.I;b##6r/HL&iǦIƑO@bZLҏ$'r2H Z&IPg M2\3'Ljv$9͚dSAbr6I?M2\3yEr7I?b##6r8H ('ZsNҎ"chG9=hqQQIʠH?:.2$e6^ Es$e_q?, ZOaQV!i7l^ӞO ?mğnşZi}1>Ɵ6Zqi7,=O?-F V%DdED!))"툊"2vDEuGFA/$ҩ^:KWC6$ztytׯ+CRJo0n+Al7ҫF%ѳV G'oyd+ hGкQ׊O%X :V ֺJܡJµϕ` /|% ~a[JupcrpͫlpF0MlF6wo۞ܿ]o;ynF-Ж9BGέ$~}h4]Je5adDF0zH,d CٗY#"~(,CdF`mRy[vjdl2Fv~g&lʖaŒAW*̍\ٻx0w_!=epN0pmg #tyiu&.unwmtcOHFnqztyH5Lt3rgV%<ŦŸA2LD\U#_ቶ[ubXLF:< UoxWxN7{|o.y}pX0f #*-x+z{i]`ô4a9wGdb!oK*Ϙ.( <;ٓBKVz*J&4N; +S}KzeR Ď*\}DIU0{EU)3IƇ2! UIIP3iǗF3 _TiB Y#We>/}sMgBDOyL~9@N[:\hX6SLMJu~c.gM7L5~7 뼶 Ԃ z+ryXS7GlfX6ecկȞ5n_YχϋjBzzpY3MY7LcPH7g}?Σ`&zİO`g|d++l95dOO} SP@şsj|ϗ[#áN5O_+ތdƇ1h ϶4BcOR#a5{l͆ۅB&#FuX2h|m.2 &ְuws6Wߛ 3["3oW9!R6j\>mXF+4SN=g ZcjiV[vl.MNUVMghi6m=a+դȌK#Դ4M]ۯ|d2ē`l"{"ͦLd|ï_mMieyzt,쟛o62㡓{~+VjKxaV– OJ0֓;%yY) &{Ŋ#@1ްWjb|,Rh-cd:TzA#5,RСļH<ju| X ཀྵqʤ1IZ#x1fXYt9_EcI2Bk ,DF0B+ڹ@T@T^'gA)#&ʮFlÊ+Z-]㽩粻wތ ua9YR^qbY25{BTCa qVxCVg %ţW_r0. ߸ﰌV2rA['=c )'|e ;1U-iAep1+/f\(9le U H-Ǽ)Co 0S_E9&!EP$E9j;bu6MLJ'/@wآP:,\~$u 2wݓ qߒD1Dq$B-1V$c:>H<I$3$$zRӜDO| AbH%H@IJ%J$V$ZĪdoXhO>HI$ΓDSP>%Gl6XB -?oڷ ^7$J aQ$E aD)M!L{ ajDS!L( +Z!LDWH?#RB^4BEDq!L(.w!LГ(/~ ix(:2O )H GPY-sW8;eA 9e[Itn.dA$:c| GPD P7T(ل =JJ[ hS5BX)$ҏt"LcˈbU G:Bcˈ[ G:$ &QݰqQ 5BQ,dDLZH?҉2t"IT .dDT\H;b#ׅ#*xU iG:BND>#6$d; QI? 55 aߣvlT2Pj*iG>O%'9*ݥJuKU< u aG~D:k#2ԡK.^%sVҎ|BJl^?l~h uY a#~jV2Pc6+G>&t! 5 aûq6Oz%'ԠdP PI? i *GPHP #j%*i{hPpQ 6 v҇T2MC:BE EhZ*ژB Ep*{BjBd E( E*{BjBqªJP@*{BbJP,g=[!ԸUm#r=]!UҎؐyĆdPJXI$V2B(~E(+"ĘPY8BC$҆V#$= j!VҏА,y䵅P[I3V2"$P6\3Br%m(B\Cb ` c2]wi {JBEO"z!}O)RDB/d[GhH_HS (d纜/HBR,C!:b&"HM"/ 9Q҉I11R8jIɗBOM!'&qhZ~1S<J BƑOĠRf*ACQ#$*A\#$+D̞2|"Fؒh̭~1.D#u#6b2qFL%`!4bq1Ds#6by1GD㉋BPg͇2\3Lhv$1Z8b#&cu~l1[w'?#*r2GvD|d*GF!B>2#L)>2I#S}d )f1N?̰B &Gye*_wa#~6wxTTوGF<+An#y#؈?5ڈ?}'<'c#•g#:U ,qEwy#*oWJoWwA7.S v#*殷AaတvJS;9wsN0Wˬ P9%pPf NI,UtA=HРI0I'*;u9e`vcbn: \4`6:H#偩;ERaպs|\5;v zӼ̲В8yH< ~' -ON.?a8)dX288i43<8HTxw'0'Ҝ`ڙ'9']<96O?4:ĹUϞN10yu_1o ㆤwнG8v/2yy4wrUcaRB:d)e']sT,XNpBcXUAtLXp<7,_'`e-$7eaUwMTq7 4[qOR"S<(G d-`}ck< cp@%a<^f[* #E8ް#X[DI, Q=\,0EEWBxIa\S<4CMt,˦L:cC!.Xa]X>#w?050=~P&^dȘa^uKÚP4Azxi{<6a+$͸./2Yi_䒛 åA~X# U>yX֐$AXdȅ]ENİ[u s1AcFvF |{2#'vX҃.̰f$?3:5>B7gl=  ca7R@tCXtOu:eмv/`zAl?=7G3mؿWߪF4hʍwGnN@j߰QI=aedC#.rE^GkP=a Xo kkadsx?ÚBuZW56Jaw;{0j3]Aoxc?dza~:ֆ^jN# g^D \?Rs}U}-!=^l׿?l<{zES30L[Y24`|\h3RԷa-ppZE0q=0-Hh'e,ii7B;4 N qRE2 l IqՊ~+([/l~qB7(d\tq@i. 8OqkE/T ꡍLDDTHxD^;fop5OW$UQ6_ *q &R-~H}vL1Cׁ! ` )9CPu!Kt͞ @6ΟO6BJ%A)GwEg" ^:&H+ a"B_kCCbart`1 'S8I9rCkA/,q m%t[>ZwYdpQ_GY#dwWN >|`}zI\)(+մ} \5S;lfp6!{#%] MoN"a9"N̾6᳇ϯ-{Ы$m)p@sF'j0ڳ"<c/[ 39S;~ȳƃwbuK;0!g_L)thYuV\ ;Q͎ 2TS?4~ F,rʴ _OͦxzPުㅀ,!T".ʊ&)%<{cɋv 82쁕U(LW_Yp>)` WaIc^Y$ni|XɎ0m<ؘGs@;y גcmN,s-+O{9C1;Դ^sB}^,ȩ?'m tNz{ ' |пxpRK~PJjS9_dUًFvp岑}_9qdXncGv3,t#B Bt C AWPB]8EJR^624t S3e*QY74x| @@3j%Y-y*ϵU Zh e>@~nЖ#PM}߸bo /@M4@؇gnr(!A Ҋ-$V}ON( G J" t+22Lg@a%c@$ZH"%0BF ؑ{h8`?#ϟ ?'#o{T,Cǹ*N^ x8Ko{蠘`j9HPb{||=!3:0.9r* ~ߥN@u}CJ~ߥ/`+T (þ?gt&`[{5[8e@qu 9}A{5 ^,طPl5~߫9طjP\@~ܷ߫vzJV`aPlN Қ7yU2"c'5qV l!F0Soa%F0VlW b¶Fv[}w}< djRrSV W3*x>f <* l&@מ0Ia/ UlI­P( u\UCS0`Qa=ʓacfӔxUⴕ \,O! }]X4,SeU`Wm ڈQ^S $Ti$,w~g]=cӶ>4dAo;kܶ"Q-؂U)en0,a#U=w5KOߛ?WP>/ ؿjG탾bCxԄSɛ}=ʰ}|z&&An,.&ZµbWvF?oۘΉf"gYFaWs{0dSwPA 2և-hw5[g;cjW&iRdc}[ ^<7z|>Ӭ6`8e4 h%c 'fC=dKY46>M,7+gttXmCqFV0}Cg1Wv dH %Jmg#bAczX[t`oUf$wB+Aٰ/ΞB8ް2F\v*Wx`KtM:β)򗑎'C(up$Wmsh M$0âF/nPݑ-灾3n-͡R5Us@E=\AhK_[J:cO9!kl%wK$:|L@cWB1@0_E-dY2Ƴ%(..g~$["-u̒R-'&)&%M U|c_+[iB}V}qp T^w\4c۽ǣV_<,PRDitkbM'm572͟ \hL{Ѳ2،Cg6Z=Ҩr>;|G?tc(вK7hBi}1 -͟rWJh }Q(svB'Ғ"\B%-q C[R]7;@/L|xEAXM*FWa6ԝv30 ^bzՒ[XXHj ߁2d/L֒hZPIk*fPlk8q-]4pd2z;U 3 ELmpfȇM`m,v Dv,{Qn!e -Tv6)hK3m'@UG+|d Cjw(Hm%!~@\ \no 4q< yhgJsGۥTzu;>H%x;OjTvFqJpp4,G35Ffb%ALBk2@;^Y{qǫ< eL Y5$227#8-8X2/ʑ&#Sb5eZ Ǧ ln-h.|Hn2&/Flf-&1Jff(6Bv E;fּ ɷp\c~ `+‹}E?F ~)@#43:1V]\W2J2pw%oxxnǀy!{\Zp=1_GCS`eW}'W%005K>J 6BYP l A%0G b RPȅˡ=BGJENB_J`=Q ) EH"JQ 4 F%G%( #6d2%J`UR{InL P ܘW$ $(@$I"yE򞐔&_8k?G~?cٟxX\?\c:c}X?\I:-kH$eOiGlԽE$ܣHҏ؈p_M?oڿ _s$ a.Q$I aڒDM!L~ a~D9T!̳(+Z!DWH?#Bc<4rBEΛDyq!̝(.9x!ӓ(/~ x(:2O 9*H GPđ-uW8BcfE qh[OItz.dA$:|2A aϱoQ@۳ B {6$Ў,J7SK@IT&*D ǖe$*mҏt"Jd\ǖ$2t"zIT+aBƑND%2HT+ GXDճyQ=M k!H'R[<҉(&QQqQ\Nt!툍(d2t" IT4/D G:E$*ҏ؈A!suHD!'DMBڱuD/qDFdoSH;2|"HIk*[_{dD_O?VI?"C}J%QO*#P{,[SZ~}%8/ڀJOHcP m0d jQ ֊si x~deeFFZ{ )WҶY^Jƶua6W֐"\"B(D!E*!aD'*kH"Ja;t%H!ԓжIBƶ%$05H%M!s'BDBO!"J"Q!c'B$DMmR8!J"!V!m!*dnDÒH7IIqOOJM|zC]wd2V ty%. Ov:s l;8O*\y|s:dC#0oA27!~8iI5dT -'w+@~Nʀe%r88Y{@} _[vǗN'W-{!u:;BUywas!-7nrCq37'p䪶qN޲2e tПM:fJ@{.[evβZ7mN! ٌ"@H G98ni^w >mV%ޮ sG&8H[BŵDZ86:0QgF"|00 ^?"$2vrUϞi'Xzpwk[!&Íø o' nR'G't1#j-uǑGnY0#<8yǣn=~O|dǬȿGn9C-0‘->3}AGnȇ.>~|֗F1?2-Q#T8syeG!#FG珄;ݲXxȤ/(-[;HÙa#>0L-|dx#T1bg# C)n0|u4׭ߠA nV `8j (BUtX=䥇IU1=YHuobB [E[2u&VyY{{Uf8hNꡠᡃ׼qiP/WsםjS '>js=NU4A߀ ̓~Т` zCm6iBD8=$s կћBo"Vz>m tӡ %vxėX'#׉}+Rs\|DaM7 =uj~v+tT߶SǷ6ڃ|Ctl3H&<J9d;/;7o囻yN5O`}К}Zzr}=ųǃ:y˘97 }doЛMsWWq8L}pӡW:ɿB?]74Z9w# }Banz!+zbGhDE6zM?"B=v=F>ij烋=ގmWÀe>/NC$l pZOBxataioxj7N?̈́Z] G"o\/AXJ xc\?{OlW\JW­y69S61ؗ'q/{i`xf?ͦHB T&iF>J.ÉA׶g% =ggg.=ٍY]{<'.r'|/t{"Ⱦбu#Б8y\M{IEOG 7cq+"i'T8i$J3tqO&qriPPWJ#$FrrU' ˌW x46T B,$@z.ϔ?$'ܨ s X.sBEڞ 5$63rC-^փ*EwNNL/^QyAeC"(H'`QMˊnyjD#bVqmڏYF2JQfIZˬNI%-I6%YgV$ԡY_L*'%jVz yQP,$R:[ACKo^IqnfS,JUiDQ5YΕ.h`7 ܙ:iTjkpt"{!7'x*2q y>PC@K l)u_9 T q}%/dX5 nl INd"b(EĐ Q8 21 bB\ A`ڰCD,dbw(EȐf 2$B61hQ 4rsq!1C!b$0X+I` T\$Dhx{(fS%Nn |r2!l[ʽLkJ`əLЎ ?g&EfD 2 Im߈DEFH0h"&IS)mwYf ax( TH‰H&2-#RI*oD$ -#iIl+dlD(WHۦE$ [8I ,o"-hN [89BND.7ҽ-q i܈u!c '"՝DBNDZO~%}*T2Xqo QI۶I*Pd*i[l?~!)2 6)6dl˛T+PRI_PT2xBJB(ƩoD=mϐ6*[%sUYE^5LZ_ߜKlvk(!i!V'A6|Jl^IP=H6|0ھ{[ x)Mp6f0`cAf~2s\U gs¶sJt<#B}ȱ8X$=h#VA#A;QQC#0P[պhFjo bi$O)xe[Q-_K_ mi҃N#6l42"Q#P⫍bc fT̳]|Q2;Q|k )qʩM{kRF&Mzk㣰z-xr iS|V=&$q>#SAݫ^i#6z`/ۮ໘979>q #b/܉8O'^ Vw&bFœ4|TӿP`dҥ# B$B0 /Db#3ՇPX9U9ZR:J YbҊʼR^$:3'F |tBPG$5rpȡI9-Pj!Fn:6#d+p%;CWEnVɯ e@:\9J.A(e&KItMW2J$yJDeI$d2H0UD+ %<34$IBI}%DDǁ@p uJ&@BcJ.AhP`0K,$2c&L* &< &@#`BYf &Ce46\`4a4 H%#h"L*mh"h"W*617HhRh" c*17Dޘ$4䊅e ƏϏY/t*~\ئE%0E/,oMN >@|A2"9N$e,ErE򚐔&ז\#"9H\(sk${H$3r/JRiErm )H1$eɵJ$3HRN͍uZ$r\Iʞ ҶQDr")HFEr}"}.[@F$%RhB$#dBRD2J")HF[$%"ɨM$#;mb(R$#MFIJ*ҷF$%:-d$.:IE2'Ƀ@?ȣ@NEdnHYI$S %2Ig qK#`cyLf8&ѱ5ADG qN2I qdOc}8'ۤBH3$Q*"ɱHh"" Mdj%/ ve'=I  $} '2dn[F&D+I‰L%-#nA"1dlD&D0IۦE&-ȤH&.mZd4‰̣\kM2p"sA"?dlD晃D.:IF洓-xȟ'i[8y$s '2$rI67vd7\ D"I,ujHmYTI2ř QIҶx" AIOdA)HmUY $}YpK2;(`!OD!Q,dSCU-hM ۤkUh ۾B6)bDUBODu:*؅ʝDBvzҶx"m.$(oDt2I IPHhHFB:5ԍQX ut$PG!m3wmуD}*5~BidL׀"[t k@>ITXl+J֣B:/ DRu^dU!s (y+ k@b5Ȇ єVXmKBںmd]!c (/z i܈޿B670 k@5,EWrEi&Q+g!c$F i5֌6BZIߦZf+Pm!έEtV2׈" aGq%c(3v/Wֈ"+`#uh`\ծdnB=߅/_^f a+{%} )#vWҶYJƶuW֐"\B(M!E(*!D)*kHJa;t%H!PTжI!J%c[ޤu)zJOBN%}'dn{DPrT IHTI&TR-ڪ**iۤRBY%}'FdnTmPVI ) ʮ *ܐ*+iۦ!a%c'T,jJ67dnԕPYI8 9+[@!Ah!V2XSB(PmtmnH/[5m6Ś& ɉ+ܐ,J+ZsȤ+i[@!u%c:V|o6+./ JuH^fP4_I +Y! !W2B~u(m8s TҷBv mVȖZ7TҷBm8 ƏP͢rŨdl5 +Q<*ۮqp oB#-I!t:dlS J%mrgdlL^ L%m2dniyM!4I"BhSH8d,V6>VtIf%֏S>^?(4QYYnv{ [ f$ΩPQ5; #/% Fș!.llw8cїQgucUqֻӄwPR/7dDh#CvB!3oY_eY/B erս|,fY4:-NVn'tK} tK@βT=i!oU2#'>X^oُ߲g;Y|jW 'a *3@HXL%+9)8=9yjIYa9 0'={!oҹαHMPB!#D*Q}}}/N+T%qˉ#!?6U>rJ֮o᠇ d;Ek󟩯=pL#䚍F>xXd,N,5ׇ yxa?rqQ`1# ܌=E͏4}w>]y_j Q@-Y͠MXXdT'JنZU =394''Q`[wBVES*'p;`Vqvi9d#B*=> t9X{mp`cIy#r`؞ |&&9>",1MyBh6}'Ds^4Iht 6~䡞͆B8 ?rN`G},=N`&ʏUQN0 ،,E6Mi`㧓>Qp`G^.:x thꀮA 렺|#jLMN\#ded 0 k]NcN\6vB/q \66;H M:hFk'6caۉ/jv# 6~ N$&Jɀ\ AQOG`  Ax|}<;ոQ{>23&~LA`EI1[ 0 N:|‡n98Oh'pT~ ͅz Ann8i$a4A'R4 M IqB V4'4 ٩%2N`RFA8=pQ7U= x?NS6BP4㐱HNh,|nDIzrB(rfɁj!7"$PjའZÙ0'2p \~ l2P-d 8@M & 69 } q$VP#ׁ h5zD- ">!t q0GV 9YV-&^zͅ>{Bg!CZՅx׼V oMxzw!*rY^⮞= qUrT./ qt%PI/, qu%Pd/IAo(BJJ[o 񐭌 bR@AvJrM_\Je`^U㜳N.= *Q={*N-}  r B zATBw ^XWT̘" +B<05 ݱ?IT\F ^" 17DܓoBH)s>*ke!3ų,Ľ_*?Bf̍ųbn,=\,lq*p2֩xtM EZ*^8:>\~b hX&x'5 -mI4GhD1H$AH{( q/&$$hmG1AbJ*ֳ %Ѻ$$su:$ZĞms#$h X͍hL}5HIz[|EA"RHh"" $Q$$(J TE[A""K-";mbdDfEA"bMҷ.# 'Q$$ē(Z}EAt0HCtHI8$ۤsP8+%yJ$\I6)$wItLrl"ϒIt g$:&6H$I6)<$Ip/gJ6)B(YJ &4*hk4Hc&W) v)S < TE-P֩m^ W%} ')ڶ e aV `%mJ$V2pB $JZVҷig%s 'D-JN(_[ } an1V[1>ߓ{vq6VH}]F j^_A-Kտp4 MJ8NR#G*%ѥIǛ&y_l`Ԏd:JY][6ǰH& ۬^:փ];)GLZg#4q.*:~Q;F`R>s6';29e(kX&H%(?m`)Oy9 /|c%)^yz(@N` Z_ސWH5 Ab46ګݫ@EER/gK19T)%JP$7n6KK4ďT~YruS+Qe\U*3r e *ZDx/l{h -bcˉ*FhijckV$ХEKy¦inH|!SvBkӓ[?â*&mrA_Tda*D kNx91U-l| ZrnK HT7*1b%~}0jh_MFW`!=0B'X@P= Fi> aX{,î #}Fhތ տik#bSY"MfObzNGV})Frw [L=d|V'+Tv`?Uk|Z9l#2=WFFWȹxۚ"'# ڣ-T- JfegѰ+N Ѯeoh2B t} /> 5Zf)>k|EٙU967;3*[rFR'hkὠ<;B{gg9h ~*hD: 0΍rhgKϰ-|t'LhFG;E2ιFiga \(Ԏݩa˦YöN;Ag@`P;ŶJpa'Fjj.=׍ݰ۲atxk9L#5Zdq1ހ; zNBĖQϱ/9r9ѻlNBo;@[WE}FVjK-X{N\#lG~*4򹘍b(ÍF= # ^t˟Tghʃv˺+T -y% Z79·D#n2Fi )XJ$ yᝩs& ] PSatvE #oXCx9bJ+b>ԓُPsb[8ԮXnC}UXV:#9-"62a&*u;Փ'ܡ5n"i,-S鈌4@kd+%FLzs\flk8!<sG*O;X1C9N}*4>/) 0#>1cipp/ʄ$h86Vlū `)t;-IWhlrF ◦Q#m1#,iN;%:@# چ " wUqC],.Z{F H+J:In𿦖|.4$ɌU6O\n:'i?-xq5K y3=)iҫ7%g3f^ 26tvmU^bS1lhr\$pپXkEYR1hS3v&]q-^=5Vkʀ%#n qŰ05u,5H;F&{`cdu.+sc|xC@ .S^ 8pДJYS nN&I(nM{:oZp%\h!K.sкKs'hՏm"wlh?J׫Z{ 5/|ty-<wX!Éq$`PR$`S @U" WW8&`hY@_( 07#,p:#'@^{\_/ơ湢^vNR8t *`]gfvn$`*F0kFV= hƮIcU~I M}]U)`E XO*^UzU WplucW\|rZQN,zULe}]U,`]%0֍]o iHe<֍]溾 ^\/ X/{\|6 cP@[C:uJ0ֵ] ؒQ@_vh(`.k{$`I}٣͒ /eg)-W>s M> T@_|t0=zmT\vh .ƲGVsЖ= e |V@[: W\З= ή|̾Gs`ײGav!0֋^jw,-k|4M0.Z/;^|x0׋F%-/[{t0=Z󵀱l?-ekFr蛏 \ש>zՍ eoz:eo.]uW?yЖ= ˉ(Ad_\WxuP/}CPuq?eF.ۉ溵˼"- .4(]vukSH! 溵 Aڔ@Jcɩ7śOᝌx+N-NcXS !^1'\Sew2prW'йq~^ft$u04v9g{SxjU$'ڴ8)߻ =8i,NU'{.5Nh贪$\9^O,z.ZUhp\eu2ʺK. Vw'wYOupr]eHF:QE~ەh 7JP#r_E5N')}ZuzInG?- `#xᴲQmZ>2dGs#Ɍ]NsȏkSeaG5=c)`< @8xqm鋂H~ <|x#lATHyZQG vx>-wZMArZWGS4ºӛ#1gOpr@B,~HX[F%8xZ^<|#:g!Oz\xȔq ]` T粏%YG7sHa3;1kɯ&&RGfyMn4L?}w 2T:W \=:I<[mLքF>r{#oZW|8>2hGcU8ZL1zFaӐy82HT~ॅRFldG-dCO%BC/O\7/L=_-IoJXyӛTx'y=xLSD{3ٞ៴my0lsA>܉|[_VX^+r ƯZi0?l@1Kґz ل 1sWzaf7?1q@SɅ)ҴuyjrNbz߉ 2BX.#GWzT<FyÉ K/+p!nIld"j(EԐl D <P!N;<T`!CaC,Fؐ I^ 'Z!q!T@[t 1-D ' rXA^ NtԨ #1-HA|BiA3\\ׂ\Э6UKnG_Dž?"&'_ A'2"9"yMHukKRHGʹ-$,H"9I!Hg$^"yۋ@R\_H$˔H.e$e%,"su%)KH."ԓ@msn+"DR0͍v)[*IvEz}DxDCA"I@%H3I$QP$$ DDAZr"%Ƞ1$ >Do ]A"N9HIw'Qh$$ 蜑'qXI2I q0JÓHmR9-H輗&El$ΟItFMcl8&Y8HmR;H͓$I6)2W$ IsHrlF.5GFC 4KeINI Jҷp"KIed*H䲒-ȜXk22$oIND/R}mZDʰz B6-"Y‰Ȗ&QB-dnD$x( \‰H&'Q¹͍H\2p"I#/mD [89$ҷBzéȐ@uBOD=#jmI!cQI:M!m'S(%QimQ*dnDVHfF ̈\("_!ODQt,dSC-gF ۤ8UbM2l!}7[&Et\(A'Q]tQ6BODmQOnBODWA!sѝD -N$(SC-5`F쨤mq:D*ۦNB؍RI_jdFJPDN%s (T2ր"Z a{Q%mѦTXhw*-Qu^DkU%s (EqU׀"*k@meIyVX`+]nuۈnJPD]!l̫msC ~mnQ6V׀"+k@XI_#hZ#h,-mj3C+i-5֌VBZIߦb+Pwm!EtV2׈": ap%c(v(Wֈ"+`t觮`\jȮdnB݅D^f az%} )6WҶY&JƶuY6W֐"\B(B!E*!QD '*kHJa;4%H!TжI!AJ%c[$l)JOBN%}'dn{:)/dltJI$emBJOHWUWmRHU i ^U2xBB(qorPNWIdymnHW%mӐ$"b!}!,dnD(HjYHl2"I$-dlfLHZH2$ҷ#4- -oҷB67BDBƶֵzBPmm+>o6+BGDZBud͊'<!/fEH_Hםb l qu<(oEX'2Y IPHt{H2>%35Hߊ$m 3""WGH2]+$IfE$[D~%A$"tF )I6+҅%"ts /I6+8&"4!)&5AF$n!N0!٬I;k&z?p_o`ߝx/V|3}_?>@VL۷~[kb//?~YڟG/w/`|AA=i,f!߽LWp^7t_}wF?%V?~?ũ_}RnHw_~sߖOoAm|kIx3Io^+/X"E1Lh`k:v׿g WmgwUdzװ_Ψ5iO7nfVm'?n,EI}x?z_cWAg}Ayb<99_hg 2|ox0P5g=GN:F*fuU/XƳڐ $$WǛo}V|w2)泒!/ks})cmǨC? }|> ɿrpg)z;' se'%)ϲJ8볂a( ]z~c;,s}}l.?Z1~{.;\њKa)62O j;<+I>/p> ?}7cv0oծفoK!́F=g鏅_p@yV|w-ߙ9ψ9Mε|$[r{Nwm ɿYAY|V ֶ&wت-7 k]du}kbw;吊nm_.sߜo$,tYA^k)YYIʳíEʳ҉zyryp~xѾ}*'IOy>+׏<)V=1QGY1ƞʠpIZ-OzϵgdO.Oݞެs򞇵gQ۩0@9Vq9w9'GNt|S4?-jK|a2Эb<}0ߕipHVx*q8}gm }6|Mjy;{c[tanՏĨk5^50Dwa Ÿ4fb655M~O]Ĩ nb#7=< =^Clu+ܻ>paQzwrc#$v⭬AyЅyN#M Nb L:w?l>$xwhh|7FU8>WW󉀇Q| !{~tNa: +rO1-`'ǵ} n"4>`-c^}qbOv71ܤ0C~\7G An-Uߐ_V-=lں嫓4 yN1궴wζy:X{յʤ~}e\Lyouqjd.>9/rI!#,z1|x^a{\[M}G}aow|}0.:v.[;>`x{Xal|GNey=5H&zuە=v`с7oPC"p nmk&~iIP˛U.9vޜ78+_Wmȉ<:|p7S noKqp< f729n=>O~P63R>~# w1B |8l vp`M13%r㘃 c?㗵U-+ eou&]?28:8A<$ NL4> c\V_:hv>]gy8YsOa_qNE݂:X*N0ŋsxVbJ%Be,_|4P:8-f +^ThĹLH[-'.0!OMogC\a?٘i GԌ/D`"&|1԰_';ݱuVɧtx9Z⭯ n. :7oS>h4CrbЅ=̹~ y79cx_o9'=f}uxgk|47t_BJji~{8ɧKFw>09Ư6,w3p ە=@1I\|eeڛ mHr>CmYpc2Ŝ_]ެ|ԏɍtw7cL<11YV4{Wz9omO`1fagnZ“-buz,]3tʅ$'7쪼#Ĭ,׋sUT? %f>^}/F=f մ'xFè6`,邯9. n? ;=9q42ozl>q{s i3`ZT c$|o1\1Gq/+H& H^>B~Y1{_ hل/~->r"|<<=H>6X3'q;L&5VdN$ri5,<a7jaP~d`[=J%f0ycxlٜ{q]#8O{_1451c+_Xξ 1ÃZC|1oe !xC: JZs/saԇȇ462?? 's0qV0 |Y!?e/$|/p+@/T}寞os~g leø,)wV fX4A,n*33}-^+?ey'(]_꽘gW,pٌk=h#Uoaz Hkt'11!E;Akcqӽguwx~)|0`}o|~|C[[,W섯'>b֭X.ؑ0[%=޸JbƞmwLkK& &ه\TbMW?/=\3?8#G3(ǣ[qļ]c{ɱeW\Vlj -REWl0vJg|Ljd4Ӂ۝$>vt\S|5Wǘof>7_='[&@4~3LL5^,3Ҵ+hRjkގyrY>[Ԧ;9ݟӗ3f֛\9=iȌgNOPb{3 =*խ%'[Xk&;e۟eJ05뻻{ǝK^ziUͽn9]WF_G oԈt1\jgl-i3flځlc5P ʘOw{vK:F>/]gck?C͇С:QIGq*'r_YZV땔g\ר=guMiGhD?OM|uI[S lS4c48=75ûˍYƣCsquMK6Ju>j[$jV>C#tϺj2}VIn[2[}t6^ R}1#ukMrQձ5:ljǗг͕B8f)Z,|=Œ<<'ou6ghOck-Ic?JffV/殰漢uouM d/1n;osߣ:|E| ij24SKQ_ 섬yG,f$[5?k? b/ڵ{MϘD}A~|Asu^k$4Eӡ4Yxuջ5c&nZxN7z§ځs?e*o|>Q^r8HGcfggOT,'@}l@ǭŔ#)}O5dM-\{7\{dLmmTxf_M\uyrSԳБt׻^L9v>:rjsak5w=&ġNS!n矋:~JoWtH,.|n~hsXwe/HՋ(si|tȣp]Go֞t_jJWT̏d0<]vtG;1GmwbLӹ[\QPx&]ms>&Z}7ncrcz>]*ӑ[euk{`t;9lhbD3c#_|mv=F{SG:eeLi]cjۻ:]/u+pLEB<ڽ;9߷tXk#J_7'/"~~3vuB/Q#7{D@{rR~jrf!^'b#컛y'f5_w,tU-->}v>p=إYZ~trӾϦQ#KϾ]k>ݏs=:W;m dZkFEN$iӑ[ݫkcm4}@squ;kUЅuqAw*=yeC췎|[_վY]q)/sJ~կ|u@yG^(y0~>W=e>3ɛG"J'Y* :|uYj=(.~tIU>{Y\_wA,FOYr-E;~Oʛ?>/Kzͻ5>GM?euZƩa%ҏYS1:y2~4I?u./oWWy.ȥ׭~)o>֥]ԏfakn{ʯ6-vY٠3| ԿG8ܘe?:2fϡnGWNC{Zv>9O_6~7(ꬓcV|z__] 8+ͪG% &q('{u~g%1`̪jw󍳳xkُ ^Ҙe?BW]cBR*>znq4U?__}י8Wݭ#JwFĘ>Ǯ@q_a>?S<ՆkIQ{_{+}nxtʟO"P}h=r~aЊ^zÏY;w14R5? ٧jf Pq G].6G_Qcq:Y %7̢oM:!g0Uctr7k#wD ]4k|N `Б;Ts?o﷫#X|$_@}CnwTߚnv\m:OgwkU}vE~{3}>5ӣ&PdѥeYE<9ӏp9כVԋx96c(õgsӶnWY:CQ*KVN>;{}sw%"M:OGUEbۏYSQyToCٹݭ=' &HגQ GқžXi䠟!F6CGTkŸWJ}s[St= $ױ9CV.gF5<:>:z}0흷7:SS=uy9k{6%{xxjX(g;֮k+fϷVځQ^fj׌n7TqŀWQ{皻AV_[^k,:`c[*ף媫C}Gmg4ܛQTK_;} :G:Ysn_VWJߺtjg% _9z|ZN'5wzpQkyU Ӎl1K~*x8+|6MDu*_%ϳ"6xK;}^]~8uy?Ygs]5&㕍~̢Gc~^S GfϣYfb={x5?QǬ&$CN9k~WjK?>"gϦ&g8~:rk1OШcknsYCıտν1_}c>L5+C}s? gϣp?fզs?`y)ԑKݭG.Y ,դ}7s-vQ A?fOltUiUfft'vUHra88 t5YtԘRu*B/jtPn4ʽZWȢ؀itUBu2?UIU4k^2O4^EUW].'^r>"^*סx UL pVxzwxU+Bkt<ʩ:<%hz'~pLOp lc[eʃV ob[r^lqZr9i[KIUfy[8Hoڶ5 (@&L1U\B$6 *]ߦShnV`Zk8UdvkKE]E9*D2dXW_ {$ ن*U[WQ#m rmWS? }GYWq %JtWS*YFB#UNX* DWq *׭ \KUNPиJTѢBW^}biaƸ3>r(\e{MW ݃}^ňW1^ƺLJU42r+gUWU?ROv'2lphPCEb_e쫜P)s P2 +qP E>`_( .+Ο0RW+<,(ŠgV<AX񲟅e4BWa, a%KhVV:aeNLꀁ,,kpmx`Łs +6!,{T&ae 0jDX V;vV(R7#PJu>=X/R?ݢܱca;J2DX:ro:'/Ċ{++ $Ydq-ĊtWY r8^s^g\; m (+]Foke(+f+3d0+MaV2 ̊VaV0+MYqa5 g f& ^4/0+Y?Ĭtc3+T1e0+N% 8+W# B+"ZqbA|HA+=b*ЊkZYVI Z2}K_-ЊWA+ hZ{ ihV5JŠEx@aC+}tЊ@+b ZFq$XqVe \Cl+V,,䶱B%:ʩ)K+>r? 틻:[zMK+uc#OʓQ+ #ER OdS+bjsej%7&P+<)EFʫvw j~j'ijҝ̱Z986QUV ֠VVJV:cZ9uZq2'b,2;R\ieG@W~ Byf D0b'fW>+W|^9+A^ Oyų+dq!F^Ca);OA^ZGz,ʁ0azZW(H6"[QWBGX^JtR)zeG_ygu ʁa~5+f^ Wj!+WMWp]# Wљ^Rg˛^!p+"~W1LA+FW^+^q=rVДV 8W(%_,|e{jCʒ|Eٞ+TFaPt%mE8zz,cj{%]?l$폽bEѳ+k^ѡWhޡW< ,+sUBl+$1^e7 WOW*d)E镚 ^0r>b{|2W_^ס`+N B)4 9+_kWLj /c){'{%+$㮖WZ+toydY^!WZ^2W@^9]T!ye=RR_ , #+W 0^YlbcWt^!+kWl$+ T܃A+%WB:~%4+tk+7R fTY|  0M𕎕^P6e{BHW|Abx,{KX^#SE9_U }%NJY9+d(_1I iy N`ax%? axe9z1+W\yI!WvZF Wßdy+W\wyś.D^ay%b啃  `@#X1]?\W=ƔWd#>+=Qqe;^+އxA/w+ܪvWƧg qWps]^.+VM$I* %+6zYΕow}]rLfܕkﰻb aWlqW>qW$UJ-Qvbw匡"w0+xB[TyŘz-zYQb,+ x i+#4oG f5L^q(CS ^Y+9ÆW+fWҤWW'S#pu^ bxe*1q^s> vBL+_'grv;׺ x+}W_LB1Bw< sO^Db{e!\dx'+FoWm|%?\>.JnWodQ_AָT`+ڼNCJ@̯oWig*::W`W6W``Ԃ,`! Bq r6,X|SS_TeIi% FX _ L p`aNhkEXj,-e65EvpPeUD`q }L0`.1X0X(cc\y,aܶ0X{a`!$^ C6Xy G,;9-2X\eD9 1Xl`m8e'H2/* (2X|,^`> Y 0!Xnb1XHB" 6`9oB,s^ocaյ,TCb-˵+cD!X`q15 ,Ԕ ޯ 3$)N,^RYmXb,{*Ke{Z-$",-AYzOo"g7)iMKE}DAb,,` J`Fօq=˩b,ʼn)+ `yO咙`^3Y1sٚ`q, ɕbe22,N`aa_/'z`y 6 N^;!Xk ®g,!`eKG$CNXȋE`q/w3,`2⯐W\lz3'g-ʧSJsT,ƜBb_aG,t,1[ 0Nqdb(sWW3F#T7XK,TJ X>X`X<>T`Z`ynX<"%\X\  >,TvXFJPۀBan FKeSN_6p5ry#lqo3r ECW,W`)v/X"`X>,XpE`jtg`17Le4 }6 ,({"XX6r8."X\-I7-4x= K +,L  seX ~,;l9@m&dnSGPMc;IaACaqgIazٽbX63,֦`XÒ i/029(>,G;71aa cŁɅak saܮ;`m`LAO켅~Cx=,7…ZM`WM~V]"`H`Xh!8Bi"-x,$xS,`=,ϭJW`>:/K`Y4, X(`q%  3T[X%X4X%$D,` P0 YkX73X(kD  ,.rJ21G^k^6ߔfb-Xx`JG,+Oc < `YΕ\,⯤\8*L᱿)垅\@_yf|ϞWW6B_Yz+B4R>Fc4?+3H_YEhO}%V7r-+2W{i|a+P+{WRWNOW)W(e }j^F7_u9W':iϐJ#J64yX(&Z$}e) F_l?P^/w^l7tDab+a8# VBCD^I^FW1WB@ gCl=, [W\ -jaxł 0ܕo].8vqW,_L]V 2x uЕ ]|16+׎"tiFWiC b ] dt:sЕ/lt~Zz]qG/]q[O0WbxwAW]]!, B r?E)Qht].⨈ԕע>pȳ7m4+`]y87t]FW:\sKT1Wa\A\ŲBJ4 +Jk r[\ \y9"re9rW@\! R e+D+ W»\a`*r%!WX:\ bpr<I\QN~+  h 2+u*iper ?\yO@+Ч+qx 1®(+Ь+} \YŕO݈+|z+ٗ(ׯW<+dfWId]IW6"ErWjpeA\!p? u+T X彈+!$,p8PmzE:Js+N薶*mŋ6V"kJV(@[!peYWfWȎ5r@g\:[ Vdo1x+TxE. eŀ+~ \SG0\q%4b= Fb<. eSW÷/E\dq%ŕ|=+u, T+1\IPgWTB5 /$\W#Vr(+w\y7c%KÐ+\.Hx'J +l,qbq%WG\"oW(B\9 5+V抝1bЕx8+Ӊtc+;\&Cʲ;+_)r4͕k+ s&&W6? Wre>(3\mSppux+[[{+9Vؖo-[ٲžVr}\aToHaq%e]+T\ipՌ|.wA-<ɪG\q%+~Bx,e+<WpZy+rwip%\qpE WE\B⊃W]ŕq+qWWF\qjn+W©X\X\vD+ WS cS Wrs+k {bLSɸ+pDٰbR5Օ u2E]y<> +NͮT~W]ɍov}:ͮ r:RbK ۬C[1 d+Wyۈ^ulzE$zʼnTW( "> # F애WB["G:WWv| KWv+^;r7^y^nK WzzK>w @'|_ڊ] 4 %JoiNJe+R=8_AO~w+ï\ #Jc+Nx~%W6 ӆ+T_L'ɉ_q~,AƘWĶ+ ~e*BrlyE@J+7T[zR+<`J%釛_1m~%]W}_)E˚VW]WaxUle׺HWWz>`~?~eY̯W`W"E_3 +]֔ +ۥ(ʎb}e뢢,o&}"l(4d|g5W(}_!:|. u+HW<__~W`Mﬤzo+~@S +N}+o_NJfï!Z?~)ȑۅi~^*w)*Ls5 \Zy~t^mWKJ^yyu0 / f`WxbY^IcyO9#/1b xEqW+0^^q"<*7&eZ1%W\$x+^q B2^a,xőe+ 7^a=zc5װWW W&WȡtzvzWC,ǥA ̅W?hWf- 2⃼&+̎B`y!_ /#%.Q+tWz eim:4VW#䪰;D+Nb;+h+`xeaU^y]]a悻96{pW6_k"NF]9_@]yS ]YfW*tzؕ0dv 5fWzjwa{B]Iveb[2 "w]yG- * !mgQ]e]!$͸+ȿ+2lvex $bW9@ʃ?=_&Wϸ!W#ʣb\9o&W  +i*+灌"rO⍘+Ǿ+@Y2Wamseahe+׌MqJsVr%4JLJH#PC|.?UboVFao2>V<'Bފ'VA[lsVqE?+gy+KފVj5ĭPcn!/[^%ފkbV(o[!\J{+[#JV-V<荷 P`BT'x@Y8#QW# Y+T\#l-+:{ͭ,iV5?PZy.;GVvjEBlړ+4 P+V+keTnkŵ9V1`s'ZIvlZq1\VGjƉakp0֊rVz׵Y+N[l[9 m[i}|C cV^ k+^yuh+`Bmgl>mT,J,Lwfvz%oG[džqpVLĆ9)VVHR* F[TbmŕG`+욈D?LdDGNeT6m6 bIJa[YʨVWذ'VpQkn %m0Vh+x[EJWĭJY"VM"܊/DD[YDE4e yV_ڊԉڊEx;h+ԃfVBm%ڊoh+`VmVH򰏣,m+҉V}:c-[[Y.8p:dKs+93܊C?V4,murx_h+~JA[9aR4a{[!K)M饭mD[7_]W# h y+I&oE[[q3 d{+K U$x+ޭ/ xHLs+JNVتn@h2?܊GV`n8zG"#9e3"ʁ)O+W o[\2VŒp%WvVVVF㭠}`g᭜fT8lrqI[!-xx+[4[!zmp%d@+4 8J"D&*E\Tq%G\Qr"b[-Kފ[x+ގQ qx+|x+DWw[! ZY+da^ : +#WWƣF+){H1ĕ}3aq*<9Wipe Rim9mŝuߙ`+Ѡ= { X&h+h+A`+>`+LTG olk%tVVF\[+S@A4P+ P+LV8C8j=6 e.)je RBׅZdj3V, H+DcVvXV*` ZD[Z2 yC+GYʊ ¾@+4; @+,k?V_YƂۃ/_P2.vViog]쬐.8+:]VY,vV7YJD;MR5*\qVNqVb e0+^; K5+ Yn8+gB^;+6,+(+he=QaVb|XZ/kV(WiEvTZ@jVW}&7j S+5kVtZ9/))P+9 iy/gDZq>BH+ V^o9̂H+Q,P he[Z& [-t^ʕ*VZa;j VznK+ҊsI"P BkAP 2\$jyV@D<)rχ#哢|@V(Zk|]LV`lEHhk垏\$X+/jóX+a| tx,Z1IkmV R/OjEP+-hjEV[`H+%DZ~cK+l-l:W4,̍tJ G,ile1V-=ŬtL"F h+ \Y R\+0bqrUtĕ Y F\!q⊉+׍"qkW6K\Y# W\Uʒr1Y^ȕ͛B8rLB\s4͕s;@J6N̕ 2W:}̕E抃{Wc0chsY$+]+tbU7 +on1W2sū1W(\.+˳+=g\1wQZyC\spEddS56WLb03 ېc3J+\Y1WnDyL<ڽ+ʽM+/-"7 㝕\E4Fsި͕ei+O l1W\])*s _J}\1:sŻ\MDd/re)\Jؐ+g- oC+hP6W^̕{k0W\9a\6G1Wv+0W\Ɔ2-e\\T\ \'6W6`r++$&]aJtŅAWD/B 6:`Еgp2]1t-+9 ͕BsM`Xr0w`s!z+{2\w76\9=lX36W*ʪ'x#p qśX\y6BQ pJ+^UB?ΗZJ+.&+L, + P,p{+^IBsw]-y+eVBoEuz\`lA  y+JҀ0,Po:qʼnWrűĕThWy^rz&bH\@\qFŕV(qeavWCxraQ-4b a0\\a.BXUJ㯹brr弌U\.+\yC0 iIT䊦h+Q[, E\A۰*݈+\4WI#0C\OE\aF❷""(Y5Jh+Q;,0ڐ,+ZW!HhB-N%rwnR-u/2Wn_]q{)$^r\p[9QgnI?$p[btK}%{ J]-U{W-|2XZn%yvߐR#Sm#3haƥԖUm-9Sj='X,se[91RlK=tml= ͶMl= ]?$:ge[[2-uRR?9ԏnKȎ[RJJK-㳘$ 1]!c9OwJr[ֺr襭. D+ˣg~`[lK}]}f[>HlKfU[]Ж{{|} \hKm2[Ož2E,?-ŝ&['^z&[)^dKKjj}Uɝ*R?SbK\ĨTNMtR=m4R}&[Ȗa'gX&[_dK $5Rlw+%CH- ͖^l^WM5R_͖[4n["sLRWwR[MuMKmYԖ-uoYZmube5~\^jK_21Ŷ_ tٖzi~mkƿOxv7U-u2a]6ͶkhBOZmᐷR@E?ڲؖ{aװd?C-t-w!_"tR#Q V垃Aܲ &,G~C-uVܲ2r2>e'1-ܳ/3AJ-,E-5@z}#=e@mCHw-|^.tq,nBB=lY"[Ed=-$NdK=uElK2olY{-| W6ROq5M̖Lr]bl5mYr[90D"eWx d)en/JpKF[*ᖺbn$LsxOo nO/)eJml(r}v-|m/leg_cb[z,lKsR~Id2rg銶TohKﳢ-K4Rwǫ#XBnJ-5'h2oRG'ڲ0%]eW0?轱Жjs.z\H-MhK߿Zm.KC-N'x-ؒ%!%1-sF#mՖW1-#[j=:R[;.`KR[ꂔjKtQ,~-JmYXԵ3@hKM%d4Rѻxuɖ~uٲ)lY&[)Ȗ yAP+MS߬W[ˬ`Kfa6 iҥ`K?uD0>_5 3p`Kvq,[s6RSl- lws-jlRL-uuvmYmOodtP񇸖Rsdq-󙯟-e9s͵-!e^$k^Lt{-=#!eNLDk@ ?RoIZ9;[C\K<^rGZRsSm+\Kn1͵Tiet ^\R+ >q,[7z;?-ubv+BDԬIȖ+ЖwR}-R=ڲL,}Ԗ%*,e [mLI-̽RvK`?mdvKuM).صBvK;nRwŗ[ ֑}xն[z{[2ݒaNh%˿["?-Z2KZo zKr1T|P +}- +ޒbk]鍷$ge[01R=f-Rj&_>N-izK8[pS7}-Kfy:5oj%T-=jƠVk=/,oX*o= [0ޒ4-u{oxK[21ޒl3e[Fz9HoY.e-iXo!vgB [*-!%K[2R?TN-uzg5:SV-Y7ߒ-$YoItK(i~µ-5h5tKBm[ /%-K&%1-5r+pZg7RP .#}kYB;Zꍅ|ʧwP^KHZOZf:%yTkZ[(\ Zj oMulE\23t_k-tMޕԽru k)Bʦn.DvWF/gMFzK62W/ $RK'BlB9ղtWZE[-j򏭖wD,A>Q-7?ZRK'I|Q3KjYf1ZѽTm^EEt lI-#ZRK2,4V%S%TTռwJ.Hg-e Jj~KZj./"n8;-TliYV!,1LA-dTP2a.R $PK=lH&ȱSR߷%,%c"1-KTLK)-oneIi!:ew/eiIRT#- %쓐iI:HKBBZQzHKgouiYBZ>QnkSHK~z2On%iFZJZ7)뇒UZhU4ZtKh$ʠgF$F_W:RR#Z2l%U Zn $@K hPĢZl"[T{uJ7RaU-]{5#}۾7u إWgYY|y[Z9ю|gYY ]>K(Yآ}h'c,ˬ^>RCWd˫‹T,穄ibl}B-$*%ZV.%ԝ) -IhLM-Cavл6Ftђ蔈e##1Ѳѧ4k2w-uΫLde/^_e.(+YVV(ESzyeEQVh8[2 J0zAY,eVV$FPJꈔm*+m\[*Se%VVle%fXe%2K++afe3+KYYܚ^l3+ZY eEAV;R#+]Xp= +$f6XbV̬aV*wXYqdgEY9mP`ne:2OxU++DJeu+SeQZYyg)+<$¬xf9xsgYYV a#VV-ЊH+iBXK+-J#, ҊvЈBgi%Ҋ%H+P-TybB Ҋ 2 I/-JG8h%䈭(Vv[Q?[Iz: Vnl2CC TX+Zk߱\S+Q,V(gZ dVk(aK+Uf/ie,|A+s=gZ >ş,%FqV|Yq&8+RkY< gDd3+7xle%VVVIYqdrwKYa0gItXY4ee^f"AJbVLT.ES=,l[YIٞ0+-(_rXYx1+:?IJaVGώYQY!h%O/)_)9ʾkie#$̫[DpV6?%VK22ۺP+w6DnV|ZySwVb#Geg/ 45!ke Y+˙2tsOg="QP5VR Rj"YxUlkX+tVHol[1`l%Z_b؊W L[4>AbdS+)12[CP+&M̻KP+W!4e?BX jʼvED1RibT#fjԊpBoVn' 4eG jlJS+)5 <v-VǠV͚ZI P+<V^W-APBo +V^8P+'LpM@M{`palJZacVܣ[,ʌMW:V<*O, {ƘcC{.2B) 2J* K2Zӧ\I4#ʡ)oeQ䭐JoeJ*V#hpʍx+aqEJF{++L@W<W!lݖw} \8Ji+s2g Cĕ+nc+>!|ObWv_WWWW9 +^\pLRIz`+) ]ȕB 0udr+F\I!]B$ +j+DkB􉑸RVzX0J- \N?pb3]灦 (+ BX"]el6Taneo\\㇎X[X[m?vtJbh+iR Sek+_RxMVH)@[%u,VY[絶B2JVdí72_BT$>B oSbn9Uĭ[(n<3ŭ,f M̭̫00!oe%\!"pe>Z)hoe +;>. z+ `p+w B\!`퍷وrdioe׆2gW_oشxVKL"nembvh4}WK*.`[q nn<[q+[ano%򣽕 V*[rE[8. BVsϊ[Uǩzik+񠭭d0műCk+3 ڊWn8mX@c+0i[ZR7uq4r@V5[mV\Wηʮokp*pe x{+ 6[ـަ x+c@JBV[ jo%(Vf[V￲V@B`WJVHBBv[b6pE W 0WW舑ed+No[Y*V[Yy+?Vf G̭֚TvcCڊV0k+sEJEVBBZ[n-D(X[JJ;T\cl%V\l$lP: J*jVُ|X+nd̯3dl8EAal/j*Gqf[+'Z- ¹2ϋ~q{[<r͍Pck.R} Z,Z1X V`L/@,NNS+ɨ?IP+dA؆ }3VR GJex@ je7눨X+ 5X+`ZRأA̐RM,?B'Zqkjjtl˦ b\+VC[+˅mkulNƎDzV0V)d lE%M[+hZP+ j%9P+=Vf7tV(?CZ\"ie9ÒVI. %P+%C@S+ejQ*,"j%,ЀZa =1bi곑V{V,/Ҋi'G$<.vK+GZgIZI鋥*\g iV$JGHZBZa ci%hH+T#DZ}2¬YyofV(wfIKͬ¬f5cfqQVCWE(+&[QVVE \x^e%(xVV2BYy\be%:VV*KQV<[M ̢QVlEYq̀y=:ɶee *PV fq cf%~yRW~Yf9aV6jY7V䕚,>YZ14ie[ZVѣanߦVf=K+"'/icK+s! %KH+ƱS݄IJFcS獴V"ԊZ"`n}VJ vq<\'0o@+4 {/ZAZ: Jz]C8+LXY7Ί֢qV(ۖY nYl/ PQtK7M,X"ĊwB<X?:-r{Hbŝc6VgTl|9S RPV2Idd<;+YkM \/zoj%@r4u!j%șVf֑Vfn V9Z艵1Z 1;jCS+!A`Z]>eZAkk%E[+ZgjS /ԊWVZe"k@FJxS[+lTr a+tV14Tc+[F[11b+LN[I[!dle`+ [򘴕o[qne [p+p+Vn%w nq+[I(r[amon: oE֟x+  ݵV( v[,Jx+\YP+s1E,pŵo+ ǜ1SO dBpE]{+u[EzV~6m!oeƼ([Yr{+VǰR;?]"YVlco%6ފ7\ pEA^{+dr୬.A`9B "o"ފ3V>[!oeC䭐 oho%(p+PJds+,[Zh%8tM 㭠r[Yΰkw[!nVs+WX\y\Z\$oqe&ZF\q<8 cW-{`tg]e+F\>E+6dqERJ71 3TX_}YcpeNYK[a{+y[ԏ [TX+vJyVzlx.I[+vVaJJiV(vlRc+.Ř㼭}wVHZbks[qJ[|HR3RxԩDŽ a+/ZI VZaP+.1Z3  _`M1?+V213`+$ V.4TҹyT",؊Ȃr!VE؊X+Vj*+;4'Zk%[cPBa Vhc+Pm2VRgklileQdKlm7$l% Vس leh%[Yc+-l$J*lJzMS: -T8[a[,B4D(ߞV}k%kP+ceԊTBx۟P+CjŨ0V\lV dO\<֊|<c );쇈 BdleQf8V`+6Q6owokl^|Sʥ,il%fԾDŒm%7VRmŗ<[Yc+c+&J*NVȪ7mm|.zA[+ɔ'bk%؏Xx23$ZwBV*w Z[0 UVJeluV\amvhڊ.h+ IU׽ʒ#(rA!#l:ݤktU;4}[onEnfs+,J>V*Vz[9QVnG5܊FͭX= }܊V(ȁ[w{+7%x+F[io`H6)[q/o%hF~8[An!܊w˭X$b uz+Jz3V*WgV9í<to{+* 3 qW[Ygy͙Jx+-ᭌ\z+wJV܇nQ5VVߚ[> r+=ojn5>­ 9`,ފJJ z+2WwV,Q[c[1/@pe W,\ps+MN&zJ2Xx C+cs`7bj WʇZ']a/!ѕ ^ԕ4+7uMztaJ1+AWz2KbbmV+)hs`"isO%;"B<,!W72I+Yi<1Wyssg+Y$lrR^ȕE@+,?Ӳ + ++ ,bpES9{\iLp+,v[(-F\x+6bM=%+r8#ޙm-bNL+r^+ ֖"oe\z+PV,g\[7gȧg*Jz+Pmx+FVZ( +#VGWL\O\ +ʁR{ ^$wf+g \uy$TJ#'qY [hrrJ&W7䊱SɕES\h*䊫+!W0Krei"Wzq!_JWrQk+^X+[irM$WzVCEɕ W\\y 5W`\! ̕0WH(B\PVsB&ȕֿkkYW (b^d oe\N[iOoŅ6v[!( CPJipeWCy)CîW"i-̕>SsQJ+ m!W+DVrrEH!W,\1UrDɕq$X Jj+#TB !+@'bv®KD]g+9Uu+ uKeWŸ%v%)ͮ]YOܕ6ϸ+\x]wPW1ʮ$[ٕN~ "\ beWxp&eb(hsZse!nk[!ہA[FllEΒ[FC3؊`+V,,[:UZ+ikSvVZ VzRbm֊X+z^lhYL#X$傭%W؊UP="^-gb)[1E.`+8VF?!ʌM9\*XlJp!hVZ,[y܂,T ؊_c+TVzb+a)Vdْ$Lʓ[q7kޢa*V @4`+D\biݍ|8؊dO2#iSvr'϶V[Q&QR^Gh")Z1wmVcX\Ej+'ڊ`Xm!3wF[g;_is$xtM؊Viir_W=ʧcfb+[@b+MʔXi+@[a j+=͢A[P[ϔ['J/m$֊S)U33 bh@J#P+WZ9?V*Jo,kbL_je<6CCZi.k{B9Vڼlj%rm`4½eR+7.jQMV&ʌHY+'{k?Vd 7]jnecɭU"%oe ,V+$ފp+˭tQyq3VHt bŊ&VUVQVZ2?&r;DYidx7 IXJmX7Pԃb w*$46q*%|0*{ZEZŢ_h5#|/Ye\8*ٯzMU=5ʸjߴ 7HES2J4ԸN$b6I*͖Vy=)[z2F *nҴe*&.\]U$,ʫɧc=2*M ;7',We{UXViXĀUݿ*X *͖t$F"ѮJu*{-,J HqUfAm*v0Uq>z*mꪰq*>iuUFFKNzu*V^˪XElW,R]2"۟BFUB싪ب PW\UiCT-TU!UoUeXz'u~U1 2da4ҽ7{,7T'Ѡ*#P \*1V*n&2K@v*͆R*mT]{EUWQί `/_PvDU^UTCn*7"΢988J_aU:*rxװ*`Uª, 5Ͱ*.q˪+’H*2*>`UFVmVg!?Oޮ] URUXU.TERTETetFUBpDUq/U啗 jUőSPTRU_҆l*%**. ^SKTTTe/Te(9 ?i*Vg*OTPmDUx@UyݦJ*,J70((~il:0*gbS-{5U\SeyMmU Hr&VUOUy  WeTyM\JWE] \W9JeU>*L~UUfU;u95*LJWE3JSeqU擩*u. 3UUj xQ*./|*+TpU'_*طUyB-i\1UT35UIS *bt6U4kFk ЦJa*Ao*&TcLh"Uf*f[)'u*N!?ۈb}H߳4Xzxvx_??*?CeЅc9F>Xar,LɁ} XT)1X.-DcK) @92c>UQ"|g$S>"#_2"SD"s*"1Kd9FAy$P _+t,w.e~|DY]#SAYQ.135OQ.dN/\,|I@bY֟Y,<Ae9FnVeG\j(,[}!S.1vG2O] ?,G,f,SQ0M' f9F;~'mNqYK2;#Y;_`y+2 f==ϐYkSf/9kxPS0f9Fy~u,PWwQd̲<#̟d,'2|`8%3pdyB)eDfRobYG+견7G,բ3rb|kw͍Q.|<`eYqYY,3w8WeveeeYhaYfGrI#|bY e+EfAYZd#O@ExUCE,^heec;-X4˼P482o 4rThfY&Y#5˙)Y$b 'm<}"w!Kd9Ve{͑Yٌ.S2y͓)JeY/T/QZ2UΣ1*˼uLP 2iBYdsH 2;W e}nBYjPPiT\*[rKe;S*,ûTe]*˼r2[uS~&2HJfY,m#*G~UHWb<򊩲݉fYbY1^h'\YjS`B,l6},(6KM 6lW^rӻ[j!HlyIe̟xl _VLe^# gYYfL)e#200?*8e1^5>e,K056 ϲ<-ɛ>K=b\AR h9F0˕O: ![в,-уR r'ZAF)X(*PY怫LKT"<:G2{|̟Uv t%eiY1rteey2{ɳTTaYf]gWD[Yjx9 ]T<˼ds2g| U )9W78:K0rUN/:|o*eۊ,cp`U'gYnY4YRG,ˏ 2*QOe=Qmbg,"Q8Qβ4it2m=#_P\d9#R222;+˻ɆY04 :e%,e",1,"dfY.,=Rah.{V|,,<=_jq4tayBgex3,|`OԕZe>f3!fn ,C,K7efYY,f))uMTғe9lƦ`>GsƐYVDe jY5,tcQY@Tׁ39BY`eYqYVeΔJ <2Lk2Nn*[.,Ke^*h?4ˌGT@(4K$WWBg|YfTQW=2K-5z\%%d$YNfY0Y|B٫Ge~^fYYjZ[jU,ˣ"8 2\1UYNz_ͲKbԭY߸lZrGhGe|S~ÒfYYUq]Qclٿ)ee,e,Y_^6K]BTVhVh \S6 2 gY&YbpY^Kh٠J-Q42 r,84\M^W8E'm]#,,K;2˲ev9%Ԕ\W YdmJf7%,e/F3y͙2#, Pgd+#XQDf9zUr~/ױBB7;\ hC4q fq(4˜Ņ)‹52w>F?w} J"̿clYEa,2q3fke_4KOB^!͖j:D,T#686falYfp^$g7U Y:K,gP?8Tg\YzaK,ҽ@˸/%7ZfuII--lXj-29yte,H|ܭF<˦9GW9 HK-OM.t+0Q!-,邴Tnʼn̦ȽPHKa@Zzd-& s# %5w~BZj"-i9,H9*ݒ,g5 PH˼ ~29G)-ҏ8TҳôTQXC)-sXPQZf$u[H"Q7[iiA"L'(-@WySe^_JK穠-R3+ٖ|(-hDPZ:e锣t$xQZrgeNAŽLe^!;iEΊi#|v1-z2i9hH3qj*eJiqғNo 3WFxѲ1Zl*ǽ!Zjq.{=I-YT:Me9et!F@2'u%nise -5>+Yhm \et#F-5Y1buw=YG-`:uhfZzueF+Ցu ! 9U'JRÆ,g5 -a -w^T&&eKBa%1%ً٨ c$OB -_2WO2'~7Jh럱Kdӓ 2 &y)"-;睋hW[#u!Z*ƥO"Zz*DKyC̋#(3E54N-C(D˼ - 2shGW/+I-KpWT[0Zf?'kdm1Z֛jHܗBZfV{UZjS tB}QZCI>=r -<ɧ?^y`i9Li7phRZIW&uਏڎ<ꃴ~\Y>|d!V ۬iMy ҡXq2'dL2t2$HT  F%(2% qh#[ֲ.2Z歗Fat"F2ZbBzdI" -W}d?:{JueK*eI"]t$ev*^ޘzO$qZ\%gnw1DwI=Y#@-i@-K::&\L-֣OsUvp}^UEHPZz}eiFc0aZKF],]">󚧚+eQZj"(^M~OrÉҙ0-(0-o+2'uRS+۟_i]_,WnaW2Geci9i%qZ^?NK'trPKwmqZjXVI*8-sm#'ԭXIϪL˼Bc|*ޑH1-3 \0-3R5B$YDx?LK\̎Tw%veib**eɥepit.LiGD{=VqiU7_'#"s&)ey"g^PrZ*\SN= 0-Ere|p1-re'8-Յ{9r͔2?= _! jsuZ7|Z֯wWC\HZj}4yTc}޵u:Oo@-Ke非_% eiYBqZf+Zdż~\a"e%PԲD[]BA-Keqjg?wj%?>j$GM.j!t}zA-sْHgOLW0d_GrZzef,ӲnbZZNi]b,Ocϊ+,z]0Z[I}ꭔ29,G%W}qIPtJҲ,Di9QZR3y,̖s&E(-sGR]wȹ*uRZJ"c(-뉸Hot*J|*SIܩJHK&r$W>tJ2y(-KL!JKס,-_@`9ZǓDzKQZ3s,RZ 3Dݖ=͎hJ= -7}SGOĤʑO%4N3Eo ,î8-iY@-K$'R˼#Բ,aEjYZ#VDjA`S2CQl- ˞ ]-+WVl-yuC8H-Kn@ge5Ra=R|? MTLoBmp+ |R =)[[Ool9%yV[FoA{+w[`Q VLhmn%V-#p+YJ@+b;ڊuh+`+.MG V~ ˳~$HVx bv[+6>rǩr'kk,RV,c2_)WPuV[!୼qV~/[ioފ z+|2ooedH')z+SB! VYKVD[!Yr0Vbn%, 8 fV[TneXN [ĈV7[9EZV,[ݑ[؉YnŎHne'VnS+Un喣[v[SIx"Ro%\tvoŚSVHVvR [BHc+[|K+D[Z9WZşEZi:i$U\iRVsVLZ8[~V[+ѕ>j+ 0jmŌZ ނd$`+7:ʋ[)9UF♀df7Q8"<'E[ muVZsB[1a_me@u2VIx9n_ b j+ j+lJ(]ogJ{+<Ȼuhoe;ӠWʡxozCoV,[!bIyފ}X%r>z+x+G\iOpeaTB5m/BoW<{+ñnp/ +>(W'+\?+d6bJ-W62opXoŧf{+@ioA4b\i5HrE!WN8ElK|yKBl+&j\)+[%b˗$Wv6s\WrFWjpe\H\Q8WFY(np%ڊHVl DV[afVh~Cld3zb+Wj+c=?G­܊Ur+[9nхʆq FoeLxc\~WVȭpO"_reC:іFDnF{+;3ue43o{+:Tz+2[iЭYs'do&WR*Dn W W+pWȏkqOp +ŕ eŕ:HŕwW\}^qe$ E8q*YZ\> qEL+W;RO+s'0)F`[!l x+]ފx+GgV4. z {魀[Y V0܊dJ(p+۰7B8Dn[i#ni܊eͭP/$No.QoQPVP9JǂC< oe!EV:طP$ uqTgVBʕ\^ln倫[jVD[mVíPW܊Zp+Fr+5"FPn:W }#ڊN5ڊRtk+>h+V[w/HnEVoEUo9 a+ W'p7B^ qf\,V|˭8[Xnc[yNn}Sh+}#D\W8JI++f\&W( WredgCMd+r+7 DE;ɕ+[P/ FsN yg f &WUؕχyZɮ\;M湨+$UWX&ku$VWr1]W]q Ev 4A)iٕV6`W CʮOȮ\?+4ƒHuű^zize'rP.Bz+V^TMz(H+G"um+7Ve+hF^`0h{eBpyŌo-1׷b`+dqE^9&+J:QWFJF1:wq+owfXݕ+T+9]aϗvWGwhTؕ5DwvWpW%EG++ͮX 9+upWJݕpW~+ב$vWP]3]1^ve3]y$]jvE]FvK r-i+GwU rjX!R)I? B̩nEWXntsedRҠ c\a>\9`4W1Ss ȕH+#wJ \y\0W6q%jsEr@s>^s!Y+ ªu+m .0W3\an5WH"" ƚ+צsevSsgraakJ$WOqe u ފh t{+p(V\zIq% -Ϸ+H` 6WR\\qwX1++xM D+>|%WXor0|+ \@\Wŕ;qXŕ %yMrh rZb_#jE+ +rR.1W4W.+󴹢ɥhPQŽpmX2:ʘ+ b/3@W(@xMPB\9"W %W,\q> 'rYrl&Wa$WXor9 +q@Y5<"#YrT\8Md:ŕ5"쟿ĕQM%R+gK)W,V\!%ŕ{K\9tZR * Z53[\I"P;;#vW>WIĕ7WFD2(V_ J\W?RM?F$ B g+{C+\PpūVpHi+[iqEALqEOqegBZ%܀ zG+j/+|WW@\ qEEq4WWN"rr.Ge2ɕϝP++A+uޒ+N%W4%W#Iˀ\!ƹ\i?rE{Vr|"W,\.+Ln%W])C+‚ m`j@H!JP p @d\meWn6m]Q,]!*t_]kt\FW类eAW2.\1"@]jN> s~1Wv_ޥLA"FWЕTi@@(ʇY+/Y6/[\yިE,= M8a\q!$W6 5W5Wni+\A!4WREW(\y% mXbĭEѕ>B=Nsz] WJk5x+z+r+v=r+7lϙ\ւV[ O+) _`%p+p+cXRFVS[9#3=pC.j+Ϟ^j/V M=1VpV0^UM8[j`+4šlk+nP[qdBHk+dD7Jʯ v4\L"(ڊڊv0b@[q*)ɣome$'V^7H x"ח[|UFm bbr+r+ 4'"(b[?%W:+v̰Rq+#+#,ȶ XM#MRrŇ} WCIds(ĕAW|B(Jq4E\kqikq "PA\S\qBxHphʖmM\ql$_Oq9 Wα ȬGpZf"?ULtSŕFlWX[= \9rnrWN`+3錃pZph+&nH)7Z\q!BU+%Ⲙ+#lD"W [ͷ#>( |RJ3(+7]#lH* ƥIhptW\mq%0S+WP +<WW?>[F߾ [.fV̹[!؊X,b+6B!%쒉=sV̶V[qowTR[qoV(U[1[[%3{K:V,[aӌ[aOVwt[Wn%pͭ&b wZ{+fꭸW{+0hoŌDQ+*+֟4Ro0ފ ފDXbJW0io$E"sͭX+"ʕPn(+[aY&bVzT[Um|"[񇃭$JX+K`֊9nZ+n u5Z+S)Nb+n*bڧ؊b+g Bʮb joXsZqc~ [#M.J+J+*"Jk5VZiXVPV' 0mi=ZZh>`+JVŔ#woX-VL[mo//Fë"sѤp+Iim".KZ[9sqNc+ "]mJ4+TV4ۭڊo\5<;} [, e XSC y&|FRm1 w2V,iS[iAm%V4r+Bh+H؊u@b+X%rh\￱{VbVV[YV>[l@l:V(ZkjEBjLjsnjEjŊd$<\#? *VZ!SjE(M"IX# OVN /%3}^-XҊP Ҋ0ʻZaMwߖZ9Vf⬰oJ,DYa_jYq0+U#0YǭssO¬4 z7J~3+7BSK+J:H+VH+iVSZ!jFbHX j+.h+KVzVpV= V0sVJV]n vX+YmjOWP+R+7BeS+0I8ZyN#lV`k֊{DkghW3Z+ kV,ZaٶF{V,m aPNij[ZqV~Ԋ;k<;#fl?+ZAeZ9=1sY9jVZ9X+Z!qWk֊|VTme﫭ϮJm+meY [ytm`+2r9[.Il.k %Y_^6/ U"ZJpVqD}hRJF.R+OP+l%¦P+KJj|72ڑZ![jE[Xj~VHiiEuYi/Cjy {<4B`[+mZmj%a1 {H8Z١V 5rP+V|vaX`8Z1bTkEAk}GhknAk:kQk*KM]/7%VTV4 VhPX+"8X+}VvCRV4"l/[[Q[l"V[?–#m֊Z+mkE [kt9Z,AX+VhH<b4JjѪԊ6dz+WFV`V ix""%BTC+#~#G FIVHihE/9@+6V4[Vnʅ̠r 0B+ …V,Z1"ͻdogşYq2+p-0+):+\KΊӰYUgg-SZ1~+,e-WZ!᫥eVAZњVZaEZUZ~;VZ9>IH+J+$Pn9- aZ>-RMCP+|P+ZDP+dV쨰VϴVN4(Lil'Ob+s rBv ` rȯD[BnmzڊwʕsZ[QSR[QS[!gV ZRl JP+FV6,ƂZуZBZ4Z9.ZjT֦VYJ[WjJ'ʳg ҞҊ _J+vJ+)i͈AiƗmi(Ҋ -)ΚYifETfo畧̊Cyk~c'L3+"eVȬדYwYqe[fE ep4ЃЩ"ͬ$kqVF:+:+ ⴳºR;+f{XVNqVLJYql:uVSDnYq7@VYdŴb+EV6""+׽Ȋ"+*B޶ʓѪȊUAV5@V.Ɗ Ɗm<dJˋEVvrvEV9AV,uPYISY9([eG RVYq_Lb5 JͬdY0+ˬX#B̊92+M(b3+tʬ7b 4 ̊R2+f7X=:+n)掏f;+X ΊEMl9J+' QVVli;Vd46ge#M\:+n=.!|ܬ*+#u>*+o eV:J?8YqkJfdVxpȬld7`Y(_fesˬP#" S+dωB๙7PY!bYͬ'ȬnfRaV}b 㬜9eYY+he<Ԫ-VFSVאZa~FBjźiE "'NkZV&Vy[ke7i] jbu< _S+ AcS+nBԊ-J0P+츩9?V`ZIrJ_H+V+hf(dմKV,g?ֵB eVܡf~Y`VxȬifzAQ; buV`Yae;fVHifJ։ZY9`ZYsYRg_ϯr3*Y[fJȄVD/B:{C+vB+, -ʉ"BЊ X+bqЊ VZ[:+|Z ªj3+$_5h`Ԙg1V!nrxɶIe'JJkheDuEYaĨBNl++f1AVYiAe`f++V˫X衲RfY97~̊̊̊32+5Y*YfeЊ=ЊCk!B+eB+l ЊqVyv[Z18 @+,RrV^Ǩ*8+R:+R;4= :+bbѬ )f 8sZyhmV.@+Ǻ -8SZP^i*xǽJ+wV[Z]iŜV^#QiP iw]7ģԊCڦV8YR+OR+^!ga0ll؊芭؊֏ e_ Ҵe2 ʳ>b+V ҟ ỳ5:+Tm-s[jn@nMt[aVtV~Vjh (. l w!Bvp+,Pr*ts᭴j Q8mno1 [bmފKmz+DV. #VD܊Z!ƀ[nڢ̱?ʖ]N$4B ڊqj+Mʭ.$r\R[y[aR[g['([qsn[Փ[!} WCS⭸+v{+,J -0kqݪŕw \q!BrV++r@-+W+SloŐ[ oŊyWHVp5WdWNL/FcW6+pp͋+;F+ĜZ\ire㞒\af++V7BC;\9SaR%WN6(Fr&W{AsK~sw\q,SK$UWDWP] ՕueWkve?4]qcٕ7ʨʬv+-X.bo+,Fr61W|h8"\qb) z+,봹#4W4WB+UG+\qTGsEB͕hP* J}+J+c#W4vWue #s'TVHnoB+t p&+WvYx+a+V6{$֠6r}VH~[aCVZz[^|]tVb+le h؝qBйm*c ҊMlWj%&JB΋ 6iҊJAqٖV^\VȬTZUZ!}xi%ԆVPlZwZ Z<@+&rO\yǨ~ZhpQ ҊE- NRZu*MK+ĐV>YTZV *zK+׆ioid∷7Gi fz;+:+M)鬐r )gĦ"^FhŋBh ~iŹҊ$ NMxhkl؊Z'yc+؊SfV6ԓd67bVjԊJTQ+V7%fyPI- 2Jesͭdx+ [[ko]a[9V ts㭴z[oe{6z+^x+5g)K0 t܊ V í\n-[ֻngʶY-i[t7R? r?@p+l ]n^Dn0i{+4_[12zJ|Mx+$㶷"죷b,QpEt^pJ}nk+@m% 7BLk+Hb+Rb+}V6j+7Q9j+!ڊJ2Vl%[വ3Zk:VEj8Z!˶YKu64Z/hPW "ʳ $VpVڄZQojBjX+7e V/vkkECkCoJC[0",QQ+sxKE\ҜsvqVVW|@c:"V0Zƌee $I52~fTx`eðTt`@EBL"JEƔूG)e_[fLyL__TxPZQSX-sbwGflysc2!}ja|V1DYh`^X*2# kQ0Zvz-ze?쩎2r[2 [FT`·&[F{!du"mKDlOu-- 2U2B42::LĖq$?"b6h~ZlQKl.c^޶q} kg1:Ky-"klZ[|NEYj l?i[Ɲ2 R`$蕊1'㵌/s$^˸OSQy~y-'lJP-։2<#Bl7ⵌ&^˼v&c=y.x-bmWeF K(ZF+Ĩ 2Bm_\˸kYp-72yx-dׁ#󥵌kTxyT`QV*Ul觱mgwEZƏZF?ֲ>Ck[ZFӥ;2bugZ3ZbDk*(Zu/?FT?͵e>2 2u3h-Ny] o2޼b7ܑW*LНX˸d]]Hu3Zf. -e.hb@{kA=Sq>YϷO HEkwi ,$V˸LXjc}P-$lyI z,%T@I-j+sW`^[j }Q-=@j+uc+(H1 5e4L}Rb##[e9e22r𸣶T;t$1-#+Gt;-hA`qE2>h'FK2b- i7S` -r)eo=)HKw -Ms?2lp i~BZF8H˾فGCe8Q99d)e4UHYAZz 23!My i7y -;"-Oi2 -~ȁBZ: x^=iwQ-@ZF\H2JJ)DZ} -;k"-6 22$H˸CU igHˈWeF\WeD"i GBh!X+Zf,d8.B81q"B-c/a-qy7~ -Z)e1d"HbZF:,IZO eih+ShAEYze\Yz4!x$ų;@xWJgtDeM8,2³ձ.Yz2'Có-Gδ@gxų 28QxYe ȏtY-e<)g,Fg韀28#|tu`DgqV<9R8K(YFon$8x=vp\,s9Y"de;Nif dqņƈ2!"2\YяQ,"2K߅,"Q2f2Mly5GLYFG"6rvóYJ2{)'',=2g Y/>KO8|g٪}>.|/-c+WFy Kd-sdKCZcs^w>NŅ5|1!z|w.(S>KYƗGW,=g].,#gJ)>KGY D5\xqj 2Ww󚝨~2 V96KTc, wmwŕYFh0A,mKJ!2„fHBkE̅)fO`f.Yx(ik VYF7$6&B]ffѥl9/̑+a2n`Y\f_6R2U 2˸dQ-ec6#)23>Y8rdR2V,cY$,ˌ},.ʲEdp>)^BYzE 2&MXb,ePYy/eԁ-q$.ejO\`,reYfre3ݲg9,˘;ω2+Z\Cg,gfM^ų,dYIRqY\f1%2U}&Mő8R,p-YRz!EEgGeLc"g-kgs%Ő".2KdCYF k,2Af2 ,3Q'/2ˌցwVT(fϔ f1CC`1\ R09=, "P-% k,3+]}"2x|,տdY (t2*Id2?-G*~D)Ȕ6+,Yf V*@pS4Y!fqFe95f1Ll^,svJS⊁4,cY7Bhc,ゃoI=~,3[<3S ⪮6K_LYųl #<˸.g$yM,Le,⢾YgaXP:V,۝= YL]Qgq@e }lYƣY(䯎q4qZa2Uh__9,_UcGbi>kB/e}SS,YLgu(KGY*gaZ|.4,s#:`K_B0YL5gCu,bgqWe|ø>YF\9,Fx[YIg@+,ql.2fa*Ygq e ^*u|C⳸ϲ>.;r24Y}{\)͉򸸑,3ݲȤfw8tŭe%YaPf2/z,' `YzF2j_2KBY\-e&ֿ2y  LA\qAҡ\+{tYCetS㑰,eSR² @e4M+4Ydx.&t,3wgdL`ł2}Z3&,=}d,K?laY2ql'gC׍Y%zaѓ$ 2'x΁YFg,=#f!}͚f%hYp(IhC4k,f!4ٍ,^ e|f6xxcשͲ\)YF7$6˸H,Us5y}fYNC,Q r&ͲtYfX3<+ Y:β՚O,=2GFeg+GRx8KOYtgY;p,f1^e&XlRdb6,T/H$6[,TOl&ciWYfO(e<fIJ="Aң'd"t72.;`;WlVfje뱤YLf1lkYBT".KupYfl^S>`YF- e1,K`Y,WeYSXaY:\ ˢ" {,[ e(V,ҦU,DVy(UU*Jdf#ULWVymMVY͖L_#Ux;*k1'MYYe̅`--ɍnYzdw |ؐ1d3DV9C"t<ǽ@VYekeK*zְ *&3  %*ĤUf|D bO*7*1J%7 X<Vy*#F+X"Y}lXbab 2sGD>e*LX|X*[JeUeULE]YܯaUɝVeAªK;MVsURlYD[U؈Ue6 7½2+s$u$GVe"YxY*[ ͪX!"S(]qU:]Xd\e[VJCYP*<<.* To/YeN3g!R+UiV!IIXiZ`_ r>IU 5 P2ZvX| 䯎$!I(\ ?M*pM$ b Jl&KtHUY];u}BW1/«_L ν[nr׵;׳قW v9ǘ" ynB$\\ᢌj)qrJf;*;aWW!]pbt6UAQ]BtX!b}*󤈫X&2:,UmDWi|uMoɾ n]^e)^E(^:\y+ʫC]ś W J**U!W)#ŽlU>qUZ#7*#;a |V5g+ڿ`yV2Wy`:UF~t L۠Vq|LlJ7xJ!˕*+V,۩B"bEM+S/g+]?Ǚ\+l V̓Xq]g!V`"NcE1bEMb%acV^y`WP_Y~*/Ulo5*oUޯVv VVVP+OQbY\c+ e+dʳ$gy Ȋf(+۬Yw(+"+,"kCXaeSBX9?J+LV+QmW85VbODo14ʼ_cE{5\FWcOc:l7X csc<$JQG# c>ōb3F%Vn#i/!V\X7!VLЃXycX`)!V>2G+#K쟌 VFvҋWXi[!/ H P`)RU`pvM҈2Ɔyͪ*5Wy".&o<*d*ml^m}*UUV<[* *2U3U߶ʳ6 lzV^UTh<e*2mp JC.*r˫Tb#Vy(xgWWWO(UDW[zxVYNploөL*SV['me*8*U:!WX ^U3U(e.BJ UB\x *&ԔW1`.>W Ex WUp«CW|U,WYN J}zZ}*.)JK!Vb^b}U8W{R1|j%VS \\XAXaQBaetqTb21y͑ōV\J.V 0]9<X1 [`XJϥ e +F ;='osgW}@WWYwZR\ )I~O}s뫐誯b3#Xq+& [`EUJKV,2,˥0`FJk#VX!_EV_e4"/`+&KK_n G+K3Xy?+i @+6!VS69 +WR+!jVsdʖ܊<٤AVL(dWlYQWʆE%XgKHYZ0 ~*+׿bdPV^dU@OdJa +2*DAV,4Ȋ# bY+Pm |+'{RW`6J{^<ϘYW%BʗUbW R `W|;j`$'U_V}4_%{2WU\eoW! *"P*uUqWgUUZ\幹AQ)WaZ[U ǤU="M1QU`_[ʉA*Vy1V|lıUjbO<0CWAa鋥U|U͖V"V ZJ9WirJ9΂V*0U]\eX&ҙ~>M\ōC\ض"J*^WBjWq*7ʳZM{{,SfSXo`%Aht5PuUpWacuqMί]jW0yfb|ӟ/*VڱNb88e*EUUWUza9GmU`4$$S\.\\e'6#bc8W)̏UKȶWiҙ^|7W1 ([m_)}j *}Iȫ]Uy+6pYRW9«yuȫ|Wm]Uc)S}Ҡ TWq b|[CylskѱUB}*4^]eh,tUص񅽉`/2"G]"u AU.Udz*]U>t{*$~꫘i̭y+##gUl} UT2UW1˶˝ 2mEĘJ'lEfgF*c7J ,b<>j+֘ԿXqXAXq+>{V0?W) r被NDW"L*U֩1CWy~o%⧇gG#N{tW@WWqz'B iu13Way*P*7w4$V/E#BT b G/+&CXsb̼SXkU>0v*%yW1d@V~bpZ[VV%J-jj$V\RXQOEX[1ObLRa9P+J+Eb%JQ|UzT_5*`UH_쫸M}=UIo__E _*'W?_4|wSW91XU,XW1RbJVeUU:;W)RH]W!DWWWq1@J( JSxU0UfW) Ru^"*W! (8}*'X૘E*T_L\\*WWaBx?1J+VaDIhJ/e+M_X*r0V,rz$ƊUG +?"+fX>6(XJ31VLXq+7v Dʓ53 VGb%JϓXqoi̅XyY+2C!V <+ 5Vn:itOk0Vj̉"('JK0VYSc+~XyIt`TcYc]Y5Vh|(i "+m52X$ʘ!̟*.BYfb|5V40V KX %Vt$V>(I%V.<hXy(/B8X~%VRWf"E ~+*VLaeBAN^&WŠ-V(TXa4yV^/ {D t[V*e2U`MNVzPb^_z5}jF*^mUZvba w^Q|uڢ,PtHCDWyJf J*K]e實)U^ThAWȾJ/*O/\:pLUG!JrUK\7q6z,UVa*.UpktRmjKl^[R"*0N*#)j6~Uv~hl-k|BFV!O J&V."b*Hkni*'PViV! kٕUH,B~sWV.fU U_K]ͅR'ʫrJ5X獮Ltz*7<_knAt^uEWyé$^_Vѕ6ۉRS_qUTYU,<2翧bS}k _%IU1_|b ۦX>`_}$UXVO*+0-WXy; +3V J{ +Z V>Mx>gUXWy¿L_e?V.Ṽ*BN`e=?:roVVtrS!:+*t+l"bV`Ō;$體W9+* pU`qU^IpDUHt{ouU\TWD ]eR[]e1lqͰ ^ei*O(z zy{9yϥR~3\*7ZH|u, ʋ*C|ʫKJ,tWَt*U$W3%SW&\<*l *UWy7XpWVS|IkU\Zxh*ܺ**Ʊa[z +LNV7N*1JюqPRMSUjWI18 XQ`fXWq R8WƊbJ/}|Wv}Sq%w}*R*a<{^YDZ_Eq?PB­$Hڸnv&O_e?"u| U_z+I魸 xnYoJQG%aVPV܊Sr+ V4˭7ڊ.TSGV̪ Ê<,.b+YYAoeSUkxfkc8ZAo֊)YX+/? krȠVZ R+)PZaXiAZq3Wi%xҊŷV(PAZiNҊ;#tYw~Z!+ Ί:+)i J1 v "]jE( jiR+n+BbV$RVB>b~DZΔJ+lNSibdWXV\SZytjTsC ]B:Bj)-2ny`9s$ԊR+/P+lV,$ZYXP+R+ˏZ j'J|V~Ԋ9P+!2ælM)Z bNjSsG@`2J4ԊyP+R+-Z j1J9.CX߀Ғ1#R"rJw)TZawXX+k4VEZq Yi%AZqJ+=5PVN;VKbGrQ0+Y)&Yv2+:g.YYMh9F %ZU? "b4 ?V~/\@+~V\ќ3z] B B+n ."qB+B+-5B+ YQ{Y!Ӱ̊{uV>܄qVZ焳2qUXRlVbEZY_s'|FXiZZygvO#ԊŏP+f@V|@\^@C$ VZR+_je;2tZfO V*Z8sgAI\`yP++hNiEVNjD@VDV@<+V,aZYP+#1jeVyDZ^z^;EZovw%^H+V|#mcLis#TSZDZhVi'kV6FVPV[V EHiҊRUQФV{8ԊR+@d/ W/+hy)tI@ktl NFb+GH%[yVpX+Z|K*V:Bt^ jV V iDQ_70֊IZ+nUk%´V\a"c԰Zi CX+Z91oV.`+%$V,b[[ Qz+_8늷x@V[Qr[oEBqJɕo+\aͿ (J̩4Vͩq 1J 2R]N+n}Trdȕ厁\m&2JVB8\JCC^\y4qBsslP͕H~1J}['9 J& DW9]ُ+NEWq@WFm!J+JUWLb(ubJ+.S<㑨&+"W{GJ ob =/ +z+ X܍bsv*z+opp+MV[YR[2GmeQeTj+Zj+V˭ȷDV([q0TWd/WdWz+\1 Jpĕ>`W )b R'J \~˫YTaҐ{.W(]L:Y+\g D;1Xq8eJ+c/Kĕ J6̕ ɑ++JCrFȕEc\\ r ӗ\\yb hj W/rc+YrB\q+ŕ^K+cy/RJDR\w-"&WPKV[yx+^oťIgg]5oEn#JWmWh\qpsEWWW|@J+of)W"ԜV\EW \!,S\1GMqe}@Zⲭ!iĕ>W\DC\)b8Oq{W*8A\ csך+ksb̕+ |s%Uɕߛ XW-r !WkFR#"JK4W^7I̕2k#/w\1uPr}q$WZ W,V\! DqPb+ WBXv@\o^ ЕpЕ慂Xڧʘ [VdIۙ W]yʀt]y+G>^!A,M;ѕ 22r򚉮8Еo ԕcK hՕ/cԕ+{2]®8].+f]%;usϠ$ѪG tLCЕV􃮸t%gSt+8+ /i+P$Ҳ+lD]s% 1W V]a.bɂp]!7Rt5]4]!oAW+3+7)Eբ+ETWKyv+ϥ Bu免uu+Ψ+0UWH]Iteiw ,++ލ+(yHK<ˢVB#Jx{\\i2nQ?AWPOtu+be++U00WHs!DrřR\鑐+׉cĄ& $5EɕA;+0W|!⊬@p%?JH+.bd`*[sjMWfignь܊v!J{VUV [)3'b+JoUr.V> , ފ0J=_]ܿ!X|W-J\+#e2sW*D\Y+O 9Kw1i"b !ŕlXp\pU8+R\+-\yU?>V ᭈ%譸}[i;I\qJwbWWqe$\*d{ 88P\J6)g䊊̩2+IN^̕hXʏbЮ] Օ]QWZw"~~ՕH{dzP bG ,Ҳ/+G^G^LEz+k+-t^ AUwwP[f%u++"9#+M+K^aMOz,ssz$ 핧ϗ X|őʅv l b_iY 앧(gA{.FHRW{Gʶa`P\."[z/J+̧*|kο{ <^a$R+W8^a^9Q",&JSSI&ޏC^1_^Pʐ5BLyǤ F{ؕ+˝Ww XP+`+ uJq`,ʪ+_+O"J]:w]Ove1®ʅ]yz/‚A~s/UWtOQW̳S]i-5XR@W^+AWTDW劮5I+,/ D 9_+UDW #}# tEع抍szJBb\>Os nbŸJ-\ zi$On]oz+:í,(݆b0m d #/J[jJ[iGl lVVȱZh+Olל9qj+dU[1TyVB[yaWF ҅ɭ fVn%GVjlW*rpVVrk0Zqk&8f'VZѺ¤_kEJlE]0؊b+Xup!HOEڊW[y3NF[,Jh+]B[D[> h+$Um剗ɠ'Im]v[AQfKll;[!)E\1n<JWdj+vU[D[y>+me j+ƴV(4HҀABmI%YJ[1l'|Vϋ胭GdV؊8sROmaJUh+|~1[ϠoW_Ou٪[~W ղ?ǥZ'2ĠZ'[1:ɤZ'Kv0AWFL0TGd,R=B 42IO133gOIOͧOefg~rwZ~@-PXF64roߌr䞍~e|4Z' wCjٯP-T Y a2ɘ2NsM+c|р>V8iiOk^r͏:ӯA_5 C̋4g-3:H#jٟYlX-Mb$r̴ZƵdZ-Hd+m1ZF{y͑bb-9dMe|sLee~_'KKNA`&ղ? 33Ts !.PP-dFT$tTIj=FC?ɤZ%ncR-˵e\ّG&2>3?kH#aR-'P-Th2jٟlW+k`]i1q ?믘V~jٯM+(܏ղZƑ(j^2z!jGe|(jZ!e:f;&R˟f2J-J)D\fj^Z'>ȄZ'}6tZ™Noi|ᴌae-N]rq|8-痙Nx-~:etwTlKg:-DSNzLeJXr7Leiٯϛq:-7OXj:-Gܝj\jeLie;fB-S~G|VMeVF`V6iIXѧO]@~DZƥd"-=M1Z>FV8F<Ѳ<1Zf[b ?{^3Ѳ?u;2Ѳc1ZkPXycp8 e@)#L7TZ<,TZ~ QZQ2TZ*-5GeLe [&2'2)cƈ+l+;Lh=Gⴌ7ǧDŽZ~8P2P 2*3xo\F` 3[LɽB-ΧxO#L0N+N-NsD\NͷLx&2RdNeܗ9Si(NTZ̑s6Euo1r4`yc;ge<9P2NBt5'a(-sa3[w~[rJJ2_ҲɴOתOqXNTZ_3{jQݴQZFJxR_^Fd` f;l'6TZ͏z[XQZƹ~5r\´´o2W#&Ӳ?%&2~B4ɴ2w2gS2fE,o#mܟ92oJ˜}FĈJ˸^X2s l'W+l˃O{AZN e\$.iļO -( EQq}Ҳz9[|2DZFT޳wļ -^2q+2:i-k63Jx;5[A`OJ衢 e|4TZ'|1LJ2UҲ28)CiLLe4 ZƹXV1V}I.),M>1332^;P^etw^&?Lh,>˸Ds2ܙg6WYƥv@hZɑcxZzYϩ<0.+[WeLqM|ee\$wS<圭~'oeyJEhyFhYfZ x233~>t"!|5̀3@:8*dV2n{ZƘ)Z#=mKo,+>xjʚ>2GpX>gs,;8}xYfuYFmyk~ԥ3|6}qN*>B'Mer*2O,q,fj=}Qֆ;FV>f/>xM,c,irMeyg*Y4;7fJ|\[+kOegsĂfyOf8>ӊ2n곌k2(Y@M|%2}q1}nfxٙhpqK]8rKgYY&b,Sϟ?26 62+|KcmX9<8 /gS+#Z|a5в?~3i,1,l+2⓷f 2Ʒ!i&2!i&ϲ~,q,K @x;9~CLeЁu&в?(4=@ˈWecC(>igYVⳌ[̎aYYϜ@hh'hYfKZFg-{>ú\ x,YyO|9\Hɏ@:|ԕV'e|ٽhq)hY 6e-|$@ e#'в,hY!ZF'@ вRh-x5W7]hYqZ(ke+@p,l 1@a@x$Qw]U3&n-K"@\ rfw9y/[ 枭&pegY,K">˸&ü|jge Z1}692}q7XYTzahLeyZgϲDKplx˼ܳ/x?@˸NfefP+<,a-c>9 t04wyoOe XUgWDOR2:xT咝:˒e灑-5u% eI*2ƩYg eylGgge8Kg,K 0u|YR6tR42\W^r6oD<{.|^ 2#g*cEf8 \hq x="w-4˜Na,w4>QV,_\84fG1e Sf8dq2f` Yfei0˸!lLeܐ3/2>9rdI_t4K'e,kOFhNYc#ĤYf4Kohq4zK뛖4˸*[֮ؽ;4hQoV ?b-g#Sf!6eKyg,cd,fMfaͲ?#o^376r͌fYf#f?9pBC,]f{il(+{"WL oF6seEYF S=}ct.*6K3qYFזnIt)e2.܀f8 f`YgZ:)0˸_9r_Ndqa)nr#ey _cKK|4ˌk9G}Itza4f~goI̔*[b^Lf)te\(9gaW$ {,c;,b4emi, ̬gemb 4KZ, A4e&ͤYS,cg,J{ C,3dʹYfk]DҰY,AcfiPe6߼n2!2bflepr3Ne&3uTMe=be;&:KY<-Y1Yf@)tpc|>K/,^}1bWE|.㳌n2}sZ ;BQLeWe!ɳ46(Kx }{_2[y`K8yQY+2\W \'^X.W ˲ı²̜y`K1Ѻ,ͽe܋e# 7ei~(K @YTYTYF:7n1};0^)T ,Ç,cbO:,c<役xݲ6".xQ`Te<,eΦWe\`.GڜQHXie1,˜=e1,͜Ce2,Ko`YFsyaYPlXf,A,c֔hOAH*,˘#8>iɲ!ʲ%+lYFf,H$e}kcݏ,;eWBEX9a=+Dי*97so4˸fSH9kgϨtCfUݷ^gڡwv$Q(lZ(J,ͣfi Ymqo *ɜv +"bgYg/8K+VY 2.ϊLw$^]]tYƢO>JՕ,gC.I' es$f-g)9w\;Zt<<^ɟgX8u%e3>5y%}$tB[tݚ^t%,˴98:.I=_̲\8Ym{oOvGfi *2n 44_ e>B4G ,j2mH知ϙU],̯7i1zTIwEdN[dE=JdoRx+r +/AVˆ|.{d)cGtc7QV+(+\U,WTmAQ[esTZRYge=Be?eIUEV9qU#U*KxV7V:*=)UÔU UUUTVUSUAU$WUy` @U1.UBUUtQT]G]sn}VV 4_X.&誐 SWv]v*WUYVWBwtUWeUPqȤU!Ӯ hˣJkI83Vy*湁V)"2y+lM(XYE]Yh%ʞu*_%*uUuU,Ub,Wz]*xsuU(tU 'lYUU)I¦uU몼ApUTApUD6dU6*M*DV|]MUEUEY^UiKTUrU)r$CQ{P竢*uEU)*%RT*PUGbʛ8/HT|I8TQTQ5U\Tq*?5UF`\=\*.U9P^ BW*e#@U\\*xATʼn_UG=Ez*:;*U*GՕ<'(Ў :D$URHPUSйsQP_TQTEPTelDUU> 9|VP%UACrzQUz(٩̜T#*…*%_`Uzgʪ}aUv/lXKU-s:C;gaUvMYi*UUtpUU wU)9¢iY=]YeU5I jUPNVEYoj$U|tX%b)]YñJ& B&'U Y0ʪ U1?VWr\󖧫,5wUپ-.b,GU[NY~6**TV9'-r(<]lq`*/+Jfa?`cU(oU1=Wh.E"*V0ٯReqUr3᪸wJuU;W] uU"LUU3?eUD xrYuUU9I! #i]/@]G\SwuUqUrM. ݊0_-%* J$ݚ*އ*m*A4U)Uesf g!2<U!OWT+RWTU HQ'ίU!% *m Xo$*180U44U:BE0"b% U>TTaɦ*FU.@*dK(I_M(*Ƣ*̫}PU (Щ橪TUE$5&*%<_N !U UUj*b*Bg*HW+bR[esB ӖV\q*v^*3aYGVqbded"*TYdo*߾& YU* S8z*KX%&&"衪"" " b#ʣhMx***[:"¦uU;uUޟO][uUVa *rRXeKW-Jd%i UYUyaRޠ9GΠ*!U 2U맴čV @f*H*#{%vuUH+V`uVR/BFaR 5UXR#byaA*֟FV1r?#LA5U+`r ]XsxUA h(VUqUJZWEW"J`a9 v@UiTUa*OEUHI*rHTYΏUaR T{po&RUY->fKҾ&JTg 9 *ĺUU(bNU勞O@U)8#nYܲ**uUdUqUŧ+{WJP]KqU***U3WE X ae*+UԕU*i ȁ)8WV9+d#i纀VςV9uhUJhXI(dIZ VVٰU'*Gݔ jp [YŜ WB:=ύ"…r0WWW1"^\JS\N\`";uI]]e#tHBWyUTN]TMt/3{u2u***lR^z 9iUNxvqWiL__1꫈\LVcB`H x ,Z籗OqP ^y,r/g r+ +#++ԧXY>?k'3ʓʑX< *N*_xHW!]²n|7*XUOW_%g_WWdV^]$ʫW«Tȫɫɫ8WWY[WѮWao?JГ*5 [3ȫ8 WWq!BEyGR*ElU<*`UDUUE<+_Ò Bn}ϕV_h~y}%}[_UW񑧯#W+WYW! KUx(ʫX^ER^}>UtUݨ8W柤'ͯXe'?ꏫ24Wb<\KtU̾U*OpUO,몸əJy \KuUXܬbլJ`*he3>eהUV1XZZ*^**jX"bꗸޅ**pUL0W1Y\E@\eQ\Ž&bŵ"<b%wFOCWqSZu5ULSW! Ή\/Ixrmmϝ3b!3#>$Fl )* OU艴UxVPP[bm#*kMČPJl *j)P^YB4"dd&B UHRVay] ԣV IU3W~U0U\{UȣJ)EU%UQ$@l%[?|>*AU[@U)B TU [SEkJSw +27TyƵEח; QbCEH%U>- ro|8EL;WYRŝ3DU>"UUTyUx؊p'kT biOM5UE*nRFS7MB*l/b4Ut0U|iuT1[SaDU9@U(ZTݹEUHYP,Uaߡ*UU,TUяRU97cbmHU!*3* iE­\YU>glRW>vpU,Uɺ*U~5pUuUꪴ0DW TW.LWen]#몜2#g\*oNzW%)*-[VtY bQAaPTe Xz BdJ[Xe!Rhh3gqU%7H`Uyb.Qf;,_W+,WY]+i ;F`%\]P*UȅU΢)UptUjhઐPX噋UU$ޤUVby*Ji0h}c+`w*Z*VȫX ´>˫$2SU5VW17[]EWġ UQW {XꅮҒ}u U^fʫ0)@)U˫x**V__ɫàlqU,W*ۛWyN룫>8-**K|0W?!*qo*>UU-OVVXKXi4+VE}U}HY_ }*8'PW)Ɂ"eR^%{ =Uuk]ŝUf«kWW2!][-U|NhTV7V9mV͓Wq&d/WQ7Wq'`yeP*{BWabUV^V9* a<UbqXa-`Gc*>UX`zaFM@V!HVY1 VJaCGX"FhQXELXEIXF瓋[U6**1UD;+WVaA UӋҊX>ҩ*^}U@U8HWQ\W@K\5 1SpNUdUj퀫`ߌU#U첰U*)9@U VUH/b૰ 03b$q*#"rMɚYmev*S$%iyV**rJVIUxjb/ *j$J`lg72[̆*; [nA[A U$%U|kP/*2 *H*#*u*#5\+W pmp-U:lAU6&*LڠUXVV)]ZGZ* IU5U|*{9+hw)@V_U$NUM$󆷑UM¾c*z*J*RVVߕUvd`Hg*{GWs]oVy/UWqaxKwUܾP^$-y5UVʫX]^%*˫@X!xx 4U΋( {ë-_Md F«X,R&**eH«() %S[* i)K@ZZmiVZedUpTUP*W⪜FU94Q5EU,+B~UTUoʪXY!r/u(*^F*7*VU2JWpf ;ʪG{YeUdUSE@SEUSEASŲiM_S2C$2#*%C byQ IDgza*ʇ=̰02Tپ|[@CPeKsA@*o/ABDʨ*-c+Չr:Id{U\STy Y UOA*O6 %UT9/"H -%U@bP!bm%MdLs T5$U>x*!UȃTy^s!UtTyj7{TYTy=#,TyR* k]T=G;<93&,a[TQɢ*UT̘X֙@ )7"'šrQNEUX-r2UU+Us.BЩ솨 1;TңTU{EUJU9_H1*wUy}U*EU"EU ‪DEU RKXT*I8DTe,MTeLzJB;*VUDUUU!bCUE]SU(PU UJ#l'W{XUEPOUSU! XU*˪BYF*l,Ŀ*NUO`''Ja*,ʭRXE\Yje1+Pe*Ulce.氕UU>g*e)Un*Ua\gUv\.Z7WY|pv*6U*ʠhHAWуWWɏVa)bM k +'BvBp߅V)2c#? P^ZDi+UKr_ 3*ѤUZhd*CU*l*%ULtUUyn MWE\W弑L2yBb]]|mpU|.<3pK*lR*J*wz-YAYX]y#\#Ug(,aQUh'h6DNTUŪ*⫪*l$W)UUUyB\kȖF'Drm|a]Nk~: UyV!4Hk9 *O>U>lΡA[%*,JO @eE_r ʩ REYBteΕU*,UIU Jur$k*E`UeUfgeUtJ`U\UaZUU%{UUaQJ*$ UUYĔ*~*mOT` -*.PSTl;PRPEUOTZuP7 Ib*`L aD@Uƣ10UBbldT|WSŝ4UPT1YKSrg0AԚ*O|L֖4U'D!8*THd TaBHX'TXbʹ!hH`)x_Rt3H> "!B*KIK!Ue(b* *n (溒*e` U a7oQ'%QRATy&h@U;XBø UQ7MUqG8Q)DUuVU5bS wT7"AUqaUI* )|* 8UVU9z\V E8* -ga U,VI@]|I-UJ9સʇZ]&NjB禫ʶ uUØ{,w#*!"0U,TaQS,]MSݟ1U\Ty+IS}lj0cbrQCBew{"*7/rll7 > Ţ*g/TBUUOUU.*ˁ* * nga]CXJaJ`1 ĭbݨ{ PXxxU1X; \J`VVAs.9E/*= J*ߋ3B5'~Y˄rU,VVrȪX%YQV%Ez*lQVJ1 X>XtYuYLsX5QUJ@UV琬ZY>RVJUXKMeU|Pʪ|߸*ɪ :FHAUDUy:ҴWT.J檪 dUU<0Qs#LUy)OUDU!kVE:IVe ʪW<3fJ\Ua*'57*w_2]6\UI"BYY*P֕U./{I]W+?#GD5d#KYU_dZVkVmVaUZV+aUشdK`ʇRFa0UzVajdC(J=ʑy*nb“WJp"U4o)ܸE*C\S\2#q P/ˆU\J*V"\(*H*VARmP) E[׵U`U>ykXX8V*ѴwPŸ*~ M|U,9mZ%AxiXUbICI<qI/NVhkšU7?!* 4rHVq nmҸ*uہWj*o$RynI*n0.rj(yʫ\).yF3^7¶$yspV*B+*JֱXXAVWyo\+|WX_2B}b笯rf[^ r*UW&WY;!$}h:P_Ծ^JS*ؼ ͫ< ͫ@/ 6yWa`UiM*ꫀܷT4_+/+Il`%y+=\X!5˿V*8WXSX1rSV< + ЎUdU 諼w6'cWћWie^E|xƛWb O*ubz*MW_W"xI**) ͫ)l^$x0-rSkafi^K*{^ɫ9Ux-UOUWI]mZWѫSWߺʩ(BP*,跮b\]lUhfp PqӼDJ*ڼ Kͫ諐*4ʬb䭯QU궯ҥD_U>|6C⫸پ}K}pJ8*[`e,9I",6 +@+TDX!UVqVH0oaE +[XQX94lVoV[Vz XXi_+@ܙHPk O {|J+F+x%V\ehbPJwoaV.#vnaŭVoa Z>-lWXaVSDX:`hŠ++3V:狰R +*x* ɢT8PWɗV1!reUIhYhʋUoZ٠yi6*'c7h i>ijY0*{UDUnUN͖+JUR*=d"lO~(ʞs?G(ssm^c, ~ 6pߑժme^+2^p},KGإrPYFC^yMF )ET1?JqT& eT`y* eD/e|/Tl`|/##. ~էe#J٢T`yw4q7Ne~͓󞑋.8IⲌg$.˸a:Ⲍ@ە^i? f;,rs,㼝!V f{`ye>SW?N`qn+G eD^U*7eZi 뒳!:ˈ#Ty={YF:dJt~tϗ2'DtZie,Y)e|32nYFYƕ 7ej8l#)Ty/8\}($8l# gyUÅ 2{+c+^;g2BβS 2bDg7sMUKg:[Y2Phture+':tyՁ0e[ԍmtq728<,}ೌ'aq|de%thaٲW*L0zW3.e>y.oUW@K?kZF-=2zY2F/$e'P|qP+$z,~HaRTy)Z, UBI1R",'+B8ah"FP_'@GE 2z+)ekW,lp+\OJߌsu}Z]_e˹+l% {.l :ȱYFC=YF&:˜ w2Ffa{,.Q :O__:|ԁAk2/2܇+D_!˸ /e1g9R>HUtyGCg:w/@gg:c)eN@-c%#BKZDW)gz-G<92.^Dȳv-"Tpy<2򛂴پ9eoA-3$K-'Dvr0Z&G}߰?bc*elsDKPZ:̂2:ܖRZ̅2~DPRZ=#=GGiBGiL "3(-#RZ0jb?{(-yt)-㩑[1Lˌ*<1bⴌDNWSef_}9-&Nly͕~et/i崌:Md2>;M厉2n㴌\8-cP(N0-oi 8-3w*G4v0-~B2c.6aZz 2"5A&´׼rDSc0-K?\yrZ3SQ RN i;2c0a[>(-낣'A*J˘T|y:VZF7ZJCDi]"L)-2o,(-Eiُ仢? RJK00-*O ґqK__LˌXy:׻YôtG;2MP0-33t g[eN{JhQZsrRJKPZƍ (Cn+gG4LGiqp2|PVeRZYfsxnqμte^ӑ1i)Ŵ|ǽ0-ikAY><'aZF&Lq)adqZf8-#1"Nxte8-]t e 2K@-=j@P\ RP˸_k2vsO~>tx P4 8-9*8-#%,biWXKZki$nʧ+,wo9IJe1+eiiZFetRc*ф+g4h-GZFxEth-.ZT7`p-{>6Vˈ2+qWb$TZ\j1uFew"bӓj1ZFet/V 1qp2Y Weð2@Y[T#>O"w20ZFE`سB5R˘ T9Ri1d"2ŴIw&L~2Ʋ%Di8F32-:D" BRyP8[ṳ:S2nW蓵M%N"ixNpZF#NDɈ|Keκc2x+k鴘]2W:-{bJe\a 2ZܖbZLi1+U%Z1qbה⒩Fxh,,8WAZ_칩@@ZQeD'wA jHFs1Qb87AZFobB!2IWAZk;:lQyM-i8hx-37^eric#ʑή0-3+|_U9-c8itiwgXfQA9-#ZS-ŕhRZNJxhG_2w5@iq]Dҕ\9siqv%2_C3DZm(-ieO0!/eM -sN$~?S΀b㧕TJiYL5TZӫiu7--FY-S]RFxD#W2ϗ2_}x?Zʳ|{, _s&t2(Ot9y,iTEJ,΁YFgZ'/eg1;g$J F|O9ʪ!-VezYh1heJ&Bb"eg%9t,FnqŪCf >.Ŋ Xe\j-hmk>BˌH7#ok'Bñ 8-=hu <㳌;Z>>x~eܳA@e\=˙+f<,˼|qPO,ǘbVP<5y,mbg9UYyXeȳ̅ 3.:qou,ʉ2ZVeK".RX'IʳwV,= g_6,˙b>KπYgbʎ>,ƱYg1+gRYf_LYىoemb$~Ԉb>#,gq: 2³h0_"bҢ<˜,fe5>gIVNsU}x2.LȈYz,{gY>KYg1_{7|೸2.M*>hg1Te&cdLeZcIN=CBQk"V2GO޴0(dI3 2xAB/Ѫ˔IƓ,Ja e&.GIyeي0F@$Z!NJqK Ѳ/!Z:dwRTW<2y]bBKz']5rxM#XbD qac8ʖd%Y5hCZ2Pi I9YYg1IX\y9r re*,=<ˌc)X, k*~`"YzaYFm,^Y:02=/4Omcg2Ǫ_6KY̶f15DtGmf<{埕;S`qvCf(Yeο᲌|/K#e^ej,B.KOqYɁ[Q*2n\,AU.xG;Ro$ e\eg#I0]eD qYC&L\qf1T %W\,eM&?ͲX'˲^aYgxH²A,N`Y? 2>֑²(b,K2`Yzß,(e>lV,BX K,㝿uP/eBYzeg)C,ugYLg%h_8x6YL"Sg1 Iep [,&pHL \I$u~ jiI9rg>h-f߃WyOXe_JM<` +yX3gk`V^/  A*f㫘bA`֏ 2u?«lwڊʘQP2=ʫ8'ܞUW"fU!Y2vyS$Wl*UFʑ* XE*)iV<[e ,TVYUJY`7P\Jɑ;dgUySpU`hWEl8%*<$V42S+Gh`E bB*&qX!`Uxf6"Xe<μq XeP]z,HgkquUqpUӮJ?qU0!jWEt WԜvU,kW\8kL"坨0J]q6pUVY^bzl?a*d5*&K‚J*P!X V9 %tUU>r-*TY)`"̀W`%BO*d B' bPԬgVv 2s:X1C`GVkaeWjZX}ՉǑZ"ŠΨFAXae||V1}F!B,&J_+clNÁ`h XG+e{\61Vz22Fi1Vm|>+,õBv+VimԯXo+>!V&T/b"t +k)ܧP,lDX142`)/zbe{@A8GXibť&V^̨$VzB.Ċ%+=ρX-c29[XIL +R-Pb "cƊN+32~ \M*J9+`lX- r|H z$V| C!cFb+m50++V2 (PbօJ?VɪY"LCloae"43Ca+-.JT+Bi +wJI+B+!V6"V bp+$.Ċg"JMA_X9w./BM+l$V @GXI["nrŠ5O_J]Nsy$9$JX"Š<ŠJ3*C|>*-Wj*gk^JKx*DW1Gu{tu*jvXtP*, 2zUWoPxruW!]yf0sPWq]eR9R6ʈA0XVq(2n>*UVYhTX7F1 */)g Z)Z1UXFV1AZe=B4bYesU 5"bEXy`'} 0Vq߰XeGVOUI`SXV XE XeWg8m$.`ֈUVy5 挰F XׄV!"6 ҍ X)qaU`TU ҂F*cxO:J n*c) VSTIVViTX URoX;Uz$%&*mI7޺]0\m1U6pU>(*Pr0KVq F`M^$,gu2#G,arUȼjY۾BG2i* O*iVeܬ+qUÿ"҂S/xrUt5*# ʾoqUځU^V%S? BaJI`UbP)RBIRxͅTIB"#פ ?*]Z iT@Yx+&U,TW$U^5lT`+VT)RGrYkll.9*^EU"FUF̻T9HT9deGYUTXTTEUQAUY *ӪJ7* UU只2 T@T _UײTUT1s^REARa)GTQQ "G!ty U0y64FTUTȖvQ\*-T"TlSe4*DTi|#L* bS OYdkNU]Yɑ*Y Q\*h&)T*/=*#pY%ӲJ#*Uj\W8E\~vGiUVx*-U<*逫 \eP*ɣ߸ W\:VpEWxU>*'oUVU<3*>AUzAϊ\@5AUUiY TehUUe5Pk'XMMb4K2:l2U`3HEw~rL* ģ| Se`Tq Ҵ2 V8tUa Qv蚶lUǝ5p(QU6BUaCVUUZU ʘ .UeykU ">\>*MH6a8lU!)bYX)aAUVk*tZ`A$3J1Uv*c\DW% X@V!3HYCe(5 ;-Q`rdg)##@*.)PԲ I-B*A*%W1`$r_H*A2ivj׭J utcϸ]XU'ʘơAWVWQDWc*7G^%e"*CW!,#Uv%ҒyOUDlU$Uv˫tBJS*l%^[ h[񼶊pWq/"K"Uv*MlWiI\FUW!q6UW1qWW92TWqb2W*dcw[Wqt絮"3}H\E$U*QV'k**W՗Uuʫּ͜D^W1!yVeU\W1^^%e.W_=~ܗRӿUW!-Jƃ8$UV%s{EWQQW=`U ӌUU:;]^=UƯ|* _Z^wzWi$Jo*bբ[e«(H (xSU\ÐWi$2~ͫȫlǑt-xNܖW1uaeTH`PW+[b+~ +ڳl숬̪x(Pr(+weeX2?%GC+nE) kV$= 7 :+nSTFΊ8+Jbqf -2)/I'oT 1"+H;+c5(GXO F*Ɗ4l&V6+',bʽ b%k$?MlgMX *a<"ŠBaeQ/a=S[X!ae>VvMǶMXmZ%V bŋbĊۊ6""?+KX&b-)J'6&VB[/bEXd!VPBt< #-0+խƊ+n 2PyEYq#J.bY鎾6'kdb6V/cW[c%KO+,BDa %~ayҦĊ MA" Md7&VX 3&V6Fa+z㼣$B|k= X Uk`FXdbs PվJUf)oWWI_EA_hBBi*\꫸. }IXނ'U?WY|kU|B X = 7EPBk*,*PWQ;BW ql~pG%Ab66k\opVU ɉ́tJKֶU*gUUV9UUI[. e*]ܰ OC`Vٽ[X%xhEdJUVᱡ"JL*DYdeY^JǛUXnZi VVq$J?Ufg[JVqeU_"CXXִXI**"t Y;/Y$DRX*=V9뻮Rp*"* *t7*սb\e>W}$eêtNVE[Wu"]e*Uqr\])*E*(dU[dUn\ ]vnW? ҅ܢ* ڋ(wKPUBUPQ~ UY$BU|UiFOT;mTEk T*$h^+;16T9S6U^}OL˂UaVL{Q~DU,iT军ҡ*fcXѦ1PUوbla U$Uq!U4$U~ho$ L;QlnU*.4$ڤ 4#'BIp(ޯfga mTaP ֒sP^8RUCUq9U` J@U:)BUĥhW")]|uUnX2!JA,rUf GcllX%%R*GVn*IY4J]eMciUz\*ظ~y"2N*d눫,չP*UތULEWiW\,U/ ҅Z*wC)J,W.Rm*".b *3*逫!R.O*gJjlWUGk[E"JZkB9UVgj[j)mmctJ>'J*V# %wRȣ[ҎJ*lUViby!EDV&d(,";ViXAaz@aˤU~%nU&JX.UpUXE YEYŇ3 "R*RM*BP*S*rb*X*jv*6 h{uiR]E]xʜwQqK埠UHbkZM&h* ۰ *BMQ*oq`; Wm'\7`UYH]zzUWe6ׁ*u4>V ͪd/*YgE UqtqUUznm*[-J8am`8h[{m*(qRUg*-=l U̧m-Om6Hh0U`(b[.*JlF3UZ[ʫ<{WW4vxU/yO^%=*10 \$lQmX+#aL[e0R?r*bpK UFH*:*A*}[%B`SV6*j6 B:ʛ3Ğ2J*jX D JAU,ZWVy1sQVhYZiici*VNW BZPhU×A\'UZj[EF[EljV9R*r `*'OptU}m[%# i*Z~X]Śeu7LViiIi3ilUvM*OohBtEE*QM@*W F*#527V9JKVy*TU AtZeV㟀&Um߱Ul [J_*ml7 BqH*G ֺ[]ŧ> VϦr_Usy*z*.BG|v*r*VcX1$bVR+m8XᙏrU+T_KUzboy*bw*1)i'«_%?b_x_e|ՁPʡ" XѭXqXys$X_eF*&־J*>cUFĽWQrFX_+n}$W?ϒ}"be+ĭV Vao3Vr"~aAXqb6VZ@iaa+e 4 `y,LHࠠ0]FWl]I^%J7,}LXNd+f=6 )F`+#샕`Ŗ2k[ò0+ƜV\CXi:SaW+lt~J_ +;_, 2FHee԰DPҿ\eX1{NH8Xq _Wbwb=,z%VHH \)J%V\-X顰q\םb,\!$V^b`++bʊ:J(+YѣY.J?6QVz&a*+V4ew+fMZdVfwY>jY92+%Ϋ(m,0Fe#CYme؀:PVVYi+Fe=fEfōWeVܸf^aVA4YEftU_}bdSfw,Yf7/Ya 1Re QVrcEV/v2 i(Vj+M9!VђXvM$Jl X- 5Vx + ϗ(,1VX ceei'5YcŭYW" k B_Fn u++-]DYrQV ee reVo`V^ȬTˬOHf!eV6!J_@YuV2gtVf7rnVgKuVT謸Ί=P+bR+R+]&Ҧ ԊJJʮo|h+Fm"h+3M.t[>\7;nm= աp+] )z+ǂ+# n 2.D8 .䕠)C9WEp*Iq+5F+cE lsWzd!:\AmV[;Vݾ-'{񾊶CVP[qW1۾"${6Xh򢖭Ξ &WL\iAr%<+.?b= 1+m!, J;+T*:⊣ߐ+re܊Q3$Wh[Mpv)FV\y"%tq <+d魌dp!z+~ V,[fDoRx+4nW[Y9p+*$KV|ȭHͭR4(d=l 6Wr+-ZʭbY rVsVF_HSϷrh+m(E[;~@ySli:8h+_]m;[{\n堊Yn bhn[s+<[VJ@ {:p+lIvո+}!qe;Vȭ!r>,ɧ­([?r+! 3V([q2np+{jV4r U[]gD B t|c+ ؊O.슬_ #5che@+҅@+&3+t( ihWZ!IRiE=^jeBVA7A.V^VZq 5sեV(J/P+IЄZ>^Tc9/2_HPZi4dG0j995{>?X+d͵rmb㮭GZe+Fʠ.Z?VZYsk  ?I=hjkK{VFg!Jmdd(VVF%:Z@SGI+^H+4h9ʂZIЊA+&QV#ɦOHVVD3ԋb1bj8VYqҸk)+wLJKY鹲ʊ\++u4VU I"ͬh¬(Zf eAeVd`V̿of'JJ+V7#$JߵJ+IQZq EZ9%\I/W"&BdS+o7jkm(ibFy\9Ѫ2!ݔV2QZif#oieLq ڝ!hqVpjiqhY޾*iZ|^V|)kEnxX+Vctkŕ IZC̽-MlASBO~JO Vzf!"¿R+￨T+1_=)ѡ!/'yzB+NV0Nhe練"،!;iVVMZQZӗZ~$ʈ3ʄZZ1oVe!ҳ 3ZAϦV /VģVؒV#Ԋ0Ԋ%zmmk%mJ&d "Jʁ\%tYh\VHb5CϞkhG@+&ɮ hZqkhZ!ծiJ^YqLb:+IYw 0+~}D0瞋1^Ǣw___A_??óTo?-3FvOF_-3]2Th ; %T B]@֏$QB_y߿zcKRWf,NԊ"ZfUedh,%~TJFs@<e~;QgJB˼*̌ZF@sh26H,<>|M ~g|g3C~Zr]'bG-UY:_ՙ~zd t{&a| }*o6B,Hr2nJ #̪Zkk<{h'g㷙X^YvRBkZf l\i"TQ|ԍP@:u̓mhJ:0}Y|6a! hmCW2n# 2YkQ@<eZG}rd-D rUwf?ev& h{(evgޤ|ye'>y2Zr}hYn-#-!Z.e>2O Ug5DPhlQh%("ZfRZr-(I-{.HhWO~@- uw%2B@2R؞2Zf =TF,(f`ޞj7NC.VecEZ慨!AY-%)e, ǴRZf% ̚|V)-bW3D0oW^si:?Ji~ܖeGp6g;THVf`v'׊+U'}O ijX*:le6$ιif rey"22Zfa0a2=G:71Z0s"n2h22ZfwZaFhR:p("Z橪e6P*e,M>uhY -3?2_e @e;!^H-ITF<1/h]IM-)e-}ix/f`{2Kh+:cIEET[7.eyF2hѲ51ZfOYF|ڽ#luʽc6Sc*D2* 2<]'D| 9}'MeV_GP+g}'7?9 R@KNc&2Ge \x}Yܱ,,s':|ąyr^;ST:2RONõ2O\wgY~Y꬗P>KAuஓyҽEhYZ-/9>Uh*Z'Ϯ"̶uD!ѲZc)ZfZ#-K,)B醘(eDh/gJ?6 E -9j0%+^B|WLeyr h)lu/8y'~ԩ83Gh'' I -rWdLe肸Leв<Fs<}j727ZL,xGbU',:88> |VeAP+G|/ 煈TR@`R! GвL##u?"n3I -GB2.e#T,޷J7Q[ѲLRC,#-RD]E,˳!Z)r%FhYZv%Pe6j)!Z,Y'@e>,[N;(-˚B)-ˈZoSJK=IO7-W'f(-c_2/Ӿ(*HKb?-u2|⦼G\`r1ZӺj1Z]WFsf0F29I-/%e{uhYVb,-*e4i, -O۔R'sQLK>O}ԣNRLz?97}LyQ xu0- ?L|f)e2Gi7MbZQt%{!P=(ipG1-5| e%pe;iQq̵ӵR}W]bZ3ZL9Y?o LK̆ͻltvJ˜(evoUSiSi9 QJv`*Ā \nŴL>9PLKu~RZLtx&eƥV'\:Yh_/E-8R˰Zg~s-ƃh1-DKE]'|Fzy*y7Jh{Z'L -=YCh5I ->\ {QJhDD -}"NO-M!b(eFj]}pRZsa i˞S~򹅴2Hlҹ i. e}M!-=i&H a-e>K-PFKctI-!uʉi^~ȃeyBZַ)e]Ґ i-H|d>Ws߹e e [lQ 0Z:Vb e>1C0R͢"Zfӏ@cT|*{}ҹ\K-=FCh%`y*(.OV! %83Gr.3Z#e6M'BUhC~G[͞s:@<ɹz#Z_\Z)2[mYfS:˼9Q^>\Yt:KYJtٝ)e͙C,aWRRy"e|P+c\3,Q-,Vqȥ Td!ʀZ|R5bu ,BD ѲL%B̓JE(hKo_'*i8WR驏hQZ=VwRI]hzTz]AZT^iYfUAZ'}^Piz_LI FK}2Gmj1ZcdzG0Z깞I6WDKAX2Bk2oj4ZC]ؓIh= #,AZv^w2=uh٭1 Zvk]Z\’)zc+h-swDw-Ҭ>If}>InhO\> Ѳe63XS-ʛB9 +$\y61ov_\_pŜMB\9v>=!W2X2+W™P!J;8h+[ݏ^*x+#V̋[_{+o6!x+D[ajx+X2󚜋VFbݮʥRib+,|`IV[y^*Vnj[ɮZ+cMX+ke'ZSk~Lhwc+vml}AVLOV[Pܧb ϑV@[HPmŲdK[Ifͭ0nnIk[!J+2z+0ko 㭴m"b h魘Bf(0moeQ0[!J܊vQV,T[gonz K/VL[@%p+ۍn܊`cí0jnЖVlp+:r+06r VhtɭFJ[nHne,ԁh+c:S[i(yuV|˭HɭJ VW:A;AjVV2Ῠ[y 7B9\ybW.W,\p7u2+JC h-z+ X]B(ŕ_W(\1K\pRgCP\b\q`+ te+5rrZurS,20Wn +$Bb+#ũYs5\X\0DW]~]]]9<0鎜bA}+9+fWvˮ,`/ !+W^q "&7x]9Y]0hwܕ+rwѻ+zv2]y$JpW ⮜l؍]iw~LwE:FwJґ^!++Fx^鮨n鮴Or ܕwx`JtW qW^ 8\^KxŊNᕋEx 8!"핻+Y핊,L饽q2Z@^r^9cIBnr^ 2Zf^97^q,)2Ll^! A!ih6K8 ʥUJDMJؚW +hP_ ?3yвWX#uJ$8>GxrSwvW]]]RwEJхWN+"&fA^a3m:+ "z_䕱u^⚶BLW7P(ĂozHQ^]yռW+c:@XRCxek!X^W^QC^Bծbm; sͦWn.&+>Wz%d ѦW<+;ջ+R+HW:f#"ʍz`ʑ9q啝j+p'G-0GE^91#WNW|+/+cA( dۏ _L+}&WK% O}<W4ޕWlz@^_*iW'wsqNB|e{%kWt+*/Nׯ4z'rI$Ҋr};Z_au+;\ b=XD,_9}WmP󧽲.WLl^i&ʂ$V)+gʖW!6b?{+B2+ 9 B%rlA^aWN\WkU\8Owe7]ݓ#aWy4ԕ&X|+!| ܹr+2*hqœB-Jcpiq W J]V]#it~Gv\+AWREWW4FWtAtЕ(2։Rቮjtf/nѕ+,7it%_t]QtJ1+}փ܅+qsD6Wĵ|Tsz=R\a36WBx%+++!ɕ\Qf%W %WU\kq{g{lr!&W\or%J,ʦ#(`_qőW0%WYW-!\7⊣}ŕ$@\mu; 8A\ɂT+m0 ۗR*띟)-#[[՝ފފFJ%,ފ Uxm8s\qTҲ Ol5W,Ij\1* zr1Xsdȡrp51W\a1ѕ ӻ6WеBP J\E+!CV[9xV,[ɒ܊܊H܊f•[˭op+ gW>P Q+J+r+RЂ+{V\?ܓwi W紸"w++d pbNKQ\I|+ 7HCqEZqJc+%W+k!WH WL%WT4W\ls6WXr\\Aˁ\y6$W== [S429@+2+n;2>yMrY,+cF7"ry>!W$WI\a.>+6mh%GÅHѕWyWWHor\y W 5K I/C 䊪T+ <$W\H\{+)G8+ƃ5W\ \骹b4͕lʽ%Ti+#%W#%WJY2\yrCKBKw> raXr U-܈+(׊+*}+bVWl[+8r)x)}S\T\)xpWثGqẻGT\۲ԁ+~\!|%r[*~K~J}\\1%²ʉ*b|PpWWyip~IpJQb+jzb+,/؊ ؊S[&[v=_J[,֊[b|bޮʇTm/Q[oll.ϝU"V,ll%0m/ZqZw2ɑĄn7▫Md?iZ+clk4\tF'%m<kŜ SZڤ֊V- b+V b[aٰ Q1Fp Z+&W,*W,WXYK^0r ο r.+Uk+C%'b4 s31WzG+5Wb5mJ#+ ++$mk4W%M 4A6\y.>\qtM;䊍Prb&W6( rf W#}F+(7N K-B =# s+ pbʢ[!GaVvrP؂+$-6Ή+p +WOWȆ\1 MWp\E\qk\AwmpłfnWbVp@Vo6VZV,[aV [l.+ W6Y}W׽#(j cÀx f4Nl兒(2g+ʋ- BE+4?O+  Sʆգr4by{X* {X (\-P6ebŀފX欷rgexފnފ]G}+MX=$ߴU`AY< '+ ㋷ .z+7KMo pYX뭐|x+J.x+}ˆ[ygVJo V|魈8now7=܊5p+![5Ekz;ցQGB-InnbVcJWFi%J+'iQ -XL2JtZY⬴~rlh8+>tVWg^gHrN⬴N4-¶TΊV fV6 "2+>dVyYY񁥳 j}wgś,,4gٜ8+Ӵr ɔcbʡWΊJs#8+ eVdY9pVDIYyf˟EY!J, 9*+}lMUVfςAYDsX94cY|^dYdo<vNmdoOY+]d%aFVJ +e*+ZYASkfmeVuV|\pB+V d܆V tV2jX 8+ˑ8+ށ4]geQU$f1vqV uVdVɬVV| 8XZAoZkIK :g%ksdV`fVʬbΚ*mJJlJ &mg@XL"bJS *;ɡ*naJVafCYS+>V]Pj呛bO }ʗ;XjJ7j1 Ԋ nmHiij8xZWk>i"nymP*ŋZ1"Žem|MIM&  mX+`xVqVmi/6êH+v `Va( AKT[q‚~k+Y[CE[1bd@meTQu aCAb+ڊ֯ `OH32W[8[mY$ 䍭h鉭d_Vΰk=Պl| ֊ʝZV shZaͪihkkWk%)@+B+ƉVƔV1VZooDZagZa(`VBhix INM8dZ1.'"ҳPgwZy hBBZZIIz;Ph VZih:2PZ!;Њ׫U H- /V\OZ "vJ*ɡ''gV'Ȗh2+_>:+P8+T무bHNgŸ7㴳sSgｘg1Ί8+1]V$?V\}ZOH+JH+ebKi MDV#Ej%/H =\ "XJhzV.B+lЊa12ZI=S;+ΊK kgDvVKguVPCV[.JRVH0]ItZ9LV$IP+]d#rH_.ĦVvjVLAZY`VÑVL`UZ1[ihDK+dUVOSeVV,SY*Dʣ͒=?JX>8+\&ͬ81AVr+hpcY9ظnS?;erݚXXX@(@|!4Vt$++YaIK%+ T{+4r3b%bőZ+$V5M7(Q+gXbŸWbѝBXSXy#CsQzFK)ceֺׁ2 (be9be,mOXP-!VJD+ 4V(XaTce w+jӀ:Xqt#+^+R+oذV$kVUwUѾ9*r4B/ =^U:ɫ8k^G**jUULU ʫXXN`}=||#U4Uجh_XXS­DW`"!rW1"^]&p2_]U(}UW>z+U6^¿+`ŮZ`fzVVBƠLPVXG^ !HYarae]\+/X1+珱2r+`e+l{+$+M`RJ-oY&b"+2"+j"+Ȋ5H_ @+ $qVFy0+=lfVfyʥ "d #Cc:+ڎ:+VyY!SV J |r B+̏ ƁqସD gžOh%;ȵrevVt9tV1WI:+M|yV|V\YZh8iuvZkP> * %B+XB+b+OZDghKf%UfVeVZ_YYqV!ⰽxglvV-=EFYqQggqV\Y!-rY!Zg#ʛZaEgE]gPgZ3ZX.7 "WlI:nhY9Lj;+"*@+ ЊbC+TJJ+|oyK&( ҊkR+VXmjEkQW ͷTk9 ymZx[+[Z1 )ԊV8K8tZq[&{}nC8Z9 ZijŇԊeS+8R+{R+vgR+UR+vZ+ߓ k֊APWV(ZݿVZ!㿭9ϊZidiVZq_VpUZ-V*B?}j@0mj9 05@+9XB+& X+rсVFV:~" VZ11XhMۄVZiyhҟVd h]YIWjsV(SZaJ#VEZqNwlij2V̙VZ19_i5ZIJDH+ pZZyO. !V^P+.Kb5b BPaZquV̬OնV"䠵b bR+VJ0jjUѦV^Av$ZOZVeWjE jETj7ɅZVHljťVV4SjZaExV̠V jeWHjހZ99V R #ҌJĎ ԊFԊR+n- P+ 2+7U0+˚Yya{V҄V,ZQhEAie?aAV,ҊҊ[ +'|Thg`C+oskO0Z;ZR4bЊ2@+g .0nhe9hf-t O Kq :h墂ChZz\h^[hhL1Ί%:+s2+7b ̊U0+d2+V-ȬJleeV,זY鷁Y'Yκ.~/`V,;ìX( ꬐scaYݺtVܚgWg %G:+s:+n*8+ Pt ΊpwB iD iC+>VZo.ʼnvVTtV؛@geX**8 H+DZZiiIRiEiRBZ񩈴bʸJkܯbǮjeO^SԊ MCwԊ2GS+ޡR+6,rymChZQwZ `÷Zq)BB| eV3VZaBMd_EZWZXjiEiE[JiZZaOJ$V,liE,V#4i`_DZWV-S" *Vi%[2N( ťVZ9,Vi#`4UkV$Z7uq Jϣ;ZVXijEķ%֊oKVlkeAROx⽨B*M[+`4Ҧ ؊WGnV;X+BZ+wX+V .\7w4؊XFlV[4[/"2',؊>V6V(ilyG[y|`+ϕ >RkOkh KmڹX+LZ r{@o[[a+[&[iulEXJlg؊(J V,`W[imW[&VmŧA PneO]Cs+:r+i˭8*[1,ҧSoeiIN=7[yOc3x+M魰vy+=[aRaoEohx+#{$ϕrFXko% B$Snq F۬btVoصފJ1R ϕfs+L.V,w.ozVXvooERoEJp*Wpۀ+ijVnVڊڊڊsDVzk+FBWvpW,beO+ 0 uWI MWj4Bk+J+ާH+:p[OkUlH {d BQZqBB1bc՘wõ]X}?1??إnh-ikʹ(tbZV!LX0«ThyПfZjE$,(QZ;"HV iF<eUFvb`(1Zr7Uqޒ?V hnW*$TLyT*0~@K+3 0xSުO -ەZT@`,UcFhNm#E-cmeRќ/%َ2BDh"oؔ *|V|~c'MqDh $D|=RA"/?+B˸@h-Fq1CreGy)lyIgrDZв; ea掊2sBc,`LqҢZ\ѢUв}~CTH`\Z es'B3ZF?e&XC]bcanRA92(eAZ7h@Zۄ 2$S2ＦB=JatUZeܐA( e&Cn#JZckDi'aZF35aZaZj<4T'N蝢2aYfXٞeneWGy;@igɥc=meJ]w2~pу\yMRLl-231´(-3}^B2~ϙה2T@y 2VAYƅ"dU*80|Vxq[>yM%R%,[e 2RPa2n+4wsqVcAhño&ϔ.}}5ŷ2~@-}"_e4zD-H=BK߷-e\z1d"wв|V1,ɋ2Wf`\!.WM-cX%W-42\!ZfR  RD[E2:9\i )Drhn-h+O-#ӧt-#$3D˸.O-Thy4i-;?F˾Q=e"sh#h󠜇0-cؔse,´a2-^r<`Z 28-y'Q9ˑ */$H˸Gi7x~Prp1ZF~O>͉BH20Z׫e^un\92qE319HHt egi٢>Dhfq4"`qq-cV#9Z"B2fB|=PJ-^TheE}o -Uh8!Zz, 2s!Zc.2D˸sxM-"h8`2Z/TPyy"ZFc~d9Mϑ"ZfkUqMB`(-s*oWT[?F˸bY*<&h٪tFzZ6FI2Yi- e#c,eq~󳃴Le ?BDi0WE񬮯elV_Ҳo @ZƇǃ 29wAZF'HxT ҲWJii7kD -me$Хg7KG 2"x>a[ iC(-PZFsL(-ô´\ QZf`.o\J˼C|ҿʁBZi:3 -'DZzeH81oO.Kq 2\ez?g -`[4:'ї?NIF&PYA-+'8P8g\(Z-RUZ%-ƥ+Π&Z_Z2n XZƘ#N'崌N4K1-㚸7G^pZ.ˑg2´,Lo?L,3WLK?#e‘Z#>MpZF'=DZILpP-#=KI¡Zx=JjYnH-= Fj4Z-w|׌'}Z/RHF?>%l]-I#Rzq$KA-۹1@-cB!P3jIPoj#PZzԲ0ZD^$O.@-b;e>]ZF %P˸wpZۼRiwu_^P6vʥ(;bYq#O[<8-㑉RNKqZpqZ;?Nhih”30-u'v0-y 251Џ2& 9PL˸2&ɹҋi6K1-+iqZfiZ޷!ഌ,m8-˽eDS0Xi=o^rfUaZbe0OZ}e){)~z0-O2c^崌rM,1G@-.~eaH gZ:*2V> Dy%j/5yҡ^Nju0W]6ZaX&2Vp/O6@H-sY%'k;Fj7R eg>s f4H-㩑tg26ZF_%P 0W,d] eFy++)Ii%w'AfB8-ί'7N)s2A~l/tZf:-̽9PN˸?1X>YLa2o8-#崌#-e|?0e=b|rW1i!u`$Di 7{^SJ˸DiwC@(-bej!LbZ放uU?I~Bizi!Jiq4/2i7`)pL|ׁRZF[yRZ$H̏?,oJ˜Frrw,GB-㚈=RPe[ Z Ӱs]Ly~j+eTrZcqZFFeⴸNB\e0'aZ\iql⊠NGŴij8-Aᴌe̐SH8-[U ie 3KQN|~q~©lYhY丹UP7B- 8Ejٿ-ŧN˸n-Gl2zLIp0-NbZ8L˼rd3I(LˈU$L PaZɴFx0-3UiOKPZF{YR/2(QZ̰܉x^ AZö)nŅ#"-/EZƸ.(J1~ e4er;ig<,EDZ#&bJHc"-xDZF{dIkTԃNi!2H5x-&i824Oa2-3ǥdZaLfN%'AEⴘJ2'*˓% D bbZɴ%*Lo0-KS2Z$MsՆi/eeO3-㵹"ôGάd2ᕼM)-ce Ӳ0-se/,ځL˜yb,Y9~to2.Ũi̕_zKSJ|6dT1)eGienP- e^iJ6!Z]eϟ&ZWe;iBt/24`GqV)91ZL>hqVŬ VSFKXb8hT$FRFiI4ZfM ZӶ:Q2\Ϗ2z\%ZF  }w|91Zb*BĴ2etIiZja%KFhٞ,{+8*[+F,&g˳?KO0Y_g}x~U|qe}~|_WV|,w_g%@i>-c\(@Kn- &=@DB*'DZLThm$X$<2]hWN,-=hqW{I3hYn-۹sh3jʖf"b< (#e\ˈp$WYa>˘7V;>?Kg?>K&Yg'Kȯg>9,3lK<h,Բʳ7},.ɳZeR=Ggxɽep^h1SJeF({YzX2VrN䑅 |goSc,@ Yi|YLg1MPeYz42fϏb>KGYsg#>KO Yz,w">81O^ͅ~Ag|k*!Zzbeh1\73ZƩe "ZF)'/D!Zh!Z:;@@X(Ѳ/L!ZLoCY٦kZhfŋfeVLYzTfmgSg;WKC+-DZk>V ie?9Y(b#՘P+㳪meCo|Dh+3V0J JF父nV^JkV6ʣ\"2~Tx5h rÂd#b2]c+LVAl'A\J h+i[[b>yV(a dhz omDX3j+zH`+ةqHVZJlE7ltZsT[1Bp+tr+ b Ss+tp+[[nSVd~gWIp+-4LnE:JnEeϰre\}] W;W⊶⊹_+3ݷЕK;t塸_tFW<1+ch!ʂ%5V^̕ Dsewv2wQ06j9N\iqIseՁ$x+TIxB/JcJ+ϓLr&W7m+,a4R!b $ı4ɕn"Wcjo\ * ө&WpWdW&TX:2sVbɭnk["k+[1y 2dao.T2ʭ܊Ef:h+J/ ݰ j+młVbqtk+'h+VZ\oe&oeׁp+DrnEuE nWi\!aW&6_qjSkTW^TeE\/ 4Eq+Wfw@BW3F+#]_];Е7@Wħ [+jY+Kt btef{+ׅ<% р+>yWnћ+T@42690S R)p奷\q%qe.RqpMq;JWp=WMpe< se>w" 25\!J,]rŹEM|irrei-ȕrcɕn ɕ[\jYqXŕs{+BA+WZYE+=@\ٲoW"bbm+*!tW8[ [VzƦҀ K j~#i+]5 _U3n+^]H6gd+w8 Pk xV譴UoE"oo%toœrk,Jl#fx+\mp+"ͭ@ɭ<'ʻVn#*fVX$ooűʻ f}\Y\=O-x:+}~WDWWU\jF\Qkq%-a+U+<+b+7q$VI[\ynW@\VUqe+\Y+$\iTp%dL\qGkª\5RʨCmD"llr_VވpVD6l|Yu^؊ʛVtV:"2 Ua+V86IqèZQsZYԊP+7勞$\AlVHnlLmc+Rb+UVD؊؊h&؊JԓYdŠr#+i@VFKde@@VAVֿ 4.ʔ0[,j?X3X Zo. + _d77 Je6<0fŒJPYY|ZY^bVF|!aV VV<(+R7"+D]EV\ldMY! zPiUV(?me%y捬,,d(Yd}?sYYqXdeZiaWX(f+' FVÿY!Rd%FVEV=4r ΂(7d%Xl+>JK7>7+@+*y+]-2&O(ܽ1VVuLyal亊mdEdDVFigrUVE-V>ծm`PVO2JVp.+XQX 4C` W+bܹ}Wc74V$_EXt_X6&#b8Xce4V,0VL6XvTb*W1Vz@bk+Ȭ$ٿ+OeVڛYUY%jf\`Vکl"2f ͬlfyYq^2xVfe|2T00ŬFf#Sfeт¬ ͬX_]gEqKgEAhZYh"y8V,RZa B+]$V 4TJOZɈSgEAgGYWt qVFqVFGΊ2Ίu:+鬴-lfV$.eV,Y-oJRfY f@ ^¬Ȭ0Q:`Vؗ:¬TQe@"FtD2%CG]yS-BE +' cy $FV|AV-RV#U Ni &I*+wAVz*`8PI'< ʈH5>o9I#+m8Yn@VAV;’i#+M" c~5٭{rY1.*J:x:JK@(+ Kx\얥PV7/җJ&+㡖_\Gc6VBceXN c#XN+QYy!KXZ+=XQ'XiXc dL6VObb}K)<J +@;+m7I4;, VƹKJX *HBQ"+ +\+VX;2&vr*V 48J @X-V~`Eh4B13LޕYqH2+nQ.b?c9Ɗ[+B^KVbx '!V-GX1J\x1xʁS)0;檫%JUL\[\M\9pUbt;4[2"W1[e^xQRbV3V^n*Id8lWWa=qSUUWaqRWqߺ_]ez?ʈYu-TJtJAN) Jo=$f(y+Wy+*UL~W!}&:U/WqߢUWwҵo**nrݾ *⫠*|>*k0l_[_ŽV_%Wʅy"o2:#*t!/JkU +; g + eِ0VW>+ŠŠ;!J+{~#J/*V˫Hȫ5PU,V9<8*`]iUVY|] P -ΜO%eKUYd6U,WVqVeye "tᐲFeUm@X\*#U?[ UzSڲUXV$VyhX*!ZU[\ŋ\UfJg 0R*]Unzom7V=CU@UfP$*]gд Cch8^cZe=$dv"J\JUVyxI"Öb*Bl~*U6iU 7^*4>*]4l*%+ʈb:4*Va)Ɋ  _[BmVk@y*I/IeKr[`/wJlU(YiZh4[i[.YMUsX%!U QUUUs@UVUVU]U3J뗠*.+4rQ)ҼCP@U|TMQ7^_PgD'tʘ&簢 :T&TѨ*sQU$PU*K:Ѥ j4b_*畚 IrњTlQ QeՁ$ZJ@1 UkQQe G~ ?J( nP,U6]o4% @wȡ lJ2U;הUQPE'\*,@MEB*&h~ *.-JSTqQeѐU UT1a.DכTqV["*Tn-4QSUƓ( JVUP*3<)P%@8: ҕ*L؜ TĄTB NTF=l2z7ɂDFX,T;KOx*TtJef*KBM(?)G, dT(RC-hKHJ Tn˶TpRT扩HOy5P LjT`RX*4 y[*O(>TRx9+;M8RcRa֔ P*H*}rT R@*Ґ UB*.`*Aג섒Jl$:k%H$CUb*Ǘ3\ b*>8TeY9<5/=u<"TTUVDT|o@BX e*-4B P!Uf&r'ʾcS 6UMbtgҦ 7k*__SEQTS6U,'TTqTZYfUdUi*MDUшUi$ 22-#T lTiPJTES 4UBگbz(bST\OtUi)WedB2)JBQ*˭WeV&*. Yē bb5x bxvU<1*,Դe~VKX8Vqh`Q rdeQ`0*QUXlY%\YSYeCĘVaBܴJw\*'by*R*7em|Wb*^K*ϝKXKU,VqraKU*/VŞU P"*"nբJ-X{!BbUlDxU젥;2"._GQR6E2/U_my GE3jU@T#\mP_UF}@\ST"E *P#t3*'Jߨ*`*s߲:Qʞ'jNj{*HSWh 8FXSqQ8T?TSQԓTFH#TT˩lcCAOTSy*VSPQ*c+ PAC*=TTi&#Z*tJ[*u,4J@VT!*d M* prGQU@URQkU"*)ݠXZPyP*gUHoTV Db^K:ZSkFMū" 8kc*V?ʂX{*r{:(b*<S J6rrT,SwbSSg9tE<#+0T^`*lԖNJY*OR*VH׿T|?ʔT+P¦%H*.hK*UTJrT⣶®J*fJ*tϯPJ*+L;I@!+T%Tܪ%k@RaTiHIT &'T(]TՏ@** NҰG OSYͩ\ISYp*55p*FSS˩x8tRS^$h*Ƿ StlFUM TucT,WR4~47P* [HDSRaT,TRBRi; IJ*}!(h!BK*,V¦-a"ttIJ!]H=)T8T,#Ry THEê!IO$6TJRnU)A(d)H~H*] ܒM$fKG%ƙ-p#RY\P*ZH*/4p%񎒊xʢlV?4ꝑTnŋH*cQ ; *mr$ R*m B,MJ$e~9+ATPEj*m%V)~FJOS*7Pʻ鸐201*S4Sq1t0aT 1?0wSG%D>0X*>X*, ӗiX*1TƤ7c#FN(yTʋRqI"MJeTn|(ї^RRq,¦R*s8)dѶTXkKV-մx-Fr*Zr*NŠrJ:&qNŚSіSiJL961 66:ͩʩ8ǕS<T6y9Tȩۜ ͩ8~SaTwM@sT.OZA"*}#,FD6U:FTy>(IWT^ElPTyTgu*}YT!LP Tqx&Bd*a*IhO &*} 7ž*l&ҦPSeqWb V2%u J4%|R&UKIx""+-%"Aa*,>j\_LurMfܳMlk_cjMjS`9ʖ Q5U:2]0Ui(kekP֦*hhJkib}IT.LTID*qA'?Jg/ m*fhS=0T:TSeT߽H5UK^Shi*nwݨJxM5T1SS5U\MSŝ@Uz;QF*GL)Sx~SePi* 3fUZUa{\LWUT] ]U$AXump}Ը ub>k0*Jf S pWqWɵ\e\(qh,Op(q{VWG*򡫀%5[*c)EM*N\Rp[P 2UtWa޸$Kp}**.嵭amRbwVwm+UTwU}N\CCX{Bhzj\\/qަU\.e+tp ;\VU=ʘ7WIrkb`l[eIlYYFKlU%c>PUZVMIĘUb%7}@,(Krk޲ k*3âߝ#E^p``ׅUnVqJ`~2j~;m.lNHV[[!\!bJ [E:9)9*-ਫ|i{-ˌ\;1qW!g[umVViQ[wmCUcmU>9'*ְc捁sS[%GM,* qC~%}kXVaߓbO6U=V WؔUX&*VRIpYIX"rnh1*{KqgJj}P\7kXJw*i y*[|꧓U7 t**XgUe*Vy:UJU\V=_Uz[l3k/l** *;2ۯ7߶ 'F?ZbRh%V|+#/&' b[YaR[Yq^*+/%`(+a-ʊj ̊݌Bc:q12+ovkfbU $nY1(O ̊OfseV&̊yF`PV,DYYX(+-\ܪHɬ*JtaVƕ~}¬D/ \aV,lY.X*+3`7bde,ov#\ҜMPee$?^Zrcɬd0+ˑ8+#U2lgeA(aB^9Ί5"NZy &Vt_V{\?8+sZ2ʈB$>|~aIpVpV,Ynhg ,ʎvi:VZZ9/VĢV:"7"ipH+ _BSi a晐V\ulj\o V|#LE'y Z^jjj}Z+V hŀ4Kb+PmeA[,G|VXjm8;@[iRm܊܊3V2UonUneh[[ 8NnEKn͌p+-ox"VXtlm&(jZϗZlj%/,)!J/#4gUPie̥ )۵bsFZKq6VtV.";[̆V G $iNVZZ9UH+VAVZ!8TZPZq4(B{c+jTп, ؊ k, Kc+[^% =CZi4[iEiЅZ#Z񙃵L=؊whV[YD[qXh+Jw0]mb~[[B[1ǹ2ַV8[1#Y`+n+0؊M`+Qzqӿb+VfSԁX+ QZ+ka00)VvjkEke1)VVӵV#X+Z+Z+=VfUC&ʬPfZZ1+AH-6Bhs+j.J6[VPJ$x+VW譸BC+8ۂ+ORWLjpd+7+{;)pee9%R:λ>[QgaO[N[[7x+ [!vjo[,r1 \7ڂ+76r'-)% -  bCpe,PWN-xT"Դ+!+OW\q+ tu,CWoWpe@Oś+,H)W](nʑ;X={*B]v\pW2DWzqRpnp6 KF+] Y+Gp1rWlqU+WOT\pe<\Q\[cVp%[y6;[|TZPeWf:/b.6 acN[D6[[a z+ [q5x+{}"]Wn%܊~ V5G\q张<WF司$+e[+D+F+DeW&~P yysWF }*s;ox(^qvkǍb]ye_!^W H^xEUx'WzevkxŭW,E^9©C)x"YFUŽ +#)J ~Pt5J.Wy WzzeD, vx}ŋ|WzW(^!A_y^P-aWvňJ?O`Wf~ؕv哘Q+#]Aovő Yͮ%2W].v[uG?Joa2K =ҏ+QW #PBԕ&Vu{uŝUWt[]lZu]Z]* VuUWt+TW;p+p㭮XM= VW 8$%G+#s fW^Zv' t+tOEQ^A ]A]J]aOw%? w.]i#[x"ۅb庸+y஘b(ݕ2qW r]qNw@( qWzJ>ܕFxJᕷ$[`ʇs_y%+ҿxf`.\ ́WFO^aupWzRT#JtW6+{W6bE+n(/v P "{vȮDL=t߁brD]>lU]a{VW6iu|FܦBqQWo@WnKs\qҿ!d%(MƖܬ8Ien+잩2`qLTWxej+LDW]EW]w"++*2 bt pWV\[V{r[+낵⚊֊ JӵV kZQX&X+ i~ Z+T嶵m^֊\Z+\j=V)&2ijMj:%;k(~~^K4eR֗VDޤVV,_&m>q_ƈP?12??߫~\NwqZ?KeNv,envӲ =RN>bӲ_2-8A)iGUKbZQ }o)>(eL>nS}֭vq}iXJi? 2߸~@-(Ve($E㦊2c_lϝ,Z{,b^!}iYq')ef_ܶ,¼ڣ-rMkeaų@dgG~_eȁgGєϲߟ|[;ϲʷY~C"죏/>>6WET<>ڮgm٤x^o}eő=͢WUQgWgYO(e&},55g%xy`,4ŎR<>*AsBgwsYY%yr³ GQ<>*;<|kYC:>YGE](e,x\č(eO"JgQ,]yߘ³죗s䮏ReFT>uk a<tїᥳ6F,5Wꮎ|=}jMN>mZ:<8JgGn$Y곦βJ1Sg?<H,?AT>Yfk9ՏkteVjҨ, ;#VTmgG ˞f.2TZ\в^%̯2c8FҡiCBZa#3F0 Z̯/m9'=W)-g6WNqJ}L x[mi۵2-j?9rV̇iG: 27VOLbZ1>T٫ѷ9ŠNQNlsuZvq۝7yg_ qZ]V~,G!RNeeuF6܎bZ"&G2:)ev3iG~4E/sJt2}J^T"~TG7(?&2"2z2oy<NB\EeSY)ȶZ-,kf`G\iu/NV&ղeO5ߴz܃P-^9|ϮZA$*:Ej]eey׫>1kfaZh2-.q9le{UZ7ǔ2gA/OqT+evaJio|n]J|VEy/O}pG>K9s9r^)>2oJ4Ƒ‚ZRA-[eP˼Qejهތ̱WII-}ٔ2p莒Z뢨9ٛT|oyk6 ղP`jv`-g]a`4;T>g}6*e"Ra-bSXl=rP\ kװ0IV\zy2[p-K&\|NZ@>˼Z X9醲Z ׁ|O(efjAql#@]BQ-uTnsZfߛsNh-YJ`L}Ci-K(4\]&-ap:\˼ qZP]ֲ~Pi-SZJkY>Zh#yAko/Z.e]r.Z*R `{{[5|)eƑj.Z%e612SUzWPV˼jYnX-K(&Vqo-ƤZ`EぱOщjYP-Is&Q2CuB,s\QV˲e^2'ᕞS\˼/W5Qh-k $QZ2Ȉŵ u2zIDluZ*#WVńkI3P,"ײZk"2/ŵT@3uõ|ٟ;Cx-O7,el0whS^K49'2J*efsKke̡UZfl~Zuh-.SZ>R9᯾s릴*ejr'CZjpUFQ^2q2kYZ`~y-}l:2^?2O̕|XÍ2|⾜iy9OotTd-3︿#ksx4ZjΞ|s?\2ycV?Fj ŵ,!p-󗃼ՍײܚZgV ?¬̸{?kOsZ7pMq-pZwY#\ 2_s\˲$eBz}õFQ\dCT)eF.i3W%ej-cRLCS됑Zf}l4eq`Vg,eFsVGrMemZ*&R-1T )e>/je^5Ֆ%,+!Z,R|8| ˖8%Mi#,1H-C&Rl%c]IZ |RRK"dJ-1gevױ) jSX)#7+*/os&iE>/@-7A)fZ:2/"tey*y/P˼@aZPٶ́#A7pKE݊i]*ee'od B8-s٥+)eFTBqZ흖)ea9̮r̳P_; 23fM"ՏRWtaZgͿ 5f~R1-ni}K*έ9v+KX;Q)-=uiPUoq[usi2N>iYbZ̊@i;ZI)-=Gi1 Rú:pTf:9}9I Le>η-o:5\k!Aea2QMh2Z*_,.ٱBNh=M}-3XM9 PDl=Ο.W.F[;țc 8hh @Q0 hg;߸4Eb,s؇Re{9KeyYze imXL}gY,Rhy͙оmQ@|4nrWu;O+N 6O.r1a^xjp%iJ̌xNg ]@K_o]t{ 23 #~ t*C?O<+<ǝg}dk <SY;_&U6Zfy*lyQZ^w(-s Q_?-ɫg Z!XWfZgnYni9{~WOLiyiOJRfg7T(-GgXLOMVver d_ig\R $Rz2{(H-O`4#L'R$c"< kρY>}^jiOK-{}瑾Ejyz喜zbZ^kH-R2X-#jy&[ɡ7=IFbnZ&C&Vs{b$'%Gx'BErk<$W_s$2qpImDjy^uaUɨgeܡZ&Yi}cyC|+o{J:.tk=8Y1; `C-Z3NT)P%C(IgeZf#9բ|O.\e!jH-IJ-#Zjy|#"捑Z[)%̌§$ <|O/MO*H+hg#@vEh2d5:dϓ mhy~ Y <M?RÔ<:+eZ@g tb4:dX嵭嵫s±$@%⳼F,ρk>,1T:ϸ5&g}~Ȏ,SW2i+Y5639Wܓ9-9lb<<+6ˤcL6˦R nfy.1d;N=fygb6c,Kl)6KOf)&URVXٞX9!, X&%"rкT`N* z+wokVXN\ f#l[r$VƕX96' !VYPV4Y!;}AjDYLZAhRYX*2hvGZ"5iedp#&2 ViEci%(+tKZ1Oi%?LJ{dAhଘ勉bJ !B8+ ߇p,rJUD%!uGZ1=_heYVhePϸrC b6h@+V<XN`cHfV<'0+%:+YEg wuYLbAƣ/h%heVX) R R=3J`Y11Rgų[ge>`raV#ìx`VXXIr>'Np!rnYYY< uVY9⼏8+i꬐z4 qV^BΊ 2+ 2o<z$q#YϧY2_gY98+z:+LY1]g{JudॳQV; KQV>\ 6ʞF"+X,7YpZdDAV[Hy'QX VnZs+T*TFɋJ# /a+V#++l;rQf>Jbs +3KXr\@|J V63〒X!1jIl~/Or/+A+ֶJ)be%JhOVh欰"򧰢tb՛Š$ +痃"c,g +Z# * R~gq VX4VvM:b4Gnc5X96 .ìX "f%%=*+&BtbSb`VnˬbVȬ|>Z0+4fduJOdEvId^PL@VDV6d5* l'*+~mY rfnRY>Kd%Lʰ1+Jb +](VH9aV(aE3aŠHŠSlV3v| |}VWnҷѿ")rK`ESa%VcV` $Z{aX>V Xq*.z+>yVdXey|U_qL_*&W_^^ ^e8xd,W/tyi^堲^E\T^eW^W^EO^EB^1y*+`R+<'ŠZŠq=’(1CԗK|<dVVPX9:VV,r|G|kUTUUD8UU%WW9YU8WcƠblB`ep~XkJ`eXyz8ݿׯ VOFXk" /(7 +7ŠpC+/s+J +FV.& +VN*pVHP4J5r/bXce~Uc:1Vخc5woX4VRc#X7n; +{"+.EV"8|6 @V&!|?#h*܇Jk#AX!a$GXy,+ Ċ1R/"k%VȮXqbESbEZb1GbKoO @Xq3BbESbvCb>+CEb%#,f +FXQ(Y*dV ȊȊI1jPV>e%iYQdʪ|ҟbe ws$ViK\XN%ʽr$ V^zLZX!_ikAXaeFXn=VYLKWRWXht-U%yB뫰/?? !3x~xV*+Duvx3WaoxWbWyx IAël*2*N!UEU@dxUy=3D|d1ҺJݹ:XRE*U]J@ \HAeq(0m:plHm[eVq/O\* !*2U-IT XR` +sE0l`E`6`R?o`euZVEX~Z-ʁ.BF_eT,rq\eo*U(WZvp}clRU~*P*Ue {!i3#(C b *')*VNXS%Vd%vh`?UB0YYgk#w(U iYrd4*G?7BV!LY{ (v*ZiUԏBwU̴FV|Id6/GVIuVZŔġU(QVa6ն*Ul% CX+ra1E:q+U:˫$:e*A!J=3hKtBë.)x r@U^e|(|@U p`07`ޓ)f+ G0 +ەkXbPe79 !V,gX++cL@)b"IM9,˚5VXI+fWK|+ +$B V>aSNaKV,XVX1 _aSp7+s`lP+sza%&+F+@X> +cXiR~cm xb]+M1V4`B +&k 2ʰD+LJcEKcecTi>iM8&h=+J/G Se,QV0RYag_e 4=5Ȋ` KPVpVPXry:YVRNϞ+NVH]`*4QvVV5/VJXY/YRV+a ~VSX@_aejia:VƣAXxCX9[VD"VH>a' +Z#l(4WXQPX!=Š\+#8x(ܹ^VZ bUJWK?ae~(GBz+zVXXb )kߌ1B^*ʡ*B*'%b*W_%o+5 uV9l-S)i*AfaXb4A[}l#U^JGmU[l ͮVVi[HcU+DlJY\NTtڏ R$9U8= ]3Wb3 [BZjU J8+VrV8Y\UU^|ҋUX%U B H*i*.WUvXy*NWWITrlm:9Uj [egK|O$p+yNW/H*" {*C3+ $BEWqUh6 U/\>]>:UX*pU6\*tWqU،U9Ta9V97ؔ* Jq`,JN*)9 "$B*/BZFZɲ|l`*֬0!b(FZeAk[eԍ*DBUkp212mU\UIpۓV:khʙ,$[Z-UUl%eh*k0Z_ Z@#AV!3hpa]>sW*Uփk\[[A+NU[2tm*2)**~eqQ&"%E;J*FW!otu5*Ҿ*]%IlV^[ ]@Ux,*N=GWIGBU^[B^EG^MUh0KyRWgWq,"', V{r/+tr`+™s|g96+"x+lBV+¦+$B1+"ʞ Vv(;ŠF ++d@+ _0ŠP+&+{m+ԛ ~++  tnBkkqKaŽHVlGB X!J+b<`ň1 lc8{c%wX9Xq-XcT1VڎfXѵYُLRYVYqYfIΊDΊʇ=jQJV]Z!€B8+L6eV>wH8YppV(BYΥB&8++J ̊2+ctߋYфY0+uŬyU_O~KY ]DVj@%Qa r])Y|d*+uFp#eŶZ*+^WYbBSdTVB{/e /CwO9(+XkU<(!(+raJe ĩ-Qee[éQVyw?TZ6\eL;5_glqVnY٨~Yge$"fY$yX:6JY?fN1 aFYJl r}X@V(Y9%8;algX1!Oc5ۤImbc㼮J T>_?*êTI?U ZU%i?8n I򣪬(w*ʢ3{52j =vFUXUUHTU95GU~UUqf9Ue]*gʪ8UWU_<ʜ*}tU6)\W%r U!apXU1f2We⪬Ϸ3%xȸ*muUVE \Ժ*NnuUȪPbUX*PY@Yٰ**@Ue$ lGUSUQTU_UÏHUv% {>?J \O*S|I݆TȈ* H"@Q#^**Zd* RPŀ I|U8SY#?cʨ22 #X"Bv*T͌BɈ*{***D5EnEd)P;uUh5ͦJD~E cLe7UUUh6 #\*UTW pT56 U`J*.J\wH9T9G UHRS%, **"5U7 "/SlL,TUƛAU U}Ue@U C bWkUdGU U QUNiTy~T;h @1Uq'SV/VStX q*kZ*fRYM'7tJv4UFbTa?@SFUn ~P3DUe|T0U5J6P"<*tT&*OX?SrP y㩐3wSq^OT)O\Q|ξ驸6S z*xx*#tV Ta<TAPe=r ~*8+TэT{P{A TTy*_PYJp*7 9+N >M{Tl>ʍ Bh*f/MLmș@] zFNe(DU<Ul$>u*6TafQtDoPEA|RM{&jrW@U9U!0F7UnG/UD{Uk\RuINPU pUVXrx,҅>)Q/S4VLIT!bL;iX?J%U`T1\Rt>I(%U(TGRŢ Ic*yC/*6T1MS b6UPRgAQ&IULvUTY7DD"Tp_mFT[#5OQPT3 QRE-*f 0P0AT% 7UFATuU^TT\** `DkGT1G[QXQVT#XpzUuES4QRDEAKTB7wT9̂* 1*< bK@EUF@ThuD]D$"vHs%UT9^ Uv$UXU*W@G %J"8CІnH%U*<JU,AT7 Bۈ*F _0h1TTz{a*P煩;AR.s$Iv(͔TlbͿ7/IwFRY`T(0*;JDaTQQLGJS(uÒRR!5J|(GQ/b|- ݻT8GT؞JIP* J$s(X- )\aJ*8FRa% ]IR@*zvB* :wAR*'GHEFAHeRIŔLjpTQ!OWGE :*En 㨰rT.2Y)騰GeQQ Q[V8*Gb£A rc pbTX"ܧrsrb}%H,; ]4R ;BX; J='R6AJe̻PJ_)ٹT  $Bzp*#X߄¾K7= Th:U!Dmʩ DU4 0p*TprXЃ Ij*曨h4#"~I4)4FSh*W(wH*JSH*z4 #,>' _* {BT|P<5 أt4 Mx4s$AS;>ǙASPp*%T8r4 &9ϊqNSk8|9 G_Né(TE$9U%r8z*z*mSaBTVRdTWN8TM< xTT3= =S5 O=6tS~SYBS!9|<:/"Rw}T(.Oe< 8GR9xr*Vʩn E2V!/P:g YrS^u<)p Th8ʍ*RY~T*1sRgEYS!@$bQNŠx8 ©+ "+&BӑTx`kiP7L@KE{YKɳJ r$=,M1%rĚɋz SSiLELeS:Sٮb*P1 ̜ʜ`*EN_ALE}LEKOL𠘊(1ATT 5Tnn5ih*h*KʚX1Qs䈂8 SabB`*; Loәb*#1S/ LNKX*wRa9 X*jXH>J8T: GONަz*ռ<$ʩʩn8_yUV¨)BTɩM^OTx*WTNz*aJS9SP r*_8béoYrŒeb Z-nb*g%T^r fRKE~LNEBAN M9㩈;WP*t#PǸʽ [QKTdHHqf UTYd]{sT9n4IQPUTUOrǫU2xUZlTeXPAJ@UXPjUImJwApTMĐ*HC8JX+2xw`JHh UؓRE'ARť**VyB>OB:J}@PO.BRX*.b[Ke Ra1BTLESLN1'%Ʈ`:`*EQ35y26Jv`GS!(\WM%U2E 2r0JQ=TT\تgX0E(1gTN%`*FTGSTMK~T̙JģTρRSJRYrT ⱁRP*TRĖR9P*rR*k@0kIeŞAR@ H Rq/rR9TRQ>RAG3Fe4%a5dTGqT\Q!x sT\+'E9Ir<8*":*mb8*ՑRIT($Zw;ʒՋJt%A)-eC9.LrǡTJ[u(V P*3B \%K{)b)ThTy^K)u{cvSQɀSO|Dc^ܤƵXj*$LB΋Sͩ(rZNegAN*O4GS,奩RSQuSSq=:(ʵd\PS1ثb_ThXTܱTʠTNp"${(ȕRX*cRnJEK%%[C+?$)J*?ʝIC*HP*C(TT+f%ϩJlM)|ʽa@XO$2~ɒcԄP*+ŵTLdRtHKYTRRK>"T,SRy*sRcJhPr'e]JI(b &P*6yRIWLE1A|w~;4!FSI^WSPM`j*V: s%89r*VꩌBe /NFcr*fLʋA 2` ,r*<6~TRLe0 i0OTr6FRYɳWR!y Tݣ|bY U"*BU+3DT30TPZPSBT(PxTC0*~ ZcsJ{ P6N@yC?%]|J<OL=Ś"P4AO!Y=)6Oa>=xqCҀlǿqCSq<+R=E$`O${jç }>š >s&'BkSG)Rax4*sD!TzE̹b_] Vcԯ☬Bg . Q9Bxb샨|; FM@T#b *T Lݝʰ/ *DTQq8*E8*d IHu $ӁTrQT;ʹ%q]H MqTQ9>+qT,QG..88*QIDG_G>*' ^$<>D@Q9MԖGg;*OG:a@pTnjTh1uTHHVIP%W*Զ[% ^J*uuBRcDIQI֑T,VR J*쥎^ R@*'4BTlRr+zxgReqTHHeH K)!r먐?P&qT|9*nv@*R!~  RHe RQ( Q/B8*Pr\8**qT,IRHRR1=e 'B**TQn_De"*¤ *1"*!DTgDe Jr*쾎Cj*E%T\kQ=KIBCJ9!T>ܨ4T> C {tk8.hku`"GB q:*tHRIpT:$B *8*g5TV9 Pɹ +t PɡEO6V=EO=89S\ag)vO@*/3mN)C`Рf;:xKMI9SziB)dqr.)l2:rX9E9xK)S :ű^:Y:t6S> S "i<)bU~ʪ+b@K?e͈*"@ b >ev|ʘ)>Sh"S;ʧܻ*UV 'B'StStS꧐;~ b)ӇO_>E+B>p|SOq/2f |<CrVP<Be1 PTUP!cp/wo *#(0gUPO~< g*!1JSM*pS^ 9Wc)/ ~ y㧜+'ss<Ï)çOm)SӑOŔO1(>"z$SOa&:*B[S2 )ýS;wO)߉RmN1$BN9r`SS c̔ ;eHF &hSBP>t`S>8ǯr2Np)4=fOO9ŧl2-:aɧ4~ 9/?M?-GAIBzPqH@(wJC*{*x PщPPqPJT7< ŌJ@TP@e_3 8*-@?EP?ʹSv=$m^~d1kO!姤 {JJO;b?pY7dD>Z=zrz;S\Ml_;SЌfwStzJz,Bnڏm}vy, }vɯ)BG_Y]++3=HPk:oJS$dg78nJG lhyɕɰEԋ(3Wj:*D[prm3wJv"#ʺQ.RM~+n+u'Rۦ¯|+EۮʺWW`*!Xj0/F` ~*k~8,c!KRaO%J]r$䋣+5&ᱴR}c8+urD_76CEi}΁X* H:>yi RI,T+,__4JmqS_̣3"Km(phs_yN-ͯT'JG듫 ~NR#G:٭+{sG߯j~)kNu xWϑl&:%?Je>7Rc+cX3ߧZ,_u`$X|;.W`YX4P*)X=`8(ˌ,or`YlAQԑ b|ɐ{tp_r_yΓp,ԧˑ(}%+S&3Jۅ RWަ/JeR^Y$hTQ+98%WV+uJ-y5i"ԕ#$Ķ5ʞ}6WE!ʓԔ3} y#CWj8Ctr־?J E^Y>HWS:FPW}zI ^ *!\x{4^ zey*.F^ytt޵啚f弋D[g{R) Դ!2O%,?T6srcTQuW6rWj {V&Agb,е+7RϏ.^G^EG=B^iG^yr E^^+Ϥiz^ART"J`"^+?7J {@*;xJX8Wχ63{'N앉mbDWJ eрbԐpi|e]B,+uGi}e\Wj_"5W&+UlW=J?{ꅾR&?hiW֝p1J]9w¯"+uQ t+~փ9U¯TbW*H9%Sڟ(_!Z?J ¯/L痸)Gv +Zhi~k3Om J}^,<eV,c}¶4Rg4R̙i%;5AzQ),O_q(Aw^,5OFdd*KYͿo+5M)9/Le骚XeuXfS eا`>z"Xj"F{ާ W`p,fGjƇOIԉRs-iyƸXv"CdRR?̕G_4RQ/WE%##W 䫯8_&)+u uR4 +O&h?'B+& ȯ(R-s7__¯+v_1_y`<>WL_1&RPD+"Jg^mW掽bHS{eN+Iw蕵ܕpb97H+sk-+KVRvpW}®KRW+uEE Ro(ܑ`W>iv~MaW Ȯ$R3\RaW>aW^@ؕF^yV"v9+5I 2NC<+)MlH+5x |ܩW vzeuZ^ <+uJ=^?"FZi{@Jy6!MWj:97'W~?wW܅^1#2CJ gGOB\h+&6JD'LYz%啚t+_a +uɕd|/xηG^AtB<3z䕹f"9nWjRLpWL] $JԹ&rg[,Е:Rzn䵌{S+uO ʳ>xthmW{ChxeQ+& GZpF|?xWV$i-m,s_)+鯬#9l.O1e`{*JwN,Pk|=Jg0˶UF`BOX4XֱB#˜0,=t\IydO&Y,9{&,~`]'NCD"EXꑈ+Uzb$ኖ<[!XOɁsHgR7W21XfeN; ZXwH剟MXKb*K-2`5\ RgRx W IƳ*1X`y[<;[v`qK\}cTi1Xj%'2s'=a/bKbT6y,K%=-IB<- w|"$Y~HXM8j,CqI~q1G`}|,C>!Xjْ6˞D`Y,r$H2W}(Wl*,Xj3g,enl\1ɉ|__}Sa>tJ }2 bz5+l_g]7}eC_{K^r瀋^(,HRCWɖ^0Zz{Ă^" 2+@H( xx7Wjus^!Jr?_>p A<;CPZ^AzE@ze <;t(ٚS1J j㮘?NY4e+@]2ȱSƮR^/8tJ2%kPh ]O| \ZJ+E~)uyPj2Ia)\)d)[<^~u%O?9~z৐IR{Wԕą?N›6St)B!~dԎb=X>v)$3 dSƘ_zJt); :pNh4ĄN:7e3SR+rPR$bfxIE@Oe$StDO|%;trSBO|)I#vXb&zʓE%z}&iX=BҴbxJ'r|G1Z~V] S|QZS:S:p*Xc\#7r K)<$=E3 ACBqDP%J]3Q5Td􎠲#TV4$Z+04R>T> FMB*5T}H,w&H*ebD *fT+R.NG"xUP9VM*)TQVK*'ý >RU !T =J-w`VlVP:jʑ.cb25K 1T{*۪CyʑfC8PB&" RZWؓS&.ⶨ| <)y, mTWSjY bl<ÜS)'R!SHOY0b:xrJT"rrJ6#T9TaRHaH!S @* H\L!5@J*Ǘo]Jb)/MץT/ I(r!LJS*w` R1.+b!> U#<H:XIpH*IPRaSR I6UIHKRUID7BߝT ̐TX+|J^ E1B*G&y$ 2*녉r_RdT FA\¨0sQAFi9#H*R/'Ig =4NQ)eOj=7QTANTg!틓bUJKłP*c@@(J<~N(maR|m, RR@(t{I*+DKC*=hqT^K@XΤ2MGšFs|aTx,唀QR^vF=Ҍ=è|`-¨+8 b2*XE%ATϝGQ9O>M;`K**Dh 4ŀ†0*aTXGu,F%bQ1ŨYF-aTj{(*; KcAQCԹҌ:*up_GTqT ҎʓO1JIտL^aT0:J4R?TēTY!+TTR!GH_KdD,c|ETKh̓T\jh^Ke(,aTfRٳbaPNX*->Pil),R Y5mBH*#7QѴQ~"LPTl=" B%KQaRRT;y*vP)* !`;*Lw_J!-*^=*OT# PҮBCeHXg"*d9ԡXHWgW#\qo bO2Z}(*Fҹ~YDE`DQUG(*Vá(LraUQTnT:B-aXC<1T!Poqu\$1T]F)P_ʔJ| &T,PB{r&PqVmFPO+TΓA]TΆbXAe*B, r&ΝCAx*d, rx !TȩP[|F] "8<CeQC~ *S b cTYq^D&/okP>91T5; MPY~ET1 *xQ!`**uDQy0QT)eb 0*ǽtIQ{L 𣨐C?U(*|)*7?L/v0*!F ¨|J[Fes0*/(aTvQכQQ@QW(*WUTUQBQGz2kaTXȨlL`Tyo2*4dFFZ9~F $S2J͙ϼ(GŜvT=~E;*#);͑Hg R< *)PNL_-GP1t2k "*9 *@ *B-P$TL9;!TdJ)b@-oA̴Be*z'\_*OH= ]=*WԝQ R)MeQTy5 ldQy+"z"sdI@4 h#0 )㨜l訸5; FpTQm,!e JINR* JFTC RLׯkRRR)Kx-ORaKEKH"T䗄TDTH$kRi  PQ ~J`r(J G^M/P:{ 6JR9U_"TRy%eM+EӑTꂸDG\ITRSe2@*nWH7iTdMINJR۠-T*H0rO4|$'|IR6Ge%- Geɮ8*5Q?DJ-ਤiJ'?bk\WèTpIHK>QF2Q8*W:*֍DO"l@i>Aa[j !aGuT+I:*[ bF,ʓ@HTj?ZJ* }wTlWg@>8*#QCGdaϯ99,htTo]QR2mlqT*qTށy$K{,qTn*TpTSy:*k$qTQaDFeʨ\kdT(VE/EOrl*(*`?\. BTQEr;Ȟ;UI**מ EeɼPEŚ IWWQp{Ryvc r@*OXOH*ϝ_ʝW%IBΑ뗉b҂P(xZd rT.8*5ul:*5G=qTRFbL/boPRyk?TmhL[-kհTKek.RyP*Z*Sf2 Ke:R|\,k(K%P*#A #rAI&J|T@ MJEp(cdIl*[nRYTOR3!R*J}=JLJ<-+ʱT^F,ABJ`*Tr[iLiL5$x}Le80z{ih*u+~4UTTm,UR3u GT)DCъ*QeV*PTy;iQV(*Ӥ^Qe?VURT7D"i#B$@LUH/GPe8\*P8P9PPqw>/f;ʞIP$ʔUSOòDO"0<SS!fI؝*u[*cM,lUN*5K@P+aUIʾ[(*T% *c5bl' =5T@AXB"U֌Y*5#**Z|qLu3ʸ~* } _ʪLD T9zPc^ud3]F:U3xCUYn$=PEU\J*u*8 RT9ub<*^A*Rj*CbTM[.x2*3{*Wa`Ts]w*IbР*ʶUQ 1eO7*RUj4ҪJ9W*4U 2AURdP*G"4*& yF F1"MRtTJ*T9(Tq-^SeBH'7`HiĖ2TSUUf@UM UcUb=êT V%UAU3-GXdUvyX7eUv*42 7MTGjFUR'QU҅gP*-8P*j<)ym.T* `HGc@Td% ŌC"UņT9\T!JSzPT(G2%i9$*T[NmL*4YTŠ *AUl[9ʵclb*72TwVU&"7GU$ʳ˟WU* Y+=UoUy3aUkY*Te+]U|do8*YŀB' *3VYduU %\^**+ƣ 7;\ʪGªbZҌЬJW9V* *֖LJ9gRTIV1= YRef@VAfTVzBeUX(LWRe#rC=ZMwB\XuءUV[jlFIK7h)rZ_`ϏbJFh > +cet)Խ#Y*G ያ*uQRS~!Veh@٨*\QU9TE%VTF|*jTTŁT}=KgMAM6T1IS*$J(+*c'Lu LZ !U@%U>!U]y '4zTzgI>[T3QeN`DzATNLI:6KH4Uy* j*/TFU9'9rF*[pAUؾT^Q"*S.*wUL(9*B}ʴVU˰*vwU*b)MuUNL]ߎo*  [V/VEVKt@UdTUQU̻FUq&bRUEvTO.U9QU KBRex*TB࢘*Sw0U3cpCLeDU5s-Uª#I^e\W+^e]RHTu UUlɫ_0MUi7 ]ʳW|xT*6 ^Ŝ|d3Nk!Ul2@ WW0(*(RG" q݈UHW+L?V&BZ+VQ8`# S, _yȢW+*:W_!>upХV^e6xSXD_;㫬Ȅ**UU5{ܫU"K19n^ef*7򝽔tL]iq*.J*Z -^ëPD;ʹ*xTuGWUjr8q|y [e8R*tj[e&QU^D | )ct WٴpW۴gs itdqcp:_\eWKWQqbqLU;@_,U*/_E_Ɏn!J}XU$UTtU\W1*lɫ194%)_]EjG]B{tw郞""4bq*4Ur%M^㞬ƄWy-w*nʫh^ +W!SL_ͫXO3Ìë92Vu7^e,zCWar`**[m3*DWIF=x vJݔW4_}cUG+0U<^Qx8Ua]Dp$$͸X;Uy*#SP ʊU!\%(Yt!UHy1rUF߉oWa3M*9UbUYWqںyUi]]l*aE(*|B8*ikUFXP Mmë>;W=;U}'*^$}]*`3ro0(+ۍb`e+JE+U_:02t~U8w֨'U$]edljZ! Bu2}*lg\U]<e2{38p.UJ+rW7WY*WѼʸ (XM2ۅWaּ3 ̫08UVc^%cëL x^ͫ-tW1V *AnѾJ*hW ]%JtGW97\ |c]erᱮ⎘uP *g"]sU&QGJU*ұtq\2O4A r$ WYz1cUjWa;dhbq`砫VtwQdEW!ԺcUi]ŎuP-9eub@Vqi-ViZ+MW_hkU*<߰ҲJIM9 }@VqzYeF"Oq;bY0*sWpUrRĖ2B>qKx$2BvUN*WY{41*,Wa\0>)*7JB6*2trî5"Jx«+n"^%(xqW_rQW-x#iUv?UFo[4h*v쫬xv{ чU<2-+[:*ݪ6 J-*Դ. i0U&1Z*"ZeӚio`mZeD,ﴊҴuVq8U2^ߢLUlC,;1*~Z*cZŻVY;#J)hK**cUPu6ɶ eUF'M]J*}*ޑ1%*t06ʱV+\(w Wb%&VvqX9N0M.bXnaJpoLRMibefl6V0b ;Yd;aN W#+Zd Y1!deYNFVAʸ31+6VeX}l(2V_{rY+hb( 攙ovaf R))-rV:1Ȋ=FVF>u8[ʽPFVGǭY1odE-E BJQ!+ee"6l\eIJFYxA+(+챀2*|HY|TQa(5y1V`cjc~Xy}l+mx}}YTrXYVOnFUzX+FlarXqp+ͬ<d1+cfISY٘3gbpVƳ-U1PKRw}V,6Y8+JfVF> 1+Y.Y r -0+̬$fߘ aV; ì8e%;]ᥬ;8yVVt@W +Yn +!dRSBVqx  Y e!/̬̊8̊52zO}`N2K`VMʃ fex}hwYОS0+fųEaVf 0qVs"*7 Diie4XOmqs{ ZIhK+σ@ZqX?Ҋ#x`.VAZNڦV:okqx-Y+޶ke䖕`X+~ZI$Z! je|ZqQ+&mTZG䋤b֊YX+&kt.Zd1TaS+YyjO0+Xy8+y,$YaΊI;+RCb-+- D+ rZ7 eis'MDZY<${[FB8؊y dU[yZ7X-[؊ X bʾQ`+[!2 [2(4R }@֊[+V괵fkEhS+y:EduQ+3k5:ԊVTZ%l(Ҋ zk dVsVq5ЊJBGʦդ ZͪZ1} T Z샴yAZ%|V&WENw¢]liH+iŻ}ZZI,TU߃bi¦VN:VSS+lhj%SZs/jP)xK琵k%#kPUZʈV ԊPP+D$-jKVS S+gZѪsDP+ʄZvD$jeݪC8VnY+X+ZamleEv,7¼pRVdl%UsO"ZVV[ ¤[C [I_m@[&VTi+!mš*VV誡eBk#hKVEX59 a5qS Vjlqg[I{gmr kY0dk$֊'3l |Z|6ꖵX+,[1$eleD E/'+l%-N,H+L[ZqCahG\ C]$IC+ˡPzBԌܕ[f|r@ IYw\)+^r(+̬Yhs&Y!JfV@zu>g$ge>=rV2pVBYI!K bV2uR誾E xaV46apǪ}գB[+fVV`0+c*'DʨsfV6 4ʘ9a0+Ĭ< 9+5#JrhpMٕ7bWhŦ9V22tLsVkVa@ZʘqnfVF7Mu^-gV极VZǻ; (uҊ "xfinJ]I+ZfjhLZ7_'%6;l[rީV`kM&jEK+Ҋ͆Vd [yV<  leF[,ϑbƻڊak+*`Q+|DZ#AfI+1-Vhiez*MI+ GҊII+Πi3VpS4]͢JVz`hs@+IWWҊ 8$ЊG5V{ Cx[+V7%K\ް`c\VQ@hZ򩱕 ]؊ )JQ}X+1Zy2 bN_JY+kЂhk弴Fcke?JY~S+lj%wJ~DZ'I+ZY Y՞YoaV<RS6fVY!J;BUƞaVۘYaYkfsifV_hbV@Dͬ,ᬄYI 1 V]WrB+ Ze}$VXZϥ׳IcZ97L2zQ+ŖVvqI+cz{"i`fK+ّi%m Ẓ_~_=UK5:Rx\jR`HvZ{:QNR 䖚V^-xnٻ/$,H-hwS5XWxey*-,ŐRݙe<%Ct˘XF*eoHXԇSjj G@HC-hu ,1*PKL}sC-x(ZjYFԧj^o1,.N,fy ղN@ZJoe"sjYFw֑W+|Vrx6Y-xAbWb2j3; Zn}oͩ-#X3*Tx㮳Բ){uZ.2z>KEqX7M,ۢZxotoղVZoVK=Y*9o+]VKòt+A[-KJzV˲[2uY-T7QjYF^Ce[-+^~:VK\ZzF}qS-dKie>s-(VE\2z w6Dزtݨ-,c[ꈀ[ zZlYF=GᏧa%#rw3!RD[TwKlYBbKma6-Ysu+ie9*uZׁUIJ~SR*s#Z lnT+oi-uDZ-e̵LԻ[7dq-T-9iei?[Ԝ[~[`-_hOS |ZxHpٻ:גדzZ%|4Ryh_A͵L/Bq-SgQ\Kݠ*Eknk:1ZeRoRZ}ֽRy-Kq&:".ed"V$Hin-n[ lZP6زn[g`K= tzೌ ]:Y`Kj ,c(ԥe e5R%m% MW`K=0]ZQyt?HlGGq-&\K=okx_S\Os-ZCZK~Bk-\id e.ZG*nO˭;N~keZjȱMkLsR[Ԗm.(VU0REGZUom~ і.mN(F[jbo]E-5.;fl!TE7R//`-L7ү>puo'N-5{ɖz+YOR/n%L1-[[bKO{wZ[~qV9xk:Z9geZb2 -ĵ4fss-=R\2֌OSYi4ZKU=bZkYƘ=վCk-SPZK=w3RUUec-ӰEXKUQLn,#GFc-ՁU6Rդi]XK3 kT+\=1y"%c-=LXkonȡi?t3/>{}gaPXKkz9a-nZv֒ҶZŶZ1&ɣLV˴2 ejd,c .󥭖x*n77mpoY-ՋVK=bMj);l%,i9ui-=ysjr2-JkYhg?V;&/7ޅTsX|[Tz Dw42߶NT"lbVhLWZի)^RSnkBXK.4PE3͵Ls0Z@ eA(bWմR*Z1W9{\XKZ=AվA+RC3=|S]D=TbvzWXx?7=SN%ToJ /ZŶR}HZdI-=d9o5Z$д2 DTQ!jp/jɧZ2- R,{уZfR%~ވ%mTlZ%{2/"h'Eu­&NLKF0-iɠZThgظi0LTNKӐfZUV4𔥋w3NKtV;-En9UҒJK(-;yiu<)-Giri]D[iޯ~h% 0-ԸOeJKF(-*%~lf+-cK(!>w iHK}tRAQ)%]p3Ғc)- ÓҒJKծVZmF$e.FZHKfDAZRo}ִFKƥSHi*.JKZZiM.j[Ιi'0'C3-eTG3-S%SӒLKz-0-5d46z>k˗LK(ҒJK&0-i?TY9n.VT6긝pZ_WY0RýcvZz=C-(%@-U^/j^I6ԒiИvZj=9-uyi~x;-jI ~*=e#d;[v2.%i@-5{j4R\Yp$mWd&:uziILKwuB_ 25 bZzJBʪ%[iɌLp \B;-=RgeꮊjlTՒ){>Ĺ\.u[S.uEd29j鷑𖣋)KRKH-5yvLnCC B8Re(-ߖxLHZ%Z2Fj^NK-U_ZjɲRKݶ#%-H- zFjIRK7} ĊBj#W7rZj^CNK=BI] L!da1C-ܞq_K d eT7jREP-yl$B1K-5Q(scZلң:&#.LU Ԓ`E,NFԒI-I("ZRe2*ZNKТ\:40-|C̴x%G(-YBiiDό$Lx)-uyo-eho.-ukJKed ?g%0-,~:1-tP.اnFZR9v*/9hI(FK-7wDFK1Z綍iCFK"0ZWF\] 7zUW'RưDLK}Z[B*Ā2ŴLo1-ӀRLKi a**O։iILKUBaAZrhI^$FKYHђ!^aLs-i%CEȱo"Zr<8үv,{_VЎ&ZXHh黮4XBi]BHTm8%-uO+WH(L]ZCu<Z܀2UPLI-գ?B'Bв8sm(~t TO ВXQ"%-AqZ]^iDKb ZjևLjh %]y,eZhsK hI@KaZ 2ZaruXjXuDR:uă<:x1-4I:iE1-̵yLK"`Z g$"g8rܐ|D:(=fC/"0mg[o&Do2Z01cgBvVFIvVr+Y]*he<؛a2 \- `i+V!0YiaV K+?,x!Ҋ<#8 #biHZqN!Ҋ_Vv-0iYVfK+ZZتI>%x]2S$YZ9.YZdieV66O42+P+lM=_y{DTELD-Zq64JM(`VvRҊq,R[Zqs~7OVZq"JVV20@+'V"dq4 nVxZbdh@+bhzZy<]mh YX+1V'E0m[[NV;[9Vi, 5i%$`HZq"Nmi eҊ3JZoV&i1v}U/JXZZIҊ=,WC&;$NgZ;BwvLfjP4JeS+;6jP+,Z7ulL P+-jTxD`HZ4BvK+=FJ(,7 ֵ!i%ϖVނH+nVkh! |vVrJ;+ߑRѕw䬌 cꗳ2U6 qVbmY1(Ya2Ί0+`V8#̊3`VƬ&Lћ MdcX+槭XPR2&@ExzJMK4MKMDhФZ4*J21CCDkZ Rrb֊5`]VikiV Vʪ,#V&ie"riiϤ2K+!VZE*VAxFJ 4RuDL8Ԋ\S+6yS+FM6VB@Xi62!B,V܈CWkj𚩕}{V7@lijeo2jcy֊V^-&5eUs{awY+Kf1vZ©%$Z!MhV̂Zaj%KsP+yǙZ1Ok%X+6nwk9JsQ+Y"ZQ+N ,ԕ~V\jeXnܫ,VLZciRPS{H+V:fj%̇bZoJ~DnAlWP+ A/I+^9rlZ0leߩa+aMx؊GVx[1glx[ѢLl%O9)VXrY+qo;@BkbdV$Q@8 ome>G \q xʸ:(p%WrDF!J-jx+y+I[a(!o%^уK fpYW NY831!z eipeL 0B.(ʱ dSfseJ\a+ 泹\q A"Wf~nr??EZ+ls+\9is 6Wϰ%u+1W\q, 6WF ʾ\Qw! "1WvROY_̕ ~seeԢESͶ@Wte{]Α3Bz'a,و+N YtWp-$/k+GG|LĕhAs'X\qC #e b^pWL\qHŕW*XpiCr\ѺuĕT}+WdqŹM+f#%9U"0`+N@\;[ D_\ʈ%q\,^WX\bk7+Ix\$sW>,Wƚ[ #UN^\ 2fwe@8g:ȕ L8Ma J!oJMl8!pU+g'pe @ qW!VoW*@^xĕxC&W\c#\1$qś3X\]Ef#!\ #]\a+ ,!@\ㇷdPfoe"V,1{+ԋf8ފsl$o\qZf)\qSpe\o*SJmW #wfF`=/x+O$ B{xx+{+vdVsW{+B32?W&peB*"E l [vgVr[Awl%'lexऀ,6PU?> n%0 &z'#[af>[!N,uE[!#܊ MuB/[[qT`N|mlފ3l쭰+![e! mU2R7m%)h+@ BC6 ((<2 PdP[a+x+V[Ib4ʊ삷yVK[I'oe,[J{+[⭸{+b[Ů-$y+ jpF ؒqer5W qາWܟ:<0WFoFUbmqev,n? nejkV ^øNQ9d1(2(lZJi?܊`4AV̭2Z9VrxubڊxVа[-W0`+b@VXFZii8IZVNrXZOX 6 a>dmj{+ZTZqԊb#*!ìuSdoY;+3qV@VKl㲱 T ]ʢyclY7"c[@nD8cX+Xj0V̬t*3+lkfe`V&Bẅ1⼨ +YTdxT eneV++& 9⑝7(+YԔ%@YIc$d%?Ȋ+K鐱n웱tƊj+aħ➷C; +E[2jbnde|ZJ|XFQV̆=)+@VVtXDYɔJe`(+^f3 aV|fp DYԂbQʊ8^c +-=2|=loQi3BȊ3, +cd +F"de+Vm65܌0 (+(+[YYqv2vYYqx!(+ޮʊFY7J8˳(bML s:FVt^xC'05ife? 6fs(+~[YIJme^{hke%эVVP:'eT4#h$HYneqQV&'頾)+geh#+Ax/ +25c%c +yߍ3~jV?|2VX龃DA֓‚ 8X9IC:5MO Yb!VNmoe+ VjbE2䫈t2^bU66oWqfJuD #W&^yn^ōJ% SYAoW4)|[WaѾJuWI) r|⫌ddb a4bw$XE*GJrXV#`xlPo`+`NbW@W>мz#WY%Uƪj\ Ul7[%UVIEV.U]*GU>]N^t+&fC@ 7v⬶*䷮<-toi])bUNN*~XWa& SYU&;bg& U4^e?fWs^zWɾ*^b_4ʾKa}櫌ĪoV{(ۡ}h_aUI_|X} 0 "־*bWCIfVpEW]MW)d4 W!p;xS!h*d)E}wͫ*UHWI_]U՛u&DW ;BʱjUn x=xwͫ88 JRUi|W!xv32հxͫxv* .W9 8XJa徸o%32zV1XXV$\rcLȎ`V5Sp ^@4Hq)d2;-UvVi&\EfǟrhErc0挭Bsg[8Z_"Xm⪰]\bo쪄hW%YvU8*䪄]UqnXLU8Īx{;*82׬ʡ7*^$ bV%Yzo*eϔ@@U!UU1?DH1: ]\葫†*--W%|\\qUoWeLwIXw2F&UBv`;MU66lf*1f8հʦ*V> WqUT\O(;WgW7]$D*4V հʡy*cU^E`Um2[*6R,X(BHcd-od*A d:zU9 Yŷex*FU#3d'Ut_VqײJd _娴2Ӌ9wD| Y?aYŒd㱃fHV1 fY,iiE;*GVi-ਈU!^5J*\P0bβ ͓1*N独2tdWe8U{#8<UZ gZU>V(ش[Kʨ].*OMX/6ⷶi'Ui"V.sK،<|U<}R]7*kTJHRiZŤh眘VP7Z%U _Ǵ ;U4Ze9UʚVQ TdO|VV12MV!X7A"*sMxZe,hUU܌VB`kVXEV!İJm` 2iX626 òJ dU/״*(L%VyNi*yVaY%kUJ;-UUʢBlWż!J0"\}L7$ʽhhW%tXV% WJwG4.Y/UqJͪh*HU3ºPU6^LX۔X甘UqUઘٵȮB*dUWJJVUe2VTАΑpTWJ6U^fUد(ʵ)жYvU&#t\w鶫px*Z=8_ɮ LM\ݩ0 W%Q*2U4rUz\/wL UXeLMiWZUfU"ªmUШ*rPU]aVUحʪ/djTIАr<UeAU9 0zԼ*$YU> Uj*NΏFU&+AU1QoU *DUqX#heUIQ,RU]cUe*}4aL@UmP}U&xe]L9`wTrAUHFUX3R =*ދT%QFUM*":.Ԫ # V!ʰ 2*4ְ U *Z;7b-6eXcXe RﲊǴ&U<iYe,f:{QE8ddXVޱUvm{aYe,<oBDVe?*i#Z%H _UƎﴊ h Z%JV*eZv"Ye7aYwJvضEJd ^xðJ *N䪌UX|XveT>QaUR -*}0gW%U\6raWśUp쪰Wo\*ai*WUI9􂪰SPUq ¶ VU3*RUJjkUGU!wRUt7U'P8vUn^vU`㪰/]vUU]VL0 bUfU iVilX 2fK`$U訙UqiX8*NUZUq]'=31*ᳫ-*;#LrXUWδ]}U95rU{-ʾd'WW pp'W*#Tm}U| W l|lqliӡZyGUiZ%?iMUbpV̺V۶ʹP*]k[wm[egc\*6ʌ|e\%> Jy&« ZWD]>8;]JFW9yܼ SUʼvGWo]ë>4y"^ũUGͫ%xG*cUhtm@WbMֺ}㿠BW!:JX*FcUfgIW!<]eUtͺJ@*ۦ.uB[WJ-ћ3Bup(TP:R*LWxW9}嫌+f_yAUHWW9:#{TU WrcD*9g7Z_._%nG|?*q쫐2~%*EqV`ed`3  1l+0VXaebe!maJQ +LV,`c>+lg`+VjﹼS-r&V rGyZD`* ȭ ( lAV‚촬 +eJ!+cBW'deBm4r?=eP"!GJ2+c2VXaCdxzJ+fXI 9Xap#+DY 2*V{u++~[Y}adjgV2P9+mcg`g%G쬬|:CrVۻ^C+Zd#{@+G|LЊ ZZbxʭU@+& ' jVXZqҊ1NkScҊV4Z9Z̻r+VtZy\ʺaZ1pC+ZaIZјЊg x hšoJg,xA% 7[w?V:FJgF7 V"_9P+C j%%ES+lK+N˶CV rfhe_hC+MIxJĔZqYSn'djJb;֊ bDqߍ8l%[*VX|dWc+N3VT[fxhc+p܅a\е`+xT/[a`+llyV2Oh+?Ǥ­8qMJ5 VU+Qk+mEٜVb0mjEΊwYߋb w{3R;e Z*M9+;⬰gqV@!0g%D1$ vV|ogm$ur,d8J:;+d¬W#O)Y4?moOOĬӺ1^<>m̬D3+G}Yq(@ bgXvcj)S+ɗZq,AZ2/]@+:heRT_8pA+ dhŏhH+|$8D#Ҋ{Vʸ#v}J#[MJ$ S;+̊SϚ@+`L@+@lVV+*̌ҟZa/ZqOJg7ZqiPC+d5rZ1R{!WEFZŏ Zm`$gP;tSz`x+ƊY0VhLXF !VƊl‡aVcĬ{0tĬg ^q =pVY Xeg^hnET;+J/YI;YaC+2(PVgJY6VVH_}X0YYy;BV >Y!ƊA?+_|i+uabxp &VM6+`+I_3r)?a% Vvnb +V,x6ŠR"؍AXa+{ +SV2DX7 ˥ ʹk0baKcaR4OwL7+I{%DwjxMxׂ+ebX7+}m(+cYjevfV'fEVVv,>++9beC+DZـViu9B>ZZI YZ["ie r qZaUJ޼VXԊwјS#i1Vu2"hj)P+V<0Yl1/j%ojP+QXVj/A8 QDV HA0Bf VXԊ{@VŖV J&VLUб-JrqVގ2>G^Ί-0\ 8AhetT@+NZIhőV)2BRV{BT6E?%4ᬤ %;+<T鈘c{2ްRĬEYQVeRVYYՂBw6oFYq}GY>#+ +dD(+CY>JFV֋Y9,ـ%2: #+Q$YIna#+ gd9 AYq>>ʊw"EJWV'iie,rDV[ZI)#\`VV&I+=|V hr3V$O*] ?6+@+5bcVkpVYqb +dx,g͙Yq2jEYYq02]7aVaV,N̊)cű6Vsfc6Vȡ$&VXXn=+A;k6VV v+H#dŻLȊ`!+U1rY  +%EȊGAVvvb +ʊ/DY\azVV֑fۍԠ0Oiez a(VVǎRsh:+B JliGbUBoeGcrS(+ PV݋R}5*#%ix r1$@dO/ ȫHq\=6VNDX2VLXqƊbJ 5LS8X P T'(I+QQX)+f`e{Vu'`eQxs|zW+~V XHX~8u(? VHi5r˾XSV -+:XEa%Š7 CXdbb&YU +ڍk6GȊӷx + 'tY _mE12UY!3de8+OY0+Vhe1VV td% 7dX!%Ċ.VCDɀXa+Tyz9eB. &V\O+OŠa +)+Z/$ +l\= +{ycVX*I%8$ S|qOx> o|TjS ˣU_WqJ|Rͫ^% UCl^e,"pk ] *#1˸$tp'SڇVUHp1O5b~\)EU襃$U*dYVq (ʸ)tsNj2x] `sl0$*VŁBmm8_Ӷ 0*V2"sc[*)]T-*lf[֓⢰BZmk\e*ͭBCpU \I*%]e7|!]ś EWoqy߸Q#p](*"xڮC\ڦSf9nۛ}S>rUVV\a 䁑l_VIUal'΋m5.& Z%J*g Zd*L(=5hdU&Vn&*|Lʦ#68៮5 JfD9bôEh0ZņibZwJtds Vq#eZeyhQUFA8ȴx7Z%; VaZ*b0b [0*Vw* `d!*U2*32ɗ+|t`,{djt珃BV Ye6rԀ_W1YqwG^|^z_W_7ۿ%W|,YO?7ǯ_`Ͽ5~(njkwݟ~w?O+׽|n$K7kƸ{5#kc5q15]_Xp9B~]пF?~ o_~U=cUocj?~/G h1z_C둟?߯BM $]v%ǯCQ=Zq5yn_ԋj c| cVc{}^t ?Ppu njޫ?Sů>_d-]~d ^/Eه}dwF㲎ύWpa^G-ڌACLrxrty9{NW@ʮAYL,YXs_996J''\D̏o~^i}kLs>6cL|:\eO/G[<|G~STtLg|dUUʑ,UtLg|$gJoTicpuXee?*ˇ\?9GrՓ|$I9#9I>~^ebߤKO18zu+H>ELgtg:G+PRMgtjh:Grϫ~}/ϿQWEN#_~S#YTQ "#YTQ,(gH6V2*|h:#Y?ҊF}I_\i:JϹ#2U|d:*Y>2]Urd:*Y>2E,Y? ,ٱun#_٩StGTCY@5|d>K54ő,tG~^Uo4>F:C8J?*Y>2E,*Y92E,΢r䬟Yi#z\iO0|[-<Ɯ8_|i|nuhˡc^Oٍ3B_E~j[H:I=>y?k/ d>k 2u_=㗳8/dO}j^bŘ*XqLoGcέE|bkmgtV1Y}iu+qe:kv45"N?]],|6sjkLԌ2Y|[RO%h8~.~ݛ|4=z]sU..De.Bxm/Y}zz^oG:*c>P\Otƚ/1}+H<)g^=|_.m^OБp;-Y<2Yɑ/gb>_Q~nSAS#PυZs~gmm}/yy;kJo_#ogW|+>% ʷE.̆t^K?J_~*};&}J?>K(tf糀Χ9R#g{#_+|sA՜oӷW_F9qƻ9RґZd#og{~8~V.g⼦F{}'tk j6|"T ~9⣇cW]n]-Z|qd.IZ|;5ط7G:&GPO^vV叿=:5σ#UEOqv9*p~ d;w/VR5l> :l>ԲNrYצ |%刔xW1䷚b)Gn*#u =^ݑؿo}omlI,^G^`}f>:"Ht\jpaOH'<;wl0TwZwG:Ac{f~;#X{?oFm{ x#X=?_ӯs~]_Oq}so _t'Wv퟾9/;><ηO?Qu||}wօ>fmޫ^6Rc'>t|oۿ??{o~ן:xA.~~bd~v҇`yoJiY-e_7˯bl)9~/?.u}/4?zk{ CRiz_lT~F}N7iendstream endobj 527 0 obj << /Filter /FlateDecode /Length 8178 >> stream x]ˮ]q29'~xa"R2RI9||֪Uw ȳw~TcUu緗p?x,\zgЋś?{?+m/}Lˈ^mzͳkjrpJ:^ų_\!B=y}|cWR8zK?$|prCb|x6Gm\߿9gt+]sy!KZ~BDCo{닭 hW_o7IϞ3\ZmK aZ8-K˿_~n ˈ^6eQ/oŞmo-]^o2- } 2bBςį6o=݂!%"3ġeň.Ee:PmtΘqH cj1ll7Lo69[1$v㗒>bqqK)©ne2mp̑C$|l7BTt+l8+i[M$CvmrCwr [Ȧ.qlnC%QCskLh_Z fK$r R7r֛ZMpRw{b0X! r0m6D 5jz-`3L;#} Qaljc'bS8m`t5Y]CHaP&uC $ވ%8z\SD0Ch҈gcQTtlk`+K a,X3md_3n]stY /$NpA3 Icf#AB95C;\H C|/xVj UlX6QvȐ@̽H .)%#H+}NqfG3aiILpJ{fFp$4, M%]2 F*0+↉r)k]JhզV%LpJ儖)n6%lS!52$V+rwtԔVI%jJơul,[j`'PrGu)JN[j@rcҀOMjmNds'3]3?CO4}T;k:5DfV%@EK…^}Tkq؎:60 ug RP m6"i6z-u•;Pc{[(VیN KjF\ۙH/tUڮH.RzޕKJw Hɻ"w=]1>!1v;R*evLNY'w[q"nNԶ[@C>vgnRm6Ґѣef ̸bM1äf } 6m-duwe&c2boGD@/-—%в,狈F4 =|8n~|A(_>K;䙺,ϔm{=4vl>0`/-'J*9Tm'tT祌)OI 5@2BaHT,YJpuy:GEczģ&"69GdҊBK֊ЈpV (Q̗+A(># k} <~ rEs&FmѢ Us{6H7lj:M=ǁc1D1ҡKg8h0j0A8!?b!@Slb\D0k\ݘ$SY9h)HaZaR$R?@=vk@`($BfbϤl! d.}|:#bz/ik?CA0[ 1l9m33?>ܣHTq$m!2*D z,䪘> %>>SlE쭪gyhJ4϶E! 3$09>ţRb6qJ*g4jXY6s I҆ dǻ;>R- iffD%86zٌòTɣƦ]0SKFqj3w ceE9 Ь p`L LWle C縬>CE~)$!ft o)&j+PDxkbQh Ë}Gkn|aFC* QF+4)Ht, d>DV[+'V >꺣k4A^HK`yYo-< LS=A}[L>GM S*^*EQd9Sw1*1;I7޼勗_}_>[Tw(q(iбc!Lش)hm*lSƠ4]~4KvthbƤ) |2cp1O_o!PD7cke! 񱭬;[_J`*L/EUgwkkQlcwM|u2 8K偰KI Dߟef:s,iwM>R78T8>c]W&gt9Wow'S!]{wK䮚]nqs}?v}8vߩ g]L*uG HX)֘zv냀F*Ef,Y8YL1&Db/R ~ TI,qB`$zjTD/K,ͨ|+nj+C,_<sT#y+LnWV2kARYboEo'jVg(fOĩD!Xjs+ f!4LªgJ!rfzKYh ( 9!!J(CZC KuZE!*nXRg(Y>T řPbr*Uh>V4X.ɠt,tbM,~#[E\LT0 *VU{5i.Vb@.+=%Wm(e+vQ]Ҳ,2نUd3GlȗLl"-woub|ŇeKZ|8n_)fp;ߙѳ,|g_͇f ]' d dU<]oR06NIj|E6&OL{Vg%ظ^m|iF ?U%2,ÐX\f!AnL@'UޔIͭYv>фe=r []F|)Bm)bhJwYr.d HV dbJb" %G SoSD?kErBU'%LhG ye1G W47XK3d5fhtHn&*Re,)p=o[ndg Xe3CTF꽏Nv(zA1ϴ!*0D+f,۪F(Q*{C&@檴aճ&.0oȶ'j=}DV{ѫv!V}'/Z{zmnksL%hHQ/]ZgC\3ѱ7"w*ܕdk-EJD뽔-RDڴs^':>aC6 "{d抈q!n6M5wy,,v#|tg˖pв'8flDqc֚.w/J_[e*wLV{F><8^7j'W)-nvGIxnq3p^N/^l/jSi?S?}CB(YaF_G$ҽV\ oM^w=DTqHC>\=X_%Gևk##/}roǀ( E+OrBafGYnHhV ZjdME7SbHS@HY;l'(ÑskHӬw+¶:VnHr' ^M<|\xvs 2iAcd;4\đ׹Pz|6.΁Ʃmn5pVy dFC"!ngm\<FƕEO,̎ MX$7 hꀟ]' t8gងH{eٱOupl8Nc_Gct>Q8hTU2|:RMCjUΤټDuģ94֦7$" crp+۰;#V쪒~,oe Q@0'>UUe`BU5de1]w2|հ2֕ &uvڎ5L!C/죚0|TSf z"mΩM"nH pSQU?EOUXٗǬt#昀QQ3G3 ?DfQ.="ϓSbʼn0P0KҎWꚯ0+V)\뼶2 unhC]L5uN(ʇ P]vJqv!"`dL>gG䢅5.A`" ˧LiL%Ogcn ^ LAǘ:Q2V[wI^؈٣A2moE6JFv@ڎ9V*ư/mcKӀV'6sq)vtitwHZOHjZN tXWrdC7g//UQaǴLů%p*5fwh2؏=Kuxr᠚gyy"]tF Uˣw=DER+Lx@G簵6YC-@a\q*tgl]u{,N<#:qۤJ/{oGt4ɀd|V9B":1at!"/UF,,3 b1,qƔSluƔƟcJqƴ9eZ;x0Er;S%”D"LY/c!qHȴ+r8͞Z:Gi haZk'a#aZ0ezNVuwi%'!(uFS~CDF,:")/e0mt$FR8e{ŌyXss?l܁řujL鰦FhΩqLLgni^渣L06$w2[j2#r=ej&d[ŘHgL&ST77hgL=`=cJwF3ftl1֒kѧ{ΘZ`L[tRM]Q0cUSeS]pV3߫? =RmS@B/87mlw >`8zdʂg6ky3+@nȲ~ Ygd,aL$el6#c˻ey~ofD#%~"+m4ZO #g1#?wq*8(P3 uڪM)ll) (q8 |R|VS2"-QgUʀsgqGZ:GYHj#Zr_bW=Jt;kV=u-{47Nn4Q; Vh[uVh< pPԨ]3M N(F-6F"\qv'`Q@QԨ]QuQ)D((VQ@rpj4E]pR@M)N^4hDiF[Ԩ%_b(uFuy"DQ@VQ uFN~ so:un*pnrvjԶqj_hU3 j]Gh%K;5 PF1 B-NGJ˨Q4m)N)>_Njd$D&^#h:qjԊD:7xcNlqysŲ7 ӆwx b4shOĨ\xQ.Fh\37DUˈMnfh rbd17T)S[S'5xK?~{5_vjeOԨUF{A85ɉrj4qjH(ǩQ Ƀ;FƝRQs]$hh%bX5=~q԰_`Q +4vv4s.ThMR^w vs"GaVgf87 `N&V݄Q+vn߲ܨ]UZ9V>c + 22~69#}U)降nch B?z9KY2%J~EJCiǷdQV~Y??'pe iWLi$Õl<釿nW_nG/u^><|59ɷ9~?bWk'qؿ|Q߼~e_~^mysgߨm~.o{Mwwbk}߾mbȕ7KzҘ?o^=Ag nЬv¼Xw+. :}U^ba'nDervik9,nvh[Pendstream endobj 528 0 obj << /Filter /FlateDecode /Length 4258 >> stream x[_ ߯C18&q? AE+ zv׍g̊uXmLeV9:~dp~bky?V<0wO 0~}zzVǣ*ic/}w:, ~xj^2EėHGo!"{~1'Na"A|Nx/Cq$/>n_OR.zɷ@Gop5D vaaiKSiJ4Q9})ӷP 6O~D,8!f~UAOogɒ\x{l&rPa7!n>lom=Yc՞vNzOC3 vegX7h-^ *- XfFBp]rH4@Q(8''$2% /q.؅-Ar\ ;hFQTux fؚ dk$ȩ[MG:Qs@[0Grݥ"L`bOlLyJ3(;ɥx9&7tsX` ,g(s lAf. f:cI=vw7 !:zRbNA|s w/>s7Wd5X(D,->XyݎQEO T@@ $oࡃܔ1= %94&?̏hhq`EQ*r<ۥP4HgD_B è7.  Zan ߿Ǟ8eD |K\y#D98:rh)#$y5ԇ sesS$Dn 4kw7XNV2C+,zJ&vpbRաnOXiܸЩ-;)M Dv錔j.AMQ/8c~:]W6 H_TM(灹kZ%!fYm oKb 8j~rG̾]٭_ιw0ô<%ڙZAd } Ht1iƛ%y\F f |4|NvAl]?P-;~Y$ZjDTZ2NX\ ;qvcϹw jjl|=Q?5!ڝ*:_Q;dX^ 9u>dVbNU9>ᤚ{Jp>eu j5'%: |U25 > T=_jYGf2 ӣw~\oynEHWj R%PpٶD/6up$_{eZl/co1e` Ɓ{to2Y ^`o43~Vc ;K.劖➌:SO>Wgպdwtbtr$xchK!_Gb@MvKm{@܌{T^~OKE…qp2ZJT<0Y"B뜞c9Kqٵ),GP4KEi*,$yik8Ob[ XC%nDУJKffPt93gTf=xҲPﴎ.mǛn=8sP7B3,9B : { aPqEᐞ }EJ{{h6PWٱdD/B1fu笋K;rte8Ƌ^3%$R'I2߯$@܉)+p軱sTQY\z쎂#3#f:K<)mv?׹TbS4ݿqʝ%-2'ƲA[ JD7rvKÒˍeqm23_N[%2@̕wsZ r+ɰx/[GYIQ\XsŽ4` ƏN; He7 ^Բ ̓pŇRgU3 aSC>0~墛DuaSOrF/#rc@с,.;p2v&J311wk}QO)F9uNHvf6݉Q~KBZ7jyI/օr%/ {F5J8rXS0YՎ%D{WXuVqOh aH£QRf=d! ˖>nQku{ܶ[{\eR?]wmݘd!0,[PN7RrU+*Uݕ0e<]e085$/&jôP[~ebW PLI88DY.1,Xm39aK@i"pӨ2ZHUaۏ\0l}(!u<-B?S@%^4z8eFzg{:5pƨM'?8?pUQ*tpg Qܽ+[RcbTļa]  =Ry&Wpoy^/,f9bZn 9r=lD> stream x]O0 ǂXҡU 8QC$@w}wYv˕]_:6&?G$ip,ôMqAux8UFRmcm+͟z9s[ٿ+9K7SiZL!`2S8endstream endobj 530 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 332 >> stream xcd`ab`dd74 JM/I, f!CL<<,{o$={ #cxz~s~AeQfzF.THTpSJL//THKQS/ f*h)$f$))F(+k꡻ /,/I-KI+)6d```Tg`b`bdd ˾*p?nv.WVUUY!> stream x]1 E{N Dơ1E2$uq( jgY5Eg)?Fx,}i\pA=FQ4W_ Э|o,Z\`q002sF`йBR\ԧҰ"'ԆE3ahXJYyl+aI )9E^}Dc$ h`endstream endobj 532 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 766 >> stream x]ILaQ .IFD[DFHoGC; >~h 8MTEAbK j,&ha߫HTPSVq$M Jeڋ6pU]e.ƚj>tYUK M؊+j~gВRbձcY #E0`ko!xiiE4ج:{Dq)^yzgdǾU5uȫDyaLO%ߵB5@]]3#))ݍpe~#=W} DJTI4OwDħA3D6=2}2qrme"x0);S4aހ"8=ֺe΅n:8 N*W#@6UĄ a2P)^&,Dw~bZ:Yf3YffOP 6i4}BOA/_1endstream endobj 533 0 obj << /Filter /FlateDecode /Length 185 >> stream x]= wN ?lKthU1 B޾`l^%q/H:o"l5 fIRt:^T llZ=GM5 d\J]j5y[$*cW}A!Q:_-cKs_'L)#f/r_Xendstream endobj 534 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 905 >> stream x]oL[eR{e^ ٦^FL\1*d8KpuBQzJm ,QPH4aK>lₚȲ }rh$'9χ JL@Dk04e6hZ\(HUu%> Djkr5יlNVΌ|v3"9[YCc [Yq}kdkLlykNL+{EWݑS;BHgR! =(AP"*E$N7 ݘO;*D W v/Im*o&4 F%&ڨ?BD|%"L^6[Sx S^c?;ۇq4**mr|Z_m8?2mr> stream xY[~_9NS p VPp%jECeA~{43w[?>8s|:g>͋ b~74ft󯗳?c%Px۬ N%.}ozc*[0*# =f1LQ-4D}S"~h=(M@Utxo BBMD3]߻ @?f7ΉhtCɂLE) R2+5?&H QߟXĨ2* UC%!IPׇ)Ѱuu4/ X4;=YrB)=FVbT ~ GɚuL:swP`̀ B/wR*]]m7ӰK̂Ả۪~<м+BGfYe#q x9w>ő'Ehi_;`}iъLtէso#Ipc_K.Efp-J9S] wmOCS~'\׌7*Ci%O"8ڶ]>U]ScZyq&9- i5X #'"zy{8)XvEN f U) *n_Xa0VM!JYp}Wm㏶;Q`@k.< D.Eoe ^?/XJr:_غv;%o~S lԺ%yzLJѮj(<ȁϷ51e.tҮ*)9}x mC r~߄s8.Zn˛Oxub623B/ZZ^^xsnđ*&Gk]}}@MPH:J8:L T9jvU'g"x䲍gjxD6ѹ^"`d`hj8Om"3(DV-zO% e|t6`P(ڃ ji6KДL`c2×lI\?#3+j6Ҥ:*t7^C`dKaĭggC2۸B81%D[bP]krt\ CZaOXvTz&Kyhe~*]_MD廟^_(r)B(]}cq u]38 $;U*WУ:u:Xs)ֻl[f])C9MLvM,Ea0'J3FP-)?āk$,XOTG[?!gʡ׮=>0~݂WS7gA i"&뙔,&u?4}#k mSpZוDvPtbifZɸ(dq *rB̈́_\9:*$X j^  Oe4(CqF1ƌ0ìc 8/`5 Z`D<# 3 9pEr$! ;.2RjHb`8BAgFIؑ6a2&> ?IBW1],PM5yhae$*P4Pi ^Xꅬiɟ&OR_3D>JbB ِGl5p :^7KE>CAv|v#_gSC# pNi vv.$|ߏCErnh3޹j(EaO,t K M{<yF|A&yS[u՟i6QDEbM8WuFMRM:|:@]9mԮWh[ "9z@u ,/u{Gi٤4u7UntWT).?{{ڸ %;kF#4mlws\LF2"Cl/ foTZIѩsrث1wī[9\cpk@`OnBsYIufn>.%' Ǚ}s_Cú]y}rd?S>P+@dY6?iqaڏ,<},q[\f_PjiSO"\0b7쯺a<[h}go)OApjg-Ӷ^]\b}ThU8T,QMUǠågx2+1ՌyCԂV埚ualz>qBi-N lUR>aO $nI)n*\f'mD&uwմe qڕ4B[WW6 +4> stream xK/K7 ΌG>m4<0<d%TjAHf\h!wdF0u˯u/N?Z=?'6OƯ{?o?/m9f?Gqy_U}/Ow_ϵD㩟T?K?u}9a?my8~2zw}î[o皿?^W8d>NƺKƺxvq?d?so繛̍?K󧋼 /yNru{yIg72~3EΣ\?s{-ӿ`/x~NlzuBxXAz %pr36PY?4d⯮ W`L,vtNd/׿=ʉ?N i!uzH dWvw}3:4\! 0`L?m>^1.ɊEbϗ_2'!Ҟ:9+-jAvK/#Bn['ZHZ8y{@#oV׺d=$xٵN.> mAX7bk?GXVuY7 Xݝ\5+qCG&Ey;z>Nj-VkizNﵖɍX;ֱVz|k&ZZ܊Iډ/Np"XKdr\tr¿ܼ6'@\Z_U֖gx\ܛZ`Ҭ=t܏&~iByyﵨZDkAO) &vwqv #eRN8ZKqz1/I;W{5^ʠQ:hD佞F"ީUgxzH羻ouqFH`yݏp<{E>-Ϗ!<=$x$|`x-X35z:Iۚ1h_'X}o$ߕ_ <9Su=N$] oIe d{4z\6g5ũ]{DžW#.nĤD6$~DX8X1:xk#ϋMR_=x>D8}i`.X7ȃmEpsoȅb}d XE{ZSm6.O+mYx@0]vZ ߓ >'l"[ƺ/^huܷ'o^x]F*mռI^*ߵ\xuߎv& y7Cjǚ $ydA1'Bke$b|/rqhȍڹvk;>ÿZڷ|[F(^ YȋcG/<=D^+^b?? WڰsVe˗SMdm gc_A@XƇoBb;|xq<ڇdUoyB U v )X)z:ֵN!?2/r#XGݶRLGCzȋ $&'gf鎓@!}f[!v?H'ɅBվׁBĺ5PPȃ'569ϸխ=g{T!˵W!ե=7wiaa샫nZ>=qlݶ^N1ܞ?1?^_+js}b*Zcp=%Nxi5ܬ^Cغu+;@:Lz:L=i yNxyJEs* ۾ԫE&SSKo__٫E: 1>i}]oBi_k:T/2++/SzEF810.y%AhkUk5a= 5 uE. &`m Z}4ՙ/`eWB\؝A^TP^72:jv}An _Yk 7_kVeqjD߆DU XHp jA4㞨Ak(TN@ZX򊲓5Ux W},(g;εy.?XԿ\K鱓ܨAUD :"6Q8;o\7#*x/NX\F o=8+mΎryBbl:P_E&Z6ײ1qZ&_Z,}X]ǤSebdz՗e@Ӛ\$_|J-r ;#֕$Xu'; "va$텩Cq4T6^s\(K 2AEġ VHtȅ It<^vɲױ6U_c`ZF^YJ|^"7;[,Ώ$d2[{UɷZR\C"gQ$WLs/!HIu($Z΂ĒDbX:-6r t-I-!Ib#$~h RTP"}hL,zw !}A%s  DBD%_T0PQIL)E*ۦ!I!TTҿ E[*M#T2PHSI&!ȩd~χoB! Q%}HƅJ2 dO@!X}&jU9ׇoB!Y؇oB!uY!T}&d+jJw\%P*i[lHWbCrB()&V2 PYIff,J&FB8SI T2=CcDpԨYJJdlƬ (V%m tU2|Bap|Cdn [%}'4:W*i[lhJņ D`%m44YX M()JdnF* e%}{4Y QJƖkjVҶB㭕-64&[Gi+֡Jkj7+[lhņ r%c[xJږPummk>0wM(Z~[THy;Oҷ#ד-*r >H'[B#I-*rr?HL'[B.AsqIƶw{߹$[B. I$-H$s;\"~&amif[FQ=5HǛwm8+DoQQ=GDQTo"2Xy#m=[Fqe5Ě痴-*k:odnEu{qq!1w~)^3NzܴE$:8i W`SnV;^DN%.+ÚBX Dr!JD§&7r-XLUlɇvs8⊳`# TM1{-j/6V:][`lnv,,WAE*E PhPEm[:,|7[aݶc^sXO}Xm-k +Oa $9eCV`<Zꉘ@邱O9ɨb Ahlc{yC;qaǮxevlυ:6ds6aD141ɔMm>"Tڞ|]LS;ʃI]QۥϏskjۨk6'Қ&A'?`vΎkN/4M`~sexmox{ym閝)qI=Ƈ껛p/ּ% c3-jCXb'\Rq\g%'0'qҲJKFD8(qC+$@$T㔫&;R1CCaY5:FJ1Pꐱ.9Xh !:PbY6$hX'xa(Ug`5 vkVJc挰B_j#rɁ"ȤKTC@YxP(Ż [*3*W(⻇ʯ +4)޲@Ȼ\qα[ ×B2 b3#(Y aZAsеY^j,; q 9HcSXz.ƕo244`X@[$0+8 ӖNd4V:|o] Sj";b&M|Lslc4:e(#J=IEETϜ }6A7M]? Em-_ۜ~)FVېyڦn d=8-mup6H\ v #zM%_zc"qpL]( WPdlr!Xْc }Ї-}S| `$4ؖл:mw0VuG۔92)umᯨ-7ut?8PwxNDN)?I- Vn}2QDd4~4Aw\[JYcHc]^! "!+iEc 8`zXh¾04%_v8!-Ѷ͌ ;ڰMvM?M8b.H[sȤ2 J)&U< >9v@ċU;VMjhƎ4ǎ tq`3Įd;굚4fMF:xhvrzpH/'N N37':GSQi#ޚ?2M`AZ)m#'-rZ/ ^BSֽxh{ćFGiB;%bW3%ݽ߂ax#t$ F Нs.?Co*K%O,t|kp$4R7nFhICo9Bthp4sw`C#0lC!za}0"r`20P2*~- ϋ躆/Ftx;#stDW:^ItĕLD7$Hܳ$A'9$b,0bU$9b>H<I$$$zNijD{ AbH%H?ID%2$$ZĒdnKoXh Oe>HI$ѮD;Sؽ-6rL2I` 7I>ok'ྞ@[H(H,#Hd"I&$ʌDDVea0S+\ [`DXB&QZHHu(.seՅ0.ye0Oƒ@8*5 a$+-(ܓDgBx~ gBqVK\!<rlAgBZj&At-BxMn!<'ѹE^It/dnA$*C!Ƕo~Q@f0DRR@۞(ªN!$QuQe*dn[FTUH҉rm[FTؒ W҉%QůET [: Q,oaBND4*-l!sK'T-UJƖN\+Ε-6Tdl H^I +[:}!,WҷP}e(JOQ{mP裸Ez0OSI {*[>Q!l-UҷC-JOjUҷP[EsI«d[>va%m'vd|C,{;Z܂BMB؇o-(.JƖO]ԕ4j郰]t'QoW2CBo4-($M(JOHQohPnQl@UG%m3dlT&PRI&hd~7PBL%P M(BS?oBʡB(-}"$JoBRB"TUoBBતU2 EɒHrV&\+Jw\%Pخ *i[lHWbCB!"V2 $PXIff,JJR|&*UI4tUHۂ" [>C`I4(VH8+dnD %l[!}'bF. i[l<^!cKٿBڶia!c'b1 [lc!s'b|2F, -$ -dlf$mK(r5b#Gblm9}dnfNoF '[lqNN22m ET'ѶsNn'h߄ǹEEΏ$}:rV=ܢ"gރ\|%9_ڢ",% d;o ?dl{ǹA%限dnQ Až!IyH"'$߷DM(ұ"ItH2"4$:m8oQq![Fq*n&$c(%H8$i[TKe^9-*S2! B蕓D^9+!Wμ7Er9ngN0̻!~>f%NP!]X HJD|?5>ğJ?`5_1>Ŀa\y>WJ|[ʝ"XAw%V8cI+rU_F"o>GNrq9nnC2O+]v<' O9`ޒ O٥`;9[viڶ #n:NZ/^ L8kCL` "|(2.EN7+g^΃xN` ܊g:rQ'o5Ys9xB0uB+NnZxf:;bA~-H՝\L /iP 2G'8IxLqs1&.<8[D .>- 66.REIJ9 ,,I3E´+]E8' Ĵq/I8@)"Z)veS&L bjlig\ YdA䩮:Ӣ:-rqv ^C=Z 9(5eJN츔i8@d?r@zy@W7 WF!K3pw[˯‹p _;ajzR2o4(I9[1N/ :TsyADI*UW_P4.rr(G_4i+RS mJ>#}( ,Q>d ߋ*~CnI`!qQȋH˘%a}kKBHAտ"&'_ A"yHʵ-7$ddXxɘVk}|3$IyEy%)ϴH>"ZD LXhJ,HwI&u3b#$Z :^$ i[lľRB?%)'Flp,$X$v M{w `DIB!L$ aD I!-Y2|ܧGIC<+rBœ.H}-0"},)f!LC(U-o ]dI9BFDО(/M74tb(c4-q$)oDL2=#&hʨ1$ i[P`T!c'b* i[P,W!s'b&, [>g-9$u+oD%X]!m+dlS~I4 XH6(,dlDL&&b!},dnD S&e!}{bn%1d<ߓ]Αrl󨅴-B1D3mYBkLo-oÅ-6b 9F ZsEҶ"ƫ Ѷsqо Eۏs&OBuz!sO!BPİ}!9$-H {߹  3$c;ν\|-H$sj@RDPTaUB`lq|j^!Ҷ4`-f${cAR;Dk{c"ҷf#"s(i I16[FQ RHHۢ-.$EmQAk[FAk$֩:Tkb_CR,nZNJv+}ֱx%)Ft*6>]wܩJp7|u @L$`8khU+!jr JF4SJp0U 'O],%#DT.U_ tթ?b52>:N޺WTE,46JT`DNnpӬk%| ] 6q#FDɀNvXCJM) àodM/BZ~\~t9#'峧.BL "げL/4RP#taꍑJw+w6 OǣYFh54ޞyn:UTUd]X~guź:+WVi^ۃ\bi1ԃJ֌o@uwPz **Ó1pa2׉,gNNkZ 57#T;I&/ұ͕F4->0kֻ gyjg kkŠAǜ]Hx wTYO2ŋ{Zei]Xk|^){mVIT4D6I*,S *>69"Ūm]rX 7jYT?/zs~^[Rm8\譃%"l!_ N~g;\GF\%NgDX8o~r>rP!)Jc[2's}y_|9|Vg|a|*Qw//msЁj!vL5Cfk#uj@5MM>uWkg [;S\;NnF&G$uH>鴃nCv_%ǧar9L?v/=iX=| vJ-9 9@ZٔmvH &$hZxi 6Gl-#u&fL;& 4A2Tΰ94J 6+n3Ԉw5~j75{*DU@3෦up?h3n 5 P#C.w 5Ү!]'pá] }:p !lK%Hd3TH_%m=S:i7'BbCRvQ)9[20bܦ PՎ#ZH:zǎ#8H!u"2GAJ#b|Xj} UMF0 .哑8P@U DVGaP3\0I}KC͘R63x<M.T٭즔p~h 9!|#yv }?:.8PڳA*!%G؃UI>>9n.F[0G(j\HȏG-:Z: @5tbU&B.; T5I\ںU(>mvg V=T )a[a8ԲV7եTLխU[0/ee4z׳PkU/TPزJL.Dc{ϱoN}:7CFQ@[D_ھIh~rf9lut''Sm1~ -+(46b_:sK-1$/-.vca@EL]RhO[+ e\QI-0y-yClN8[ B#^~ ,s`tॢ A }M:أEv9h ;kq2i:㔹sLp+`h;gu[ã3Fp5gnXbNΫ g=y ލ l|b~ i0b & 1}kJa$v9joͭp 0@cD]be2(pBXg@'oa`8a  Ne}0ppɃ 2Pw0" ~FhsC ;ņF5C J~ t LNK#MVkvD;6=:EHF$a5#}XD?lMB?'1{P&JfE"pb DT2`ta ScB"{ nQ2TpPǸБp6D%}'(JڶuR"CBدm>-P*֡VU%s'*mJU2P.:yc'5mohYeH+[PZmPSÅ\ 5 aF }6+ۙN$WҶ|B]Jq_- PPI i! ^ .*|(my$"mӐҤQ*߄"T-BPT2 Ez 角M(B;TEo\JM(BTQo\M(BU5\oBZJ7MY*߄"kPVInd|BI^%m I*[lH"XUoBjJ7+ߌ"䓕\ߌ"dPYBC$RVҾGK+\3TPZIBCJRBm%Q(B \•oFBL}3P8W2AtQW . +[TH]EߕoJJBz%R+i[TH[_ضi M)b=XA!=Sadn[F!h\M)b좒cwLvT0>D Cdl˛Y K%OL%s'4St*[>yJghhU2|BJI4TIۂBP-HU!mAJOh NUҷ|Bg-Z!no ]%m U2P_!mF2|"hTF<2|"F'h=q1YLBƖkdiMҶ"X [l0l ҷ#o [AbȷF 2؈$L.dlk]e:IN2mNо EۏsIuzEEy$}K(r>ɵEE$cK( w.Au s;{$}K(&!ܢ"%C%idn{ǹ}G$?o߄"m*-L$c(6#q.AEvc8@DTDdnE5'!)&"c( IJi[TTeչ-*S2  B Hu!N!ɟs%\_?gXo&߉KArZ9,8 <89!/Sb] < K o7'o5Y om'sg;1'.ϑYsRvrUs'YV)DU!\ќ՜_\:? ]?eL*le'[v'TI< o`8Cqtr8yʞ }[E&m;9kH#`ʖQyˀ9.?H}јB9c,'rTIzbE.l|<tyoܴ`ZSO'X:գ N0~pFSj'B3Ss'"B SEdcGDNh#0yQ=z4?8ty{GaeqG)'tf=^Yy&Q|IdG "S免Ef"w<#,_TXl٘XD&l^,"{.683 2BkQ2LIۛ).-̓pYqeSf E.nal,"?6z!6iܰ~|XeZ@P Ȫq5:!5LS^n!1ŷflڸFnl-2l>[b~HbpN?0z2©-ad89<~q .]j1:L %fye88DL;LH,ma Ol'dc-aыŏmE3LMono9L "4P}Gǥ .{z.ˠ{Þ"Qa"wxRg0:;EX6N¸dHIr>= {$SHP-Le X 2j~X k[Dq!e!>GEȰ98BQ^zJP̔,2ʐ @#.V\xJb@P665f%qB"aKT=Nh,th[=CNsO.;roi.- _rBk$HI@J)< 1+ŕ_AKo^b)6`,.y/! 󠀡k/nOH_}8֛v>"b|)"pwXFc$u C;,'w,I[ EK/szajiyFGJ=/"xMr TUa3ly!άN"qəUBaEh=]R0Ӂ|Ҭ=bEnQ -Tjyt_DP{]l? rWOqé_D u0Gp f<+GMLyPcF# ?v&#æz5<(A\04/ ^(@LM+0\\`ƸURYϋY?af!Ӕgf/)x6:s0.6€ŐϘ怼b yQf:'Y}{8rEYJ.y&/h#P^*1)/T^5ƭ$7R0$%'pR(V{9 fѼF{%V'޼҆CqN:z*R8\·K!='?/B׮^gNqh+T9XdT_j@1kb:VaȬj`2k,‹Nz!Φoά k3+u?zMNBS'X8̮:@,k1Yn>7\, ^z 2Nn 4=T0 eb'N ”2:80Ȍ3htхlewoi;bvpWhi\毦 v*s?Ϝn5- lf [" /Kl F},FH d8j0?!lA? ms6qhD%0A;[]|d@$y<$iO%BN2= {H#Q9 E>d0*< C.J!Dh!)D|wTÕB$yA`!7R_4!FlD Mk*Q+9~9po?E/,oMN >@|Ar 柮ӵO7$ddXxɘՍC2I!ϐH>g$Y畤<"܋@R\cH:$kHgOkHOkb$eɵ\D} -6rWI'v %[lNDeAbMҿ[l '$R$J#(He,A"I' A%Q$2$J֒(ɜ/I#s$/( yj-t8 Z'QD)zH(@|@<CKE~( PAU܂"kIt+B-(XϘIt-gBxM3o!<'ٹE^It/dnAu$-C!ǶoQ@f*0DSR@۞N!%QQm*dn[FTUH҉rm[FTڒW҉%QٯET [:E Q,oaBND4j-m!sK'ԛDBƖNDU9*υ-6]҉'QQt/dnD_Hb#nC5$ [>$l~TҶCMJj~M%m'dlGTI߶*[>W!lUҷPoEztIǫd[>a%m'xd|C,?Z܂BmB؊oZ-(.JƖO ][Օ4냰]t'QwW2CB(o-(O(JOH QohPtQm@iG%m3%dl&PRI&jd~7PBM%PM(BS5?oBҡB.}"TJoBjB"UoB B⪤PU2 EʒHyV&`+*Jw\%P *i[lHWbCBB(&%V2 PXIff,JR~&:%7oBIږfFeid8k aߑdnƱwSHEE$[F%A$24I F*IiȒdlE $m4I2"hHaM0I a$ tHdMqcܳ^=N\_#Su`)Y `$_'g 85N`. I'!akU*'z[9SF'7ɃLz:ո f._@k?dr7#FřO;sEP *x:;S ߇1 %3[5qTӞEn_~ pY698E9xIkKOcݻ p`[uD4SL.Y<@vkl=EnZ MiE<ۭcr3",Sq.y> <<'H 8/r3yi$^X䥵 jd0AYayFЭuКt ѭD 9?;R"LvP.YDS,tke!9`٥[bif|ӭ%Fx!`[ւn5%nЃ1G}Jz8Lb{ ǥSj|>Փ8.Ymq\.[ [ݏqtH1-WǗ;_O̎eQWǤ 6~,oX vߒGӁP3 X!htfjyVՏ6Bo퐁LmkW_AwܔGAz.i؈7Jz#lhjÞsS_`Nh ޡ5@7.mE~B/K) #tѡ#~y@1BjFJWbFҞ/}J-iX` @iaNZQ,caH#4Ƣ {9oAYDR\d%ЩGkRd+=Y/m} n2Bs y ER CHeB;Jle^:dٓN_l5 ]FZ˖@vfRu8f2a["4[0-2 1k'Q-C-衸<=<9@--r+Am ж 054 uH{h;&Oh.i^dE i[hvXPSy`%)K۩1+ma>b0/q+E:PK%ΏmR KsjiK,PjSF$ieX/Y QakKE FJ]>=PZ1PK%S!h!(鏏u Ǹ9r:۳ELʹ=x+}Sl+b]n{y[ idp|{awiʏS^SҝۡLm[%y-ۙ Dž҃vkS)3CI:oO_s9d`ZODz3:|0Xr+i Usë7DBAWLxF5z `┊X1u,vZE3ekS3^y3PxP􍗉:zWC<^m…Oxa D  y :ԅ_ܑW訃$'p&аRqlؽ89sV '橼=3WY\Z`v C滼xW'@8'uI%s@ LeyiV`dKx0ԖUSya_qN&zJTFj ` u0_|^ S&1;̒ 쌅(D;z`zd\3,kx~9xZ;^ÙNs3kt2qO4,͓fA3h\ 7[,x0]fE#ޠN)p6[A>gk?1v#gJN$q[[xK gKCNF,F_ /co=$;[(0{œs64 M@K;șj'E#+8$Ɩ8&dc fŝ@wQ5sVͥg?VN.:{l_Anyˈك3pͭq"d] x+d^ r!,ۗCyBT߈T["YEu!a!5<3*T{u H y>X >GvSC##Ƀ@(ʇt$H sCϵ.r#H$/c#2@`S:Ʌ?lTH /HPH^'r-Ez=!)M$-I"#"G$%D2E2fAj\d쓔C$!|Hʳ(+IyEɵ"ƐuH$*\Hʚ'"IIu:$ZĞm{K?IG},Ib#$2hW ;o}bN >r  a.Q$I aޒDM! aDyT!̵(+9[!DWH#rBg\4BEޛDq!L(.ix!LՓ(/ QN% tp)dnA$:#sT8k2#[ ѯc 8BcfC Yg[Itt.dnAG$:“| [PD * Pȱ*bоل !o6Ք$,ж,6S?IT#*oDԚ ۖ5$kҷt"c\ۖe$҉(rl[F i[XDQ BQ,dnDTNZH҉2t"IT.dlDT\Hb#؅M,Mnק֢3%_ k7mxpHIsHF#PsOU ҉'QQx/dnD_HbC$ҷ|JXH۶P2`/kҶ|}-`ҷ-`ϫҷ`m!s a+o!gȱ.m khYzˢZ7I0`cҷ}}݅-(=䅌-`/0]}Ly!/m[ % XH ,dnA1J0ʰc ikh`bc'0QF<Ҷ<" ۦJ0&oY\7 TQ5HBPh,d ƈ*BWZX =U٨5.4c&ժ\ kB5|Y!A[X ͲU)uBƚPh-mQ-682X ׄBӉ kB! 0f\ȵfˬ [hpΉ.M2\Ss`u!} .dnQJ0f]\3 W⅌5(r%W^H[3 =/d |zKpq<{!s NyWI5DBL kJ!J0'E2s`!mM)X\uT=BRHװmGB BRHkgw{,`,4#dm S2*JYH_ )j2|ʜJYH 2=#DI8*dlD(E [>b$dҶaW!s'B D"BO!jK"[!}'B@D"B!+dl$ҶM#-b [l!L"e!}BY&Z嚡:M"aj!mK(BZb#I$-o[Gr [ -o:BGN"r!c[xNqt!mK(Bd]ض5C]@[ַ-*BRDBu|EEH*_HrmQ$R2"\}tH"GBƶw{9 [B. -*! [Bm87C{ǚPE!mK3 ead89Gx2];iRHߢ"LG [F%IdpR24J f*IɒdlEz $mI2"hHkRoH?Iq=iZ=e~=eW0ݤy H@I@dqei@xr\7՛r{q8rqrc ##.YUuyKh%XfGKq%X ^ J5un1p[U% W Ju&P[p!ܦ,n5FzB8yj`:JF%x'%11+3P22$#0P*P802Huz}mF.{jH,RD#taidtr/hGWF5ôjYccFT mY 7rӠz7)fFE(72Ip20NvbSNF`nS\fT,~p\t(2)N%Cx2ES/o/g~ie9zFୡɾx+u%#:Z%x鷠s,oIu^6Йڮ]jp6xu|7sm8 `7{P,jUqOKT%}ј@ #kMQa'7UQ[cXiAUc ªN_U~<:5P+ cd! jP%G,*huXY2y{Vo3TTE5qQ}䝨hT@EaI- F%NHjdRo{_G&7<ʅ@ʞ-e4mAWƆְqckVܱQ7D@c<\$1#5^ԐhZ`Q_˦jWmaRm~uYōKn0Z  lӝ}?[}qS78n{mIƓb&^araljfC6i<i6EgDhr| ta6If<&c5̧kn/jXmhjOx:_#vAN1X-Q& 9 Fnm UX-㽶$]Z^ "BFsĘHxrZU7 &g5<#NHۊ MQ2AkYl=[׼0 ^s|~ҿᶽ`x6/r5pMᔺW4n{KsL۾NNMA]`m5 f-;iqC)%FT Xx`<D+V+(apIb'@ cX+HD3L+u6q -x$uFH3ܧC3Ë,in(JF%RB4 əIx?ETN*l5CɇBέbkW C I3m((iKH@Ifz\a܏V8(H'gPKguYd"ɳx۳J .}š+5v_D:¨Et1JJ!Y&85Zi k,y`' B̲+V_+Ki5AwH:m eVˣ7 VKq)\[jA-ExTZFZDF !$ڢ7)js]+"5P`[q$ []:bYcX:ׁµ"lac_.P8dAb, #Xqp0 Jz6VW%s밾$7!hp&#ޗ]j`YItw$0=qD_9S+腇QFd3 2{`bA~11!Gәc(d0g '7>?_ItĕLDH֒ ~EHEQ$$X$ qs$ D7Yf 7tI4_D+G!\]h*T!\ɒh+ b--6bM.pO͠F)p)[SJҷ؈mnh&+Bzi.;{(A(ID!L4() K40)QO0J<j0 9_!} H azYS$JS Bneą0kN̺f߅0CO,fIx(Dž'Q$ tf)dnAg$:3T8g2Z ṯc 8>#fC QyAx䭤s3Ε-(t/Jp/J*B%>Trl5`!fKmTdr.Q UҷtBJefUZ-Pyk2Te+JƖNW~-,T=dl鄪IToag%sK'T9-JNH[ z a=+s%m +[:Jx!WҶtBEJNx_ -6(d7 QI 5 a룒mT2P#6k*i[>O%c';*JuOU aOEzk-2ԣK>^%gȱVҶ|BJ_޲is 5Z a3V2Po+[>>t!UW8[=JvS<땴-Pm™JOhF C%}'4 Q'&*ikhp좂(-ԔH%c44lRR*kBs-uӈB8CSI_ũd E¹JƚPP!1qJ5B8UI_"*kBSZp&1V\,KJƚP[!tFLU2ք"& t^%m MU2д`!( EL&V2ׄBpf1KYɵf1Y6+[hh3fD+i5׌B8ZIBC㱕-44f[Gq+kF#5B8=\X3B.ʕ5J.,J.#5QJI/c5B8"_IۢBm~!ꯤ)E*.TPPI_SP4T2Cʈ$ROTה"T\?SQX҉$ER $|"4-INv [>Bg(F-R5ҶqT!c'BdDBB*dnD’H8VH2|"lIu+oDhHVWHb#y-6BDRBڶi!ML"b!}A2|"I,ow\(7 [B$2\3ĦI$H-m E[ [l@6Dm-n!s5C$t-6R?dn: UN2碋NҶ"IƶuBmM(Z9H=yМ'֑$s |%OrmQ O2"=}5$m8s>Hҷ"=-*ҋ!H5$[BIwۛDs{ı&`mif:a$[FAsqIk{ǹ8$[THe\V5-HO mQ!JƖQȪZTҶUM%s(dU$j UMYBB3Oj9fUX|9`\<'W/a!E-ĿJ/ă)x:APM`7Hw7f=o>'Pw~S  ,8upRu8ZP,_ -:Huk(SY's-vҫ(T2'Q6'0 9r $ЪGb:N`_:'`B%iL, |86 4u\ &CN \egTO\Rd\`p ksЫ scS=H"!tۛhy:ANF:~@Aɬ:NޚbLÝ@T#`:4feKَ.>rS)R| <8 N;yv )OM U2? ^3Қg8'wuHgA'/vج̋ۃgʏ%Ź nOo#5k4Nӏݨfbc咁N:`1X{[8i]?OwKuo J_9'jӬNK]t=f-zzOA/8BO_6momq~m9D۸9H lDNl+3y,ٜn6A4M D o>MNؠZ ~$4囍i\V#4𑇛 н'f#!9hzƁ'8pha i%h6B Q8=AȰXүpC#"?f2N;>@C&ydA'2a>a'T8 cӏ3Nq c8,c0Վ/`p> E1]CJ5S;g%p5`)'GUeJWN(Ym7tZ؈1ȫ9F,;& yUjd/3hZ GsB L"4VSN4*}Vg_i!ȏLzpzWƄ%$0o>4oPZ&v6DaN?r(e^;F)d)X\ _80I'YDyX͖" Lz@L~3'iLC%S"L~DFJ(8E_ ?"c'NBM#{(IJ'wPD[s۳f;NV_%qOs죚x.ώIL$^fo=D  فF4€Ͷy/ !~?Y3~h ~3< ?uZ<(DMۗ?_SRIC],Ib#w$1hK now'@ @H(Hd#H$$I&$JDDyVŒ(]KN$Ӿ$} L(L44HIe$$JDzD)xA"ObD'<3$X3GJ%܂"@A␔ q*dnAg$:³_!q,$:j!<&ѡ$:<2Cx 1J!s  am*9}e ښMRX S AɥeT29,kV*[:jS%s2T*JN@Vɵm*b\%cK'T+eJ*V2tBe$*UVҷPɳj%}K'Tdn鄊 \ Օ aņJؕ-P)+i[:{%sK'T/%JjT2ؑo:QI۶uQ*[dS;6-P秒 .S%}:ԭdn^3VI"CJ%Q7t*9|BJږOYXC][]'`nAnk!Vҷ}CJ.r%c'ԍ.J냰]tj'QjW2CMB8PI T2РB!fo" D%m _T0|pƣdlFN XJ%}M(bn1&SGi*kB#95ўB8SX#*F5.bd&1Tǣ*k\ĘU%sM(b\tUׄ"F*kB#fI4VXg+#ouۈѹJƚP^!ӫmqJ,5JPhʱBV׌"*+֌"3 f%c &Ѡh%mVI *[>!1[!Uҷ|B¹B(m!^%c mV2|BBao!-d%s',JvIY @ R嚡8M"Uj!mK(BZb#TI-o[Gr [ !-o"BEN"r!c[xNit!mK(Bb]ض5C]@[ַ-*RR$dIu|=ܢ"eAB*o EJ\[Tt?H-H {߹  K$c;ν\-H$sb~ IPCfd.`q EzX$i[^IƖQF\9}Gq.V!Ii9dnE.!)&"c(M IRi[TTKeڅؿ-*2 $N%):btOu?)1رw`LjOao'fz t9@wK_չ}q Cn&FpPrp3B?Y#;]oJp܌¼_ -]o 4O\ .1jq*WKU^u-gh3r*u3c+kFw]%{&Wepvbd>uqrmX{noNhKm `[7p,[%H*A ڑfTT+ iO!L*ATSJUy\\q,)e!L;+3oIk~p+A!L9Ht2 Ge3'X㔐Ny7H~=-6`+?J+ 2Q蠕kcu7BU#4D:߁FPó|R!gxNws97| `W*Y F]@a7,bb]#bw &{aM$=ڌd2EQ#^ ց"ؕTNj'Qr2xSYX=qvT _{<| Bm͚0aIȳ4밴A?T"uʈǣh ӾmKFni9~XlM66*ڔtPc: Z4K/4r{ `rp$*۶B!%|s }`3Pi=xXnTT6,qLr0R9v1ľJ.<Ų IS o__{5K`0R';O K[؏9[gh:|4ΤI#mAi ktYl:152 bG]r8TǶAktusQd֒m|jl<ٞj $ []}I'tl ^:lyN᫦[{+ taﮅE{6}EK >a3{6w| z}K밷^yiI rHm +O^k{vl7}lqزLYںh_}=܏Gp7QVt?"9䰃ѭM~޼=ްymXnO[w> q~-$H@o46п-=~8~͈ӈB]qkZh~&Alȓ7_| &Jh4 t8ү+lz0bKLp WNx:W椌 bU4M9CN⦩žKB9j ҂SBs9r1\$HR䉦ɦVDO6{†RSTCIJi,KpbSV>/z}8Ma}"^{!}! l;dװ8n܎1lj24g);]8X7Γm d6_z?ʜߐf传qp@aI \d8h4^42i҃Aᠤ')@iK#3Nhj.&;Gh/cѨ)R-z0i:dtaqes\u@]÷ӭb]cf֢ ѠZ;K'ϵ}gx-6|{+hfqSj^f6\svsCϬdJbq8G9~?(ŬŵǖCZ`Xve8_9mG{qVy>c Z`v 8hܼNF+&bZM1{ y{!z9sVh_pZhzpttԿU]$ ,(ކdC BoaC"2聖̇@e"8PaF K{0, R`RqXTnjHB10|Jҏr} X,A߄D.VCIcb^:_ƲcPr¨:;ӞׯX~Fʋf<٩6Yb#yۄ4Kv~;Ovco_33uVv$bOJ^hw@WjG"ȗV 25;<:vUB7[a:xcy36xi0)ݝ]4/!߳5I X2@[AJ*hpvH 9ŕ8%Z`xN )2(bAH)ɴ2 6c6ԂdQ(DŽӊ8-IDB_RD:S+ KjIUބMV+IasJcD Z'vpoXs Ű*l|#TAH lu9d%R ] ExkVĂ*PlDD !-UQD%e[{JA:cImV0ŵ;J!7BȭJw ͍ŭ' !X7!QDVƉCx/ӛz#< mo^&q=8kQo=$ENFQ8Le?(0G}.##!D? ; A2H ћhɃ5Aj":'aݕ0. ˾VY)5 5 Ft(#Xa0x=VW-;$[GH4G$5#cxD2|Mh=pY1ZN,Ntk1Y.FNr}qA0F`r3FCB,v7XT:S y~<䳂OЛK0@\$NAZ&N$H|oI?b$(HZcHFuE~;J,H܉Ix& ]oB4VDG!\`h* U!\̒h+b--6bNE.pO Fl,p)Tmb-6b+,e!Rh- BHd#B$QbSB %QU$J aV ҷ昅0MD-t&QR\$ʭ a]s$ aǁp`(`}H@BqIR!dl6L!lTҶ|B-JƖOuTKmPvŽX%} u*[dCD]JϾc'1m:54ؾ,`e, ^l%}7ӭdnAp!W2|BMBبq>ޕLyu+i[>}%s8/-PA%s 'JOhKTEc'8Q;*i[JƶihΤ ͫJilL! ET2ׄ"y O%cM(bvUָ9JƚPļS!qU5B8UI_d E̕%Y%cM(bιUm#*kBcwp4ņ&*[lhRNVׄ"+kB8XI_3Z3,#-44D㡕u)B8Zȱf9ZHB#&c [hĄmM׌"y kFSI48\X3@NBښQs!c L'HuKpLv!sNBRy!sGOBR{MҶBƶuĨ~֔"e\$ ה" mIDMה"\?SQX҉T$EQ $|"%4-)Nu [>Bg|($F-R3ҶYT!c'B^DB*dnD(’H5VH2|"DlI$t+oDHTWHb#y-6BD*Bڶi!JL"b!}@2|"I$,ow\6 [B$2\3I$F-m EZ [l86mn!s5S+$}'[l9H蔓mk{h-Hiummk>;A[ַ-*RJ$Iul=ܢ"A{K(RF/R$)$cK( w.A‡ s;˃$}K(:!ܢ"-MC%idn{ǹzJ0~n8ք"+ i[-+${9-9ȶqNBa4R20,I"OBƖQ5J٧ҶBƖQKYҶBQH$MpI8A5Ozl^*n=uqDZ9JM۬B<*ҡ(թɍK?x>\Y}bfEÐ~&>r*'F6>Ÿ]pNa—ǃ?rR_qtG*oBXLj^uNvBGiAGn<;ci\Xxwr18eDd)#xpT/(nYp;%nx%J,|d%|yP9mAk8^XK8B#/^9w *PRyaJG.~JVN{,Tļʨ}=Ȯ7/cfBx:T#OC ^t^5I?!Hm,q~D> qȧ뤧R}4ZHXJcZ/caI#25b5Gdy[տ;lXHR7x~[T>m.,ƾʹw-`#/WVVOh}9i!cV?=#A*0Y8mӍw>2Cq];hb6 )6:'rx/0A+oMӆyxQ:3?ܨKfq'6կh> {4EC4NrƳЌ~i|ki}_c m Vя GZv!>5h}D2y-OeeIrZxOCh)}ydzɕ;)D?N7hcMycGW6B-΍ޏM cAO|NѠm lMDtl_& G(S#Z *? NG-YmӤ [hDžz|J %:QI's$*;؂_H`#S5q G6mY`Q 'X8G:ΧS_'7o|4#q1w_p`Շ3Y}bɬN8ў':8& <`H0ㄗ>NhhP #:`)ޠ3\,T~rKՁl #U~IuЕ_u(1my-.HR9/G<>u058j!ѰuP=k6Lͪ鸏>d+:U/ ROΡ?_9vPrx׿No0\_O#<.N8c$Xe9-8Qpޏ y⊛~Arx,0kn Ho K~$O݂: $?xOh$PxLp#Ï|l~u7~:А|DuLL-gMa@A݋ϡ6# DCWfpNS즡Zr?#d :Arqq"; 4J^]MiQWPRELy %uUNpWS{@ ./aUKJX #.\, CqJ`d0fh-kkyE^.eN9??ePb<'́`+9)??'4zG!*=t^P NP列V7zCVE:9,h'Q߂ ;KNh APN3REi2uN^1ƔO rO: ^:% V~~Z'!jd hZ[3)j]p_ty7pRB섖?;D+gcCftCp% {ΎVHbɰMRmtH.vVȵmQgKR\!cK'DeBQ>,dlD!DE< [:$*ҷt"ʴ-ro [:r!>WҶPŠy%mK'Tydn _IbC͂JzñP-Ps6@*i֡FJ%c 5d aӦjT2|BBeo[U-P׫v*[dV"C$U2~[>a%m'ԁd.f-{ Z-(m-Jo[܂BBEdlхc]IX}v+ۙN$WҶ|BJq_*[>JS( -LD!ً ƚOp~xTҶH-H}k Y%id; aEdl{ǹA%idnQ& A¨!Ij 2LJ#5"mK3 2jAwSb!2];΋IHߢ-%$DdlE5H!)&*"mj"28g!mj#28IdS ,q %N%ĩX8SKİ?NKh߿? /ӗ ~|+s1?[lo[gG*Wy+Ҭowފ xwbU{o?N_71==qM?og"Vl1Mpvm]EeM9Jow>6uތIOfw`;DٷoR -ӭfĶuC'{ɽg3gU$U1vm9<RAQ_ȗy:MZ}_ݗ-ݸaߵ_o.Ufn>W!_.\֕/Scv^1>jpI}Ay_xG~t2 n]kZ^u"~hX׋f'mЯhxil f(3%ۈwq/.\O~ŮM~φQ.o^R޻$^֭n;'/NV&xߦd_]˫D'n(|KAA>3z>(AylJ Aih l6y4^<,P6WWUw;rP8VBW"[`nk 1Iy%|gVNݯV/}WW o-uu ޟzEE~OZ!I> ԕJR5ˣ+j]&V/B2-v5udהy5/[|yE^}@>ٮ$Q Q/mQAQC\6;ۍnf+.՚OQ`>}lo=EY޵n QQAQ*,JRe}%G!?ٺu+٪-/_l(ǟ]R.S~ $-Ґ˚BYMG'|T|ԗQ>*IyԴdyGGey/?wSnNp_p o1>_6;tſ,_^gO?GGưr?JAQJ!P}P${)kyPc"\}TzEo9#{}.kGq.K\]51a\sτ6n91>Ar#dL"#QukYhna1pobiz3L.99t oo| }|y{='֌t+P/Y˯ͺ4y^>Ƨ:u&+CxKYr鋙>@pdO! ^t~C=TׁER7hĻu-햺q0I˻~u#e}z;vvy }] >9o7탄7X-Z< /V_k{'_OC\ݦcw}/Vo>7[m4ߟ@P<6lquy_ Ą WuM;x{.ɳG$A=l\c#H?22ް{IpyPEGe`4t^V0˪!ߎcLxY}ͨKȋ&o~r=]!n:'u;6!;<,lƛ4tbzS KWn?'ÚgXl d - 6ׅWy6g } e-9c&1 1qw _%66;nD7Õ6f;tȻ/ISnj3to|Ի7'}ͺ~Yݸ~s'x@6qP\yE430Ad+,|0n&L2aq-47:>%N&j-/U'?VV[%ŷwiOEnա><:LwJ㾎4=Cw߲ŏR1>`% Zq 35 H/_$1Մ}N[I.^8;jf~sd&92s|TcڗOe_yI>ׅCEfr,sYE5j,o=r\m W?uX#ߗap+Í6 ~GwӅ; 96|yP{t3ޫ[ώGn.-_2~ufqu˸lm=j"#.ryb?'bȂTzPЏ%~UN2/@;x&>H&>yenw$e xH4"~cmJ|f |YVnl&~T@0遽Rsh:A_l?3Hp(1&7Do|x7AUaTlKfƍJ nf}4DvS?v^>k"xqXqmk'\^z=t!TG|@:Wm '~jXe#mc wl(ɝBvvm巕}S.V(]ze_VyӶ޸3ÙUi߫s94Cy WJM"n>27Bw7z_}Ҥ斊yKgA07DuJsXk7y?CkniV< jx:\MuVl_F܋^R#ރjK8o}v&"-fPu︑?Y oो8x3ߵ&>M>kBon4 .fe º15窇mCA:a)6ET9=,# uB?rlM=~ dϬKNfU,yi Z(Yg3&(6g[% PG*+rqu]y%u_rDh7/q!#6#֫|q.vVzx0cL/1*^ohEojV3AYN +\֑MYA@`_R!𙮁MkSU-l@^ ^%-_phOpM}%-{s]SY]۝s\59/~pxlrwl c.z!d"fo¾˔wXI;(G kKۧxfמ I[j<=r (Dooa\W?2ma3ekÌpat?]an`h1}5@0:}dr~P&V|t[8̉*0K3t|[;A2OwFxpiڰd.~p<7VJ|#wݚ !ܨ6G7|@Xkia=Hx f`gD=mܘxŸc(dկ w=vnViKRP;xr뼌iVrqƽDG`fA҇RCM׍xCyBug~\ԍ)X%wn̓SW[>~/oN\~dr*0 (B %aPso8K5\C0cƓ DZ/8HJ'R1(B 6SI]l# R͟2g?غ PztG3&}ZmYXS#{2*|Cl}1c mXfr}r#(φs:0y30kSA0;jYX/k^17ۼ|0أ7a#ˌF<[_ձfjf_,Edr>1-;A`˦hO\ZO'z3:(BW~P >sTfw!OcG:>$;1;\AFrߝ#r );=>Qr1iEEd"ba _8=})=hlj~pW]؏ , sXF 5erzaRaF 3yҜol\o43|XN"|nD鼙(5!"'SHpܧN5408 ?'„KO&}RK# yrl}=Gɺ7& "#B~ ;,Yx簆w<:l-f9r,+H 070mGN> J{2f>5CA]m؍iy7$/[޷^>.b+WB܏}`jq7F/2mOGʀ`5c~߰*Yyh8'g#q20%іhv?R{37% 9VjzgJ4EeZl=F tt,17f,Iw$E6&oQtY0:f!ڑ'ްuY&g,}Ad7޺j$' ]8>nzV ?y=c=bStt4b/ &fabRwC:oZ'I[J[^~'EmU&f_x`?>$dڤI)5ܓMrs WgPɇH^#y9Pw}1WA+xPѲn ~5t73mnz8F𑋑_H&pض=o}7Vϥ|SaqqwQڣkqSa,h"PXY9fAKaƃ . lލUY|f>ƚOECx9+b~lEB۸hE1LCY3|W;AoE&6I XA>~Njr^&i99sY7]\Lb1A xyrVAk\"u Z&E; ETw,LQczh:",fgjQ\%09O|tqεPE›,f=^KZ,rK--uFfZ,f;y'ON<6MҕUƉ(EUjE }=heQ˲~52Q:|'ֹa :99ϲC Ԇg3XCXkr? ¬"ZU[QoPBiXJ;1&b9XkXĎLK6LÂf5~"L@jyޒٚq7CIy0WQ +.s1_yFcm؏ITTi#,}0U˫dN)$U{&'tnOE=)&a9L‚v1Q4,a'"/bZC4,? SfuE**yRPqB1qq-3I H7WcS4*.Ӵxe[$b4G zҋFnh K,=6޸T^U$TTGV%CQN\ؑO ^8;ME)$,u|؏'+iR&b9);3uq*7n/(z/0v/SԧS/ ̚kaBvp2YSa?f IZ T2SvQRa; sB5hZF 6{ӰoMNL, ;>og0K_9hye{:M1tOCAUT+Mf ?T>LORXݚ/ X41-;K{Y6M TʞMnr)Xcd j Crc2j MO>f![4- Duu /v ӴOE -fmXH`W?;!&XvpVjf`9ǫ(z)^}vG)ϰ9.WE]cVsy.o:?&hy9߃j*V&.Mթ^_ky Hyk0l0͠PJmV:p۬4\n+!jSq[9n+sVNΘsq4VB<n+1*- ZtׯjT2xhҲ^+WVTcmEmWķn+ۊ0Dn+ v t[ɹB^RLf Cᶢ"~r0[_le >^~P@^iŢr&VBi%eV@+-Zy)*.Ō(&/g8+7uVeVUB%&#eV<7\m#DYyFuqۙzBNJ˯2,X-/]zha 2+1YY{ bu!0Gb4AY gU8+wBJ0?8+cmn&>Gi7eY>b%DZ)ҔBgn)OU忨O{EΔVo@+VfпB+bª|t>AT6M@+-G/9a$bg|V(}.'H k/hźBVaWDZ1 V>) VZR@+!G%q@ۙʘguGG\ .i{J+i|bbEZiʾ6^jepFkEBk q=||i%V>{Vg* 1b+&Mlb+Xnb.dkπMo0u]GDB\w3K,Z1[jg27$*PtAi%Oc4VZ iɗ>Ҋ#J+IJ+uH+t@Z1Z2_}W&J{^J fJ+-UZ9nH+N-Vh+~"MhЊJR@+-Z;V^ JwEq̛XPV6|-m7塞K(+//"JwPV/J5 V(+5l 2bӋYGɬ,0+'^Qe'JuDV YyRC\ޭIdsOQ nHoAV^IDVFmp6\Fqg0VHXy!51VƐd^g+7RcerXc^c1VL|y+oc%J4Vz{X\C+ۚJcX8QcqϹ$ dżz>u@Vk. +#2XQV0YXqƊK+V+g>}5V+[D+ Qtb kxnk8blQB9- ʪr] lXcE@ce.3xWRCccq+&ok=Sb\)Bth cy5+T,b&+/'f+7XIpb@ 9r/b@-XQXi bI[eYe7bc2_ @ FpF8+geLge$Ί{tVFUe:+XY%guZ)]hiB+Fu #VvT@+{pVf|9+8+EuVZw@+{A+ےP)ʰ#"Zv\heZZh@+'aZ@{Zٷ@+/!#CQ r2Z;7'ܗVыbh#X-BXщXarp1VY6VMOcXQ֜`5Vl+ ce_cEcrW4VhFa}4 Vdiwa$V0KN.8ʊ(+@AYeŮ1*+FYiʊ0(+ƸUV^PʒYq5ŬP-Bބ̊2+DeV^y{wȬ\eV^Pʺ%Yy18+VLZBAh%Bb8+p(/gtf/qV^PY 㬌f/B4qߚ/8+5Y9ZYk`V)PfSeVqz)+*+b(+>Qʪ/Xy|]AFy'XacYVjXn :Q@VHXYY鐴ʅ|d"+d~YY +/eNBdE eʊ+eV>n]lNVh&2XbG#Z+/jX~f㍵$SjfC Y֊w|Kj$#e#Vfi;`+VOn_V\rB Z+iaVM%=J_lC\,{b9_k0Zd`֊}c`hRV meQ܊h+%J5:Vl\m1kSV8C[y}h+%Vơr8h+T[`meaeV#V&HBh+Bh+GV/_g5J#z+^+Wy'Wz!\+RyWIhWHN\)ʥRCSqZsNJ6iVl#D (998 WZp|>SW\+\!)ű\!it,VA x\yѬCqW0W±B\qɕMN%m=ȕgx?*F+f𩮌0* +]]itDKDWFeNDWQTt7ѕ争?}j^פN ,L 9ޚ+jX#BHt]}EW`ԕvDW^LЕfXI /2y'\iтʌa|ub4E e+.jT;\ibʹ\y1W6Rs4Kse s)2J{.\qYI+/t*Е'=|ʚ|-±]Yv+=)@WگUt+MtAWL! 87QX!\"QWzr䞄t3#sLQWZ~{+RU],P]R]u帩u奈З IUWtXPWhrYRbdՕ!W)W!$DOIt`.\s%W+ߜV+Q[^{+L݋xh(\Ѩ\9J4\ٗ\+.\!iMrr!w}?[.z|\ Xɕ;tɕ%Wn$ȕg. Gr%)+(+pA\8?q [W(RTqEAŕg=e B\nO̕Χ5Wt,rw 򥭽 ֨%WƵ>ɕbȕΘ+Z)ʸ+T?A{ ɕ Dr+rźbɕ+%W^,׼y*E\qݪBĕ*bJ5+܊fK[D[iCvj+fj+tcQ[ͥxmR[aRn8%Jth+Rgmj+&Tm'%V[Nh+ VpJ h+/V[R[qBVhSm ڊz32 b+9V⭌7tJ7Jw;JVj[to`v кSo񗿷½of[3oELo,ފ-qpB! WP\ipZBG+O`*k22\y'WFYm~eyϊb-9W.g6 W֍3p6+-\99+J\)pe ;H)[NW,b3NHWJEAp+qr5E\)ra#*E\RH7⊫DW#"aQqelqJ W^RJĕ89_nR%Dx+H)WUWTWsWt #Auh+֥T\IK\~2.36]Ot+w[r_QW Xԕ[#JG+ +]R]!aKue'<+J+4`+rll2i(Js$\γs~N5W=#??SЕ ]?+T])r\ n]!΍2^+V]"u~n+!/9R͕1L`B%+]!RJtV^t%{+2SzlңjefjezX+&?֊ЅJ8PMx޲%֊̙ʱAqeV#)0M&AQkXDV$ b4kŢqIA?nZbqOAjeQVX-Rj2^xR+B2 -V̼EZ8Í7DB+cfG0Zi1JK߄VvFVZ^ RAhLg^UgΊgV.[UVK PbJ-ΊER+w++ aZZw%B˴VOkkX+@@tTjSj 0VJjHJ ؠVQVDVZ林-!k(윍H+tʂȄ_|V UZ=#VVIu K=VZْ҄JBZ9B jep"ZyFQVy a,QVڮԊ ԊԊ ֊mC8I6jD"-b9eV:V猽[JŖP+ׇjšԊ8!ZX+O*VVDZqViŐKZP?"8b؊Ab+`PbؚEkT mVZ+M֊A`Zy._P>9)(Z)!}JjZMj j=V^Q)<-`"oiEUiH+-{:$VMiF;@+O`g넳2xA+WF*B+3l[n9;51hQV*Y)fņ]0+-ΓY!nRgS2eز*qVYq]gg_g%`8+pVyK,1VZ2"~R+}P+VƱ jeLfjeR+lca҈Ίń:+#G6>JaVzqqa`VX%NqVƲN hzYhUZY!1VȟWZy\"P,mXhũЊ#^Ҧ&/]"6 cYVF (ZOaM"J}BZWJ+,)H+cׄYj$ i!ҊٝJ+I+H+y¬tp bOHpV)嬰#cYg(ׯb瑷2wp`V0*r3Y ʸlQRG&" ]cŻ,Jf+5VX7ykXy#1VBDQ]_+ 7a1VhTceXCc X+cɖ5ғ:*+6Sde,dАȊlVEVdDVƹ4(+c3I>5J e 2.tB>Jm(+mPf%2+6zY%C BRPI-վ慳= 3OgS' 묬~eFi0+YY9aV¬5Y5of%iVYQ-Bf daUYYpM¬P믲RQHeEj [PV4QVR e*+>bfe<Օ{7uV4??s܇VV+Z1]hŒp{t:+%Y ΂Bg?8+9bR꬜%8+m:+eKY9WU8+;~Cw@무XheMpc?~8"S H+ VZ 4vҊ*FϔV,kEZqPii{" Ju?\iOH+VF)V|jzR+/% VV%kE EP+)+@ iP+lkVXH(b%SCVJxjkPV@fJ0SZ(ʸ!ϛ3˘ jH?81JepCZy*珊R#bTIZy1 V:ZQZyX+#x݇,G_Ys&VJbVGX+KkZqqVbГJ qP+JPhV@+8+CGge_2F$YQY?b g,΂pVk$. ""Wg8qVFΊ:+pVɫl2+ ceE QVL2FY2^ +/#sw|AAV Sder| ́|X)V`J^VOV aZ'h>7XX1(riX1WK`eiXp|?V\XyFa9QO_`ES`E!`e_X9z'fbz6+c4 2 q6 +_=+.i*L}DX5ʀ_a~VC< _>!VzC#(JW VVOyMd|Y+Bd2JaEVDV?=J/+0aY!Ⅼ|Ld\"+CX"+mAVF?_8JY*; +f|gX;hE. e"+yBDVF'[d_*W <75*76KKVT)"x K+b>cJ3ͤVӑZ1? jΎr暤>hE"/i+lk6*uVhiJ+vUZЬb7LJ;j0J) P+M ҺcƩR+vMpqVZqZ|!BS?{J!2FZyWNjjPV_ VZ+L.Myb~}_Ks$bXP2f(Ll/l-VZ? ZlIO+BWbKHkdZI>Jk Vl-'҂ J)Z1q (P+/#ԊR+*ZyV% dR+$bźԊEP+VZYVPirj̃2KX+ƶGԊVJP%ܐ2Zq=W"J~VzvZEiH+cN+mҊJ+KXzzR wP+O׏uBġ uVVzt6~4yVZ҂uۛHByY+E"\eG%ʱ[)/rkʨ+]mDKn[i/leIʳ>;lE$CltJl<~V[ml Z++EX+Z+f:V+kW8Jen³nEHnE nź m\ޗ2lVڮlb+ E`+/Cl lqk GGΕ' Ji6j qJmJ!RGj\ܥV udJB+/hev2SYOzAYw#\Rhy ZoZЊk;J+6ZiżJp' ؊/3V#b<ּFV\Q[g`8= 8\% sÙ"[[o) JEbV37RNRVhzފwz+O"x+!Noez+`x+"x[y]o옴x|\z+jVoe|r/f ܊%C:5[gDp+v(2o~]op+ɭ3{e ci{ `i%w:-^e\ⴌk 2# #D=/8-Ҟi8-㍣iٶ75LgGRF6&ZC/Hq$.hf_9V 2Χ-D 2Nh0(9+@˸b-hy#Avwq5!ZA e,|1Yf}˶r~O(-σ+[f\a=/W>ti'5$ ,<&2dۏ2֍¢Di89QZ;,J yW-%L˸8ô+s}`ZeF^?"L;Oe  ?2g< 2ԦഌC4(Nx:-,2N8-r2N-ik)<="3'D-0-H( *<+|sDŽig ghaZ3&Fte P.3,SN!Ngme< cgiZ$0-e-f1L˶ B>3,dˌ*d]`ZiOHaZicaZƨ!{'LX4&2F2nKiBiiyqTU[eFO,ZqgeYqZc=e]Ce< )c2c hed8TX3 ߲^8ky󍃵WHq*2,aCkyF]2lX8<21̅e,(Y̸GO\ayyZxφp-Y1Tp-cK(\8Rkc]Le,2溹k|e B#kl8Iˆr26y)tԋ2f-㯾U&2Γ`![O&bx@ɳ6Sl%'v-h,Slc0*[{_ ],)əLeYM2%[FO|-#b2Ŗm*/$daLL%-Wm?d˘GLq Ȗ![1eof-clَuBl֒-%[^4d8$[Ɩ%![=p^-c-+lK-¶<e 6̄my~ؖ3Bmir¶:BT[kgFmq FQ[:ɋ2N-Z+X~̖1\S|2dl㈜1[m~eϩeoLel[ЖqɮTxmc`&A[F|)CЖtwlWe2{[:Dlye-#=2k]4=XHĖqF22Ve_ŖqMeƃDlȖ'1?+d\dF 9jyly[oDȖwDms4lxRɶ,q[> 3ݖq[I0/-oe\12w042wq[FhkYJYymχI$mg|rd 2fWĕɶ6DGnoLe#5õl- ɖ)<6[Weϒ-nw5,ˤ[Ơ 348qIΖn*txmBjI<^ [<[}2,F薱ns噓w|e-&t˳b59vx$,oc4B2ʘ?oIteDaܲ^ )rK-.-i[zAnwIL3  lKo-ہUmQO^0ٖ139öφiNX-b<X2Fob8vkq1\{XC2B%uICqYFr2xa5D[z+mqKИhUBX֝A4[LlEf˘fa.͖q}B*-vW-A[mvD Ж'h-Ͽ 2*e&<1[e-)`0[6ll et2C-Omöm1i B.ٖs¶ӼöX $2<1¶P*a[HQm36Ԗ mSjs-V h-[DY˖V ᵌFp`s"b`˶[Lli HL+"d˸W!dKJw&d3~6Le[vVl;Ė1Auٸ_?b˸UeÑeA/-o 2FTJ bB`˨ZskyQwHZ3'^x-c:õ@Z֜Z6A[8&zKY`Zrgz_Q)VKGX- `bLVKkblhRpgK .%V˸Z\|xYLӰZzbl1x.$Z+3T3k-tUjcI]9j-xF@ 2Kx f>Nr;QMx-ck֬@xt9:>ggV1[ʹblsaf˸Aϳe\T>2*;9fK 0[:1[I< `W>|e?ܕWĦb wWYWL(F^i? WA^Y$"!b+k&WxJW>_+%WbWBz%+9+M#²HS#8#'^yY{+ In++*p}rVy blWv*yK9g@^! JSye~++A:5+'W>$H* ?y' +;iV+oy8WGOyebJN啝*+4rr ^vf B)|ar@g􊵅+灂rõWȉ^QPV3'J)z-3a:"WyQ^!JWyrz啝}ge8J S ,jh +$/b +%3W(_C)me%q௜rʯՀ_x_yy+@._Y)_yCsCTh QA h~+OT5qg9u+ɯ;Y+Ln{+bӂ-rI_!R|++wN_9(HW.WJՍ+l++bU+zW(`^VCzŤ+%A1ݞ$H`)ƤWFJؔi΋욼fO"?+ R 2W;bYQIR8}eQ_񹩾+hX |UD~C-Q絛Tx+s]}%oW,B_CWr^ Bxn!Lxe+Ǘx`+/r߾w[uWxR®<6XrwEdQwqʶPw%75ٕsgWX&}[`W®ʚaJdW>î8]lRue%oԕu^NZm5|4TW,?+3NRte k +&B\ \q+PR se90W> \\qRs%1Wf4WW`+\A `W+2%\5lAYBkĕ1qD\ Oۏ2f5){W\qXyĕ5麗+OZRx+|Uqֿ2r=#eW*C!ZŕS|#X OyT,S\yuމ2R $MeV)[qFne9ؐ[$4^n壢W[Ga"ezA[PZTm'gGF[i󍃭X/3WlĢb+V̀Z9訮R kE?k5Zy QwR([y-`+@R-\yb+MVݷl+_yWഏRXiEUieKML'.J+F'H+U]"q홗DZ)qo_*l T R+ VNFP+/jgy-V*r}C  b^VH*bqԊ֊%VOV|kP@Rlef3͛*ZlEblAgVzV. +؊b+>k/&2$ٟVFo9 p#VZspVHի/]O"+"+dܟ%AXvSaĕ +6+[VAV>PK^ J//ya%f+V [`eyVQ k$|k|*^9"0X`9Hb+S+Džрr~ p*z.4J->VVXiKaq9VB*S67X)`9yMt#+:V}XO%J+.XN`ENP`pʡ"+B} Xa FʊO T]e_q;qDWnGW+bʯX|' nJU~˫ԑWрe_)?VtVX + J7)gX@ P+UX6\T=7r-DXqBaŨvzXWWSP__ENR_;J|V}#M꫸B2Vm0X|⫌-"؊@_,w}E_&}]|U|WIQ_ER_e\Ul!PָA{d*U챂2AFUH~* UQb{eKl*9V" VVSV**TVYwUոxXh*UV* *M77~ Uz@V)A22sU'rQU(+Br`iLB>Om'm{m2.*'K*%UIȶ m[h|htRiJ[VLr kU-*^*MXnl+`~>2&,R}QNBrF%V4VLXR@cE\'"+#7SAV+μBJed+-XyQV-r< K'XÙvMm|ygKї-ÁY9cʬ3pWfeሲrS2rP2/"beeD?yI*+ e%' ++VUX4nVn*ВIb%3vKX{X_ae/BX9hʭrYa +`V^.KV#+W +XXPI5g>/b2q%4%V^"VXE bzD&%VLpV*qV _Ίd 9V62fV GhzZ~Z7=M,Fh>B+ l[&b99ҊσJ+1B+ZZYA+-ZiX6$Ygr-V> `#.Y!VF 37{Z+hR+ /jHjEiH+Bi%VN|b} UzJ+&rWZ9wo(CEZ\iUTVoie˖QiMiTh@hJ]V. ^hŠ0Њ̮ΊfJDrV ,|ƹ:+E=⬬3嬸s⬬?ɬпʦ/8+qOYa% 2+&d-׊ЊZHGV`BSJ+$ ȕVv7?V l hB+O@+@+NlV: 1ZhZPh:+TPp>@+ރ p@+BVЊVЊJUVZ1Gh#8oV0V,V (+\WJ+lVѪʘJ++ \ҊDҊ[uƞ^  1hЊDJi+au˄VZ#BEJB+ J9cZaUhЊ~5B+,Za!Ba@+m*b_iKjG?JǢP+O,/FJ꨼Oji(j8Z. Y8X+~9`+қ ?c1 V֐p+Ví3Sŭ[a V˭३3R[fR[9 ObS[>[!⢂ڊj+j+r+LeyNV s Bkfr+^jr+`V(̉Bsk뭬~ଡ଼٧V>G7yrmΒ/m ͹Dh+ myqU/r@N*yMXŚ*Tz Y`ڽXXE༰ЛpUs*t̪Bz] pUYUqQ(b*g*qX&*dV!ɭybTJ)X&b%R"[e|ּ  V9Kd)*.ZZeM*VFi+gU=0icGpX/Ҷ*q0WyÛ,a.U*'T+WWi'S>WCVXㄫl\JEqUZa"(\g0ɒ:}F|g\s~tU씩rT\uUF<ʖ;[㪌uU\tUysê EVWGe*cr'q t*bmJjUhVKY7/Y{e&*tSV3 $UN` i57 |XR!"Cy#B(|UVXYJ* **FVYJxA 5$o]e_tUVYt^!U:sW9vvyUWW鯀WYp?UF&S^N{* ȫ|>AUJUfU,Lt۷.]মU^%-UVubv*,[WW1FuRjܟ*u#MtU4(SWyVDW9]U0p$ B"q*"*lX*ɋ0{W俗9SFBc*dWdW#BI`E"`ELAcL&n$cV^[>ZerpZQkZ9,~d{cZqڨd7V H8,B@jEIMj%x^RF*bv9YazV>]h% 3VFZyaU¦Њ]VL ZЊ ~ *V h+@+O1hLE[A|˨Z1OQjӘVQjŲ72S̥VV쌪9˒V"V,yCZ31w 2rZilX,V5@+G%-ZGc5X+[v*J\ VW[Fm^b+6U[ҫ3m Cj+䫩̖/P+KpZy9VhRj6V4VAkV7Vϖ=yHAk,)Z1]jŪ$VZzQi剪 8/":#WhN DVZiw UhJ+Ī_ b? ;hX%RhDh?h?wǐZ9Z9}͡EeKۉ \hЊ=VH ,.?%eqX /Nh;UgeTy鬌q {XQhFB+Q묐XgeIΊ8+@L!̊eV/'1*+fV\hXY\[zv馤r U-x*gUkTx*9iU4߸ r**τUH*rnAU:g,yrUxjd^pUVUIWń*dU%C]uU,~U=g]B>*XpUc\"UWWTuUX V VI>GaeaxVV!R\RY4neIaUxʪ*UtVe*'*:*;∲ *l["t/rrVq^ZDЀVۦ/?Jc2*TXI<+K&B<:Y<Xe3))б@UH-R=Tj}Q׀DU>%s0/ bzJkRAe8󛕯2f8!^Q7[hL}WT=J~McMEkg*&\SeoR;u|<0U \`&]S:G0U4n"BFM*ԭTi(3bgn*wS菦J/*ꨩ"&B6ygL-*_L.4U4U|cFSEH Se?: /߿ e5U򥤊QIj躦 S1U5ʇ8MI<UP ʇdKRE(RmI -jxcTY_M.jxT0CT1QRKbJkMUۚ*K5U5U`]Sy䪩  BJd*3VU 'TUAR*+%IJϏ!|*Z[T93H,[ReL",pIݒ*T1Rey$U_ʵs@(b> ZIM^Se\L{jRT8 N*eUʪ㪬BU+b ETӘUUTUe@U繪%A*RĔ*W ߨJѠ* +UYPB T~Q'tUY$Uh #U!PSZS,*k*ˊ|T?UI*%UׄT,ES^Mb5UOUSŖ͚*VLrB*,TsG7b3VI{I+YRňrI%UH)bF 7HRȅrBBi_pʚIM U\)B5 m%Uh)lBtD&U!AT)[B *^T!"U>HVSΒ*Lr({-aU QV*neU TV\ERaIyC+WVQCV=Ke{=+QVQ3AVʠ*/+ܔ+\7GYCn*k`%`,*˖ 9θ*Dɺ*ǝʸ}}b$6`rʬU0GPAUhh*E0UL[*Iň 2ȔX9* wPL8 Te󚉪Q>B݅T1GRReZ:Bli*>#Se<*#}PW ]g8\W%0 -EUF ㍪_T,*Vd m"NU=/@߉{5*tUyBLq0TATLS*t=TKT@ ԍqii-zTiQ#]4UIlSNҚ* ',mPPX%S?Jɪ\ݲ* I*{dUQ*B!M=k`qR) a*# RE# SeTWSٗ"t"קB~TVTe`X 7\T5*}}<S^3QVDU:)@U{pVe!$yͽ ı ~Y Y^1*LdUT{eUGVE~IV'Xq2Y9JXEVJlj*0U} VbCY>Y祲*HX dUȪxUU`X@)'YTEOV},r_0*UY>xXUO{RI%UYR =%UTR!UJ]ReT|eLK*iy* 5U҈RR!=Kc ܫǿ`JmL WMU* =LuSP*Oy<-@U,Uʲe-*TUaAUe!BUmstUKWuUj0Uv1 E]?\3W ЉCWecP%ʱfVS:MhPSe?WZm̛PpDU rLU: ? %* k-UdUUd@TѽTS麊 GT-Thu/ʹ.\p \1& wN21B psC(2QNTlnx*طSSa z*OU& Ԡkۊ*>UZTqJQ=ZTa"µAE{*^UF |pU:TqZPeF,PEAYUd!6\;**"WTi]QsATqE*kM^J *i#'*dТKjI95*nV2e*&ng*0 0U"uT]@_@xGTa7eT(T$GTsEsmUPU~E ZTɾ*,J5zUܻVQd4?\T WUOUP|{Aa1U>;JiX׏K2UmQV0UBYݪۤ —Gb0hSIs$ PY*{Ty0UV^TVeO*3X]?XŊaЮy4EX/bʊѰ *V |褀U E*l /U9Y- XhJVUq{yY5BF0RY͚UfbVa5Rc*b_ %*& n*YlU+esGVZ"jג,U-+?*2*or)^ad5*ݛ(G*d/b ii- FOdʖU4.2U@dfӲ e+Pݰ % 0iVQ6ViU\(a[E`_UQXXEA[dҶ\(i%" B]K*[M`Ŋ_qԒjE tQUc+vyBS Tbe'( &V V Xq"Wbu+>4$VpX 2Uv+51~Z V#%Vl+ MKX3/b,3_aE*%V3؟V4NV:/bTcAuC2\pVH$Y1ͮפ f7YavVpV#=sC+"*@+·ZZqU@+n 5` 4 ʕL<r!kjLV$Vje+Za+V;7᳠V4sZVZY KĨVsOjJVdJVVL6q҃S*+EV4kAV^ȊaF&xp<UX}1V5|ޒce.~#+.^Y#+;Y!᧑LDVؽ0GY bV P`BVt<@V y!+BHr rʇ9+JAVLidŕQHY bmH#+@VF (dFV6i +0VpedS6V@cebH5jl>U[EJ}+#0V+bXifY~԰__ZHG25>Z_'nqP-e#y"7rzJ I*q/3i9F}Ri9FA i} zAZgm\&Q0 e y# !Ji9FxԆRZ3sj^fdḪGwL*F1brڀ2?ʑ{ JΎRDz:i}dI rϛiybZVZ'yYž2?;4E)-Hd2ec7T~pJ1,$J6ۛi9FvY07刯Txʰt^ĕž'>Noi}MSi_'M9-WL]y2?|C-(oxհ=f|9;j9nv@j9F~|ZQ˹੔r\ΒZ*ZQFPR˼㈔2zK-ӯ2MLDj9FCTZ8Tk}o2 ǨT|j9FL~xQ-~Q-Ǩ2Ic*帪GeUZ^=CI-(^RJjZ'Gl;sFj9FiZQ”SQTK1U&28&e~EY-(* rOXTk=.yF}aMJI-B)eUTGGY-]Umٳ哞j'=zyn[j7uLZf,Wj? ro8Na9^Z^Jj}ɍ2QS͡Z摜ZQ^rWߍ2@NpI-(=ZQXYZj$Pj OA-ǵQ嘅\fxaZQ4XZcՇON{0=m䇗u"|.mٯ)e>rYJj9FaԟZM$*e!VJjc4Zׯ(eޙ9Sje_ǨH-Kjm%c-֖URxДr\ SRN%&Y^RV2Γ?e2%Q'ʧZE5c+eG^ {&Rl遊jyuZ^P-g?aXfla>obE2G[씢Rr2&T^j.˧#X1Jh2@f6QZje~ Hh-G_PyǼ}km-?0)\1* CL2_X![mO!*eזB})eŵtgEk#jiZj]jЯՠ%<˕XW/e\Bj,5Oe,f2 )_͑Z~PXq-+wA5ySoe~Z+sb-C RX싮72<9l;_d+ZqBkef_T9NL,5l.Uy-mb2>՟2Qj&1(!&2 iiSĶ# Z^p-s(y9/S^K:0ׅ2o^xyy-BYxX.g##~3['tWy2k[k.{5ꋍ룵~ZccTG)e6GkɼOi-a(&oeI29pXsh-~<զFS.RmH`kg$Z^(^`/ky_T{eq|| l'2rAǘuTv{JkyMB Z&&Gi-IIJ8Ui-5kyfS^XK=Y|M32jmZZfLX- G2Z~8bAZ3!LQ-s[,8s䨟YeX.#piYEieN8WE1BZߤZ^j#Gꕆ^Tli}E̳SP-uB|,B%j"_ZRkjav7w>HCH-QlI-je_tj'_]ղOIZ'&3X-۪{3Vl)yɤZɑG j^fR-9iru&ZR!ָ+ _ 2a0քNy-n`- Pk RS%;{c-sp9c˩/eQԐZ^bd*%Hi-sl#r'jPZf!xS Z戭P-1fy㽥0RK=Le>q>owWw/F6!Xjô|W 1LKݩuY:I1-s H.e=uTd9DZ*\绐c!H˼+|*L]sy*sh:N!-{,(H˜A|Eyh9*-i-_9xhyMbR4Z&Rѷً2G6OHʑŒ⤐*Hˌ|YOVKOVKXc rcPN|]o5 i_&hqZ~?+N+,e&_Z"X崌ih=9r`?z7غ´AqҩaZND)-e9g޸wgJ)-= ^"M!-rTG3܉Z׊Z 20X>5%N˫2'\ TtZw2i̖yr`=c;?*-3SB:Yٌ2O)]M2{ZI 2/g_1-54 U0}%xq9+Xa;Ll JibOORZ=&tK@"W.WiyuRAZjTG ic&V\ RVKgOV˜V"VKY灢Z^|ϕ{֮sS<3h.a*e0FEZfK?,ծ jyuơZ1fN11[$>T˼pi#wX#XN׌6TliEfiZf[m9%8 jS-K67PQ&2K, bmKZ1T ް j}w5R98-sei˝@-sr XrZ*\oRNK.`Y+ H){;G9-RW)Um^BiCLk۹P̖UxqZL2'\WJ"i :}I̞1Jq$y=NOc̠r+2o2Ŵ̘ KEƄbZvbZzH+YaZV͸eN72!biQs&Mύ*aePqo*y^-LJX QFKς0ZzM5F쐶ёu@NMPٿTBD*_O9-$|Y$mr֒ý|-;(Z-9#e2?e \AZfxU1 -(e)Kt~aZz& oR´t| mb2y>}֫5LK'6´#tO1-s,SwU/tT>|bZ氝#[Hji$p/wq Zf$tZI,eN.6q`%L8ϫ2!^򵃴wհgJz!-u i`4TMxjdoi ʏ,(=A vU-ٛqғM ց{e6\bZS;?|2-_ҹ0-|BY7ٱ j57jy7Pk8-3[%oSN˼ap*k5CQNi8- :qZz)NK3qZjY'V?L`^i:pU87@<-KrDi{$ڵ#RZ#jQJKUPZjVZ^m+J˜lOh1-*i0-s2q2(JhdBeoq-5Wleuiet9FK/c %K4-uQ˕b.@˼J9ste TަTS@^'q$@|`'t}rh杯 # hTykeΕ՞V}>'rYm#)S>}#,5YƲJュP>K̎ؒ8~|},;<>Ke[קҩ -5?Y!Q>쿣w]Tx 72'tH,G3ï,yRAp{2&UT.>6|JEJ*SoY^,s/ef* e띓S6K`IY1lw. eN,U*#gPŶ"&sYc5ݳ}Bt`r?@2>@ŲF~aY^3,|W*R FyM |崅)59 RI"!^jգ}(5!2@O92d.O0e@fy;#򉳒Y^Fp.:p,|8o-R hy=́Tܔ=SV hR*QL˰ZxR,s( &AstAgy_YWHVѠY^,)2^b)?LԱy$,u ,7iu,]W7Fg|,VPY+P-}zR9e,qvyYeQTL- zpH-eZr TO O|Ggy ѣt7:2Kg ,= 2~gQmICgy-Egtt 坉c!Ggd%t4pJg.UG5z%'Z)&:qE2cL͊ftlZN>hyr`,3iNx@kh9>x,I_ ufy,ih9~YUGuufyMC&7)I!4q5% fCWYce/^ao^RU A[FtVS[,'m5۸b- ]m+UbFMԍʾKl-g׺ V*V(UW1\M pQqHu$ I0*S*F /\%U5WؘT]8|Mt7UΌULKm]eu[W@]8tUXi]t@W9l*-X!,AtCW6MdIy K*^Ӆrn,*g*^J~$W0H`Gʶܴ5'O +$(8zUX!ʾpwX߯Ƣ+՛Xbo6VI죉{l1X!Ċ (E7{ceH AV_YVēYĤY9gυYY>XAVΛgq$pL)8䯂|>_."BDYy(+-VVr'KT@gãO6=QYt|؜[eeKp~RVHZY.iVLZY[hEVhRZ&he|% #VZ4r|SVc)i<`KVTZf@+-PLiSWZ!+bVK$]KB?- 1ЊQKguV'YYU+eVɬY6Y|$5 "?VE#{H V[XYTV}OrtZXaA%++J|QO}gm*."U۾ʕ1oRN`E?V`%+tF+T5-r+U|l'4qBq*U|B4֦V)v*ɫ,9*άUF\,y}*.f K[+XыXn`?L%JWj,8Xqn_a̤V[XaX6+T@4Z(!V5V XqL'ʗ2x*%4T cl:7jXqC`%P r+LSb;Job}*eBn*+иʖYʆ-3[UمCPU5"DrTU JB* U9&dUTh`U`UYYNYaUFk *T\GP;QEU U9=[*)(רU*Y*\A*7 [5%BJ}jSPTa6U6Uɺg*I*LU!٬JXͪ0$jVa$XtU +dUê٬%*H5jaUdUNFAoV%| Eq*Ui4VGU 〨.p#w4U6vLTQjTYG@UOTFU6-bwʑMo*c*'U*Ga!4Us6KP;(Ѐ7Te&U!nר rq9AU.6UynpP+U١7pUUqr,*ѦVBUqpݮ 7 fUt,U #j*ʃ2 }UU,PVVy$clٌm{lmǐyVam@[`XpF[:kU*UWj[/Va':i!mNVViUF[m [jcmUVZ[Ł%Q**{*wllkYWW邲UU'W\ŌUԶc* U%ݢ mXG[eVi[ɶUՕU]Uȹo[[*LU(j]tU҈Lt uHy9W!yaU!ȫSRWQWiG^H|K#UμIpQ \9*LVI|LU Ŵ* d-?ʈe!'0Z!l*K*}Ukiz44^\#J>^ʊ U#Ը楸ql~ٶ 8k@wb碭2N~Hf )S*6M<,wW}*@m\^ 7V#lL=JS*%*d} _uCV𚴊&zsmU. Z -T祫Uv=p&9UNEur[WBHY6Bo.bJ^VIP*V1@,SQvp3Al*BM'Vi$Ze QU Iд`A*'ZzBK7;mtUU܉S[eLrk`8V9R;Ҷʂ"ڶ m(msɠX[E[其VѝV!mh*ƁB}*BѶL(j;w' Fk*{UTUFƏ*> U(kDQWY. t*9ZW1脮2S;󚄳ZWldkqvW\,4pBl]'[Vk`*N!U4V!Tb,C[eαUMe`kNܶ <=<* )`Զ [%U&j%8ZKZऴQ&iN$ ZeVVqTZXsӘU)P5B )tDil޴ lmEbI*.c

qʍWWq\]bU-2Uz 2sCX xu  8|+WʨXXgX1+6/`eXo`%Kt*U.  _wZ-mo^%Yo^}V,WX1G`^#"J iB+w? w rl`T{JIN$ <;^ l+ʺ naf9VSWiv^:zyK~UXYi_.W!lҾ)W૸c*7Wn_}UW ׼ 5*]w\WWa`*~bN OϗBy UUWqnuV`ImJVY RqB/V?YDV1ma2aU=O[cmmulx~*ۖmUv*wV1m[Amv>lZEC[UVi[R~Va`KV!\XR`U m"x*/B [etSb&ֶ U-V!QS[EJ[2D[be?ml*5 y*RTm$QZegK7ʨ[Iw ҦU=U4%UuAVRV1}2؏Rb,UXiYyN**x)LBesdB-Gd/oZYZeS Z%ѶUgUt WTy*ʚWWm* P*ȒV6hVe?AVqԲʇY*M 8PVaWUAVaMe=dJȪ@*wdU.4UUfZUYiU*@,b¼ QfUn]VBeY+Uya,aUL%oV:]&ݺ*Vdꪐ_Ӱ%d߮{nx骬GXUUXhU%*#U8 T 5r&Mר *4r@U#Q5-Q)Q Pbb **Jٷb"PBZ*+C/UVU`*ꍲ*k*hVќ**DњUkUyY'i[*Z*WU39`U8VroY˧UVD؟b01"/CfUaU6UYTeU걫TaŭIjOI U^JHG*FMC5Uhlg&*CR 1Ufsҥ8*#kT*5r3Ty}TDUاGQ*:&-8rmTAtT!7I JiBզi*h4➮*0%U+-85T)b$>7*RedFG)Rer@<*lئy`Ȃ@X4(=AH%UxB@դC_2TqsuP<*DUT\UU،UPU؉Ug<VabG\EC@\e=[e9!bX7߶J~^K[QmmAVhj jϋW(8Wi! yͫHʫlkF *:*EW!2^_ELN`VX7Re?/`EmL`Tbį}{_Eq\_`WQWW9t*/+\VVV$s[XI'($EK+'F`ES`q ~ x+XaH`e= f HjeׁV%H+=fDZ^heZ˫aT",;縥{UiEQie#UZ1ʮBT@ieFʁ Qz% c9Њ Њ 4BAh؎#J}PVآVYٙ8YaʾfeVX.Y1҃ߖV>0H+VBjY9apV4|VȷZxȬQT>Y Z ~A+y$TYY65ʊNʞ4Y"T7ZdeY8u +{R}Y_odEdHDg*+̭˜MeGd++䭬ЮZY!",UhEѰXw rAxZYoV hp1)ZVO heEVȃjiEUjevVYa-Gg ݁Vz WZٟZbZawΆVX?Ymgw ҕ4:+n(b UhFB+#¶`XB@XR'Ҁ R+D"Z1󶩕hM|3Vf%ԊuV@kMgVŵ.0X+)b+[ok=аVٵrROFtm~S3)MԊGC[ VFRBfAbM?qTb,gjJV6 Vojc%V-P+=Vt Y{jb5Ί q~gSpuVXlgP;+ 5qVo¾8,ԪX@+ے׆VΖ:+C_ V:+[R!Ya & ;4b%@YarV4@VLAZQZ&RZy)*V,WTZlie ҊJ+r ( V$* &ҊCߖV㦥=bЊ4 ǐ)3[C+V5Z(V,ZqyQ?YZ1q\hbSVN-ZaWb !7b Ie gI Y@+LJZZb?b&b6<؜! Qͬ,;'fł|VٛY*aV̡YaQ֋pVv7:+=B= w5rErfVr$̊:+#qVY YYN8+Fh% -8JKH+eR+H0mjjM Zi%j!ZDiVΐV4˔V@Z2XirlCje[aJV,ЕZFGieK~ZI0HjetS+ka-V(nVZ!PBGK+U@Z!Y ޖV[ZqҊҊJ+,ԵQ-|tsJVOiyji nP+YmjEIje}R2Bh+ǴVXAhke}X+%kat͋ 3GFyVb1֊S[+kB@[+NSBNZhSjeKZqf}㮁Z+lE 2Goj腠VZ8VT)x) VXmie=pVCTH+T)dj-V_j%bolҊJ+ b[ZgI7HIZ9]S+BؖVȀmj0tS+& JV\ZYQ}YWg1KAYy9+[rV|鬄bV T.M4$bi%BZ8g:+8:+gYO`X7bE<ԊԊ}[a SV⊭uk+=me|n+J NSlVdVP؊Eb+,E4Bc+l_VV< KmXys+@4ͭ[aVVine6*ѦJJc%V^`g^se[ioaJ x+孰p y/oe[yMS\ixpxOsx+k[q (J`+$6" 2 >1[;JŴز ʫ[mgZ[y.܊AVȭkSs+NVZ@\&./pçT)bLPpeٹ W>7?qW+ccZ\Yވ+ﶸ"r\;ɹsWNo(ĕ'/na:'+궶(D[qpBVok+σ.2* vAV>HDIPAjڥVH@6r`;@+h uMIZZ9?&<,?5bCjlZyK\g'ʳk\P+9ZY*)PҊ3,UjVXmk'[_btCl逭ȿ<;ňQlʳՀ\V-#)[_lŽVZ[[y-؊GnͷlK#zP[96N!ڊ^$J0JmepVX[z_ "ڊ6'Yr+.]oEHŭd{Vv"p+;h#r+2Ur+r+Vj23R`] {NR95?/kC#VԊ}PZaV3WVDI+"H+a:х_!,4 ҊRzK+3H++ʺliYʑNYUћYaKfVeVpeV묨YlghpV~f=ogeߡYihqVxuVQgE-gwY1FgCOܕbVh;ͬ-b*D3+&v2+nK/2+wˬX-r0kifŪj'TZEi$T]i弰N^JL [Zɾ# ZDAZaV1$ЊJ+pKVThe]b'4@aJ#P+HJ JbMqKS+ ԊXP+>lV+Nĕ#ĕ&N$W _+;*!oqXh+r!<+#jsDJi5+ĕ5_'k'\ĕ[knVQgoEB u_ ̈J8x+݊\\ȕ*K"܄\&"s@# &Wd$WL\qW9!$W;Trt&W8$oFndVFͭiioEfS[qV0[uz[J#p+ [qV^yq+͛i$ʝǚ[ZKn VzrxkVV6ʚh[s+hͭ4r|[)p+-{Jin#VHW[>D=9R+i^F[9^V8mۚ[pYop{+_ z+}>!Zo%RlkaIaQsn%_kڴVX}Y+b+'>7[KlV[Vi¦ V,kZik%[\4b9Ԋi#V.Ը⨤.! (5P,VιV>gaP+#V"5@Za{!Qis5#OvliŞHie#V!ThEOhŽ}VT|V}rrVjh :+F Ί:+ର vVgE!VpV,mgKg1j cge4i,YQ;DohŽ|V6dwFZa[C 8Z!MRpI8OC+B+%J"X+ƹ[ٛV b} TF,gb++Ρ ֊3C"ǟ`+lK؊R_k+[`+CuAlA@[qiHgVR[a'"X+OBR+qR+ jes}VϩTZ!^VȾfM`HAL+ؿ/" 2Z`+Ub+pb+j&؊b+V HXn,ҥ`+zrs;X&fb+/I%ڊzj+2{j+ ڊ]Ck+j+9P+H0܅Z ojEzJjV^*4᪴"ԥ2r@v0jhŹJAB+ }feb)ee<lڧʊ!]eKYab|eeZXP.(B^Ȋ}z!\+2 ȊȊJ5VZXqyXQXic%yM+8oe bʆPz"¾\mPL. Ba[ʇ { +-kX*X9h+>;VV"Vʚ@W1؂ [Nr kX 7rV+ `zdY5V`V8y~` XI;X1$bsW x$WV1&fDmVMqV\'lܴUJl[ܼU Us*[Wq$5_Jh p]}q*:*sV~Vl[[%)iM,#*MViW4UhZű%`kǤVta+[V2kYAVa7U +8BVY=y*.q(((=`U-JZUU^׌PUz(r]+aU\UCUVGu*>eUY**լ [X@UҪJENPUF)k*٩MUe(**Bg*CUq*B"?*!ri[zUFw|*n:"[*d¿dM'dU`UN ꄶʶ|T1P8;TWV] UΤyrWWIʽE1 - * *.U4U$U\PV%YU@O*vŎrpUPZYk"̆D誸\ڮ c3]K$S$]앸*YVL|*ʏ*KuªP8U1ݬWvU><~tUJ8 V9Z0"r*ʵ@'aO*n ҽJ[0*lĸ@WYvtQu"AWx]MUB]&AWۨDk^UU̕W1L^UyTkrUݑWy];% z6r64{((ū^ x6yUi_Ry_UD^zUnrUM_DWʘXyǸ%!f1V2o_8W!![_$wvk_F8**+I*#.Q"eŠr\mxV% +; +c$zeum+c48bNP'b1 [+7< 0[+_Jb͍ r +ﶰ"yB5Š +d^ž+A \+ϝN`EH`{*?U,WaG2}"*TWi&ʈXawVX%x+YMj`u?K`DV%J+ +@]sV%W` % J1++]/+ x XMW:aՇVԏVF EH=+z-.+>V |aE`!XqM+P4+p* _(U_徹r*jbo׾̀Wq#rW}*qaq;U>*U.UY\nV\Ų/q=zc* q*UVynl l|lV"UYU l,miU~WWqqvl\xU. UUN9 tEu-U04[WYhߺʝU+* ,ԦݸzV\PW}P\ʝ'4Oum U VYZ$ sN*tz*.Mh@PӲ #l|޲"س!0kY0VL*yU\u`eUaovUU{W%EYu[UEkJVIZXBeUY!U?U@U9;TUث8SU! Uf$TU۪ r)7TUy&TU(:U&J) ͪHȪɪX)$J*CaU U;PU!U6hU% UUUaŪnઐ۰~ɨVv>X\BસD^Ua{]VT]&pUpiW GW#=2VU!׬ 8/Ve˳LV[YI"N* fʳdUUn8+U:Ѩ*Sw;TNUPy*YhT兡0kTXT*DU7>|*2o*c=9XJ LsPU"qVX ®ȭ8\PU!U_TE%ahF*$GU3 UEmXeaTU +c*.r JWEF] e*:*P+Ш*Var*)8PV1Բ Te%[-m*`*洬r PQӲʍpԦ󯑢=G?=WY{cm"{=_6Ηe[T6rSͲ\i0z /Y'YN%AZAfPgLe7T4X)])e/`2bqBP c.8EhuK22X{ Sх]!0r(YL,ge -Aegޥb 2"2>b cpR1dB\eПvYƒΓ2<e@-Ųue> 2~BbYbY֏MXqx2/wT{WX'Tl+e_*|,rcDeR e )@YFHS+OgL+ke@oe6,csYƭ+eHYf_E/e,AG8 2֭c #XF"8,᱌^d"YGEW$8}B 2>;K,zs dE,Y,\[ie\/e6#ߟO2z8>b V^N<^IXocD±9D8np,,= 2Jq,HNf8^sI±UcLZQ8]p,KQ4 ?c0b?P,˳XF{$(^b2z0X^]8 ryVQI|H,Rф6eG"̗$XօBH,#&J$հHI,˹ri#N>*KyXƳR,㲝V*0WY=[=8-Nϝ9XCpˑX^ e<ӭ ef|,.X@qTd/aHFR¸TTguG!.7HD4 RH!"h"OxeIL$hLWJdO+ʖv#̛"vRчaT,aYF*eIV[X²Dzdl^"T~1Y -&rSCme# eY?eWG6g! eGvD18b2~DdWKd?%\,#(6HD'8DHEs !Yz 2HKkBOW a9Y R"R?-.\DBUuu,K42FCe&.KBEU҃#$hӹ7BAjG!Yme9 ,,ɲ6!Yfi^RIםesdiT*EX%2dc)e\OHɔ+e>Tds'vJ,X,⭔2Neg'o3M!2B7CLudYׇώ2zh 1Y &˸xϗɲ;XDP~T AYEPuفe̜̼f, oaX~eu,#skeE,c4XO!XY2ZXkY aYeΑQe#%ˑ}) 23o\,xX,:D²t$e&+,x2al²01aY>eOaYzet__*M)Ge;ޥTp#DeY*]UI~QYzL2Z;qo8ۣto2Њq{`i[U0˸gR0LV޷`Z,|T`V[ets"_e&~Go)e㹔2P,%XB yt}%NtS2buǗ2`]t1t,k)eWųt?e;N³t2"8ϗ2`~D,vazg3ڜ-c8ͦY!Peh2G$A] hҴ-=Dhc|R -c~ -Z-|-̈2;Et2zMEt e9Y!Zɺ(Bt ŧ B˲7ZF\/;B( eYOZFSz-Eh ZFNBRZF`)e´bU,tHeޭRZFRJHh%-2yBZA|uiT̘ -B2zȀn4(GNGe3e4#$˝ -HNE$eR%J8][d~iq9["0-cvWL}.Ŵn*/Lh2:݁Z(PKH-يmj" `9P˸ZFg6e|PrJ9NˬI N2rteet]ò*PGЕZV۷qk: #~ZfQ2%JA-3e *@9%P9-#mi.6Nxp`Kj҃u^j6C^<jv2W"2ZKA- jP\ RRНg6X˸ՔZz1eৱukÖ)ekyXhqA,jZQ'ZFWŵXCSk)p-˳be\-peW%sk e $-]vZFhݟ`-#tt卧2z@!Ze'Z˘DYQ1ϙ 2&ZF1el/eIґWq_RKZFd ύ2yH-#6_ePw"s@ZOPuƑ 2]]8-:-k-MӲ.,GrQN,/K!N A8-p:-v:-2n%ˑN {:-dg,NN#U^'Nq')e_NRu?Xe:-uZ2/2)3㴌K,8-NtZ:JA$O2'`HUiYT#qRHxmoe&O ?9H̆RH }FYV"-뇒DZ>$Hr. ,U_eD*e~/e bLe􊼤s1dZSiqPe msriE\(-F 2 eyNm ciYjdLi3:-K tZZ2NE8-$ȴޱq`ZF_2'iq-29aZJ^ 'X0<0-#8kiisRZLTi#*iR e2´qdZ12q1-ôCi1ҲT2O+-o2hW匒RFJ)e41Z旉RF sG9-5E(2"#Vj,@{سxBZ0DxioC-%%Z$w 23ނbDeF/P}k h{ ZVvh_0P-~Hң ʑ-,+ u.fS%ZFt*So%ZkŸD -TZ>J-J)l*-=lAiqҲF1ܢTHkYvp-ɵ̲)ec2[pZƘ㥸1 ^˸"[kck1}QlbZck$Zk0+krHhkZfbj%p b^x-sUO9ΑĴX_k^˘N*ix-c+˒FņkMSB<etյ,kjtk9Z>mƲjJDPo?U2n|ti-'yZzbZˌuDt)l%؊ e.YtIeJZ*GWx-+{赌9fx-Wԁt-{^qgeҳBZ e^:*gh-}KZ$Zj-=+EkGj2^q:%be\˸2~Udp-T|؉h-RWe.ׁ}h~Tw e|h ǯ`-恵!2q`-ňr~xZâNWgbVhZ-R V˸jY+Kj86_A-fP  $PˈƟ bPiB-EjWaˑTWbFRK?+Z*%34ZLj3RC0,)2f bBTR-V.HaH.p1ѿCs\iYep1?ZsdR-cE2TR-#_#' lmjto2PΉj-;GQTTˈMbzT R-)+d5L7XĦ,UZƣ*M1㿔x9c22KiKiSCcQZO fಾKhŴt2hݿ0-dJAJx_Lbe_ʌVI@Z!I+9P.SZ5)X{2$y)fV% Sѕ_ʘUfN V#VUmk\V2kk~`+kNV+$VOI[t~c+xb9\BdĈ2.a:-ʚF*V a+;=cUZ1[9֊VVƒE}'i /k\32S>* y2[rV*獭sS[Y+VvJ&V hmp+DHVF\%hyVR[!d2W޾VW[ pJ= n+.7b9+"+<[\iĕU_0X )Xr Jpsty$[qXEYWvŕ[qTLȕ@T\nb-ʜBW*PtItN}𨮘b1+fZ4rTiSkr 4W_sŲ>4Wx!GW]*T(\97t+b抙+]]]rSvEKwnEwDz%k++ @lyxrm.̧uTmwzܕu7qWqWS] XX\2ט*Ok]_H`Q+ Ä]DQf+#%efW,]+ؕ]Bvu+/m &baݛ] v1x+d5rBȮ:H(ԕvŀ)9Bdbvؕcr-/+BX`Wd@wvW|஼Wu&h?&J)CuZ2V^hDxTWBrR)rW4J^9. ̕W&xPRyeCA^9iyŒYy8W^ 3W^>W^NQO^YܜWf/5H چYn@J+ N}ܕz]Ykxܕwe]i" wE"[aW^슣 sћ]Q]-&v+Nؕ~<ˮ,dQWfjRWص )UWt6UWTW-ug Y+oReM.ѹRue(@]Y렮XR2?U2'QWZ*muEjuҭՕ#cDWEWN+@WiKb{&1Wrź,ɕmÁ\1 bre.S$)6ʋ+ b`Fs?Xv,V1=6rC֊%FZ+mIbUVsle+rpVn8+Z_9+Y1"rhe!jhYhZ%(Yc 8+28+LyM{Y`Z!Q&:+kdVì6GLӈdV/2!O%)Q:+]¬4P+GZ'Ԋ8GZ9R ԊԊ@ԊjY_ %Ԋ~&Ԋ/jkeZa ֊a|)brLc+ [$]ZkŝnV"BŢ؊%H/lႃBW"; mʈE= P­\Gr+Vtn>q­b[o1%OVV,8jo2q* oeTB (s{+[i%ފEx+]JFlʨ>h+kV,[D[cV6Qm2DP[9+9+GCbhk+Tt! wnk+G[ykpxRpŬc<0\cjqYW0WWs &4򨁄\r W*+ŵҕ-£% $W^[\J pŸn++t-b99yk\petU x+=Rĕ2U\ hb6܊ Dz5VZine APh , bVZ[yvx+"z+#`Aooefq_᭘ʎoeS)oŌWU6~ !EŕuC(qSW\l\ubtmc+lዹ+ƺ2勹Bػ͕]5W?\pmsŧJwA+I8]QouX@A]v+,dW5 ٰ+SadW,lyoD yeTUwؒW B[^92nzŞJzhgȔ+d34RWH7r%Gp`ߏA!TC#PG:M-Fۨ*mWDd;N>Ciz%+2?z%z+pW^a#+)Lٵb,򊫑WsS ⁆#\FT$:MLBPۉ 3+F^7]+/CNf,W. vEOWGKX~ғIP j%=1*ۅND􏲴hi% JI+cۣ}`VhK+XZP+\RTe$3$gVl1Zqc,jőP+L`B0O4F;V4 Vj%sS+w/X+4 x[[C+^:@+V<Z5BZuggeul?geiT8+xvVxYrOcY^60+aޔ̊jX9u?X9X!W a1VpT+ŗƊ6| B("V\b:b1M%+L,P+&xMx%+6r>"V(b.X@Ċ/5Ozº|v2.8Uddad4:AV(s `Y{!d xFV4BXq"oj #HXI ea1 +wBSXX7jkd;gTJEKĥlފcՑ6V뷱bc+6VUrmT"A+ `/YqPdYȊ0+aVؐJD(6t?¬0P5b f%d3+^YqƟXi0+@Yz*ͬd fF&aVQAkiѭ%f%B xMN)+XYeEO+Fb;.@ʈ!2zW| Ċ +[V|&b=C8+3!g%;-HkC+̗-+EҊ…VniVRchiJ6ւZIzױ@y b_GJ2V&.FJ }`@9@c/M1 2֕ Z 8 X䶴21VYʾ@Z  22tVHP+rU3H1`rVjx( 9DvV,gg%g&]ge!}ghBT7wvVR`g䬐M dPC+ he=ZB,V\jh: t?`4 pKVAQ,VF8m 4e28ЊH+MI+V֝V*ABKZ)Ur3(JVjH`+.|a+^*3bV\[el_3؊w^bcDJ6 B8؊3j𰵶nVl$ T/[q:JWQ$tCୄio'S6ئHWx \Y..gkr+x V&J;VRdnCp+TG Nٜ[\JV*A"V\ZRI"-[@[q፵Dxck+,E[1S(nkV\ n%J7lne;(m?V|nEVHȠ86gm; Lone<Y㷷V[+X+flBaA{Z["k‘}@ ;V.ݠVLZy7LoLj~Ԋ+aV8jeYBLxSOS+VEZqVFT/6J?p?VƃV le[i`+;cUc+8H`+ 2-}@rJHVز3~p V"@}YZK=5J V GD3lVI=7Md i%K+Ҋ"$0VZ0i,VLZ99x`i>K+/!iAH+"hԵLJq+V0ʋ'Rյ}$Tb`r ~ÛZIᘩoڌ`FJP+IZC܇Q+7 嗋Z:cj%cimDoC[I`#܊Mq+㶗r>oE od[1X$oś[vdX''ioeY*zGVRjoťx+5J\; A+\r+KnH Xm"o5s+^V\ onŕuV&sp+!/܊i+m%5k+462*|#n V对,VN5V#Vu[)TG?[aSx+Zr+fV'a x+k䭌ܖW|pJ{:"pE{N[Idoq"qϐ+)r+91W + t%| ]U8]1^`teÜ]E+0(4Bѕ1FW tl̕Tb. ;cT +;C/rŬoȕ& +@XR; =ɕ+M2.4+!# ŽW(_5B'+k L4ĕ*\O&WmM@\H%r+ꃯH^q W<28J*捯^1j{ qi!\TcuA?WbU۠2GJS⨌綵y E3AW2oiCw4։@`"X62>rE`qejOD*s|]~u"(,`^W~EiWF'ʪ_}!|eɀn7 W,$Zi|e^WV~%s|e[uW D^yVpC06x)zpW.++Bnq r쵾@_a 5 ;Z_L@KW#=X" 4Wµ^[|n+ŮGvEQWԕJTmmeVk#AWJ1'BW*Q0W.Е *bO AWl]]yyd]9@jx)9ʋ $+1Pht%\beѕ`F+6W՞J66~$詘+kW~ftѝѕk2+ w;ܕtvWL]fvW]*AEU]!NvPW]TavŹɓB_byŁ+O$RC7v%+l46+aW*Z)dtJee+ʶH]3aFIG]"Օ[JQW_IA]C ue}N+x]kt.{;o2iseI5ϯOa?]Hn+g]5]q`tpt%; ]'hNG̕1Δ2, 46WE1W [\!wJmu+1J*x+VW\Ez+6RW<{ʸ5PWMI+,[]t +{Y]t] !tŻ\jftZ +/++I\q^Pt\[M1W\I=J!\5⍆&r&ȕqtV~dRx7 +5&W@HM\IR'J"s.oM\ +k'®xXv%ؕ]YpnĮd{s+ގ 1ؕb ߊ8i@SaiteĢE42š>tC+Ά]!s-!bxK5̕ \v1WCqe\: JF <W%J)s%O Z!W"@ß+!We\(reOȕR CZ'"W\q;J6N7]4"hpE_+cV(3v[z[ xps+%sn9'`[Aw7ͭxVs+uV۟]'oKeSbKeKVW${+~V|LCCPkmr!j(ir% Wr% ȕBkqЇŕJ$W\/ u,W6X2ĕ_<8+z qZ\q.WB"xJq=-̺u SWmr6Fڥ<+%B-ĕW|!W 2bBM W+Khî4uue[4S@WI]^VWtD+f!WrDwɕwvfY W ؘ\1BD\01"WHL1M&rj+*!WRb{2W\Ec5 $_ʮnrx&W\&s%+++1BR芷!2+1N]fW [vJ]a3+xb8I"ؕLŮb)wJvW\jw+D]q?fw%|e_`.ݕ*$e3'OI+vWR+,ye<4ʾsWƠஜYThoL+%IbmW ]weͷ11b)x0bx|H+プ/wۛ]a#+]a}/<+_P˶®8,'fWO6̮ٕBg} ,+c:`t]ATrl4}Wє>v*te6 t]&t%xЕ;f’HЕq<0Ҡ+,\qk̕BJn3+O\+W($H>]q\aWٕH@fW c]]U=]!S5ʍhwFJaW,\~W\tJVl⭸ +VBNr]V[o%V<Xo%qy+ާ8YW+7##V%[Y5{fV"Y[=r3\bF ;|q+QVp[kjp+ė8&2r6TonEVi?Q+YVFR~~V^@ ԊCDMxLbj 9V|BmLjŅV Z[N8+eg1qV'GX5@+Tv7i}#rVYaNC+cb}he uVX6%C+!Z7šZ9/.1WZVXq[qSSB2Mli+û8n۠D̓V&mŃk+렭8) VڵDVbMY[im`{ h+*Njm`+Vj7F؊ȍNck#zRZvķgVEG/V?Z֊#VnV>mGuO>MmlBSc+#E ;[[Ih fc+BCl[J}V K[9[!C؊ˆ<(&[>^ :V"SIc+^ ble}-hO:VFCo#kevDV¦O¸#֊3r|S+&jV*sUV1P+&[Jt v22Edjez;R Je0눜egB;+UwYq ;ZˁVL YنV^ZY_V۟:ǂ -Zq:tpV9Z KaX+Za1JzX+NB≭_m`nkwVFa#/AdK7k+;8h+=Ǎxlc+ZMmkœX+##^m1CJf2ZY+a‰Y+[?l?V}&k墘֊mx#l[+ZJRJ.֊Bm+y,e jke `Y+(Z_Pk\mVŶDX+.S?JnhY+Z(겵fkE_T[ V?XZqM[K+£%Ҋ+-lyV~"WEBZS H+l>R_ ̖V̊Z!/ZhЊiTZy^Њ@+/VZ)-QYyؘge\:=A+thV%HZȌ.ie_FҊ#P%ie+V\202V&RCN--Aڠ/$5 䒥[Z232IVGZ:J'H+{ C8ljVF!&eUCV-Ԋ5JI+}=9VmjiP+^q r?-vFZڣ$V*ZA7^r'hJЊ㝆V"(Ί=܇U9+Ll)rVƻaY䬸X roolheciQA $p#fT?VhF8+!g qVY1+ۥfe0e5ͬU'LY YA0Sh@+VF^9GZ b6C+qZ7Z1R{g83 k#V-S*-88XZBZ퀴U+V촴1lZ؁V6A+#h%=VxZ@+m ZIBCA+M qC+œR) <ҊOF,x2fi0!"BSHZ H+H+liP BZq昡TZ1bЊg_@+r"mrb!xc#K+$DZ91V[?SJPFT㬤Ί+Rg%Ԅ[hg8+ 8E^NfVr֛Y  BL:̬x 2"bV11+cpV<2Bl}rq]U-8Y u ATYY 0+apVlYዳ.9+ Qͬy̙Ya0+?1+ `VV\4 8bfVWzbYa)fbVvfVnaV$s3+#fe 0IXeIo@Yq# e%* ʊcofe%h.ʊQV([@Y1vqv#O<% wh~;+Yq!h%ǙxZid<ʊVV7"FRVV✠̳1 "e 6(+iYYǯܨEYjH3+DY!YX1+ޫ(ʥ-'g HY qV0K[ hıiiewVj- &^)EZqnR6n bj%2Wa1 @+7mlgI;+ YdgňFK+hH@+. bjRs-lLodh.8+~Dxfd5̊Ⱅ(0+Ӊ#ځZN~G*h Y V[+nV5m%#(qe6FUr^VQ n%1Xo5q+Zm2Fmi>8V[oԐNob k p+Ž9)[WV3!ջZ:u[+vmxk|E֊0} ZagBbje @ xg'g"3+l`V(< b+̊۴Gtͬ<7엮AKge>58+>Ί qV؆ʳZDʰJ*P+~ԊvBLb϶V<)ҦVBԊ)P+yZ9YD nZ;TMeNFJQ0+.ňb% goh)ʶЊ׿_[Փ煮^~/?~Wylk'娪{RZ f)-()-u'vjva*NdӑRZfv)lRZaHKAkrحmc? BKu̖$U*Pc_1H8m}hΝZ\gn:Zqmz2Tol:CdK-;ŵc h,V*S7U(- T,c=ZJc)RSgGN,u.-tW}HZ+öyHB}?xAQXy3Zg9F Yj>Y>W7 @81*v)$>F>,ǨL,՝Ct^Zg|JR:K][5YLMLuz"k6όE}~MY:K}a8msTy`N,<?Yꡠ{v7B,§qjRgG Y*:8K=.u4RoY^)5TzI?qUn#6־+7zYw=Z]:K[nimR&}JQMR8KbRi j++ב:K]kYu:7\gzMUK=ni,lgggͪwUXgY'}0gIbSgVYjKϮ:Qz76gAlY3>14sYs>K}0?L8L,tjܞg,ϒ@[KK/W_z={~,[h_HVYY&eW% Q< -̯?Z0vEód%e&TKZg_ Y|TG"tl81faRCkPq7NP,X nfؔk,>Yk9l h7RKMT QQ,խ=RL,]YɁh:4K C)泺1fMY9ķR"q?'Y4 iz(ΟȍYaq"_nԢY9 Nh⽷^u_}hjI}vDTc9jd",5|}7E,ne$Kf>z(rUb9!Nת#o큿iROXDT'&iVLa2mԃw#6jdLY) kYYx0-H&elb냟X,'mi,:t}YzjsbV gϩԩ g9} qĈU)ft38KW:puX61~ʥ}>2ŒdLl Rv,nu5R?YpۑXy-Cg0t݋H,x4rK:K}?5(1Riq 8ie>]Lx,$dkJf%we 4K췙fǢY",L]d4^XiiqK4CfQRǢY؆hw6͒I,-RJE[QY*sKY4ui,F}[f'"X;;,t fn,uoHhڴvYj&ԣ]):69MLs;,,H4K=%fa1-UX_+5T8Kuc"]gX]f7YtIpWN;o%,u-;*:ER}1!ͳLD,ճ4RQ'yiz*V/RFK,uFROkYQR:KI@ʭH~q]JgY tc jևK!Kc,5oߏu^fi :rTþvZgBYKie C2Yj ՠuK+'ӻΎ2Bt Ih]vD-CUnכa&ZjmRD ˞-Te,w7vӾ hg!~eF[v-DP4R9 4of\nsELSV)-5:Et0+A+-RSHJK䢔2uRZ,PJKE?]RmՑmw>6Nr3-ǘ^3ӒКddRo8MJK} J)4 "+3i9~ѧR=9#-#T\a;$e ?HhNR-}]*7ZE -X,O-[w B6jUOe"QJ_鋝|Yha6 -fjď"Yp-uCfj:isIM-c8Qi43nԖ6:}-~˞ՍBK=e]4R7t?/DL}-sIc^WGZ5/ -GZhL-j^ޫHl9Qn(,u"z!eL YG|hYj)%}Cs;~D#|i!Dj%h3-5f`'OY|^5I,e ggY*Kl6iutc[g3!Xu_2Ig%y݈g/,by~ׁY:kez Jg 9U/>#;,{(e 鼥:KOĴҷFY2oRq8gj$G62RnYzO癧|)+j]YztY=fZի#kYw7iGų$Ҁm5YjnwyMgN>K54űX3g;Y+KhN@K%lf-3|g[Wgq5,u1u}LY:v(ޗ^ruR&t8>p<8gKqlrxդ3楳"u4ϒ2wf)U2K(Y^t>m5Β98g,I&f6K}6,uϭR{mpW:5Y;^1l4hVnG^rwv RxͳTVeUxyhWZheBų}ի;DgtYͳwi~8Y2R9sʉxNUknEYg饻>ͳTVe}*ϒ .W-rRLj\m wef$RhL3YI[i 4͒Y/6K̅T#eN-mfjݜmP1RY3Β|It[:jEpi.qΒp)<jM:K=W6o%tz ˥HR5Yǽt::K&, TT۷t釶3VMt<ghFi0gƬLWA:KZgQ0L,Տ7Rm_&N,ųTBh,Y" <dQijTLMLH,%$( R_XG,YWgW?y[_K% HYi_ߦy[IUԲtYEy9i MgY@k Hi:kYb/nY:'rYx{ Tw^,YJgɢ>tU˥N֍rei+e$ed~A,zj,Yfɢ6Kזxq)ed$BM8XntB92K=QtaZfo, G2K}蝖YIdwYR6 $ΰ YIh$fI"&4KE/U}h,B:9,]X꩎zfyM,44\R>-mezHfrE v ̦YjXY(`:KfI2KΑY70K$,2KMD7̒`*?Y*ػ0KBI`DKfߓBOeF$Y$RSŲ&K-1Yɒ(:&K}&m&KM.r&K}ie 0d Ptr> K:pPGţ]KX@kv}NQk B}|U K2^̖ 5^FYDBL*,SD&Kjȭu@\2YR(RžBY+8ZefYiXò#CUVE,}4˒d"\~QbR,ʨnhrzfQe(w]:99cNY`}𫅓խL>,N*K .ЪɁ<eI (KPTU3z(Ky:NQ: ,]#J Ie=RYL,5,Չ2 Z!%%. eeۭ*wbX;mY(pT"LX2=IJLAK]oEeT$s`{yUEt\ݭ{:8-g>\{EA= /,:sS;6Ŵ$Lh,+cQ},S-NcKR'Kf$t#9V$LqN"pH:4KꂡYBTctDT<5I I"2Kr(C,SNr "h:,9hCtN^U/yU_<^ c%U1V^*2V d!&@l$AcŁ+wXI Vʋ2Ӊ++ζXX!a1+(oh}gU432ʃ4yQ*)2RX +jaeQg"8$J.All2@b/ {Xcb%"+7'c%9Y +ɽYq'J mc3+YdTa4Xq1x^+zx6RrSȊΔ1_07YXq-[XaaE+9wVX =^E+⫘mi^euU6n |qE$UW7Wq)̫bZīti'ʨ üJfͫ,&«U4 ^%*/ ʍݺ!!*.BWI9JHWqy8*-y! Wo^f^|<*#^4+* ^\(, *$"W^%*!0"UXE32.׈Wqy$*WI=9?WyU W)[P\`s#^%*cRC-ɾ *;U* _*㫐l_yB*XJͫ3*U<܈BfLW35r<>*.Bx)2M*.rIW983*?yksxgͫ/ yUjZWYcM``yX:udu{ *Db]/xkr)fe^ЌxĊ^e1{!^e;vWqBe.8^ߘXX7MZXL1Vu6V&< @VCBV0Ycde&:BVUr˄YaRlf;3+Y̊fV̅YcYqIo&2RVdgeEC+cl\6V\ ndt++ EYY&$`eS)+aDY`eQ=++eGY 3+d&febV2vY(lFO)bVEYj{3+OAS8+-EEJǯVm8b`&hE-h%ʫgC+VZ9NnN2<&i~@Ҋ+ЍZSJLihe2VпqV2|bV!g%;+DdΊ@+ŪZ']%b@ʸPL#@V&d_ J#+ ,`BV@AV4Y!+^42YaQ*+alL6V =a\DT`)6V2XI_&+eXzJVXW m@*Wv r܈WI7k^4*WYm,^kUͫWNz*v'̫2>Ex,FXY"l`$+Q X- DXq`e zHi`^*#m[H |̫ū5\xϦ̫lcU̦YW^RG UNWT W9_zApU2tWq&ip!2Jp{DW*cFoⵛ*LU\o^e'(e^ŋU6V|(;Jd|D[UҸ8g `㫌W_5WY 'JZx=İU2OW!0 YUm[/[ElֱUc8s4ʊk]%UN(ݘUDW8ں-tYryMQWj^JWae^pU)*޾UW$]e̬9"]śvW@ ]%*.qt7rXm\C#pTg**AeD3rn@.ҏ0*/2Oi]eߑ $ ]śXWIt*O{*.EWf^V>%Nx.x_ *UR]R:x*ͫX華T{| ]VRn`=  +&`E+t89hq/X٩X5zja%+IXIr6Vb Yq^FVLxY|#d $a%+DXYo^'J4kUCxT2n^%9*㾔^ͫ\J-쫬6*~UH1\*vU^ڌx%WLd^v~xZ<-FWBWquc*t ]D[@/r4VtҬJͪxhVE3*JxTq&(#RUpD6CUT>.ݨo)Pу **R8с*,Tq@R*PeF$x8*ϑMKT`*)*SUF"PeoPR@ >U5&"OJ=&,ߖ=va gbU[1Ċ6ܿAŠ"haeR1VVX +lVbŘtMH "TXXAUDXIWmašiWcaej+TXXфNV\Vaہ;Š,xFX^< LpUtdc%6+++i_+炇ccvŚ7N YaWW#+6XYdŻvYL3(+x iAeTݐ)+@YĬ{7rzW `pVr>¬<`-c2(+\CЕBսJC*B‡җ3 +M"x#0-3;_BXqCi`%+W!l+J"V[X(rbHXg-KXOVƋ2s=VaV~fT?Xѳ{Vbw>muSXa_EEYU*_x|WTjdV&A]+r2 IVa"zi^ūXȆW1Sd^ĶW&WWq*Ux+WŜ42-eHXq,Dzӭ{Xq!Ċs!VI䎈Z]â+1V&iDG!Xqj2V0VIaLWXƊl8cV鸀 lXXg:+"?DQ2BocOv2V:Ɗ -0V)Jjo1VJDzQVJ#eŽq(+GYnI郬x/j++$ԪO xbe%'YKzQV#!bbV:wf% TĬ-L3+s) HfVJ VdeԜ1+Y2ĬPyhfe]9_bVc0J++AYqMT3+"f~|+@fVBYA3ꛕodef}ІuH@VWڃd3m1V,u#+αY!de2t@VXC$`FXXX$ma%Š3M;MĊ/ Ċ6DXϟ~ZXّVRۀ(V\#a%VX4&Vkb%3+-ebFM+Xqh- &VRebIDbk;+ĊL+LB;F1"beUX? ;M %6VU`x`d| $/FV xJv1&4VVFcFa/߰I@Yy-wHY nL^~@8raeэ(+7ʊ„QVTPVY u<6r?~dYA2|mdEe[Xry *^5=UIAdPWAWݼ sU(WI q*:*2*??EXt;UU*%VaWU*b*"|&[*}\ڶJc*[eWN Wqpt,*v2~)eu('*@x"-ZePblcMUP:*L\'p\zp/UlO ]\=YL&lԎTVɄYVɯVl[IV[[ʢ 'YŒUYDJ*񎬲 "ϲUFHV ą2Nh 2΅TiVZiV&ޢU5xHAVGI#*1 \,X[>DV9EV!^YY+UjEXEaAZVO!*I/Jq}@ nUxVUVqYtYزXn"Yet" 2 U;eσUM؊h6 I @YZ}LT2*r eSK*Z436r_HUO'P ilUWxۘWW^mW&l^1Jūh3*3]%u?x;*bj(ʊN*NU ԰EӸ YvUF߸~*\e W%l*. GJz3*iLU _%\%q?*ߍPEc\Ł@*JuA/>rW,^2Yī7Tx Oj*.^52YU*ATyM3 Vآ0ĊĊ7 uX/Xς51X[TG7&+.GraKЉmXYfVyìDY->3+NYq֗fVnFbVHFNqVH.Eh*Ut$-vBy?XV?V&$`ie| I+#0ZI j%iS+!|V^329V Z )$k%kvVl)֊C`+!5V=P;0VƟT$m}KJ_LaBsVf}V!ZYdd Vldnell`+s\ ?4B: k2)ʘtal4`+]Ha+_A[9(<{+&Vj )-WЩ\3ko%b|x+8V<=JNJ{+ߤz<Wފ7r]AVH_3@RÄBh&o \qx.\J Qʄ eqefZ7k0"W6r0BrŹ!W@WE\yM+ƹ W&CJ-\'| Ã+R@\v%#^-% D#)y"<췆,!p+d[!S'ފw!Rjo ho5x+D2 &oV[7y+xd0{+N'[01)V |VLVRcnalfnX`;ĭ$nb̭n%$Wښ[q&e3|%₱+ 8+6jEJ'dGsxFW1yѕGb0BW]!ltņЕe: QFWmuŻG]9|DQWjG *S9N QW ]qk+E]_*P tEK?AW]PJ-AWWhx;^#^͉2"+ϒ2GTW&ye2n ^JΠ8ojxE+xšY+BW/ye$y%#dz +Y^*bzРLG`"HJ-+ +{e+aax & .++Wȴ9udW=b{ PVLxg{5tW.J+Wңx++,W+R$ kJ+ˌF}OR BQ+ci}yJWI9+rUW(;b{%¯2^wL0a|e\G:+[>}WdQ }eWE_l~Zʸ+O52H+WL_}|9WF&GEJLgKʱw60n~eDZ ӊ6k3WLF_JP +eUZ]+~Rʤ& Whʢ]{GR JzCN^r+!W-dyc#x;+l-xW+}o!x҇W&D򊋢,b++!2W<@^< yenSVW^6Wb x%wɛT^!w`M䮜˝JqW̴y]8aW,A®8Db4ICF]I}T^E v%.JJ(aW&= v|'vMv ?j+6 Į$vedHH]!"1`(xϸ+UTowUvWw䮸*Jzͫ:ܕ|w'J8]g]Cwl]1iw++⮗4r3+; bx슳P&v%4 n3-5D]xfJ \$Wjs> w+K]yU}WY>Į$ q] gw% ܕ t]QGaWrj3B蒁WV*WNG+7DW&T x2HB}+ dBl?]&vWFJP^Nn/+th+xx+Ϩ+aQWrPluZ $n-rW*_/yftb3Jt+5WRxP72κ+W\1x%ʄ4+? x%1+ dlx^Jf%X] cᮜvW+MWHU+ܕQlrs_,*]A5ٕst]Yveamvefiv*y ®\,]~]1 Sve?i7+]9;lLu̗ؕaW!t?FaWߛ]R}ՕJןBauENBW*gZ|Еq} b,   W+> ]+[\aKqh2⊷r<W"tZ\j#xreE̕1kTaet ;rfW=̮bvWgI%OQo`+qWHC4:+.p&+o<+lVfteKa 2"E +,b9 IW6WQ=J(G+^\ag/r(̕FW6%]ϯa?g ]9 LЕT.7RYrHc+AWW >VW>X]L ]ٌaWؗSaW<.bW< @!W)6 0B?+U@:"-EJn>W<_6+; A+J}=!J5W.Wo R'QB_!JW\*}"T*`aXGxDW _aJmw_+ _T7W"H_ɵ6Wp)A`ʡ+W&H\9*]LmBDr̊WR/}ި"0xW\6+5WRg}eB' z+/ye JryeWk X'+L"xŕ+^jrQgw=+]]qU6Jzoՠ ^yC /gx\Jg^qlfWvNWxݕxrW]Y;rWNW^-+fMFin+^SWƻxM+~N^q,JL ^y܎$xţh+r >I\ fWFcs^a$+ޮ~B|Vya`W1;t{t>wE,we%]~vWsw?:@ؕ,Z?r"a%+6։+ʪl5 +)B/`[dKWB+}UX `4}}VBXh3XaM2v-| ._U UUh^%yMU\stLxpa\zlĸ rbpW9!UpkpuR*dXWU*.qEWU\@j]UHR-Zl@0b, *g\% sUاlڃaV[!Xt VK2b~ XeC*5Bh`gWq`\*5;tX쟬Z~*U`Y%%f*c5vA\U\ȑURR%xYв$h`BE)0*^*Wer"`J7L䗋VQgU1*6EUVeXW`]%cQ*A+xVx8=ѾK*^ouk_e[䫸p _{WG.*aZ䫌`r#rWل,֧_%"XOM ,#;2&V #`ed=_X}?V/ ]$`Xq' b8 DXXɨaez~h}&axHVbRF+,'Ċ VQU*WI#Jn*|baœt +~-ma%+g}&aE)[VH; +ԟ1i:+Vƣґ 'L ,(V>GhzsUjy:_%Oz*ۣ3Jb*1 xh`>+%԰Jx*] LoE,lqV !ZX(QŠ&a`3+_B90VmLKn!VbAecoMJ?@>Ì)]YaBR DlRcD %*F&aeki#!VlAxhebzk&VAʘCKX!ehPVOBrowhe%m VVx eEIYJBS(+1שּׁxBne$ RV\Te@++FBY3!de2.•;i!+#74o"8dƞAVl LH̊J p3+̬tfaV·OY٥HY>VVf]i(bV9ֵ:uvVSqYYqPfeMbY>0+ͬ3ͬ8jbV`ͬ 2EYA$YJ m$++TFYqt̊HfV72bgeY$Sf ͬ8L g%7$RJ!qYg%$Ί>pV$.BMiΊw> gggrVjf0 0+NO=̬xef2CuTo$a.>1SjfM̊9V(rqV>Ί[ 9qVldފ}y쬄5$ԻZB?׿}꣟Rg/_oto_#̴|k_~ȟ>fe#\Iik2Rn² 2b;e:Jȯ8tʍ5UU3; 2,(Ce\g2\:0V;Ee5`t|a]ҲRZ*JH5сFZh+2aqѲ NqB%hYPx-.h{2ZR-u}Lh)Iie$UhJH-#SD'GH8 BZHie_lT:0e|´,ˋ!eq?42? V):$Y%BZTHH'iWAZ 2]G i2gBZFFLSJ˲J2Rڈi.e$/rYꂟ4fZ*MZ('ehɴ2242R}_+ˮdzlE`W#TnA-PE*6?-ɳČIG51-&42J@m"iʹᓸuLKeꍛiYfZB&vZ7f2oi rZfғ9-qZfiɳeigu evQӢG[RMô̆42S̃%ELK}> 1-ۡE ?Jl.Tg:γԣ iY뀐(Gl^Hvcieb$>;2o94ZEJB˼:p=ZY;!k P2o ^ΜgQ"/>˼y42]7,yD$xyųlj Y*_ e6[JGfo)D66N,?WY°s68.Ԟ_~Ys珄V@t##D8<-i-m'I\clA2o{Y7>,'8YHg5,z β\lɥR~[,3TWB82w28a_*:5IUB%ucT`LHgNOt{,'!e&~+23Zgɣe ~ϲ]~YbRct`a},T6Bʦf1ij̡gQ/ZS]W*>vQI2"Rg$%m-wZ$thɬe땖_ٍ hZ%"C_Gi.J,MTH2/HR[BZj@I#-$REj{3I2ZfH#-*i~i%SV9e=DYԿ(-b,^}J˶ y)-ǖ1$e#)-R2nz)-"}RRZf;Ң:8Hi KfQZ<iTjׇE;We-emz+%"fZ{ô̓ e{˕߿(-1~QZ_#IiQ=/Jx2E^Hix%1-K/2g"ey>-cս!)DDRK:Zs԰$tя98SԲ/PJ2;]҆ZBXj2%/PK4ljدbPZ?VlevjKZf9I-)mY jJ + )~`A-#jZfE[2[G^ IjaH-#We}R52'n>}iZN2o2pԒ*~ZM-GR(,9tz{Zke^-]Oi9wxeֲ֒0Z|֒)Zˬ\K]~ci-Ik񔾠 zmJkCCJk-Ak`I"̆ZKMh-U6״֒2>+fY(i- yNZKc-5O:nZӔ2)Zfoie^rqkkh cb4֒XK.a-/#% e5k^[Ga-հFf"e0bW:ߚb.JX-36+%V˶cwG72Q-M9iR_ ZT32'C/iEuP-5ReBWjU}Bd 2[$Q-Zy|d$Ւ.EUX-@Y-& eVp.aޥLelX-rbl7տX-s0ZjnE螡Z݇jؾP-D,ex/CQKc-QDc-63XKlk&ל 5kk]Ok.]/y-eY(R!W6Ka-ZHV,#E?[-5oVK ,o%2rYkcIs-sepõU5]aq-s%%5^l7=kn6ytAh- IkYZn\ˬ'k*u,͵d5 e>?\~2_ci-umZk%Aeg2< q- Z|j7$e~t;i-sPtZK %HkVZKeHkT"L?VRU^>8^D7֒U'[˂u乏2gk} *Gߙ^Rq;Zd[mRS~0HlgL[sJ܄Ė,!d!eHl#"S6C`t ԠC/ȝjx-ZR^sX-s[jDie.k]T ؒu` -q l/3[f"\l.̞V l1he(t1d R WvխZfגP<^hi enkIrZKZ9ֲu/ZGglfĆU!dlrD,w-@ #AT˼xʍ-j_IY-s$HY-s@xjqV P-Yk}U9vdHlriMD2-sXز|G,,lEbs,TځIkCcZqZf-Z TlƆN@`[GJ{-kk= 4[-jI?[-kZf;x oȡEv.ZF^CZfCpi7y{x `K%*W8k;SL4TOkRŖ-`my3n2߸+ũ;[܋l`l[e j[<$l 52xa,[<6ز܀[<6I*`K].lq"OQ F%eR_. bţw-=VK.( [a8-12FA-`  !r [E-Nْ -vdVlٺŹ6[HV9b{2[tbT- ud02ٲ x&[בnd#&[ sDdC&[jEGl_Obl:M-~^[lqHdK|uTA⩵͖v -/ EfO1[7ЖdP-5 ߌ^8a(oS`hKd4ڲ]j -sx.Fjl[mIՖ:sՖ2{̡wPԖn?-;t\ًۤՖAXmq~m!bODA[Ux!ebdDVGnɈDrK[pamsw[nwGn.bQ_-W%$rK}e8+¬y҉芖[CnY]c-M"rC[oO,&9tW-[n(gD´ܒ{L-^طq-Wcnp"M6R+RY6[i|[LI[y`L}[4En|AnY 5m%(2W58]p /|5OnF- 5R3R #[fCy-˥ܲ-,Q?r †[ p nNC [ܔp[rT[T}B"n˜t/Rˣ"b>oi%b["ݰ-ElKhgYnap|«l.Jn˜e< ܖkcK7ےylv[f|n˼|BFmv-mkG%|-T4J*J-p ŹV[ 2{> eΗ2{wU[ !ecZmIjK6R[΅~L-m|EAՖ=^mnC3ͶTO;*IbH#XTW9~rbmN"=-Ϊmjwϰ-5d#b[Hm>ؖQ>f[Ab[ܱԖ6"_j|ꬤ-=eT-xQhA[ Br'YmIDm-k^@^ V[j ՖԈh~SڊEт޳͖9 e6f"[f.Yew=Ȗ'u W=^.'zJN-lR[/h%m"Z(t"[\`%c$Ȗz-sBl'rlYJd L1QǍ [|D- A8&oe^ <kuOR>\K\p-s#e>Skr jr)Ls-2SV\KuakYs7uZkYns-!D\K}p-ۀ6kqMk#C*C_P[y)bL⺑[#`e^O5O-^DlOO[Eb9ߑز\--y#de_$ڭ#slI eΖ;l26^kWD'kgz y-zX2uZfJڈ1׼^=a!iZkaa)[zIx-ky-뷑Ev{-NR7tZ_O^٬x-."ג.^K ^K%gkll~kwyrAR:y-5NQ\KH*颪*G0ZfNwTUٺiڥ^K]@ .gwͭe{%Z\+aeJ65ҹ[[`RVH*s+zVݼN-ڊk+nme! tZo #Ӏ+4+s-Op%G+uE\ yuCR dc\9(A4qERpe96*4;+pd\ykp\1pPnpe 鯨NJ6Bj'2mVjl f)V Uoe$ne5Ch+ b(ڊVW[^SJ־trJ`mbOgk+;7WVF[9.`+$[ Y+q?V\kkEd*Z2,2ʡ^WϛZ BL, I P+T \~bW|$ hIJ@+,d$Њ֞g?;+Fogbb9+/gvVl{Y qV6vVXY9܊Yy \ eeדҩ+)+~[Yqݵ?Pfe%VV\مb}mĬ\-u8@ eVVBxgec++;1 *BYqYpduFVsKY䇲R-)O\jdY!fe̬ÖbVvAV0FVAY!iAV !+CcFV\gd";FVC4BVdS{#+_FVƃ18< +Y9 Q=QTYY&3FVG\ʊ7VV>vR +!!+KSYfd%& ȊGtBVȊP!+53Y\ZJ( VV=ri(+%B Q(+3_=u> dey P9Jv+KymOX+obEzwAX(aZZI +P +vT'>`@+GX)%MC +@ZXqOka%LG +$! lf`ŚG nFjV.*$*WQXxIU]s*s=W!^K*}쫄h_jP૜X죍f&`C=?RJUJdV}XYu5"a犰BgaLEŭWQJ3JrDëͫ4⥵Wrh^(*'-*Լʥ]UjJs^-YU.W9wA8*cb]łuG%, y_ͫ@(ZxarJ[_IXa`ūVr5p Pai`ŁM+3VՎUvͫxu$ =y̫a^3ϼ+8b_|U\TBa|F1U{wW9^V6!V^ma8*:7+H, nӓs a% ,TBiaeWxXX1aXXe,ʧ}BZX9UXAXajXX_+cS2,KXbbd$9l,\P^S" +Ɗs挬0VֵCFVT[G02^P?K+7o"Ei:VHZ~VBt!|6 [Gp{ Zxnԗ :(A1-h Pbh*JuV[a3 V TIV\Bp6ҊK-YZqi[<=%.P8 qW>=gKY)bʊEVV:c?eeEYnJ`/ʎnJ QLVV:.ʊRV荲 (+|FV+YʊRVGsA-eQe`VVs++Z V"VG@\2C?XI) e(b%B+ V=+= V.JX WXa+1jVBXX8W1a+>..+= Xڭ |?Xqj`emj+1:XYBVNXYl6+u%tmV\7tK+1 (K+ $Xp)+ۨXa$ VHXY* kW8X46RQɤ*nU i "]eWxdUXUf_R $Uh6 pU.-WqO'_eX. }@+ uoV؎`[Wz3*/;WU_4;6*'}g쫰_հU_ӢP*^exG|3mMF*QxWGP1Uj@H*5Rob\.KHٲpeN(\%UƕAW9afW4pnӞ Vd0VlaZU*;iO*lQZeTGe״UL)Vag*3BjYV!hcbK~qh[U? **@lRjKUlU [EUb2 X*~}ξ?U܎}t Bjwlw*VVڶ ,cVɢIhV ˚V!- U<2QB4`ȲLW#*'au 2ıj-zA v`x(B:ElRUո {fW]U<4*Bg*M*W;"EqqE0B3JE6SF5,*'Ul\ ULBUb SAd\=LJ~hƴUZ*@*[, I BȶFжyK`!+[%UOU/ø qúWBh**^JU ZVٞ*V"0g2x,M+DMxaUt*dV :usU V*.EUH45UBBlr c *U,CW^*~ R=U؍0!.*,\Ŗ1~6,1*7VյYmQcURg\`8a\ p%$*:"HQX*qetZl4SlHl+ *^@†UL[WDɺb -3R,Kj*f+UH4b& mtT*2B~exҌKJBPīxw *bļ ,^e VWa0*^rz*!̫ W_Ogռ252v A|;PU5WIW=!,]Q൅k&Vb 6QZY1e; y"fVXEʿiA?(+]*+ۡA++.RvUVDY9|YYllgjCaV)C+NRMZ!Ί7}TyZq"G#@+޳ @+bhBЊ5푀Vy 0f d ܻ Њ7,yV8J:B+.6$^Zd/7Wܟv-ZA^3*3>tMV1$Њ xQC+/ Њ[)ʳΊ`he`}@!47BJԃty;m"Њ8L`vVY!Z23FZnVE{K+9VZ7FZP [Zskiem-8F | 8s |pKʂHVƭ }{rM$,$VjiyܖVU#t@+_- E+rm^Ϩ6"FJZY*%,N]I*׾[Z! i}v/kǒRcYV$[+lfrV [ak{A7B*oV[JgPZ>(CX+&b|֊m eRMJV\s.k4d`蕥4b ga W_v+Tm[_aϞ++5'J}wWbP+Dcw2RuD 앱P0mP_DBRr{j=/G+U tWSz+TE_Y6ŒZ< BZwK&8#ʜ/+vL̴9W+nW?^sa bCW<2"+W\nx+^RG}WjJL+$-ʍnxe4Wꬻ޺TRJVqWSUiw%#]95❰+oⱜٕՁ]d8/vWN+\Y+0+.W<32^..= WO7 Wp/\YӍp% -!q9+^17 \1Mfp\+9bWƊH\!qe4X\1q1n~qţ>+r[\1nqe>wWt@l/XK,G+HP!WR^.i+_G/+uI;!|p+ o|E_1\у8r4m+ "|DzB2Jjcxʾ+!m9+n+i+!a>3ͮ<9*I&5Baoî@ +.74쮸k` +x4++ε_~vW>q.wE\]9k+'fW(7ď3UkTx]LP]9)>t "1BT~ 2}@Jؕ_v*r]슋Į,*fW0®ePw۳ҹ+仄\qݮ"Wl6-re)0rf1Wr`Zrf<+W]Ij͕H7+6Wcꋹ+۩sA+Kz;P6Wqt`s`+nBWF&6rT+;})ԕ,TH]Yr\6ʭG՛]qVٕӑﯻ+ɗ 2t T]IMG^cSʊ"Ų+1BݕA,+3*E 3jܕvqWRLqWI-+֘+R)ъCF6WAteh2 ]QN[]~QWp +J3/FM+j׼Z9O ߢ梮 VW yŏ7+HW\5my߫%ߦedySW{BK^,kyWr㵼 W<yeijW+D^ ҩ !2nSʒ.xeԄ^a#x+ vW*fLvm"&J#GWD ^# E/WJkiw<+l+>c`r>]<Z yWAܕ\t]9\G+:T/ w堻}M8_2zm_,5 \+ mWX X+^~vW<ԏC`wt+WpY]yDʠ"bTʠP t]!3͠+te[t)> C++7\+Y 5ͮd5 K Bؕ'6IR 2 &Wve{J鍟bW T!]2PĮtmfT\J2ʣ &)+椬X:jVWb"ꊖG|'ЈBW{+;Zt\+vt>Aj@WN-]URffteqY\tWt/ctR+_s;{?C1Wp=u I\Y'ĕ6+l&mp46ⰋUr\9oc*{Dn [J1ފB(2Jy+QQVV3–p+'#ܮ K ؂[a e~,pe5 0bspҒ^"ql W# {n\9l/r7\@eU\ѧҤEV+=Hjq}"8 bqL9+lLLE\p0,`LY\r_`_{`'̕(KFWN#+xuŚ JVWn{.+.mEJpԕmY>Wi"]iwEaWvK+#ؕJ!ܕֳ=+|| 4^I `xŊM+IÉVU$hye<>rjmwŖݕ+ηbJ&|W:^B.xF'.^6b*PJņxʮ+~^ 2ixa+'Bj,vW+^qCWnD<*M5GW< {UbX fi.wVwڙݕS'kwQvWl]YHCD+I^Y`W&׈]CJ9;^_G oaWTumӣQRUZ]YFbW:ue( uGNpԕYAWy R1,抡i+5?~̕a&F+']i෢+A]YЕz+ՕwitdA]qJOȹ`6W\ފ2c|6W0bIǔFWѕ+T˭⍫l V02r+_+BA@W]9|DJw6FW {=d35ԕ%Rʲ`uk+Ia۴!BE +zw6BWt%7 ;]q@FWB/ vjV/PWl[]!,Yv+ Brs ~+N~2a&W5Klhz{BB8'SJzmVzrIE+Cx@W+6^FWZ 9WO59L P0-]M8COJ q hzz+ YjʠM?W]kwʼnrWJR>vW\iw幸+pW\bw^q_4B7!z%+iM ݡW6v6E,WHh vW\:ez%cW+!+.0r5?2YKO+̷x@+su/΢X_9W\H/!+y,]_a> }ҭx_SJdNz8ߢ_WHX_-g92'VTqG_as+.}e)WfG_!XJ`_ jC_nWRc]Wz AJI;1b|ŏWjI4pB6U+Li\_a_d+g'}j_3:+A_qJW`lSWN r~&T,_rH+=_q4v+++Z^"W{8=ʂT^aV+$4^/ #|϶W/^92E앺u-WvwVWFަ+~ ^Gt(%- +c)Z^I% W u _ɪRmk|%C+Kd|C+; V%\b_A.)c6=?4EVϚ/|ŽʂnJ }%,I+կ_qMf ,_[ > [|eWQx||ŮO+e|!_1d|%C+ɕk2aL+_)RQ AWg|@ UW/ xAW^Np^G^>Ω핥W$ԲWv-$dYkWn}-<.x+l+`5W<+Д]J׻,}ţj+,PE_ac}CWk1cWR |}W0,[+x_WZon|dz+npW|{_ᓰW\{X#tW ^]o{B+Z+~X^a^l{d&{z+҇Cݬʰ"}6=JKpJ5օ4l\bY?uT+XU n+FL2^y;7+ xet+^Omx|{7W^YQ^PJRW*r|Jǀ%x#RcwW*sWE yL+qG+z+z=L{eQ4&W_qWL_䲿NWP௰D? Xe52ū+ Xj:%/ŎZBocS]K6 2#o:"eUTX+iFU 5W. +LI+c q+8_e~"$g~% Q+92(V̯x j~ega~+1Q_IB .hc+.6bKPj_^!Jn2$ͯh?a}]}e(Nn}E_񭀾bZ I+dO@W85 |şm|eNc'{{Rt ~n^_9;5cڶWؼ7 {// W^Q8򇽒s.{LWz i+ +}W|^Z]}Wbye(jex% &+;GW|^yO +oʜ@F$xr xB[)Wރwr\cx0ˆW(}∝ՒWj+Xw^ٕC+RWؕ®' E3x]AMrrePWӖuȨ+D.$uk.vVWȞC]"u%>ԕbiku X]F8ouA+2XbE,k*s$+ ]єx)w%[]1row+]]~hve1a5] 2aWȾfW]|+lvc+v]̮X@3¶w?r><χc{1y;_u){We>P}υlc2ǨjP3Re"@9(geFi8- h>vZ H9d|:o:wuZֿӒaNLNK}Cm\ãMK-uM%*:͛jOd h.ZjӉP-Y2԰MT _Zj/(Qe]؋uPYA>p]WFrëA42Z\) B3-BM*-5lݪIiaC,a!-ݪŭ}p3-})WGGzG"mhS!TpH9h(iQ"-uq&=i__DuWSi+K>0uej^'m:R3ĊRO@} [mM3R2-(K$ 1xӍڃB)-}HStc+ۜ|FZcURJ#-ub[iɠ@NKuRein]?rZi鞪s;-u' Rs3]φZgZfTK]Ny/M#\NS-u=Cg.6ղ4MOJuujBPY-ձ} jA5hRVKu/_7q7 kos Y9Y+R]~Z.RXK?uw^c-napXK$\竗2?2`h{>hKVK=Rݧ>s\.5mcsmheB kpXKϊ, a-b`֮?+XqIjYXKMMV+*̛QXKݴ/ 2a-=޹!u-$Rm@.L׽eWrzcI6SAq k~ͪtG,2a-CY5Rȭ#gÜV[Z.ic- ~ZjVGZ,^9ݴJU\`KuU ul^`K#&^^z|+ز~[jbK=㺻r΅_p#q3VGZl &Ėٍ;7~-yJle~S-5ҙrBuL-q-sն{v-<2]FA4LbK^RC9\*vCl9[IZ9q:ZlEV-l/(ݡz>e(>z% ,3|-5Z\+R' P`KHqfzeSӾT-NF[yD`K?Wh,O7mlIXJ^RB%:(e^kZjZu^K1k9kiγ2b{ײ,3Zx!ua4ײLklǔ(AO{-u7ز6[^un RVc:r*L+ڭ[J:$EG} R& ԔTQ`-[wshezlY~[# bK"Cb ŖRcz%TV22u1lY"[* ɖzΟZklbreٲ~&[bR"[Ȗr飚l9/t2[̖jr^F1"[z#;["K9:^9 "[jȮShDlYf82[O1̖C-[c3-}[lЊݮݑJl1액}[l&lbK Zl!Cl?ҵiGeËl!!e4l%ɖ ʹ mBgelY6[ҁCj'ɖԷؖjf[̶ԤcU[zȼ-K?/N[@-ҷ{zx$(ʶTXCmb[ J-}z}(mGؖ 4E6۲öܖ 2Wz|'޹-5ԑGUm%~v[f7ܫUjK̮?j\!%+R[vlVdKCGn6l?dK""[gȖeq@dK* [潲lSlK42o꯿:"jTHTy-{kR] 8Jis%s-sn\ˌJEs-}+Y;"&%e(|@TiVaTB}x-ZfCЉ5e&'#m kEG׋j[(G(餵UkѺXpͯ^0͢P֥كRZjn/ ˅XcVOR |zͫwn7ٵZj2 4k|[^KE.{C9}L{-3 Brt(TkIY5l:,TK2 \#Z}ϕk( tZk#mZk1Jg@8RkZj&jcW*ͣ pEKkIZKQ8QT5ֲ^ZjMg[|ݢ IKC-$9hqp4RZjlޑRԒ3RWH-=(БpGZZ}=p(Z2Bj\^VR9+RfTAZz!zZ@TKZ_?n٧喷Wv rаU\O:ip7-^q߿Jd*JFx%ݪ'Щ 8M'NQDuZ|RBCJhIe![hqG@6h%WSDK5) M#WC(4ҩZB[^Ǖhd  DT8&Zf)"F-إB"Z2RqSoP }he]dTWF)>*0Z h%I-usѢ Z215Ѳ|x-Kђ"FKr1Zz-=בC ?Yh^M-Ylh _-B,?-uhIB-D2:RTJ+-5+⯞}W :=Sn۟2PZke>Ui楯, J(-$%(-i`hKX] FYԶa[Ziɓ*@-2jY4Z깰 a+PKYa= iџgzജUB8-ޢe)l˟dU( qZ:3نvZ}xRѢɎN#0-'U1-ɤiq:르tk^5m ,])-DžiY/V~LKR"̴TF#ʹ԰\Åi q)=ն ô8"ҽExRxe-%0e,%h1-5葟LK/]19?3-,WSj%e+60-kj<ʹT:KTQT#s+E^PKW%9ZjY&2Zj /Z/\S-Kg!Uj:6O>>7GTcFd)@Ca餹*Qirfe/55k6oWU\KRZE RRD<UEkvxJqZ\ee %$9ܕQfZpj2+]Z2R!n}uluOՍ&MI-iҝW/kPIi `-CI|heiZ{KJk S,rvFӵZjL - kݩ#T8P˫DdEUC,MOTK]r5*R*iH=⋢Y/ kй Z iW%EM`-YVk|[U;.jFnTQoՒ'\Xn|{.jRFQ[-U6tyqAjr;5Z*RO>:Q_ѣe~mHR fmȒZ*6RVKʷZ@`-ը4R БVFXKVZGMzTm;VYQ8: ѵ$ĴA\9Q?Ŵ@LM5U7pPM;9-iARQ\"ʪA+odi[!rZ 2_LK ЅܔUO>*PZLu>)ArQU![OH21Ӳs xk^e3j!),[yyO`I1!ru)Zj|.tUUZfw&RSU)=" ad(<j$\-O  +OenesBl*>*v䴤sʪ҅`+RAC1-wnZNwbZj"1-T`ZJWTWu3ӒK3-YӲLVĴT,^s{y'FI!zy7ti^stv+R_TJ;-^=m9 -)iu{EZ.;KieYRgvP1cr+yZ94 dJ&S|]2Ogt0# ZRЗuZy:>@+I6¸'Њj,Z@Zg!r'ZZ$EZZmj|D!iV*V:ԊB`L7V+f^2^ny+,w+%p9 ty/WyE^y(Fp}"V iԕ!+߭>ʧ}dKC]Q(1Kll}ns\q=Jb6WX\sM9lg̕RFd+bC͕Wۅ]1v`tdЕ{vG݂ѕ]3t+{#%]dtź0J*AWD GԠ+7?fX]qPЕO 2(+cЕB]D]a`ue;VW;2 :+|J>u+.Q2 +-芇\FW]]IɪW]qGet2b"~A] 22VܴSԕ끛A]ay9ꊛՕ.E]EG]Y#Z=s2>> uŏW+]2Gr'PW\ERԕ QW:E+ bvٕv]q-+î\wĮdxivK+]`WΛocu+.Av@+WfWN:S+^ 0>eW>U]q®6r\mîovaV+]avanv|ˮvmy]y_aW$6ՌFWLj\Gcsr+ʌ^~͕o`a$ls. ?+Q\C̥"W2rBϙL\-rTyPGl1 RCFWyBWRYtⲃ(uI+b2#M0W( r>:RWҭ[]qu%2Օ YQWP/H]Im+̍FWoiʠ+sfq.dcteM|ℨ7rS<7&鹖+qOd芧IVWHюny+vPWBZ]iY;+/>+^5> WnW+L-Py+p WnhC+rUb+\1nrhr~\&抃6W.ؕ@\-=+ס-+ͮxPy_Wjydy%J 0+$K^A$W([R}Y_!f}QfW}+<ͯx +WX_PW}e2)D{h~a}WHqmYxYW|\zl88b|&~Ԥx9 B/ _4R5z}5\q0+w/+޹rF^:w~Y+`!NJeȥpid{&nMV|e@+!̎pMßy E"G\}_qҧЩ+tWORL_?]뭯 }% m.~= O +)_)UPy(?~2Wf6銕ʂx[xW5+U: E,G7PXl%P V@X 96XH,a AQ8+X h8,.`yطB'\B.(`y7`1< X ! K XϏ+X\bu &XGB8E;`I KY>!XC%]!X,,`!;-~K^#Ž ?LRRBs^MZJ#~{b_/yQ.EUڧ7CW D_a_2+_a +T W^{%w?ʜSJC^au,=0#T[KiD+yW) WvxW\mï|$~M:򴌯_oW\2 +dn_9z т oS"JW|W~_qo _6*WWS _+V2R;WDa Hx2t!xe~_ ) $^!exۥ^60+]6[˝W>eB+]qgj]Q]ɻH]1auփ]O)lu\a_\\q-bB1Wx \9+7mAW1GoBVWrԶJUPWYRʭQL-7r/RW!A T]yv# r^ +IQ`wemஈ~]^FW\>}AWj/Q-H"芓~ܨ!+ߦW+.\s{\y} %+\&+e!+2Q "᷐+G\:`q[+0-+ ;\1wslSgi6W\qYab\͕m 46W\js&N+o'se:+q|CR0Z xz̕ٶU\lsx7\aC-Vx\- eg诨+tlu~0jPWcm+QWu:S+v;W̐Y\q}ϟ#jqa ĕT1\!W- Ѭ+,4\&WX!\ȕ`.m+aEw\mY:̕tYm8hsvO¢E0τ>+͋!NpĘ+ +{cs DcX2/2W(+s0WF RBʧkrҵ&Wd$W!Jbs? rF (v!P`I 2֧T7 cBux+l2"J⭌cVH[qBʌח[1 vފ bVo|o2[rV\L[\yY\@\\Xf9W T{+o[joE]p\NŕnU"⊊|Wqe9@ biS+-KB&GUr\O\qU}͕>1WF/ \q6WRvlU++Ņ\al䊕+$Wz.\y>-1WUsbcW֫\1KseƎX)e-+76䊻cI0RireI+ ,Dĕq@+!W6\~022 ph뒟r\6lsŽ5WT&0Wz7͕ϓ42W\]q'h]^]]t}@WMW !x!$M?Jo\.BI+f]AWxl/w{;$ KЕX2+b96 .ϑv]tήdDWXltvWSW̚T\lw\ɕ @MlnrE reW@\F1Wzjqx͕N\q]EȕXI1p\!vE+`+J+ǝ' s\I8J-,-xWqݹ.+#鿊+}W(\a'b ~n} -"bʛ\VOez+'ފz+RHS+c^pG,,ʾ2B8RAC1+#*˛VA=/T+w.' f{+A/oV [!wgV[HTpe;j"\ ĕA)qeyTJ\Y ;\y>Ҁ+xKVpi+lQ(;= X2p2@+: |Y++9+7^+bV+WDrŭ\a&W͕\!FE䊏Rɕʓ[qr.b +3=K}Wn#Pŕ1a޸WFw2R|r+Ԩ^+QO W@%W\'\ 0J\O)tJoB|?vQ\s+&/ w+-Uqd+!*(g+N WH )M@6bϥ_r 5W\#isE͕OF+#3]IvѕDWB `ڂ0]agFW&偹%2duȕ1ּD]!ٕv$d 2rCpXx b"i+[]<t=]Vt^+.b 5+#I1f Ԛ+B+\a6WbCHmMBsM'MIȕ®0M8+5W30W.\qu\)]aFW(htE]iG&H/+#s|+.]tnvNm!J|+iBs|5W|0Lc$W|(Bn[*[aW^#ފCx+o뭰XފފVV{bq{+Gv-[/ W>+ī[\9$W%hEh͕ԢI`)IdIuKqũʹ+pP\aMBĕ_W\U\ݴBGqwqWWWt$W Wrܱ\ѹ]y+j8W\ql EӘ+h)sb\kb 2@+v-+++G2|m8\YZRq%-c K͕1A ۋ6bPVrEIse#͕1~WserIHŽ2 pȕqIE:(m>ͮ(BJu+$rA]dBY4bԕqB0,K+Ϫ+TWYԕ'I $#xjW6o+N̕Wެᶼr2aP^! yE^x9+B8Ł^Y+[^;u zîrv+,7²e+%ȮIt[" +I^E.q/+3jFPImcx+A^!xQJ&w<w3Jӎ+졻YwŨy†ஐfʞ]y}*SDD]:M+ة+/}ԕ"PFJ$ԕcКJQ^YBٕ!ICve#b[+`WNVdW^@0`WF|1)haWTbYò+9a#(+Ov Vo`WsovĶvW~+݋]qrCr]Q^iOxb"B%h+.S 8<^qMxE8PxP ܕԧ,[h'he^B۲)LMX} Bv$Y}X՛b8eL23WXXfb H,S:Q% XKXbv@Lkt |.@,4KJ!~qX܊^2vX>!``X !/!X'Ž(ͰWJ#uXttXDa2 ˧^w^7ayB[R"iENO<_avX,a!y* >uaXH@hfX'!# "l*2bQX^vwEa1 )ue6(,3OR 4+ ,/u",v",EXTDXGb0aS@#,Wh b"Xv,xhEm& ,[*0X%2u ,\X4 " +kF2m:~uXѦCP,``|LyM. G d)=ˉb$H(ɻ" ҏ L+}WtW_k]0௸|+pJ+* MWxl|W_92+l;} WHUD WW WW-W؂ˎr70k|W|b/r1_!],J{^y^Q^{ "nBvE+V,b+lʝWI`A+PWH k|BLB_ِF} JvY W.+c@|]_!P"BYʩ.rq`4ק%b X^q殽r"ig[5+y+\o5ᕱ %@2+m+cr X**J'^1ӳl I Hlm^DWxWxExefԁ#qW dWgî̩F Lue D] CQWp-WuE uI+s0$pĕG\1yŕ +[bq(rZ\9A WP+R+IR+;yB& 8^jyj%je9VگZy(V.DC 0R+n!tWj}TZ!jE⣩YrZa뺦V-ie3@ZbIi`+BE'iř!J"\W@V:ien(ׄZVX)Z^V+jmV:je\P+C էZZHiZÖVN-Yg)YIZ4* qK+xb)h$Lhz@hs'Ws%.@+[ZqrZRh8vV,l| p8+Y/gvVOg`l6Hig Jbl68+$tVޤ묘8+KY9H2:*8+Y⸝FuVqYgBLgytVzSvtUtE謼8+7Y+O2Kl' VVP+jfS+W›Zij,tKidH+`K+Ҋ5"J+7ҊuJ+ 遴XԊ)MP+b JPB bix;+:+=Age 2iUJ+*X6J+n窴RU?b¯ AVZa /r ZWkVNJ%9[aB(➄b+N"[ bNʨle}Jl  dc+1܊kkeTlԁP+*VʛYyTgjtV'U.:+ꬰ fq;+8q2+Z2+ߛ4⚏ՄYeqVX*YFg*57Y% (/JzYqWrs"VH5SZh]F6V4Vg1Ίd~2@g㬌iNGC%Y9>a`VNofEJfr dV JOJ+vH+,>J+'J+oʖV|n*7Ҋ^-!sgvҊ* ˋ6J+ ۦ(42&>BWzS+'jv[ ZQjjV6Zyv.J$P+n jȽSHm722V4ݤV niV,AZ9g1+c[P0+H9̊OveVνYf hEyJCH+"~J+G0miZZJjVIHZ+TVHZ%9'\C YY8VΊpЊJ+H+-?AK+*IFV zJi,VG+gJ9VF?RJf-IP>ԊNԊsJjeHq[ZqE-d[S9j͵VƢ:Z+ӋBNkcҳ3}KkEMkEujZ5Zq7EZaͪZalk%ۉ JSS+_n4+JhX+idGEP+J8XZ1&W{~Z Z#GB\{~ `M^S+@OAWQ?lEMUl&p4~leNJ_lybV 9X-29%}:4[=O؏;;Q5r\le3lEXl[y B4؊6h  ċpfVVVX_m欭ikFS+gmςb4Ai1/BcI4 ~Vp\VXihEwB8J+t[Z)1bHg=uVR8+rV(i:+FKtV.LppVLYqGvVȽogVZa繆V6"!B+ PAh% #8+}<٪+o b(dEWdYɊl#+2"+:"+FV\ +=YA QȊa +-. |_N7hd)ce7G:b\dE g:+ģdVXnfv g7c}\> & 2o:';X_Xa%X1ʊBAҮ (G/e|h ĂdbޒJÒ*+msc++>VdLZoJeŕ *+b(+\TVpZY3Yq/`Xd`JYd$2$Y1r-¶"+㞿#YKdŕ& Pd`EVHY74 SX"+&Ȋ3K ,SdE@rYf7\y$ZtYfK Q.rfo V>XYfe~'ʜGe,˭e^YkUf'0Je̦T`mf]Ҫ/U`#Gr;St+Sb8˼,ρ,ۻ_n*e,3?Q\l#FGNS/e)wS>\=ʌ.l#}M-mXYmVmoQ|H˲r\bYbYQ;FTȤRIijﬔERk(5o"YCŲ̋§XٗbU~qT|pn躯.l#=- Iȑ3՘AYZQx1U(<peFDND,J(e`R{d(ee 2g)+2|Lߟy| (gR-pˌ.toe^Qn4(QU>}NlRY#D,շՁ[]NBYYe,st 2P"eN5^2OfT5AQYefeץ&(aYX9ò .,˼ʲ{|ϻ >@3E?}ȤY9h9{We6B̙*l -H,G"o2c -eUf]0˸{4%H7GebYf3+2Y9,2 2iWŲ,㒰,O̸X2JoYOZQ:޿+2?8F,l3JӦ=:|6b2ev-5h|Zfd?-K&@|uj$m>B;?I-r)eyhY!Z9-eȅhϷ#sW}~hY 1Z$4?e\FKe62Zj7]m;2G'[8Y22٪qog1ZVYF|F)eF>;[ԨՌgPHKŢ*H2 ҲRrdr|#ҲL #OiZQH˼B=28xv*!# ie婶}Jy?RS:e0EZpeNl, g/4M!-K3H72[dM~,(-y3宆0/&o5싉W,[:m RZf ciHQZfK^{fkAZ6F!-oe/e T4Le֗2o4:˧~Y~@Zf~+HKB2ކFKOkB,-3ցfT!2Gaf&2I"Z]&EPd*$D˼lyQa^BiDEy~yI__p-QWFKEc\ E2Qf* 傴;F˼0c1ܐ+ y´1L,(eJ,8-KH,N|<z8-UQN6J#y2DnM*eu^j0-ˊOSL|"݁[DhZaZjPG1-eSOEFи3Ӂioc2-ՠ2LKXZs 1wuZe&jYBρZ9eRL 2ebZu SL 2O(˖5aZIKU gT8οJK-D`Y+ߔR+Rϟ۝eּ`1(-:JKwQZW@JAZu -Kge?}K)-so}μ^u2#*}lr޾2'5 2n[+':,,H{pYY#VZ橫e&2/'˧ZxLoe_RRM+M*+eyh|Ӛ7\YJ~R,qP|:51\,9gY®!ZّW֙wSD˼UԩaѲhY.e-K5D2 2{Ol=-O).Co@-?S>be/ʷM>,hYb1Zj龮(2D2Zjz[e7F˲nnp+{-~%F˲(9?B)t/ZɝشX<\̓1D%e% GզwL-#𤄖%V> &2e|Zg/M.ZֆVBKQ_L#̑Q~f -3)e7,˷"DZz!sB"te2CVD<hO,2Z1 -D[9Ue3G꪿ThFQ*[1H63&Y AZ:.2PJS!8y@Zfk˛ isHw]ղ_ỳVBZGBiM"[c9Ș,GⲔwEid$_ߥFi`3J|ϔ{^Gi1Ie6#ozYީғK-M].evI :sWO_m<Ԋh=B^t^ho`oC-9w{h'DK}C-DK%!Z:]+D2hբ(.:/yF6pU"$e(JhYL -*e9oQ2?H3jCmq]$U M- QDMѲ-QDrBcNBҭFh"lY9[QB *)eQyeZj8&1}@Z3eBZ(M!- ҫJ -r9#HY3-s M~U)re~|HIA\I=˰iti=d0BZ֟THC) iYAZ:[esiOBZ#9jǖrG+vbyR9TN H b Fy`qJ2Bh\2Zf[ -ˈ.i}!w)>Z*dހg iTN*ԫUHKt9HK㡴t=L\q=ITTô,Ӛ0-5k_~Nȉ%/8- MWNKTDtrZef2RSD *eYKju)tJ7TnE]) rZf+K;GjÉDjYoZRB7T r/H-?b%RKB ̑T7Z(gqfg޲50JL.f9rTIٓJSP~,e,# -XH=Uet6:HKW@,cAZ:6$VJ+oe!.[R }R;+JuVduFVXYiade#G)>Yy䑀̅2FYjX7[YeSAVd" VAV'2ʕx++kR2CeEd奢p3 +EVzDV=YGAV.%AF@VH XyȻkcE#JWiXbъĊOMxFC?5U(,D|?!V;B+/R E6-|<"GBX)bB +ϙ&V(XiJcwbX;XYuf$VV[+,ĊCEJ},C &z+ZXyjG`KjV5rd\}q}klU2vW1|&ⲱ9*~W>|Jr1Wj߬UU$*- eZLm^Z^xqKW>S^Ut(UHU-쪾JBW'O*ϗMU, 2}1XRbG+g2 )b7rb+UV!Wi:hPDYJ1*rW b&d*rACUJF4לRcUDiULj[eE[e$P%^hwR9uI!W"dM-x׻UXmYSY4MVٟ\ZT hQUHYUeO UmW^Iู*/_VAV潲*ªzȪ\'I\V*3[H5*NC2!U\({! jYeB",l J Vq]UZ**SHѴm(3U.m)KhI8Vq5~hJ*oV\Y#媌Rt,ʈE<.Ҳׁ*ϛURU!OVaULl[X9YKdU7UNVV*JYp)Ve|.J>GReMRʻh"wu T銘6UR 2>HH*nQ*cU.WQbb( g!Jj*ۜ BIRk*-gM#B4تi0gS%CS2z4.VS&b0JZSIۘ 5荩0lS1L &*`*[b* cKRIKeRar|,Z*X* G"e2j+c8uRSRiJbq(#rw@@R)SVTJxNT/E(QyTiJLTTSTZNj)Z*c,"QSy<TSqRNbp:Z*26X*{6mKE,JLE* L9ʡ*S$`*lT&J?!TFM 4cr*MҜʢ\T|7rp*,A4Rq؟TA+BJ**&*2[idH%U$)<_UT\QLP#%9IȨIMiRxSSIl*.%XFQWQ~*= 2f_5TItr*L~bpF LMsL4Ufs& !UƄᎱ&OSeLSI2.T_Ih*IUQU+j*ǀ4TFUxP,֨vAsUFUu@U @Q%PEUޝOg۬BQXQ,o a ;2Ȫ) VEVݲ*BV7*nqU᪐>2]>lϸRVevW`UšUKlW@WE0TXe.Z .8l9daªɪ4VŕL]+!Y7 U5+Yb[VRҺ*o,ʱ9W2UNm/b@^ $BDfUƸ>.V#J3N*vw*ⵯ4J_e"TM-2JW([c>[ V`鍆Ulm*j*%U*,G* VxUX\\2eUHTUqVU~D*j K*Ӧʖ^M UUUK`UF Q>tUUi"Y-dJ8X\9X~UqJYzYŠU9[ª̀f}2 fUdUU*_Vªڰ*n **êJh*zZ*KyAUZUM[ZUٿmT,a듑ʌD'#RVa ғ%hG*)%jCdg LUIаJ*##ȀU܋a-,5XUyqUVQaV VW UN]F[*\B\SVyUiX^XŻ Xe,yS`[ʝS*Vyհq Rq O*=hX,aVUc̠rT`\pcRB"Gh{ܶJfJ*swm pzpUOUVMlA[v*Pͦbd$m}Zg,ʢV+hKh6V[0*360il*7{p5UR -yͫ}UƁW6XJXqul]E]eV[IO\ů AYq75j\٢5*6B dtdPWQ`W:W=qV3UUzTӸK\Un r|n4poW3WiD\鷸Mݳ MtH/U^=yXWπ&*\*wW4-xYx6yU^pt򭫴삮*FUޘB***ƫUUlY*1^J7XO 2ܯUҮr`J:mV9 a2wh!UZ[VqhӴ h1JU\@HPOٴ+N*+RCuBU DV MGroS*'-d ʇAt`^]EG]ŧq*W*UL#Jt2U,\n]%;6Bʤ{T9W2:J<rKW^*yULn^X7y6WaUk_8z*B]^ŘH*۸ȫ ?|?GVֽ*1^wV")ֿʞDVRG@VFB>7َ20'C)_C`Ɗc6Ba9b=L#+݈0Y]@V6bfdE8Wee #u2"|_e8 _`Vx50+̊e00+渢TYUVMw%ʱsJYyޮe ʊY*+T催EXY~?%Ȋ"+-`XȊ)"+'"+4F ZȊDȊ "+&ډ*+n *+mDYqVV?6DY1ʊ5(+b7ʊɕ(+oS,̊j 'cXheIJ)hVVZЊ{ xtڜ @+]VbwTZQZasEZ!K[jtVNwZtVXR(?m@.~Z+B Vދ?YP b+&_c+bb+Rh+y2Jor ׯTB,Ub+l؊b+n/_c+}VE>%*{58b+A_leV b y)b+AKle$@_9R"W^͛X+ P+]b _BԊ(I,#VZO?N+ݿ(x((!>qBA+]U+5'YE:ĕ!R\G\mq)m+WW+㞬ren̕sZD $0WwbXһ@kEʓϰ+#鯻r]i+Rw^\?MG2{$G⮐ +]\+鮌]cV:^#B5莿!U#xϘ+a\aBrK$W,\roȕQO%,\yK/S\qqen}rR5!WɕS\91Wa\i2VWiQWKԕ1ue|+ QWzeՕȽ+.+nڌ J+q be+=]qG]ɸMuU]&B&\͏I0W>.+~D^؝#O(^aöW`WX2T^qCc^q,B@+_f#4¶m+oe42d xbJ-+'qz Γqj ;鯌'^s`_N<sOZ,Wvѝ!b/ <UKG,fOʑu+*%++ O z+ 4{+_2zMQvWW\|%+ G+*JZ^I@M|09m& 3+d]b2iwE# [D6b0_xIWExEx%†WWExᕃxeuW2^y7́WLw^iXx HWbFyM!IGyҬW"HMdCmǞWf<8KmyeiWy?y((>"Dy+sG:xe /p , @T@^a_^1 L+rW"iyœb1u+X+6GUzLze^-^aWW+^W(lyl% lbNyiLWR^QlW^:y[^!yep-(7WTWZ}2WbD^W\ny;Z^y9Wf(hLz+$r|<'#OV^a{e8+k`2[^mW\ht;W)}+痆Rv5=\+b{+ 6G¯TIO+T,ʭxqEUZ_q,"'¦+Nm{)z+WF3|9 Z>ËbJghj^!bE6z"u镶UWA J;0+)Bt#a| a%6|s$J{WWƯu&b@Fs+2Y.wX# =+u+k`P쩽2Ni W Wwآ^a6~`^IBAA讈 lnF^c:HV{4qW #+4 +MUW-GnW^D]YX+SU+BudVW2W]KL{gʋB)8J'\Gʼu%Eԕ ]N]Alw\w|ݕ8c]9MwexqWF3h+H +艸+Gw\_ܕ9͛⮸TX#bn4s+@m{e>9w7^Y ʜ5WFo>1l=B^ɼX{EyxWлW%J +T.C(IEz ɤW 䮎4+WD';rK,G,l\N ]W!{W4lWŰW^yi{=WuJ}W7ȯX2t-{K$X66&`-/IJ-ҝVX^E++={~u\|(ʶAdf -~<@N%JK+iT4X>Y`s7 XN,\,6I^v`ae4%X$XR˝-4XƑ {Un);K/Ak`aK {0X: "r7R, }K ``4XT2:BAYB WpX~O_e u"u&wS`yS>ڕ6j,_q(``92#X̭jE#L { Ih&X E@cS^X-6RQH[J=f㷃_qOZ8_0(W2JWOR*W0WzyYW:uSe+nU2opt,#WA``[KM)r:,DZ`qK>7%:`y0۹X,r",Wz'6s;_~7W_iC~~MWܶ~(M+gZ_O?&с 24|^+B NWu7B5ʇ{W+%yҗ^{_^Ԁ^mW̬^cWW2 \:ܕtWwkw] Ĺ0"]N +7 [+/+ ʍ"Bi ʸt`ٕ^+  2~PUtqw>3H ˠ+c#J. {Ћ \ 2ggR7J\.N X.Lq8Lr7ɕPB̤:PC72\ao`IM)X@+ +iwx+,v ފx+M[&' ųAn[Y p+tríPb=?JצX 0dk+ț['[qOK lV^l8L nKVn0[YYjn w `Y.܊zENnnEe$܊ʭ=rSo[nENmeZCVබvj+ʇ9NSR[')b+$6BCc+Kt ǍtS һX⎣b+ Ia+s# |wdQdF Q/2 vc WX\\P[)ggVFPelE[V1Vk^Ukm۵VHYF fŠ+:O+.֊L(c +_̘+7 {i;yg͕p8 bzJY\q)r h P8Mpecf $JW&K+W:/B JK+#G. ⊺- [\a?DK-[\qb!t+!W 2LM+k1WF3fsCҚ+0i9ʝ=$Wk\P̒\e+Ey3ɕ~d%P͕l puB)vZ@+oo,K&5Bp~iz+[yʸ[W*gWCAq؁ + V+\TFWu EW-uV]W]wueS] uTWTW,8]? DWH1JשGJdWF aW ˮ+]Ϥ® zvWvefk®A+Ǜ\bWȮg+ v]$Ĕ5Uo&{#)a$W6b9JדCtU?ʌ$l rdm^2˓Z$MWL^nzN^|WFU@^8@(]W`D7啥눼Re/++w- L D^#[+]&ba"ϨW2h܃rfE J' ҅W6M" 4hxY ^Nxe.C2u5㮌` 2KexxNx LUW^qV^YdYݕ5)w!q+$ͮT#îL+)v1UWN QWoJS]acWf+(t:1ѕ+1WF˪_$W/HȕJ"*KSqE6Qq7F\ͰWzGTWܣZq}X*Jc +cSs ɕ_ W܁+lb%z+W|rRn B⊩ۊ+WDWWWRa4#%ΑW#Je (o%2b+*r0ile[[a,jPV^*"t*Ҋ;",M.5ZZOrmP&P+}V.*>V2Z%GZ9?+ELNgZA%oj2tfij If+V$Vy$b2Znhj\b k+WVPZy7IoL<Z|Ik.VB]7B8yR+]'RX+O6LZ-˵VPa+7o4dLM#J#h+ͭ܊nVnECne s­B+ ? 6jh*xhTheWh@+ hEaYhԁVNV 2Ɯ9ǁV,kiEie׏8>hũ " ~aB+i]@+ρ3Uk~ênB+yZ5UH5cu1c 哚 q8+., .Hh"3V1͈r0V#Fjh0qVN![) Wb@gD$Yq2ڼH,KfUe&򆲲p(+Gb*+]_ʊld;W煗Y`KX}7J*;cc6V#Gf8 _ͬ.sR+vPo8+ì4+&6 2+Vʬt2vgTjGDVDVR8)dAȊABRDVu'e:R;㥔e I4|(&~M[+'H4ber %ߐX2X4+K}+ǙG 4r~DWRs"+B[+X12VL+DV0Ba2H߾Ɲ V >\+X+sZ=ehRJ{+}jVF`դ}|Yo}*dët)2jۃUTW_<V7n]&PWTQNؿz=X$cP2&nWޕ0qg0+Xq'c+21VfjcEbe=G̢Iber VxĊ#1ȕXҩ| +c8{!V5B(r|PD V V:TғK+<1VLcX陭 e +G< R-Y1&Z7ȍCYSMʶ|m5Y!V]beMbYI<@#+"\cŠ kmh̓LE' BǾiF~|Aǿm!?/=_}ԙ -c{eq*r 2&t9P-3GhٿlѲa4ZF D0Z~FDqDWhHZF'^GJ)!@fT@@BTda%μ" {,,UF:ˈT:L2~G|,3e,{D,3#e ge.R1q5#Pgrp8g26YͬY 2o傂5.ie)f,DU βg'1aV*0䔜,#ȳY9/2~oԗ,ډβ᫳DtJvCgٷ_pJ-5gOӨ?8 HMgr"2~ה2a~St\,x<;6e#S<ˮ2m~xyEc~ٙQ YƏs۞g)te,qg]DU>˸xW,M"#>hAtN*7bџ2ZEHeJh*K2IU*0h2SP-cTda9E-xˤZr^Zbpj ZF"Tx҂TdaoUC;{C10KQ-}| ҽ3Th6ՐZ\TiA`&2Z\ \JpP-cCP-c~H~j q%+Ys\X-c$V˘)TǏ2/!i~SjkZvKZC27gqT˸)1-?TXqj>kRX/kى)2aVJkEhqEs ehZzeO^Qӫb#eN2Qn5gk.X|$ eyIt2f1%b_v-jS+3j?Zz2:zz`Vs)e%bjY.MEɻe&5eNXZ '݁Xj7oVս2˝vM'2gea4e4+KY-2fP-s#wnM61neT)ekjMsZk_j|n~SK6T)&jYod2[E>9B;6wZQ-e߿P-CD aeq jd2U:X-=jtKUe|?+j=AP-3=*/)e

\ja9Th{>o2N8X-3fuqN1Vj@ZƻBjg'KQ-cBwȤZF>6TrnB0_e(eIZ!eA*Zv]H`&2:[Zƕ])e㻔ҳH-UoRAeeQZF^7GJiƻBDiY´|0-3[)LՁRZZiet&Qn)q7hqp앯@˜lXLˇ\8R>xl)e>YN]g,Xk93<˼,uxԑLeo=$Re|A4#'`Zz ҽ?L,L0-@iڷB$iLIHg 2ަ~]ea(#Qf66i9IiyyW Nje.j,P,[:V)NK8Yi!qZƕDʏH e_C4i'? yRHE:2.8iqJ\i9/i9?Bhq+"e%F2+E̵Ex$Z1hwRD6[D˘R 2g`"Zƒ SDo 2۹J!Zfi-̑"ZƍW9{Te.ԁ;i!Z\GhSo>-G2S/rHwszZf2U#ZeG -fZw j -se'y*<{G%`ShXBˈXGhq"BXY=`D,$Pe|t1ZfP^r&<{$M=F-=yK'AbphY ->1EZ?he-!H2qԌ-8Z\nhŨ|Z\VhmTZF|"D7hs-jY-cg!@˸=,c`x%Df gqU5@ x-#oZ3 R@-3a'@˸e1Q8+ٌZ1hY.gqDhq2k FhabJUYs^>Y8aWѻ|l Gg#2^S-Ji2G^hÉꃂ!2b5iQZ2´8i1U@eִrfEK3 2.z! Ť t'2L2-`Zf9LMɑrZFg<8-M6N˘N#B-\iefi9OiM9&P_q jW'4CemBNPKB-gt(-&tʴ~#RpJ-cZƍɑZ* Qj|H-gej1HVK)Z朢2y' 7ZK+TQja1TqՁ;LI-3|\I;\#:-ݷഘSҳ3btZHiôe r^ PZ .>;J)(-.ԁ)QZ2J@-i7\NOb(XeV`i++iAzzi%"u`2-WцôT2Gi9*M秕UZRő#oֹ̿RJp[v[Ez(-#e)U9q̓k jqCeِ Z+ P6B-ݼZ < &ҳ_Gj#RIOH-s60˓5nP-c"QTxzIWjZX8VjYdu Q[j&R8Bh8TR-Uj)=5Z΋Y*Te%R-s%T7u$aDVnҴDVn)AVNCDVLJY9^_2ieB BʙD;+WC;+;+aVHPd 2&\B8HV@[!J㍭2#9 [SK!b1AʐAgc+b`+PlWkZiBkVuTX;ЊgFhEhCh&1B+7HB+f [Vsi:p5V&V^vZIOʻ+tdE%cTZcVUVZ+SZFhe{&{en,jbp9+&XE* Ί5w:+Yٺgel8+ĜuVaHgRdVN  0+ͅ 2 QaVLjf̊KJ(_p0+B;YnVfZ`V%Y^YitCg%Y;+XSb~o wd@+PV2idFV/G@V.%=;b#+,O:iWa/R*&lڮb=]J8*󨮲w@W4*URJWm W|ͫ_.ʳY*f˫4ӼI(BRC*P|lŬryQ)␥}o”~c|9}Uv} 2џsbN`pʸ ce91Vƽ(e5V4VƊ"+7YzV#+adYd#+֍E*37RW!}M"ʬWIC*,ʫAXxwW.ԓ*, yJPWiB^eWW^Ţ~yD^ER^QJ/|,G,"G|8Uf;U׼ʹWY btɫʫFˍUDZ"<.ʕ7J8Y!*W/q'*5i\*3?\巇(\EI/JD4Ҕ;VcW9W!&V*mUBEV 6Nu-rG|;(QmVH*:6aUz=Wei*ݥ᪌K qU/oW|vUr[WhLTU*mQUnCUqVUUoUUTUpX==Xy9UDUFEe<*3>W?`HXx$j5f3uKe*3u.I*](r_k* TAUTe:'嬇+@JPvhUIUe$)UEvQUUӪJgMQUfQUPU,RUQUP-2b uL2/TTaFUUaUaRQ'j{M*PLml9*b$Vkӵ*SLKTɎ(mUc6PRlHG(k*<U!QVEUoUꪠ,ꪨ/XvbJ*{F ` l_X9J*UcamV>*Vm iP l,}rrUcXdžU̢V9VWW堒UWeQTpUTW$]EpUHVm2obJ* hXltx*,v6`a#+ d~ޮ Q]dTUUYr\=tUW5vU (U~pUZ*@ VzuYldU|ȪO˪۬!#4 ddQQKHT%y@*ª*T٨/ ;顪_u!/CTvÚUS\'BdYHerYXJaU\$UdUwdUjeUsU4,ʘŸlqUkWAu*AV@V9;UMPV"|iK*7m[eCVV(o[asV(VVϳ?J?(UfET}epM\/ʱ‫lX5*Yn\Ї x;*HڸsG\;*J*r1 V1:2oUfy1ZX-7\E[E!O\0q* [> [g6*#YWiZzCh2\-O- TA tY$GeŚcOʊ ۭr.-ԵҖ JeoZdaVЧB4JY9NxϛP#ҎJ#/0+ଠ3RǟY_SM(,寋D9|­D-'!iY!$:+Y^8 _g vVhg6^Kq?8Z#|Vb&|S+i :jA 61V#:סoK+5bя؊j+` d 7 \ipKWzvE=J7+CWKW+QbJ¥ͭRs+֩R[9u^ڊ{o<_ $[9dV|ȭJp+s Vc2xr"ZifZ+l*X+IV,|hkKVN51 ZqR{OZ!֊uiZ+VIkX?bmʖ4V2ZikE[kD[+Vcia Yr+ةr+} VV܎Vm*h+Ga?L 4J|oD EP[a䤶j+s/ b+bh`+-N[Q[[!xV.6bA(JW$Ʒb+C-Z ؊؊OVB(@lkV B[qV h+̧x$ꊿ>V]٥VjD(r_+V.P+d-ԊT ʮIh J+ͳ(4)\`JH+ҊJO+֊^ rC9Zi kňJ?b12!+b7O@H%X'ʌ׉BJVkx֊Ԋ#j4V cQ-A|ҥH+=DZ9wH+m7!|G)'x~ZZ? Xh𐗔r>LVHk;d\kő֊EPP+](JV˂Za7rBJ*mBTgV.) 4J;!H+Q({[Zq')"6%ByC+0H+CB*fK+)PZ!6rnibԋb 2|+IXܕ[neZwRwqW(wtWSwKvܕP)tIWƙHB0"@FE+^!0ȦWX"` bʬze!^B~W^]4M2^G"2Jk,%B\9{G$^Rz;A^1z 镇vڥW ^?^Ԑ^j̱WF;<( ]{3W(^ٲ_/ʸ&W̎D^S'޵YR&ۄ^z+̥WXo^WN+;UI+It:P+-a+4++4] "5>MP^ʍF+n* >NХW}^~+nZ*kMX:,b] {Wo nb+&CXGkrFCtm"JWKX@"2 uc+]B|Ixk1Wzr1l*_ŮP  ]q ٕdW|,%;?-Iw+]1^we<<[qWܥwb+bh+< W#X8bu򊠇 P"+L /)x=|WF]+8H]!%́+<2*W+rSD} 2L)@ܛK+I8cmz{WJ] tWtW]a+vWZ9pWguWuW][wŪL]IutWȈmw]O]iw2^a^7]]qʁ/EpW؇@v}=]]1ʮ]ve>u ⹄]afWv[1zHivJ$Nf5ͮx ڡ yͮP b\ٕ`W U]pXuqE+'tEJteg.+*vRVDQWƙs" VꊃZ+nQWڐjuwb+J+aQWuŌvՕDȮl[n+*]+%ˮ+%aW vlٕy@T ՕQWF9ԕU]^\uGՕ d@ve2xQWHґ]W]!-+l/ʨ%kعDh^+VTWmuE`KudVW6\]}F}1WMseV `suT+׈悺Jp+Hc%䫺R}JӨ+TWXiuEgAWr灮툮\'+ ”ѕ K+w+;ҪI̕w5W6+3T_%xxyO?x\_s޸͕(j.K9%\I3x,BrEbGr hj| xsŊ6WJhr_r$iK\\I V\aGW#+# >?+mvI. 0MsB\aCq%W>Jĕ}=;D\)Lȕ h\Q9?M G\OIEՑW]ŕ=%۫_QYJ\vqVЕK*XbVZ+YksU#͕r+c F!z+I kre"WLJ+ P+[QhoHB X&Rc\1Sp,Wp%p,MpR#\; p2u\P>[qZ9 ~p+6e+Ԋ+W.J'y"-qŝ>#J*lTz"Qww+ T $p˧Wo[ %6[v!r+ip+ͭ܊Gs+dcʭWڕ܊r+[y5[Y ܊uCr+Vf<ʇ) 32\^WX\l"ފox+wWފ{ioe"ͭ،V8>n{SnV,.[yNVгI2$j+tr+=("mZ-TmZ[[yPYl+݉܇> 7JqesVDZTjV]Ri9V- J+H+){ Lik$&rhK+V{(%hi+IniVVieܧ)v aC~@Zk3㬌!qVzf"Q? r4rgdžV# +8+8+リH ge čr_8++N1dZ9TfL8YYqDqV,UY8+{8+g$@+mc\ H+.´gV)h\H+$2`H+= GZq?EZy0V>rIgieQ*F^H+IrT9OK+MMGZV B2s⬸uY;iEU:ᬰ8+P:+j8+rG0+SJǠpVY1A_f8+WB+ B#,[ ЊeA+hE@h%WeE[eE0PeE\YeEc_eŞWess|._eŰJ׫r=PQVPUKSCYWUY!ExQVLZYat $Fϑp++4j; VX9XRb倱"a6Vxhhi'X1?d dE& wr]1VھXh߿ʴ ~2W75V(RmdŇʊ " oUVQYq򾴤(+FcCY(+R \gYg 2+ }ˬޔY!cQfEIfEIfe%J eETeeO颬lQYi'ʊͬ-ʬl/ J dVȴc|O*Rc؈TV,JFFDV+l%#n@B`ei\9CQ|R;\7 X$Uxm_Hr+b M+R~V`e X9T`XE4Xeut"ا‰PV9UKeKYҶe. if-؏r|jY@cSV!ײ{+Xe@V1QeU(1VVm[ iiUVZ%nJhg7 r*w-U>*^:d=-в*>UF/ku}ȑo$RV^VaUZq 2ӡUZV ZꬦU;a,mK[Z@ljki6>*>U䈫Wa;U7'*$#`6RU? J7/u*>uO8,@CmXB8YV!߶ !U qI-qmEBVq>pDl]\$*N1dU $\VEjVdY1}\5 nTU9UiPs DUf_U:| {U\7t VTKw&E*>CUUDUUDDU{P@ Bh*ΩUq28TU%2(VU!WU5NU;-TsUUjUUkU>G*+"TUe_UELVŧJ,X@BTrI`U6mVٌ]v\&S& eFoe,(nm&>Jdgj',HoJ:rS2r~g,}+{xkm\|]}>+ey}T0e߮6s̲Ż̲:4Y~O螴, R2>B`}G̲ܽf3S0ʿfM V>7ՂYf8G3QuGP2˼{CZ̲OYx5wFoy]lu<E^4D,=e^݈%ET^>ijy"YQdjudgKjedGfG]Y0Yg=y~ց\?n, dQ0ôYf#⮌=,fYQț|]?Y/2c=@1DM,B̲~߂Y.|e.9SGMe|YfK:e>;>[=]z`506C f][aܛ@,YC¼Zj'}f\y%ͲҢYFRV~YF].9τh0&e,A?+|$2+j1#ʲz9__N,u5o5Va}BlkeŽAeGi~t,kT.KV?XT,} !,<(ex[f\a^'P˕|;2#$2*|+eցJe#{-i,sTWeQYH>ThFedbYYYVS,\,:gE(e>?)[c\y)e74 sS.l~5Ў2oa<|rYN`,sDw.Me`Ջ26 Y]kje fG-ua3RMH1 ˧E?eU 2w؝YjtQߧ`qY0х fOœЂYf;e0.|Tje 2# =cʲYԪsUʲ -SɲjuRaYg˲.3p~P3Zz/O,snSO,&es#T~< ,ן_pYl`Y~?*Y(ef=4hFμ栗u2H,Y `-W5뛙BheeufeQ}o?R#՝h2m9}^46l3U{oe6|G |DYfYf Q6lfo62ʅw NY~?)efm‘OE,~f[h9 rT efYfY >i9Js'u0^2ǕiOEW /m|w2dYsS wVþg߇'A|9c#YYY<˼ʳ~sR+gx=Ձˮ1Dgм[8\pyêժlx2; gYGxp9t[6>:zf]@ E,#,3pbņfY&>YkVfwT0Y&h}<aW4Ce,ф,n2X%*"ThY漱YpGd-ցOpPYLIqy,5_eee}.2o-I|~c, fA)0p ̲&!o<զkuܕ8bB\Cl˲}Dbp2{x$e],3@ W0! f?-e,g2-,+AY:02_ ̲ 1ԍe&aeޚoft]y*\ފ]G2MnYf#ը?ْe f=I(qilSj',s5myl*AZ,K<.6ˌo˟\,c 6$2coD;kY*M@(eRg?;920s,suxWų8>Kó,YYx&ߕg7~媦} .OV:|62Uo?,s Y}kt%e#JZY/X:mY5xZϪ9 ,eϾ,BϲL@gY'gYfSídRXZf\ee/@K+su%O-aR6Zf@=RRx/- el=s.r@i8wZhYV" PBzKhgb_;ܔ2;Jۋ2JC2S3q *B3Rjkhi$Z!)bW[w.h'˷.#P^hWDE)e&JJ-*e>9*7D|͞#gk&-WDKw-=hL^6h#UhPD>+AIѲ"Z;XN-EؒB-= Ѳ|Z:2yoݶUB>k*Y^i:;*8DK@x6JX޻!ZPi!Z:0DKF 0_I RShg D˼,!Z:W ;l^)1ZUQFK-NN٪a$Q {ç2W 1NhF??YBP-s\_ZzVвZ0BKͅ!9R3h1 2p%a ˓ $D&)e^As7ˑ3jJK!~}ծKi^e*- yFCKivL)--my]M ґfC2?+?yaZj%,]S8"/0-_:0t*"N˼9̞ rGP={q% j7gxZL^j9eLEH-5dmJ-Zl2#be/#V ,C@-P*P Yj7Zi &ᴌّxNR˹X~H ) -t(e^ۼh\-$25'hFK20ZU-0/H2ꋃ{.I!-E*AZW9QHThyͷqW"d -*eVi$u'Dҩ= -c3wAZKu iOgEZ),]dVi/#TirhY4Z: eKjVmPHl i)J'rfNeeyZi6bZzNid3R82tۨIVЧrZ_Yd~e4k(e6AC@-7H-+VTifΩi8-݀RT2o8TбH!RQH3xYNi-ʸô{&禘Ni"5 ooS'_t (y5#YiÁkuZP9$BTqȖ9ЉmSdK篮jJ-C+Ȗeenٲ2ߔU]''㛲* [ l|d,DSd˼~'l(1d2 2bu lÇX+C>J-U(#UYuDky-k{9>-ٲƛs*Vm&etfKa#?PȖC,wLȖe_d˼v6l1S[fSd|_&uUۗ3Zds?6kIQ9e>=j1‹ײGS^Kg]Z/`\[t2r! lZ(9,\`2 7`_Ѭ!nk>dM9< \M=Շ0Y}d[SOu|3FkZiRgHNjYOB{:P-URBY-rȝ$+eY-Kt:V\6RV˼+{ &2W){ʩjĞr#-VҭjYwZ:Zf# \_ZFN$k}cXZ*W9GRYŒ8^]yM*>0DZft=kߧ'<,Gռ`ĖUb̍2[^Cqզ5Y-D>b#Iq?-U)b()3-OԖ%]jK䢶,-K(jGmܑoʫMaר- ڲ?2MH}ٲLcN~[͖eKb`ID2[yL̖%S=1[#G%=tETWNٲ=S-s1(O-G-emO`O"_e^΅̧C}xЖR`mgk@[NesB[: emIՇE,ԖuGmO#GRbu>1GjveQ[YV#ʛ~E_pdC,-S,flg &5ViekGȍeVigC,ҹs-K>d? _d%Ol?1kSs1JWhX҉+Yore'V=Bܟd\y=%W6h\9Vs\q͕"P* u+ ]O@i9+\Rѕ1b+Ί0ZotLzTWhuHGJ"+huTBAeW6kb`+75+m]a승+7ٕJR n+V讘'r0W)\+G ft`,[O PSq"BWؗVJ,rS$Rkͯ+޽+ $d,6XUJx,{yXnG D _G_rVЛ_>~ES~%ͯ\JW$+ہYB8J WFMl9sc)}y@@WFEn>;,-EiO+%15ʞXŏ 2Ը|e U#X2̎( W|ť_`P  WWV'瓶2֦9|::앱qma,{e|+FuWWN$+_׻|+sW^} +dhrҿ;٪89W_QD_1G}eD_i+U˯Hɯ0<_IJ-WA_OMk勯-XA`9}XВXTZ`!\1߀`yyIG,P,vmP H z2OS,,:4_`!eh XH|m?j!Xv`1 O u$ *J`y. <=X `E`C ks XJQr`a9v!XIp  * FXQ@X52u`,,Y!X捜!Xske`0` !XFR˸@/LV,B},K7z2buqXhEIJbXXN`"A8`! V}&X~,51Xz|e r,z\ r+y8a ,.Ӊ@XD`i6ˍ'BK ,*,8@V,kyE egÃ&Xu,lj^'BK+,W*,OhJZaqaH ˤ%@ZaUa9^@(,oU, 2,>`Xai euׁað\[@ CTay1 ,6r~K²g k> ,7fFXF8 K`;IHo@T˨l, ,+ Y3-8Q`qk V,k}P.bKr`qYH!`#ps, dqkօ`dWX>'_5*&XnKegG 7 hEe wXRkEK,~N˂z C`kS`9ˆ(Ⲁs*` `iCecg\``mIE ׄ`q&n,E``lU; `>|x1lɹ` fsso_q)M ݵzIN$Oŵ'CtΩ;^ЈW{2f[ܔ+P+ +!.`1[+ rS%B%b3 GC1@m,A۔"Eb-,ˈ+}`󂩯W_aE__|kW; |'¯07b7̀_ќ_LE~a_y~ekr靄_v.ʶcÄ_Y3WVrQϣb͖${[{%̦W^Aoz˶+V=Coz W| WL^ym^13[{W,,^9b8^_0{LFHa+&,=L dW^&J E_S}w+m4+b@+%mwEKwESwܸvWX]! ["YCreWaW2eWna]Q>]y+z+n+l#ڴٕotvYؕM)J?;dWFY5ƔͮȮ|/+7ˮ,aW˔]٫ܨuOՕD[]CqXRU1W]kugʙ3ՕfXUWl++l DTW(hu0KlrŠX\ 4b]ɾ;m报9mP M, vW+\+vAeihB߁zJ +l !7is1\is6W|jh,Jc#AWL(mt]q 2sP]]Q ]9oܙreLrg2Sc`v%i͕`4rB@Bɕ& mlD5W(\ø\O\++R++)iuE uc+b(7 ꊱW^ dlxE Qx2^^^91WRػhl__6 Ȯ\6Qmv ,Z]ٶ4?Օ-tū+9à+ bl ![=B͕ Is%ᑘ+f϶r}mbl4W:k\1|m1M碹@JS@++ KT+B+}yW U4[p%Y4,pŜW4WӇ"S|g?JPNq>El#ڂ!ZLkX+Z+JVvVȔnkŇ g1JH+oB+ hNYC+*B+ [U. <!cR8Gh% PgEUg}Cy s7ⲦԊ"J*R+V^nB`)I=@8rijYjerjɖh+؊C[Kc髸>ح<$ E: `+/; OX1\aёAXa =TX(0RX b9 ͫ\ ɗͫ\~x Ob遼T*օɫWiw_WxWA WN^#ūX -Wğ x@*▓*W7BcWquxvDAWWW9*''^?xˣU"WyTnUHn^O %*'*6i\I> pBy Dba#1yUZWyiIP y6o]gy` 1RW]疺JU,*8t2jXJV_e U|W~}p*o =Uë,^Ey**.S|V%Wqf}D}'*"7+s C8XD`}rVF(tU19BCDXi ae>ewVj`m`VzvCYFwVF[.l#aŠŠE+f6"E2MX!5Or+b~ J`qJcVX|-teJpϋ82+ՁSF&z*Xx **/ ]ԿEWfT]ݟZWnTWNtBBRs*=]e{ U(h]ym*7c%tsZWGW1D*\UT6m \Ux0VVAU}(h41VmM*/*lyMt4¢p*6ZqU <̇J0Lm]UZi޶*H[GW)\E\\, PJUDUd"U𡫴 2Y|Ҧ⣼J*=ʃb.+JXG{X 9 `msVQߪi] 6%3 MI+{n`eDԊX9cWagWAW9u}.U'`be<8G%׿BR@a͕+-HZ - +?E +ۦ#^ +PnW}oWAzWqԼ Sy6w«dc]Fn*r*WZlLUUFuM~V*@U;'**c _eW1b=4%VƠׄXi&x/+%V>[+nFQĊa B_bp YbMK+$8/B "+ 㩬P(+(+LJeEYaSeo{D c_ T%VܝDbŇby[]+HJ+{ VƐ8BsIWXyO LÆ+7žM~b K$4.JVhaJFWa%V Š@ q-?n + V4QXaBN +Z+ -!+Š9+<&+$Bz +Ņ, 2V*B+hTBIVPZqoKVFMoX":+MԥXff%̑Ɗwny22VƊ%+V-kYhc80V#XH<نTeegwm0UV0WYqkD T ŭG7b1~2+ʬH%2Z( , eV,“YafVʊ5(+8f'@VLYa9 b J=dJ4(+*+k|N 3fELfŚ0eVޛFf dVYI|++ʊUYɕAY̰VVFNEʷYd-nEVvooj6LU2EYll \= +"+ |vh"{2YqB7YёYHQf !+R=2+DnYYZ!"Њ߁V((KhC 5Zhʩlb~H+4">m(i4kV^lEMl% UMX#"[iFJ+OZ!MV*7.VJeeF%T~#+S/p2FV7rW>Jd%FVLY!  +d¶:+O:+LjYa:e"˥rP bBY醇b)ʊYʊc*+,7B# 6{ @Vkr|TeCYeha "rZS"i#A"NX VTؔVoVVhΊu\)%WrVأjAYqʢbճ 8Y YiۿydVdV,gYq-bI>J0+'50+V׶ƒ_e_ZI06YigpC+۝ [52GC+3VcȠ鬜_&SgFV.O:Њ P VޗvBnbC+l'b B+m RC+vB+Vw6†, {fUB+O 9a@+*pB+`VGiZI0 VH5hiV>hJ+J-ThhUh 5VhMiqH+ՑVOFZVaVzF, [4"\(LVJhiEBh6!)gؐΊ}J8+:+DY/Yْ vV58+R_ow#q^b w2oZ^ C+i2Z3'oyOq[X)Ww,6:wpV9+=fEZ ^'ŕ c~WYڐ̊ ƵqVggg&Vcjl*9/ǬԪ卭Hb+<) u VlIle;B=$b lo#V.n.^n4nV^%oe;k+j[pk+Ӥ/UF[ h+.fn!ͭhU nI&V=[VmOr+Fĭ𫍷-6W"Bte.z+=npmM"|h]atZ /+aW4YaueaK2RٕH'=PWtºJ\[]4jPWFA jRW`dXٕ%U]QR+XfW4lm+e{X+GR)ꊊY]lIuE VW,7J@ꚗ3 |Օ̯1]2\m>+"Ң+aH+Ә1=+ےa+ݢzIutn+\L`W_Bl]0EQWү\QiDȕ rHbb W+r%Ζ3B> 5zE]ALd+T0\"BH WFC,+zr5B.!Wtjr +E0Wos+` 9)⊷+ ģ].jt(u^BHB# ,(p XI%rRWB`YRN $\ Z`ႃ2I{2QpOIf'!~RI+WFel_Qޝ nWTe0aO $#~EXWs5*$I_i٩[H_ɵf+v+?(MReT C+*!EM( z-+W.2 B64n\WʬgB2= W"26blp&{%3ny_.J_IJM]G^uB^*y$7pXrV@(;JӐqofFy2iāsO b+CezEW+I( Wl£JtɍH^!YJPJ\ W"+^9.ausD}eWz8LI]a]YT7w7Q6',%ܕQ 0+X,+1!xEWb~".]^4 * n`Wʐؕ0hB+p2+9"5ʠu,+EJݕ(ݕx߲OuWD ]xRptvB % Ȩ3oU4bsWTJWңۤbD +f`ti*VWT +Z}05v2ݰ+LPv%"u [+`U+GHʵAWH]RۀYHJ7ctE+c"t%okC+dbXqCWȠ]]!;u}+*huEuAW@WVԠ+C8EtNJܹ'uŜnQWoQW䛈\!s+JVa.̕\EsEKB~J<\\Q D&JM!\ٵ1W1W1W@0Wz\!?s:H+Tse]te5b-2WL"re^Lyf9Q pV[:Pr+ǩ/ʘoEOx+LLVt炷 p_S.o4 (`\Yg Whpfy_p+,"pWT o#oEVZ[GKeMZc"oe¥C/p\\QĕN䊪\)SJ&a\JȕyIr^0BL0)cɕC\qkA 7$,%g'WW\Q:Ɓ_ped 7q+,# \Y.Wg%k1[@s+,%"nUd9%k+q7[_ɭPnW4 ܊7D V↼^V0 Vb]$Kr+kѷCJõ6=V!p+[Qڧ>ɭH0nz.VR[arڊ*ρ ʘ夭B֗(mEVD[?@[`6JeGj+q㒦Hj+H[;VTlmEah+uVPiS4xVX>k+uĭ+ȰBg ( "}i+1_Ime0R򅥭h VnmVCBeI[ii+d#J<{+A)!oފ~V5#TAAsVtdy@}୨J̊JފnW"B~x+d+ph A2W油$sf^[sZ 2WH-\%CC2WfU5\W\= +d51BiH J:%$\! pB+ JUW$"L?"\IBJΰ[ 2IHT+ĭHíL*ɭ5"\V(q+]}B^%rH[(mrh+CgZ[^R[oo-]@['k+>٤dEDSRk+(܀$aJ [팭` [9f [0[)HEJF.[) oc+d [Z52e X+Z@2g&[+>dK`jk%gcm 3JZ+dH I ֊ڱVhV Z'5[+@wZ >Ҋ&!- XIie\pURZQYK+IZa\VPVZ)E.lE,R)VH[iPNpEi+S/'C }paWȯE\B\W挒2 WE\`2 I+ B뀥bGH ŕQW4jt{TPW4auŃӨ+%(JhdTWbGZͮT+ î&B@ٕEaWU)v%+s:6EWҳyBWn.ue3 F]Q9 +ݚ?s+<*X] J b@슭+bC Y+F`WdW|dWfvtbBʠ(+T\G]vEfWIPʈ#vG+ʂ]!yv'rWN\]%+h}A`Wl]6vu'>ͮ0bWbw L8 +bvEu̮_4e \)sEVqcȲ\jUf+Rs"˖!3O#s%n-ΩZj a\:famdU+Jk+uSXIr ȕuoJŕmQt=+8+JAIqeA\Oȕ^O+EDX|ȕHry(RY  .ʦd|Wzш+1bpC*f6 ˙̣<+}AW{btftEAFWHq]7q4BWH]QZЕ$?%@W++sż 0WE2WJ"6W\8\BWAW6+|Í BLp C/芖3XɖDW泺 ?H] X#+Sr*"Wt+rŗk ȕI&/䊞DKG(Mv}TL5k@(aVjNS+o$reW\\jpGGAp?k+ZAA[!nEPV{[QƋ D * VF-ɭ ¯> &܊KV, f=rFk 3dɭ̙6hnet[erV!oxŭG-ViAí4(JfS dnE+V Hճ i ĭ  ⊏E+S&ٙ\QY!+LATMkɵ!WIȕWOBL("+J@sݫŕA6W2p Z+fpu \ \UpY*pp:$\RaV*2ccy+%Ḙb4ĭp³ d? ƒWnpo+nYR8422`ɼy%F+_ c"6WxE\qeZH\a*q-+ \u( "ʖy&WU?gCH 2T}w_}st7כ7?q9o ^Y}n!m<*iW]޾޽~gj߂vxvb~cFvۯ ~|ݷwn߼1+oM_~T9/o>~{w7ß?)Gbcl)])7XL\M'm6_6.&[׷FL-F$fyխӻ?VS G%:mߚ9cfw٘ y|]"j+&'9ʁܘ{glq3I ñNsˍtu?g|,óo?W)}.ba"?sU,U{ovて=}Q N=ɖSuWoܧc)>rGsMyN|^g4O$PK{覣zU[NSl9EלxM#|:ruzi>8s[x)27Vw\$ߟAWϏDmݮl9 r G{+2O'ީEk_Q"vEs.tx}Kp|9c{UK{ȇ+4;£_7MAԫoG{jùO͜5)y9C^[&F_}ʥ=Zȫ(29_8k]Zν|GƊ5Ou<~H+=N6kJ rY,BiaM7ZN-^3be=O?V3/po׳tS62׊eK{6A^EK0^%-^kdGӟY0*⿛ c<E=?4huxїQ7k?#gZ,Pcjޕ5}~پtBA±F|о4`lyLye|t-ݛc <NJAo KͫGax!|zv~So??AzӾr(/Me/Aו˫Q-- wz!rwo{}w#G[/?ǻ>cary}A.Vm}!4|}~z}wn?fq }Ǟ/?|K'?Ӽ_Y\޾?7m?M8~#0T8~ʫfߪ#@t/_M qnn |̊-⸂;Ymg3<~=lB=endstream endobj 537 0 obj << /Type /XRef /Length 376 /Filter /FlateDecode /DecodeParms << /Columns 5 /Predictor 12 >> /W [ 1 3 1 ] /Info 3 0 R /Root 2 0 R /Size 538 /ID [<3fc63dfc92f7794bda3e50f815078fd6><130e1f7c6af408195a436d491753f570>] >> stream x+DQ=sи0, Qdaf! eΎYYMl,4dm15 ,lDGK{y{\-Si)X{TulA4k_ޙc?wq`6功k `6%Ɇa0Ų|]d%Y֩0?NF5EOоgYk>-gWs>q=υKNa[ dD~ W4k[CvjGC vd]y!$6ѯ@32A%uph3U&]sz79 o0-wz qR?s6_iR<켱 tϡ5g=]־WE endstream endobj startxref 775898 %%EOF brms/inst/doc/brms_customfamilies.html0000644000176200001440000026056615057751077017731 0ustar liggesusers Define Custom Response Distributions with brms

Define Custom Response Distributions with brms

Paul Bürkner

2025-09-09

Introduction

The brms package comes with a lot of built-in response distributions – usually called families in R – to specify among others linear, count data, survival, response times, or ordinal models (see help(brmsfamily) for an overview). Despite supporting over two dozen families, there is still a long list of distributions, which are not natively supported. The present vignette will explain how to specify such custom families in brms. By doing that, users can benefit from the modeling flexibility and post-processing options of brms even when using self-defined response distributions. If you have built a custom family that you want to make available to other users, you can submit a pull request to this GitHub repository.

A Case Study

As a case study, we will use the cbpp data of the lme4 package, which describes the development of the CBPP disease of cattle in Africa. The data set contains four variables: period (the time period), herd (a factor identifying the cattle herd), incidence (number of new disease cases for a given herd and time period), as well as size (the herd size at the beginning of a given time period).

data("cbpp", package = "lme4")
head(cbpp)
  herd incidence size period
1    1         2   14      1
2    1         3   12      2
3    1         4    9      3
4    1         0    5      4
5    2         3   22      1
6    2         1   18      2

In a first step, we will be predicting incidence using a simple binomial model, which will serve as our baseline model. For observed number of events \(y\) (incidence in our case) and total number of trials \(T\) (size), the probability mass function of the binomial distribution is defined as

\[ P(y | T, p) = \binom{T}{y} p^{y} (1 - p)^{N-y} \]

where \(p\) is the event probability. In the classical binomial model, we will directly predict \(p\) on the logit-scale, which means that for each observation \(i\) we compute the success probability \(p_i\) as

\[ p_i = \frac{\exp(\eta_i)}{1 + \exp(\eta_i)} \]

where \(\eta_i\) is the linear predictor term of observation \(i\) (see vignette("brms_overview") for more details on linear predictors in brms). Predicting incidence by period and a varying intercept of herd is straight forward in brms:

fit1 <- brm(incidence | trials(size) ~ period + (1|herd),
            data = cbpp, family = binomial())

In the summary output, we see that the incidence probability varies substantially over herds, but reduces over the course of the time as indicated by the negative coefficients of period.

summary(fit1)
 Family: binomial 
  Links: mu = logit 
Formula: incidence | trials(size) ~ period + (1 | herd) 
   Data: cbpp (Number of observations: 56) 
  Draws: 4 chains, each with iter = 2000; warmup = 1000; thin = 1;
         total post-warmup draws = 4000

Multilevel Hyperparameters:
~herd (Number of levels: 15) 
              Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
sd(Intercept)     0.76      0.22     0.39     1.25 1.00     1329     2113

Regression Coefficients:
          Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
Intercept    -1.40      0.27    -1.94    -0.88 1.00     2178     2118
period2      -1.00      0.30    -1.62    -0.42 1.00     4902     2333
period3      -1.14      0.33    -1.81    -0.52 1.00     4286     2705
period4      -1.62      0.44    -2.53    -0.83 1.00     4934     3007

Draws were sampled using sampling(NUTS). For each parameter, Bulk_ESS
and Tail_ESS are effective sample size measures, and Rhat is the potential
scale reduction factor on split chains (at convergence, Rhat = 1).

A drawback of the binomial model is that – after taking into account the linear predictor – its variance is fixed to \(\text{Var}(y_i) = T_i p_i (1 - p_i)\). All variance exceeding this value cannot be not taken into account by the model. There are multiple ways of dealing with this so called overdispersion and the solution described below will serve as an illustrative example of how to define custom families in brms.

The Beta-Binomial Distribution

The beta-binomial model is a generalization of the binomial model with an additional parameter to account for overdispersion. In the beta-binomial model, we do not predict the binomial probability \(p_i\) directly, but assume it to be beta distributed with hyperparameters \(\alpha > 0\) and \(\beta > 0\):

\[ p_i \sim \text{Beta}(\alpha_i, \beta_i) \]

The \(\alpha\) and \(\beta\) parameters are both hard to interpret and generally not recommended for use in regression models. Thus, we will apply a different parameterization with parameters \(\mu \in [0, 1]\) and \(\phi > 0\), which we will call \(\text{Beta2}\):

\[ \text{Beta2}(\mu, \phi) = \text{Beta}(\mu \phi, (1-\mu) \phi) \]

The parameters \(\mu\) and \(\phi\) specify the mean and precision parameter, respectively. By defining

\[ \mu_i = \frac{\exp(\eta_i)}{1 + \exp(\eta_i)} \]

we still predict the expected probability by means of our transformed linear predictor (as in the original binomial model), but account for potential overdispersion via the parameter \(\phi\).

Fitting Custom Family Models

The beta-binomial distribution is natively supported in brms nowadays, but we will still use it as an example to define it ourselves via the custom_family function. This function requires the family’s name, the names of its parameters (mu and phi in our case), corresponding link functions (only applied if parameters are predicted), their theoretical lower and upper bounds (only applied if parameters are not predicted), information on whether the distribution is discrete or continuous, and finally, whether additional non-parameter variables need to be passed to the distribution. For our beta-binomial example, this results in the following custom family:

beta_binomial2 <- custom_family(
  "beta_binomial2", dpars = c("mu", "phi"),
  links = c("logit", "log"),
  lb = c(0, 0), ub = c(1, NA),
  type = "int", vars = "vint1[n]"
)

The name vint1 for the variable containing the number of trials is not chosen arbitrarily as we will see below. Next, we have to provide the relevant Stan functions if the distribution is not defined in Stan itself. For the beta_binomial2 distribution, this is straight forward since the ordinal beta_binomial distribution is already implemented.

stan_funs <- "
  real beta_binomial2_lpmf(int y, real mu, real phi, int T) {
    return beta_binomial_lpmf(y | T, mu * phi, (1 - mu) * phi);
  }
  int beta_binomial2_rng(real mu, real phi, int T) {
    return beta_binomial_rng(T, mu * phi, (1 - mu) * phi);
  }
"

For the model fitting, we will only need beta_binomial2_lpmf, but beta_binomial2_rng will come in handy when it comes to post-processing. We define:

stanvars <- stanvar(scode = stan_funs, block = "functions")

To provide information about the number of trials (an integer variable), we are going to use the addition argument vint(), which can only be used in custom families. Similarly, if we needed to include additional vectors of real data, we would use vreal(). Actually, for this particular example, we could more elegantly apply the addition argument trials() instead of vint()as in the basic binomial model. However, since the present vignette is meant to give a general overview of the topic, we will go with the more general method.

We now have all components together to fit our custom beta-binomial model:

fit2 <- brm(
  incidence | vint(size) ~ period + (1|herd), data = cbpp,
  family = beta_binomial2, stanvars = stanvars
)

The summary output reveals that the uncertainty in the coefficients of period is somewhat larger than in the basic binomial model, which is the result of including the overdispersion parameter phi in the model. Apart from that, the results looks pretty similar.

summary(fit2)
 Family: beta_binomial2 
  Links: mu = logit 
Formula: incidence | vint(size) ~ period + (1 | herd) 
   Data: cbpp (Number of observations: 56) 
  Draws: 4 chains, each with iter = 2000; warmup = 1000; thin = 1;
         total post-warmup draws = 4000

Multilevel Hyperparameters:
~herd (Number of levels: 15) 
              Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
sd(Intercept)     0.38      0.25     0.02     0.95 1.01      978     1849

Regression Coefficients:
          Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
Intercept    -1.35      0.26    -1.89    -0.86 1.00     3742     2198
period2      -0.99      0.41    -1.83    -0.20 1.00     4554     2746
period3      -1.26      0.47    -2.23    -0.39 1.00     3970     2394
period4      -1.54      0.54    -2.66    -0.53 1.00     3914     2686

Further Distributional Parameters:
    Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
phi    17.93     20.58     5.30    59.08 1.01     1387     1022

Draws were sampled using sampling(NUTS). For each parameter, Bulk_ESS
and Tail_ESS are effective sample size measures, and Rhat is the potential
scale reduction factor on split chains (at convergence, Rhat = 1).

Post-Processing Custom Family Models

Some post-processing methods such as summary or plot work out of the box for custom family models. However, there are three particularly important methods, which require additional input by the user. These are posterior_epred, posterior_predict and log_lik computing predicted mean values, predicted response values, and log-likelihood values, respectively. They are not only relevant for their own sake, but also provide the basis of many other post-processing methods. For instance, we may be interested in comparing the fit of the binomial model with that of the beta-binomial model by means of approximate leave-one-out cross-validation implemented in method loo, which in turn requires log_lik to be working.

The log_lik function of a family should be named log_lik_<family-name> and have the two arguments i (indicating observations) and prep. You don’t have to worry too much about how prep is created (if you are interested, check out the prepare_predictions function). Instead, all you need to know is that parameters are stored in slot dpars and data are stored in slot data. Generally, parameters take on the form of a \(S \times N\) matrix (with \(S =\) number of posterior draws and \(N =\) number of observations) if they are predicted (as is mu in our example) and a vector of size \(N\) if the are not predicted (as is phi).

We could define the complete log-likelihood function in R directly, or we can expose the self-defined Stan functions and apply them. The latter approach is usually more convenient, but the former is more stable and the only option when implementing custom families in other R packages building upon brms. For the purpose of the present vignette, we will go with the latter approach.

expose_functions(fit2, vectorize = TRUE)

and define the required log_lik functions with a few lines of code.

log_lik_beta_binomial2 <- function(i, prep) {
  mu <- brms::get_dpar(prep, "mu", i = i)
  phi <- brms::get_dpar(prep, "phi", i = i)
  trials <- prep$data$vint1[i]
  y <- prep$data$Y[i]
  beta_binomial2_lpmf(y, mu, phi, trials)
}

The get_dpar function will do the necessary transformations to handle both the case when the distributional parameters are predicted separately for each row and when they are the same for the whole fit.

With that being done, all of the post-processing methods requiring log_lik will work as well. For instance, model comparison can simply be performed via

loo(fit1, fit2)
Output of model 'fit1':

Computed from 4000 by 56 log-likelihood matrix.

         Estimate   SE
elpd_loo    -99.5 10.0
p_loo        21.7  4.1
looic       199.0 20.0
------
MCSE of elpd_loo is NA.
MCSE and ESS estimates assume MCMC draws (r_eff in [0.4, 1.7]).

Pareto k diagnostic values:
                         Count Pct.    Min. ESS
(-Inf, 0.7]   (good)     51    91.1%   328     
   (0.7, 1]   (bad)       5     8.9%   <NA>    
   (1, Inf)   (very bad)  0     0.0%   <NA>    
See help('pareto-k-diagnostic') for details.

Output of model 'fit2':

Computed from 4000 by 56 log-likelihood matrix.

         Estimate   SE
elpd_loo    -94.8  8.2
p_loo        10.6  1.9
looic       189.6 16.5
------
MCSE of elpd_loo is NA.
MCSE and ESS estimates assume MCMC draws (r_eff in [0.3, 1.3]).

Pareto k diagnostic values:
                         Count Pct.    Min. ESS
(-Inf, 0.7]   (good)     55    98.2%   150     
   (0.7, 1]   (bad)       1     1.8%   <NA>    
   (1, Inf)   (very bad)  0     0.0%   <NA>    
See help('pareto-k-diagnostic') for details.

Model comparisons:
     elpd_diff se_diff
fit2  0.0       0.0   
fit1 -4.7       4.1

Since larger ELPD values indicate better fit, we see that the beta-binomial model fits somewhat better, although the corresponding standard error reveals that the difference is not that substantial.

Next, we will define the function necessary for the posterior_predict method:

posterior_predict_beta_binomial2 <- function(i, prep, ...) {
  mu <- brms::get_dpar(prep, "mu", i = i)
  phi <- brms::get_dpar(prep, "phi", i = i)
  trials <- prep$data$vint1[i]
  beta_binomial2_rng(mu, phi, trials)
}

The posterior_predict function looks pretty similar to the corresponding log_lik function, except that we are now creating random draws of the response instead of log-likelihood values. Again, we are using an exposed Stan function for convenience. Make sure to add a ... argument to your posterior_predict function even if you are not using it, since some families require additional arguments. With posterior_predict to be working, we can engage for instance in posterior-predictive checking:

pp_check(fit2)

When defining the posterior_epred function, you have to keep in mind that it has only a prep argument and should compute the mean response values for all observations at once. Since the mean of the beta-binomial distribution is \(\text{E}(y) = \mu T\) definition of the corresponding posterior_epred function is not too complicated, but we need to get the dimension of parameters and data in line.

posterior_epred_beta_binomial2 <- function(prep) {
  mu <- brms::get_dpar(prep, "mu")
  trials <- prep$data$vint1
  trials <- matrix(trials, nrow = nrow(mu), ncol = ncol(mu), byrow = TRUE)
  mu * trials
}

A post-processing method relying directly on posterior_epred is conditional_effects, which allows to visualize effects of predictors.

conditional_effects(fit2, conditions = data.frame(size = 1))

For ease of interpretation we have set size to 1 so that the y-axis of the above plot indicates probabilities.

Turning a Custom Family into a Native Family

Family functions built natively into brms are safer to use and more convenient, as they require much less user input. If you think that your custom family is general enough to be useful to other users, please feel free to open an issue on GitHub so that we can discuss all the details. Provided that we agree it makes sense to implement your family natively in brms, the following steps are required (foo is a placeholder for the family name):

  • In family-lists.R, add function .family_foo which should contain basic information about your family (you will find lots of examples for other families there).
  • In families.R, add family function foo which should be a simple wrapper around .brmsfamily.
  • In stan-likelihood.R, add function stan_log_lik_foo which provides the likelihood of the family in Stan language.
  • If necessary, add self-defined Stan functions in separate files under inst/chunks.
  • Add functions posterior_predict_foo, posterior_epred_foo and log_lik_foo to posterior_predict.R, posterior_epred.R and log_lik.R, respectively.
  • If necessary, add distribution functions to distributions.R.
brms/inst/doc/brms_missings.html0000644000176200001440000053304515057751350016526 0ustar liggesusers Handle Missing Values with brms

Handle Missing Values with brms

Paul Bürkner

2025-09-09

Introduction

Many real world data sets contain missing values for various reasons. Generally, we have quite a few options to handle those missing values. The easiest solution is to remove all rows from the data set, where one or more variables are missing. However, if values are not missing completely at random, this will likely lead to bias in our analysis. Accordingly, we usually want to impute missing values in one way or the other. Here, we will consider two very general approaches using brms: (1) Impute missing values before the model fitting with multiple imputation, and (2) impute missing values on the fly during model fitting1. As a simple example, we will use the nhanes data set, which contains information on participants’ age, bmi (body mass index), hyp (hypertensive), and chl (total serum cholesterol). For the purpose of the present vignette, we are primarily interested in predicting bmi by age and chl.

data("nhanes", package = "mice")
head(nhanes)
  age  bmi hyp chl
1   1   NA  NA  NA
2   2 22.7   1 187
3   1   NA   1 187
4   3   NA  NA  NA
5   1 20.4   1 113
6   3   NA  NA 184

Imputation before model fitting

There are many approaches allowing us to impute missing data before the actual model fitting takes place. From a statistical perspective, multiple imputation is one of the best solutions. Each missing value is not imputed once but m times leading to a total of m fully imputed data sets. The model can then be fitted to each of those data sets separately and results are pooled across models, afterwards. One widely applied package for multiple imputation is mice (Buuren & Groothuis-Oudshoorn, 2010) and we will use it in the following in combination with brms. Here, we apply the default settings of mice, which means that all variables will be used to impute missing values in all other variables and imputation functions automatically chosen based on the variables’ characteristics.

library(mice)
m <- 5
imp <- mice(nhanes, m = m, print = FALSE)

Now, we have m = 5 imputed data sets stored within the imp object. In practice, we will likely need more than 5 of those to accurately account for the uncertainty induced by the missingness, perhaps even in the area of 100 imputed data sets (Zhou & Reiter, 2010). Of course, this increases the computational burden by a lot and so we stick to m = 5 for the purpose of this vignette. Regardless of the value of m, we can either extract those data sets and then pass them to the actual model fitting function as a list of data frames, or pass imp directly. The latter works because brms offers special support for data imputed by mice. We will go with the latter approach, since it is less typing. Fitting our model of interest with brms to the multiple imputed data sets is straightforward.

fit_imp1 <- brm_multiple(bmi ~ age*chl, data = imp, chains = 2)

The returned fitted model is an ordinary brmsfit object containing the posterior draws of all m submodels. While pooling across models is not necessarily straightforward in classical statistics, it is trivial in a Bayesian framework. Here, pooling results of multiple imputed data sets is simply achieved by combining the posterior draws of the submodels. Accordingly, all post-processing methods can be used out of the box without having to worry about pooling at all.

summary(fit_imp1)
 Family: gaussian 
  Links: mu = identity 
Formula: bmi ~ age * chl 
   Data: imp (Number of observations: 25) 
  Draws: 10 chains, each with iter = 2000; warmup = 1000; thin = 1;
         total post-warmup draws = 10000

Regression Coefficients:
          Estimate Est.Error l-95% CI u-95% CI
Intercept    16.17      9.26    -1.35    33.68
age           0.09      4.72    -9.48     9.16
chl           0.09      0.05    -0.00     0.18
age:chl      -0.02      0.02    -0.06     0.03

Further Distributional Parameters:
      Estimate Est.Error l-95% CI u-95% CI
sigma     3.09      0.53     2.20     4.28

Draws were sampled using sampling(NUTS). Overall Rhat and ESS estimates
are not informative for brm_multiple models and are hence not displayed.
Please see ?brm_multiple for how to assess convergence of such models.

In the summary output, we notice that some Rhat values are higher than \(1.1\) indicating possible convergence problems. For models based on multiple imputed data sets, this is often a false positive: Chains of different submodels may not overlay each other exactly, since there were fitted to different data. We can see the chains on the right-hand side of

plot(fit_imp1, variable = "^b", regex = TRUE)

Such non-overlaying chains imply high Rhat values without there actually being any convergence issue. Accordingly, we have to investigate the convergence of the submodels separately, which we can do for example via:

library(posterior)
draws <- as_draws_array(fit_imp1)
# every dataset has nc = 2 chains in this example
nc <- nchains(fit_imp1) / m
draws_per_dat <- lapply(1:m, 
  \(i) subset_draws(draws, chain = ((i-1)*nc+1):(i*nc))
)
lapply(draws_per_dat, summarise_draws, default_convergence_measures())
[[1]]
# A tibble: 8 × 4
  variable     rhat ess_bulk ess_tail
  <chr>       <dbl>    <dbl>    <dbl>
1 b_Intercept  1.00     703.     834.
2 b_age        1.00     674.     672.
3 b_chl        1.00     726.     815.
4 b_age:chl    1.00     651.     586.
5 sigma        1.00    1053.    1065.
6 Intercept    1.00    1222.    1202.
7 lprior       1.00     967.    1222.
8 lp__         1.01     670.     863.

[[2]]
# A tibble: 8 × 4
  variable     rhat ess_bulk ess_tail
  <chr>       <dbl>    <dbl>    <dbl>
1 b_Intercept  1.00     567.     852.
2 b_age        1.00     549.     656.
3 b_chl        1.00     598.     837.
4 b_age:chl    1.00     532.     670.
5 sigma        1.00     999.     989.
6 Intercept    1.00    1003.     791.
7 lprior       1.00     950.     860.
8 lp__         1.00     738.     968.

[[3]]
# A tibble: 8 × 4
  variable     rhat ess_bulk ess_tail
  <chr>       <dbl>    <dbl>    <dbl>
1 b_Intercept  1.00     565.     726.
2 b_age        1.00     558.     762.
3 b_chl        1.00     577.     853.
4 b_age:chl    1.01     526.     676.
5 sigma        1.00    1094.    1210.
6 Intercept    1.00    1217.    1134.
7 lprior       1.00    1085.    1418.
8 lp__         1.00     756.    1113.

[[4]]
# A tibble: 8 × 4
  variable     rhat ess_bulk ess_tail
  <chr>       <dbl>    <dbl>    <dbl>
1 b_Intercept  1.00     763.     656.
2 b_age        1.00     819.     713.
3 b_chl        1.00     822.     715.
4 b_age:chl    1.00     759.     675.
5 sigma        1.00    1004.     901.
6 Intercept    1.00    1000.     902.
7 lprior       1.00     972.     970.
8 lp__         1.00     660.     735.

[[5]]
# A tibble: 8 × 4
  variable     rhat ess_bulk ess_tail
  <chr>       <dbl>    <dbl>    <dbl>
1 b_Intercept 1.000     769.     802.
2 b_age       1.00      746.     841.
3 b_chl       1.000     824.     918.
4 b_age:chl   1.00      743.     794.
5 sigma       1.00      841.    1075.
6 Intercept   1.00     1145.    1063.
7 lprior      1.00      761.     968.
8 lp__        1.00      658.     990.

The convergence of each of the submodels looks good. Accordingly, we can proceed with further post-processing and interpretation of the results. For instance, we could investigate the combined effect of age and chl.

conditional_effects(fit_imp1, "age:chl")

To summarize, the advantages of multiple imputation are obvious: One can apply it to all kinds of models, since model fitting functions do not need to know that the data sets were imputed, beforehand. Also, we do not need to worry about pooling across submodels when using fully Bayesian methods. The only drawback is the amount of time required for model fitting. Estimating Bayesian models is already quite slow with just a single data set and it only gets worse when working with multiple imputation.

Compatibility with other multiple imputation packages

brms offers built-in support for mice mainly because I use the latter in some of my own research projects. Nevertheless, brm_multiple supports all kinds of multiple imputation packages as it also accepts a list of data frames as input for its data argument. Thus, you just need to extract the imputed data frames in the form of a list, which can then be passed to brm_multiple. Most multiple imputation packages have some built-in functionality for this task. When using the mi package, for instance, you simply need to call the mi::complete function to get the desired output.

Imputation during model fitting

Imputation during model fitting is generally thought to be more complex than imputation before model fitting, because one has to take care of everything within one step. This remains true when imputing missing values with brms, but possibly to a somewhat smaller degree. Consider again the nhanes data with the goal to predict bmi by age, and chl. Since age contains no missing values, we only have to take special care of bmi and chl. We need to tell the model two things. (1) Which variables contain missing values and how they should be predicted, as well as (2) which of these imputed variables should be used as predictors. In brms we can do this as follows:

bform <- bf(bmi | mi() ~ age * mi(chl)) +
  bf(chl | mi() ~ age) + set_rescor(FALSE)
fit_imp2 <- brm(bform, data = nhanes)

The model has become multivariate, as we no longer only predict bmi but also chl (see vignette("brms_multivariate") for details about the multivariate syntax of brms). We ensure that missings in both variables will be modeled rather than excluded by adding | mi() on the left-hand side of the formulas2. We write mi(chl) on the right-hand side of the formula for bmi to ensure that the estimated missing values of chl will be used in the prediction of bmi. The summary is a bit more cluttered as we get coefficients for both response variables, but apart from that we can interpret coefficients in the usual way.

summary(fit_imp2)
 Family: MV(gaussian, gaussian) 
  Links: mu = identity
         mu = identity 
Formula: bmi | mi() ~ age * mi(chl) 
         chl | mi() ~ age 
   Data: nhanes (Number of observations: 25) 
  Draws: 4 chains, each with iter = 2000; warmup = 1000; thin = 1;
         total post-warmup draws = 4000

Regression Coefficients:
              Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
bmi_Intercept    13.70      8.86    -3.12    31.73 1.00     1837     2019
chl_Intercept   137.37     22.43    92.82   182.28 1.00     3320     2906
bmi_age          -4.79      5.68   -16.34     6.30 1.00     1558     1893
chl_age          31.25     11.43     8.49    53.72 1.00     3411     3147
bmi_michl         0.12      0.04     0.03     0.20 1.00     1993     1959
bmi_michl:age    -0.01      0.03    -0.05     0.05 1.00     1624     1901

Further Distributional Parameters:
          Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
sigma_bmi     3.29      0.75     2.18     4.98 1.00     1614     1794
sigma_chl    36.49      6.43    26.58    52.26 1.00     2933     2664

Draws were sampled using sampling(NUTS). For each parameter, Bulk_ESS
and Tail_ESS are effective sample size measures, and Rhat is the potential
scale reduction factor on split chains (at convergence, Rhat = 1).
conditional_effects(fit_imp2, "age:chl", resp = "bmi")

The results look pretty similar to those obtained from multiple imputation, but be aware that this may not be generally the case. In multiple imputation, the default is to impute all variables based on all other variables, while in the ‘one-step’ approach, we have to explicitly specify the variables used in the imputation. Thus, arguably, multiple imputation is easier to apply. An obvious advantage of the ‘one-step’ approach is that the model needs to be fitted only once instead of m times. Also, within the brms framework, we can use multilevel structure and complex non-linear relationships for the imputation of missing values, which is not achieved as easily in standard multiple imputation software. On the downside, it is currently not possible to impute discrete variables, because Stan (the engine behind brms) does not allow estimating discrete parameters.

Combining measurement error and missing values

Missing value terms in brms cannot only handle missing values but also measurement error, or arbitrary combinations of the two. In fact, we can think of a missing value as a value with infinite measurement error. Thus, mi terms are a natural (and somewhat more verbose) generalization of the now soft deprecated me terms. Suppose we had measured the variable chl with some known error:

nhanes$se <- rexp(nrow(nhanes), 2)

Then we can go ahead an include this information into the model as follows:

bform <- bf(bmi | mi() ~ age * mi(chl)) +
  bf(chl | mi(se) ~ age) + set_rescor(FALSE)
fit_imp3 <- brm(bform, data = nhanes)

Summarizing and post-processing the model continues to work as usual.

References

Buuren, S. V. & Groothuis-Oudshoorn, K. (2010). mice: Multivariate imputation by chained equations in R. Journal of Statistical Software, 1-68. doi.org/10.18637/jss.v045.i03

Zhou, X. & Reiter, J. P. (2010). A Note on Bayesian Inference After Multiple Imputation. The American Statistician, 64(2), 159-163. doi.org/10.1198/tast.2010.09109

  1. Actually, there is a third approach that only applies to missings in response variables. If we want to impute missing responses, we just fit the model using the observed responses and than impute the missings after fitting the model by means of posterior prediction. That is, we supply the predictor values corresponding to missing responses to the predict method.↩︎

  2. We don’t really need this for bmi, since bmi is not used as a predictor for another variable. Accordingly, we could also – and equivalently – impute missing values of bmi after model fitting by means of posterior prediction.↩︎

brms/inst/doc/brms_distreg.R0000644000176200001440000000616615057751266015575 0ustar liggesusersparams <- list(EVAL = TRUE) ## ----SETTINGS-knitr, include=FALSE------------------------------------------------------ stopifnot(require(knitr)) options(width = 90) knit_hooks$set(pngquant = knitr::hook_pngquant) opts_chunk$set( comment = NA, message = FALSE, warning = FALSE, eval = if (isTRUE(exists("params"))) params$EVAL else FALSE, dev = "ragg_png", dpi = 72, fig.retina = 1.5, fig.asp = 0.8, fig.width = 5, out.width = "60%", fig.align = "center", pngquant = "--speed=1 --quality=50" ) library(brms) ggplot2::theme_set(theme_default()) ## --------------------------------------------------------------------------------------- group <- rep(c("treat", "placebo"), each = 30) symptom_post <- c(rnorm(30, mean = 1, sd = 2), rnorm(30, mean = 0, sd = 1)) dat1 <- data.frame(group, symptom_post) head(dat1) ## ----results='hide'--------------------------------------------------------------------- fit1 <- brm(bf(symptom_post ~ group, sigma ~ group), data = dat1, family = gaussian()) ## ----results='hide'--------------------------------------------------------------------- summary(fit1) plot(fit1, N = 2, ask = FALSE) plot(conditional_effects(fit1), points = TRUE) ## --------------------------------------------------------------------------------------- hyp <- c("exp(sigma_Intercept) = 0", "exp(sigma_Intercept + sigma_grouptreat) = 0") hypothesis(fit1, hyp) ## --------------------------------------------------------------------------------------- hyp <- "exp(sigma_Intercept + sigma_grouptreat) > exp(sigma_Intercept)" (hyp <- hypothesis(fit1, hyp)) plot(hyp, chars = NULL) ## --------------------------------------------------------------------------------------- zinb <- read.csv("https://paul-buerkner.github.io/data/fish.csv") head(zinb) ## ----results='hide'--------------------------------------------------------------------- fit_zinb1 <- brm(count ~ persons + child + camper, data = zinb, family = zero_inflated_poisson()) ## --------------------------------------------------------------------------------------- summary(fit_zinb1) plot(conditional_effects(fit_zinb1), ask = FALSE) ## ----results='hide'--------------------------------------------------------------------- fit_zinb2 <- brm(bf(count ~ persons + child + camper, zi ~ child), data = zinb, family = zero_inflated_poisson()) ## --------------------------------------------------------------------------------------- summary(fit_zinb2) plot(conditional_effects(fit_zinb2), ask = FALSE) ## --------------------------------------------------------------------------------------- dat_smooth <- mgcv::gamSim(eg = 6, n = 200, scale = 2, verbose = FALSE) head(dat_smooth[, 1:6]) ## ----results='hide'--------------------------------------------------------------------- fit_smooth1 <- brm( bf(y ~ s(x1) + s(x2) + (1|fac), sigma ~ s(x0) + (1|fac)), data = dat_smooth, family = gaussian(), chains = 2, control = list(adapt_delta = 0.95) ) ## --------------------------------------------------------------------------------------- summary(fit_smooth1) plot(conditional_effects(fit_smooth1), points = TRUE, ask = FALSE) brms/inst/doc/brms_missings.R0000644000176200001440000000471715057751350015762 0ustar liggesusersparams <- list(EVAL = TRUE) ## ----SETTINGS-knitr, include=FALSE------------------------------------------------------ stopifnot(require(knitr)) options(width = 90) knit_hooks$set(pngquant = knitr::hook_pngquant) opts_chunk$set( comment = NA, message = FALSE, warning = FALSE, eval = if (isTRUE(exists("params"))) params$EVAL else FALSE, dev = "ragg_png", dpi = 72, fig.retina = 1.5, fig.asp = 0.8, fig.width = 5, out.width = "60%", fig.align = "center", pngquant = "--speed=1 --quality=50" ) library(brms) ggplot2::theme_set(theme_default()) ## --------------------------------------------------------------------------------------- data("nhanes", package = "mice") head(nhanes) ## --------------------------------------------------------------------------------------- library(mice) m <- 5 imp <- mice(nhanes, m = m, print = FALSE) ## ----results = 'hide', message = FALSE-------------------------------------------------- fit_imp1 <- brm_multiple(bmi ~ age*chl, data = imp, chains = 2) ## --------------------------------------------------------------------------------------- summary(fit_imp1) ## --------------------------------------------------------------------------------------- plot(fit_imp1, variable = "^b", regex = TRUE) ## --------------------------------------------------------------------------------------- library(posterior) draws <- as_draws_array(fit_imp1) # every dataset has nc = 2 chains in this example nc <- nchains(fit_imp1) / m draws_per_dat <- lapply(1:m, \(i) subset_draws(draws, chain = ((i-1)*nc+1):(i*nc)) ) lapply(draws_per_dat, summarise_draws, default_convergence_measures()) ## --------------------------------------------------------------------------------------- conditional_effects(fit_imp1, "age:chl") ## ----results = 'hide', message = FALSE-------------------------------------------------- bform <- bf(bmi | mi() ~ age * mi(chl)) + bf(chl | mi() ~ age) + set_rescor(FALSE) fit_imp2 <- brm(bform, data = nhanes) ## --------------------------------------------------------------------------------------- summary(fit_imp2) conditional_effects(fit_imp2, "age:chl", resp = "bmi") ## --------------------------------------------------------------------------------------- nhanes$se <- rexp(nrow(nhanes), 2) ## ----results = 'hide', message = FALSE, eval = FALSE------------------------------------ # bform <- bf(bmi | mi() ~ age * mi(chl)) + # bf(chl | mi(se) ~ age) + set_rescor(FALSE) # fit_imp3 <- brm(bform, data = nhanes) brms/inst/doc/brms_families.html0000644000176200001440000006443615057751266016474 0ustar liggesusers Parameterization of Response Distributions in brms

Parameterization of Response Distributions in brms

Paul Bürkner

2025-09-09

The purpose of this vignette is to discuss the parameterizations of the families (i.e., response distributions) used in brms. For a more general overview of the package see vignette("brms_overview").

Notation

Throughout this vignette, we denote values of the response variable as \(y\), a density function as \(f\), and use \(\mu\) to refer to the main model parameter, which is usually the mean of the response distribution or some closely related quantity. In a regression framework, \(\mu\) is not estimated directly but computed as \(\mu = g(\eta)\), where \(\eta\) is a predictor term (see help(brmsformula) for details) and \(g\) is the response function (i.e., inverse of the link function).

Location shift models

The density of the gaussian family is given by \[ f(y) = \frac{1}{\sqrt{2\pi}\sigma} \exp\left(-\frac{1}{2}\left(\frac{y - \mu}{\sigma}\right)^2\right) \]

where \(\sigma\) is the residual standard deviation. The density of the student family is given by \[ f(y) = \frac{\Gamma((\nu + 1)/2)}{\Gamma(\nu/2)} \frac{1}{\sqrt{\nu\pi}\sigma}\left(1 + \frac{1}{\nu} \left(\frac{y - \mu}{\sigma}\right)^2\right)^{-(\nu+1)/2} \]

\(\Gamma\) denotes the gamma function and \(\nu > 1\) are the degrees of freedom. As \(\nu \rightarrow \infty\), the student distribution becomes the gaussian distribution. The density of the skew_normal family is given by \[ f(y) = \frac{1}{\sqrt{2\pi}\omega} \exp\left(-\frac{1}{2} \left(\frac{y - \xi}{\omega}\right)^2 \right) \left(1 + \text{erf} \left( \alpha \left(\frac{y - \xi}{\omega \sqrt{2}} \right) \right) \right) \]

where \(\xi\) is the location parameter, \(\omega\) is the positive scale parameter, \(\alpha\) the skewness parameter, and \(\text{erf}\) denotes the error function of the gaussian distribution. To parameterize the skew-normal distribution in terms of the mean \(\mu\) and standard deviation \(\sigma\), \(\omega\) and \(\xi\) are computed as \[ \omega = \frac{\sigma}{\sqrt{1 - \frac{2}{\pi} \frac{\alpha^2}{1 + \alpha^2}}} \]

\[ \xi = \mu - \omega \frac{\alpha}{\sqrt{1 + \alpha^2}} \sqrt{\frac{2}{\pi}} \]

If \(\alpha = 0\), the skew-normal distribution becomes the gaussian distribution. For location shift models, \(y\) can be any real value.

Binary and count data models

The density of the binomial family is given by \[ f(y) = {N \choose y} \mu^{y} (1-\mu)^{N - y} \] where \(N\) is the number of trials and \(y \in \{0, ... , N\}\). When all \(N\) are \(1\) (i.e., \(y \in \{0,1\}\)), the bernoulli distribution for binary data arises.

For \(y \in \mathbb{N}_0\), the density of the poisson family is given by \[ f(y) = \frac{\mu^{y}}{y!} \exp(-\mu) \] The density of the negbinomial (negative binomial) family is \[ f(y) = {y + \phi - 1 \choose y} \left(\frac{\mu}{\mu + \phi}\right)^{y} \left(\frac{\phi}{\mu + \phi}\right)^\phi \] where \(\phi\) is a positive precision parameter. For \(\phi \rightarrow \infty\), the negative binomial distribution becomes the poisson distribution. The density of the geometric family arises if \(\phi\) is set to \(1\).

Time-to-event models

With time-to-event models we mean all models that are defined on the positive reals only, that is \(y \in \mathbb{R}^+\). The density of the lognormal family is given by \[ f(y) = \frac{1}{\sqrt{2\pi}\sigma y} \exp\left(-\frac{1}{2}\left(\frac{\log(y) - \mu}{\sigma}\right)^2\right) \] where \(\sigma\) is the residual standard deviation on the log-scale. The density of the Gamma family is given by \[ f(y) = \frac{(\alpha / \mu)^\alpha}{\Gamma(\alpha)} y^{\alpha-1} \exp\left(-\frac{\alpha y}{\mu}\right) \] where \(\alpha\) is a positive shape parameter. The density of the weibull family is given by \[ f(y) = \frac{\alpha}{s} \left(\frac{y}{s}\right)^{\alpha-1} \exp\left(-\left(\frac{y}{s}\right)^\alpha\right) \] where \(\alpha\) is again a positive shape parameter and \(s = \mu / \Gamma(1 + 1 / \alpha)\) is the scale parameter to that \(\mu\) is the mean of the distribution. The exponential family arises if \(\alpha\) is set to \(1\) for either the gamma or Weibull distribution. The density of the inverse.gaussian family is given by \[ f(y) = \left(\frac{\alpha}{2 \pi y^3}\right)^{1/2} \exp \left(\frac{-\alpha (y - \mu)^2}{2 \mu^2 y} \right) \] where \(\alpha\) is a positive shape parameter. The cox family implements Cox proportional hazards model which assumes a hazard function of the form \(h(y) = h_0(y) \mu\) with baseline hazard \(h_0(y)\) expressed via M-splines (which integrate to I-splines) in order to ensure monotonicity. The density of the cox model is then given by \[ f(y) = h(y) S(y) \] where \(S(y)\) is the survival function implied by \(h(y)\).

Extreme value models

Modeling extremes requires special distributions. One may use the weibull distribution (see above) or the frechet distribution with density \[ f(y) = \frac{\nu}{s} \left(\frac{y}{s}\right)^{-1-\nu} \exp\left(-\left(\frac{y}{s}\right)^{-\nu}\right) \] where \(s = \mu / \Gamma(1 - 1 / \nu)\) is a positive scale parameter and \(\nu > 1\) is a shape parameter so that \(\mu\) predicts the mean of the Frechet distribution. A generalization of both distributions is the generalized extreme value distribution (family gen_extreme_value) with density \[ f(y) = \frac{1}{\sigma} t(y)^{\xi + 1} \exp(-t(y)) \] where \[ t(y) = \left(1 + \xi \left(\frac{y - \mu}{\sigma} \right)\right)^{-1 / \xi} \] with positive scale parameter \(\sigma\) and shape parameter \(\xi\).

Response time models

One family that is especially suited to model reaction times is the exgaussian (‘exponentially modified Gaussian’) family. Its density is given by

\[ f(y) = \frac{1}{2 \beta} \exp\left(\frac{1}{2 \beta} \left(2\xi + \sigma^2 / \beta - 2 y \right) \right) \text{erfc}\left(\frac{\xi + \sigma^2 / \beta - y}{\sqrt{2} \sigma} \right) \] where \(\beta\) is the scale (inverse rate) of the exponential component, \(\xi\) is the mean of the Gaussian component, \(\sigma\) is the standard deviation of the Gaussian component, and \(\text{erfc}\) is the complementary error function. We parameterize \(\mu = \xi + \beta\) so that the main predictor term equals the mean of the distribution.

Another family well suited for modeling response times is the shifted_lognormal distribution. It’s density equals that of the lognormal distribution except that the whole distribution is shifted to the right by a positive parameter called ndt (for consistency with the wiener diffusion model explained below).

A family concerned with the combined modeling of reaction times and corresponding binary responses is the wiener diffusion model. It has four model parameters each with a natural interpretation. The parameter \(\alpha > 0\) describes the separation between two boundaries of the diffusion process, \(\tau > 0\) describes the non-decision time (e.g., due to image or motor processing), \(\beta \in [0, 1]\) describes the initial bias in favor of the upper alternative, and \(\delta \in \mathbb{R}\) describes the drift rate to the boundaries (a positive value indicates a drift towards to upper boundary). The density for the reaction time at the upper boundary is given by

\[ f(y) = \frac{\alpha}{(y-\tau)^3/2} \exp \! \left(- \delta \alpha \beta - \frac{\delta^2(y-\tau)}{2}\right) \sum_{k = - \infty}^{\infty} (2k + \beta) \phi \! \left(\frac{2k + \alpha \beta}{\sqrt{y - \tau}}\right) \]

where \(\phi(x)\) denotes the standard normal density function. The density at the lower boundary can be obtained by substituting \(1 - \beta\) for \(\beta\) and \(-\delta\) for \(\delta\) in the above equation. In brms the parameters \(\alpha\), \(\tau\), and \(\beta\) are modeled as auxiliary parameters named bs (‘boundary separation’), ndt (‘non-decision time’), and bias respectively, whereas the drift rate \(\delta\) is modeled via the ordinary model formula that is as \(\delta = \mu\).

Quantile regression

Quantile regression is implemented via family asym_laplace (asymmetric Laplace distribution) with density

\[ f(y) = \frac{p (1 - p)}{\sigma} \exp\left(-\rho_p\left(\frac{y - \mu}{\sigma}\right)\right) \] where \(\rho_p\) is given by \(\rho_p(x) = x (p - I_{x < 0})\) and \(I_A\) is the indicator function of set \(A\). The parameter \(\sigma\) is a positive scale parameter and \(p\) is the quantile parameter taking on values in \((0, 1)\). For this distribution, we have \(P(Y < g(\eta)) = p\). Thus, quantile regression can be performed by fixing \(p\) to the quantile to interest.

Probability models

The density of the Beta family for \(y \in (0,1)\) is given by \[ f(y) = \frac{y^{\mu \phi - 1} (1-y)^{(1-\mu) \phi-1}}{B(\mu \phi, (1-\mu) \phi)} \] where \(B\) is the beta function and \(\phi\) is a positive precision parameter. A multivariate generalization of the Beta family is the dirichlet family with density \[ f(y) = \frac{1}{B((\mu_{1}, \ldots, \mu_{K}) \phi)} \prod_{k=1}^K y_{k}^{\mu_{k} \phi - 1}. \] The dirichlet family is implemented with the multivariate logit link function so that \[ \mu_{j} = \frac{\exp(\eta_{j})}{\sum_{k = 1}^{K} \exp(\eta_{k})} \] For reasons of identifiability, \(\eta_{\rm ref}\) is set to \(0\), where \({\rm ref}\) is one of the response categories chosen as reference.

An alternative to the dirichlet family is the logistic_normal family with density \[ f(y) = \frac{1}{\prod_{k=1}^K y_k} \times \text{multivariate_normal}(\tilde{y} \, | \, \mu, \sigma, \Omega) \] where \(\tilde{y}\) is the multivariate logit transformed response \[ \tilde{y} = (\log(y_1 / y_{\rm ref}), \ldots, \log(y_{\rm ref-1} / y_{\rm ref}), \log(y_{\rm ref+1} / y_{\rm ref}), \ldots, \log(y_K / y_{\rm ref})) \] of dimension \(K-1\) (excluding the reference category), which is modeled as multivariate normally distributed with latent mean and standard deviation vectors \(\mu\) and \(\sigma\), as well as correlation matrix \(\Omega\).

Circular models

The density of the von_mises family for \(y \in (-\pi,\pi)\) is given by \[ f(y) = \frac{\exp(\kappa \cos(y - \mu))}{2\pi I_0(\kappa)} \] where \(I_0\) is the modified Bessel function of order 0 and \(\kappa\) is a positive precision parameter.

Ordinal and categorical models

For ordinal and categorical models, \(y\) is one of the categories \(1, ..., K\). The intercepts of ordinal models are called thresholds and are denoted as \(\tau_k\), with \(k \in \{1, ..., K-1\}\), whereas \(\eta\) does not contain a fixed effects intercept. Note that the applied link functions \(h\) are technically distribution functions \(\mathbb{R} \rightarrow [0,1]\). The density of the cumulative family (implementing the most basic ordinal model) is given by \[ f(y) = g(\tau_{y + 1} - \eta) - g(\tau_{y} - \eta) \]

The densities of the sratio (stopping ratio) and cratio (continuation ratio) families are given by \[ f(y) = g(\tau_{y + 1} - \eta) \prod_{k = 1}^{y} (1 - g(\tau_{k} - \eta)) \] and \[ f(y) = (1 - g(\eta - \tau_{y + 1})) \prod_{k = 1}^{y} g(\eta - \tau_{k}) \]

respectively. Note that both families are equivalent for symmetric link functions such as logit or probit. The density of the acat (adjacent category) family is given by \[ f(y) = \frac{\prod_{k=1}^{y} g(\eta - \tau_{k}) \prod_{k=y+1}^K(1-g(\eta - \tau_{k}))}{\sum_{k=0}^K\prod_{j=1}^k g(\eta-\tau_{j}) \prod_{j=k+1}^K(1-g(\eta - \tau_{j}))} \] For the logit link, this can be simplified to \[ f(y) = \frac{\exp \left(\sum_{k=1}^{y} (\eta - \tau_{k}) \right)} {\sum_{k=0}^K \exp\left(\sum_{j=1}^k (\eta - \tau_{j}) \right)} \] The linear predictor \(\eta\) can be generalized to also depend on the category \(k\) for a subset of predictors. This leads to category specific effects (for details on how to specify them see help(brm)). Note that cumulative and sratio models use \(\tau - \eta\), whereas cratio and acat use \(\eta - \tau\). This is done to ensure that larger values of \(\eta\) increase the probability of higher response categories.

The categorical family is currently only implemented with the multivariate logit link function and has density \[ f(y) = \mu_{y} = \frac{\exp(\eta_{y})}{\sum_{k = 1}^{K} \exp(\eta_{k})} \] Note that \(\eta\) does also depend on the category \(k\). For reasons of identifiability, \(\eta_{1}\) is set to \(0\). A generalization of the categorical family to more than one trial is the multinomial family with density \[ f(y) = {N \choose y_{1}, y_{2}, \ldots, y_{K}} \prod_{k=1}^K \mu_{k}^{y_{k}} \] where, for each category, \(\mu_{k}\) is estimated via the multivariate logit link function shown above.

Zero-inflated and hurdle models

Zero-inflated and hurdle families extend existing families by adding special processes for responses that are zero. The density of a zero-inflated family is given by \[ f_z(y) = z + (1 - z) f(0) \quad \text{if } y = 0 \\ f_z(y) = (1 - z) f(y) \quad \text{if } y > 0 \] where \(z\) denotes the zero-inflation probability. Currently implemented families are zero_inflated_poisson, zero_inflated_binomial, zero_inflated_negbinomial, and zero_inflated_beta.

The density of a hurdle family is given by \[ f_z(y) = z \quad \text{if } y = 0 \\ f_z(y) = (1 - z) f(y) / (1 - f(0)) \quad \text{if } y > 0 \] Currently implemented families are hurdle_poisson, hurdle_negbinomial, hurdle_gamma, and hurdle_lognormal.

The density of a zero-one-inflated family is given by \[ f_{\alpha, \gamma}(y) = \alpha (1 - \gamma) \quad \text{if } y = 0 \\ f_{\alpha, \gamma}(y) = \alpha \gamma \quad \text{if } y = 1 \\ f_{\alpha, \gamma}(y) = (1 - \alpha) f(y) \quad \text{if } y \notin \{0, 1\} \] where \(\alpha\) is the zero-one-inflation probability (i.e. the probability that zero or one occurs) and \(\gamma\) is the conditional one-inflation probability (i.e. the probability that one occurs rather than zero). Currently implemented families are zero_one_inflated_beta.

brms/inst/doc/brms_customfamilies.Rmd0000644000176200001440000003246115053072461017463 0ustar liggesusers--- title: "Define Custom Response Distributions with brms" author: "Paul Bürkner" date: "`r Sys.Date()`" output: rmarkdown::html_vignette: toc: yes vignette: > %\VignetteIndexEntry{Define Custom Response Distributions with brms} %\VignetteEngine{knitr::rmarkdown} \usepackage[utf8]{inputenc} params: EVAL: !r identical(Sys.getenv("NOT_CRAN"), "true") --- ```{r, SETTINGS-knitr, include=FALSE} stopifnot(require(knitr)) options(width = 90) knit_hooks$set(pngquant = knitr::hook_pngquant) opts_chunk$set( comment = NA, message = FALSE, warning = FALSE, eval = if (isTRUE(exists("params"))) params$EVAL else FALSE, dev = "ragg_png", dpi = 72, fig.retina = 1.5, fig.asp = 0.8, fig.width = 5, out.width = "60%", fig.align = "center", pngquant = "--speed=1 --quality=50" ) library(brms) ggplot2::theme_set(theme_default()) ``` ## Introduction The **brms** package comes with a lot of built-in response distributions -- usually called *families* in R -- to specify among others linear, count data, survival, response times, or ordinal models (see `help(brmsfamily)` for an overview). Despite supporting over two dozen families, there is still a long list of distributions, which are not natively supported. The present vignette will explain how to specify such *custom families* in **brms**. By doing that, users can benefit from the modeling flexibility and post-processing options of **brms** even when using self-defined response distributions. If you have built a custom family that you want to make available to other users, you can submit a pull request to this [GitHub repository](https://github.com/paul-buerkner/custom-brms-families). ## A Case Study As a case study, we will use the `cbpp` data of the **lme4** package, which describes the development of the CBPP disease of cattle in Africa. The data set contains four variables: `period` (the time period), `herd` (a factor identifying the cattle herd), `incidence` (number of new disease cases for a given herd and time period), as well as `size` (the herd size at the beginning of a given time period). ```{r cbpp} data("cbpp", package = "lme4") head(cbpp) ``` In a first step, we will be predicting `incidence` using a simple binomial model, which will serve as our baseline model. For observed number of events $y$ (`incidence` in our case) and total number of trials $T$ (`size`), the probability mass function of the binomial distribution is defined as $$ P(y | T, p) = \binom{T}{y} p^{y} (1 - p)^{N-y} $$ where $p$ is the event probability. In the classical binomial model, we will directly predict $p$ on the logit-scale, which means that for each observation $i$ we compute the success probability $p_i$ as $$ p_i = \frac{\exp(\eta_i)}{1 + \exp(\eta_i)} $$ where $\eta_i$ is the linear predictor term of observation $i$ (see `vignette("brms_overview")` for more details on linear predictors in **brms**). Predicting `incidence` by `period` and a varying intercept of `herd` is straight forward in **brms**: ```{r fit1, results='hide'} fit1 <- brm(incidence | trials(size) ~ period + (1|herd), data = cbpp, family = binomial()) ``` In the summary output, we see that the incidence probability varies substantially over herds, but reduces over the course of the time as indicated by the negative coefficients of `period`. ```{r fit1_summary} summary(fit1) ``` A drawback of the binomial model is that -- after taking into account the linear predictor -- its variance is fixed to $\text{Var}(y_i) = T_i p_i (1 - p_i)$. All variance exceeding this value cannot be not taken into account by the model. There are multiple ways of dealing with this so called *overdispersion* and the solution described below will serve as an illustrative example of how to define custom families in **brms**. ## The Beta-Binomial Distribution The *beta-binomial* model is a generalization of the *binomial* model with an additional parameter to account for overdispersion. In the beta-binomial model, we do not predict the binomial probability $p_i$ directly, but assume it to be beta distributed with hyperparameters $\alpha > 0$ and $\beta > 0$: $$ p_i \sim \text{Beta}(\alpha_i, \beta_i) $$ The $\alpha$ and $\beta$ parameters are both hard to interpret and generally not recommended for use in regression models. Thus, we will apply a different parameterization with parameters $\mu \in [0, 1]$ and $\phi > 0$, which we will call $\text{Beta2}$: $$ \text{Beta2}(\mu, \phi) = \text{Beta}(\mu \phi, (1-\mu) \phi) $$ The parameters $\mu$ and $\phi$ specify the mean and precision parameter, respectively. By defining $$ \mu_i = \frac{\exp(\eta_i)}{1 + \exp(\eta_i)} $$ we still predict the expected probability by means of our transformed linear predictor (as in the original binomial model), but account for potential overdispersion via the parameter $\phi$. ## Fitting Custom Family Models The beta-binomial distribution is natively supported in **brms** nowadays, but we will still use it as an example to define it ourselves via the `custom_family` function. This function requires the family's name, the names of its parameters (`mu` and `phi` in our case), corresponding link functions (only applied if parameters are predicted), their theoretical lower and upper bounds (only applied if parameters are not predicted), information on whether the distribution is discrete or continuous, and finally, whether additional non-parameter variables need to be passed to the distribution. For our beta-binomial example, this results in the following custom family: ```{r beta_binomial2} beta_binomial2 <- custom_family( "beta_binomial2", dpars = c("mu", "phi"), links = c("logit", "log"), lb = c(0, 0), ub = c(1, NA), type = "int", vars = "vint1[n]" ) ``` The name `vint1` for the variable containing the number of trials is not chosen arbitrarily as we will see below. Next, we have to provide the relevant **Stan** functions if the distribution is not defined in **Stan** itself. For the `beta_binomial2` distribution, this is straight forward since the ordinal `beta_binomial` distribution is already implemented. ```{r stan_funs} stan_funs <- " real beta_binomial2_lpmf(int y, real mu, real phi, int T) { return beta_binomial_lpmf(y | T, mu * phi, (1 - mu) * phi); } int beta_binomial2_rng(real mu, real phi, int T) { return beta_binomial_rng(T, mu * phi, (1 - mu) * phi); } " ``` For the model fitting, we will only need `beta_binomial2_lpmf`, but `beta_binomial2_rng` will come in handy when it comes to post-processing. We define: ```{r stanvars} stanvars <- stanvar(scode = stan_funs, block = "functions") ``` To provide information about the number of trials (an integer variable), we are going to use the addition argument `vint()`, which can only be used in custom families. Similarly, if we needed to include additional vectors of real data, we would use `vreal()`. Actually, for this particular example, we could more elegantly apply the addition argument `trials()` instead of `vint()`as in the basic binomial model. However, since the present vignette is meant to give a general overview of the topic, we will go with the more general method. We now have all components together to fit our custom beta-binomial model: ```{r fit2, results='hide'} fit2 <- brm( incidence | vint(size) ~ period + (1|herd), data = cbpp, family = beta_binomial2, stanvars = stanvars ) ``` The summary output reveals that the uncertainty in the coefficients of `period` is somewhat larger than in the basic binomial model, which is the result of including the overdispersion parameter `phi` in the model. Apart from that, the results looks pretty similar. ```{r summary_fit2} summary(fit2) ``` ## Post-Processing Custom Family Models Some post-processing methods such as `summary` or `plot` work out of the box for custom family models. However, there are three particularly important methods, which require additional input by the user. These are `posterior_epred`, `posterior_predict` and `log_lik` computing predicted mean values, predicted response values, and log-likelihood values, respectively. They are not only relevant for their own sake, but also provide the basis of many other post-processing methods. For instance, we may be interested in comparing the fit of the binomial model with that of the beta-binomial model by means of approximate leave-one-out cross-validation implemented in method `loo`, which in turn requires `log_lik` to be working. The `log_lik` function of a family should be named `log_lik_` and have the two arguments `i` (indicating observations) and `prep`. You don't have to worry too much about how `prep` is created (if you are interested, check out the `prepare_predictions` function). Instead, all you need to know is that parameters are stored in slot `dpars` and data are stored in slot `data`. Generally, parameters take on the form of a $S \times N$ matrix (with $S =$ number of posterior draws and $N =$ number of observations) if they are predicted (as is `mu` in our example) and a vector of size $N$ if the are not predicted (as is `phi`). We could define the complete log-likelihood function in R directly, or we can expose the self-defined **Stan** functions and apply them. The latter approach is usually more convenient, but the former is more stable and the only option when implementing custom families in other R packages building upon **brms**. For the purpose of the present vignette, we will go with the latter approach. ```{r} expose_functions(fit2, vectorize = TRUE) ``` and define the required `log_lik` functions with a few lines of code. ```{r log_lik} log_lik_beta_binomial2 <- function(i, prep) { mu <- brms::get_dpar(prep, "mu", i = i) phi <- brms::get_dpar(prep, "phi", i = i) trials <- prep$data$vint1[i] y <- prep$data$Y[i] beta_binomial2_lpmf(y, mu, phi, trials) } ``` The `get_dpar` function will do the necessary transformations to handle both the case when the distributional parameters are predicted separately for each row and when they are the same for the whole fit. With that being done, all of the post-processing methods requiring `log_lik` will work as well. For instance, model comparison can simply be performed via ```{r loo} loo(fit1, fit2) ``` Since larger `ELPD` values indicate better fit, we see that the beta-binomial model fits somewhat better, although the corresponding standard error reveals that the difference is not that substantial. Next, we will define the function necessary for the `posterior_predict` method: ```{r posterior_predict} posterior_predict_beta_binomial2 <- function(i, prep, ...) { mu <- brms::get_dpar(prep, "mu", i = i) phi <- brms::get_dpar(prep, "phi", i = i) trials <- prep$data$vint1[i] beta_binomial2_rng(mu, phi, trials) } ``` The `posterior_predict` function looks pretty similar to the corresponding `log_lik` function, except that we are now creating random draws of the response instead of log-likelihood values. Again, we are using an exposed **Stan** function for convenience. Make sure to add a `...` argument to your `posterior_predict` function even if you are not using it, since some families require additional arguments. With `posterior_predict` to be working, we can engage for instance in posterior-predictive checking: ```{r pp_check} pp_check(fit2) ``` When defining the `posterior_epred` function, you have to keep in mind that it has only a `prep` argument and should compute the mean response values for all observations at once. Since the mean of the beta-binomial distribution is $\text{E}(y) = \mu T$ definition of the corresponding `posterior_epred` function is not too complicated, but we need to get the dimension of parameters and data in line. ```{r posterior_epred} posterior_epred_beta_binomial2 <- function(prep) { mu <- brms::get_dpar(prep, "mu") trials <- prep$data$vint1 trials <- matrix(trials, nrow = nrow(mu), ncol = ncol(mu), byrow = TRUE) mu * trials } ``` A post-processing method relying directly on `posterior_epred` is `conditional_effects`, which allows to visualize effects of predictors. ```{r conditional_effects} conditional_effects(fit2, conditions = data.frame(size = 1)) ``` For ease of interpretation we have set `size` to 1 so that the y-axis of the above plot indicates probabilities. ## Turning a Custom Family into a Native Family Family functions built natively into **brms** are safer to use and more convenient, as they require much less user input. If you think that your custom family is general enough to be useful to other users, please feel free to open an issue on [GitHub](https://github.com/paul-buerkner/brms/issues) so that we can discuss all the details. Provided that we agree it makes sense to implement your family natively in brms, the following steps are required (`foo` is a placeholder for the family name): * In `family-lists.R`, add function `.family_foo` which should contain basic information about your family (you will find lots of examples for other families there). * In `families.R`, add family function `foo` which should be a simple wrapper around `.brmsfamily`. * In `stan-likelihood.R`, add function `stan_log_lik_foo` which provides the likelihood of the family in Stan language. * If necessary, add self-defined Stan functions in separate files under `inst/chunks`. * Add functions `posterior_predict_foo`, `posterior_epred_foo` and `log_lik_foo` to `posterior_predict.R`, `posterior_epred.R` and `log_lik.R`, respectively. * If necessary, add distribution functions to `distributions.R`. brms/inst/doc/brms_overview.ltx0000644000176200001440000017472314571050211016373 0ustar liggesusers\documentclass[article, nojss]{jss} %\VignetteIndexEntry{Overview of the brms Package} %\VignetteEngine{R.rsp::tex} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %% declarations for jss.cls %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %% almost as usual \author{Paul-Christian B\"urkner} \title{\pkg{brms}: An \proglang{R} Package for Bayesian Multilevel Models using \pkg{Stan}} %% for pretty printing and a nice hypersummary also set: \Plainauthor{Paul-Christian B\"urkner} %% comma-separated \Plaintitle{brms: An R Package for Bayesian Multilevel Models using Stan} %% without formatting \Shorttitle{\pkg{brms}: Bayesian Multilevel Models using Stan} %% a short title (if necessary) %% an abstract and keywords \Abstract{ The \pkg{brms} package implements Bayesian multilevel models in \proglang{R} using the probabilistic programming language \pkg{Stan}. A wide range of distributions and link functions are supported, allowing users to fit -- among others -- linear, robust linear, binomial, Poisson, survival, response times, ordinal, quantile, zero-inflated, hurdle, and even non-linear models all in a multilevel context. Further modeling options include autocorrelation of the response variable, user defined covariance structures, censored data, as well as meta-analytic standard errors. Prior specifications are flexible and explicitly encourage users to apply prior distributions that actually reflect their beliefs. In addition, model fit can easily be assessed and compared using posterior-predictive checks and leave-one-out cross-validation. If you use \pkg{brms}, please cite this article as published in the Journal of Statistical Software \citep{brms1}. } \Keywords{Bayesian inference, multilevel model, ordinal data, MCMC, \proglang{Stan}, \proglang{R}} \Plainkeywords{Bayesian inference, multilevel model, ordinal data, MCMC, Stan, R} %% without formatting %% at least one keyword must be supplied %% publication information %% NOTE: Typically, this can be left commented and will be filled out by the technical editor %% \Volume{50} %% \Issue{9} %% \Month{June} %% \Year{2012} %% \Submitdate{2012-06-04} %% \Acceptdate{2012-06-04} %% The address of (at least) one author should be given %% in the following format: \Address{ Paul-Christian B\"urkner\\ E-mail: \email{paul.buerkner@gmail.com}\\ URL: \url{https://paul-buerkner.github.io} } %% It is also possible to add a telephone and fax number %% before the e-mail in the following format: %% Telephone: +43/512/507-7103 %% Fax: +43/512/507-2851 %% for those who use Sweave please include the following line (with % symbols): %% need no \usepackage{Sweave.sty} %% end of declarations %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \begin{document} %% include your article here, just as usual %% Note that you should use the \pkg{}, \proglang{} and \code{} commands. \section{Introduction} Multilevel models (MLMs) offer a great flexibility for researchers across sciences \citep{brown2015, demidenko2013, gelmanMLM2006, pinheiro2006}. They allow the modeling of data measured on different levels at the same time -- for instance data of students nested within classes and schools -- thus taking complex dependency structures into account. It is not surprising that many packages for \proglang{R} \citep{Rcore2015} have been developed to fit MLMs. Possibly the most widely known package in this area is \pkg{lme4} \citep{bates2015}, which uses maximum likelihood or restricted maximum likelihood methods for model fitting. Although alternative Bayesian methods have several advantages over frequentist approaches (e.g., the possibility of explicitly incorporating prior knowledge about parameters into the model), their practical use was limited for a long time because the posterior distributions of more complex models (such as MLMs) could not be found analytically. Markov chain Monte Carlo (MCMC) algorithms allowing to draw random samples from the posterior were not available or too time-consuming. In the last few decades, however, this has changed with the development of new algorithms and the rapid increase of general computing power. Today, several software packages implement these techniques, for instance \pkg{WinBugs} \citep{lunn2000, spiegelhalter2003}, \pkg{OpenBugs} \citep{spiegelhalter2007}, \pkg{JAGS} \citep{plummer2013}, \pkg{MCMCglmm} \citep{hadfield2010} and \pkg{Stan} \citep{stan2017, carpenter2017} to mention only a few. With the exception of the latter, all of these programs are primarily using combinations of Metropolis-Hastings updates \citep{metropolis1953,hastings1970} and Gibbs-sampling \citep{geman1984,gelfand1990}, sometimes also coupled with slice-sampling \citep{damien1999,neal2003}. One of the main problems of these algorithms is their rather slow convergence for high-dimensional models with correlated parameters \citep{neal2011,hoffman2014,gelman2014}. Furthermore, Gibbs-sampling requires priors to be conjugate to the likelihood of parameters in order to work efficiently \citep{gelman2014}, thus reducing the freedom of the researcher in choosing a prior that reflects his or her beliefs. In contrast, \pkg{Stan} implements Hamiltonian Monte Carlo \citep{duane1987, neal2011} and its extension, the No-U-Turn Sampler (NUTS) \citep{hoffman2014}. These algorithms converge much more quickly especially for high-dimensional models regardless of whether the priors are conjugate or not \citep{hoffman2014}. Similar to software packages like \pkg{WinBugs}, \pkg{Stan} comes with its own programming language, allowing for great modeling flexibility (cf., \citeauthor{stanM2017} \citeyear{stanM2017}; \citeauthor{carpenter2017} \citeyear{carpenter2017}). Many researchers may still hesitate to use \pkg{Stan} directly, as every model has to be written, debugged and possibly also optimized. This may be a time-consuming and error prone process even for researchers familiar with Bayesian inference. The package \pkg{brms}, presented in this paper, aims at closing this gap (at least for MLMs) allowing the user to benefit from the merits of \pkg{Stan} only by using simple, \pkg{lme4}-like formula syntax. \pkg{brms} supports a wide range of distributions and link functions, allows for multiple grouping factors each with multiple group-level effects, autocorrelation of the response variable, user defined covariance structures, as well as flexible and explicit prior specifications. The purpose of the present article is to provide a general overview of the \pkg{brms} package (version 0.10.0). We begin by explaining the underlying structure of MLMs. Next, the software is introduced in detail using recurrence times of infection in kidney patients \citep{mcgilchrist1991} and ratings of inhaler instructions \citep{ezzet1991} as examples. We end by comparing \pkg{brms} to other \proglang{R} packages implementing MLMs and describe future plans for extending the package. \section{Model description} \label{model} The core of every MLM is the prediction of the response $y$ through the linear combination $\eta$ of predictors transformed by the inverse link function $f$ assuming a certain distribution $D$ for $y$. We write $$y_i \sim D(f(\eta_i), \theta)$$ to stress the dependency on the $i\textsuperscript{th}$ data point. In many \proglang{R} packages, $D$ is also called the `family' and we will use this term in the following. The parameter $\theta$ describes additional family specific parameters that typically do not vary across data points, such as the standard deviation $\sigma$ in normal models or the shape $\alpha$ in Gamma or negative binomial models. The linear predictor can generally be written as $$\eta = \mathbf{X} \beta + \mathbf{Z} u$$ In this equation, $\beta$ and $u$ are the coefficients at population-level and group-level respectively and $\mathbf{X}, \mathbf{Z}$ are the corresponding design matrices. The response $y$ as well as $\mathbf{X}$ and $\mathbf{Z}$ make up the data, whereas $\beta$, $u$, and $\theta$ are the model parameters being estimated. The coefficients $\beta$ and $u$ may be more commonly known as fixed and random effects. However, we avoid these terms in the present paper following the recommendations of \cite{gelmanMLM2006}, as they are not used unambiguously in the literature. Also, we want to make explicit that $u$ is a model parameter in the same manner as $\beta$ so that uncertainty in its estimates can be naturally evaluated. In fact, this is an important advantage of Bayesian MCMC methods as compared to maximum likelihood approaches, which do not treat $u$ as a parameter, but assume that it is part of the error term instead (cf., \citeauthor{fox2011}, \citeyear{fox2011}). Except for linear models, we do not incorporate an additional error term for every observation by default. If desired, such an error term can always be modeled using a grouping factor with as many levels as observations in the data. \subsection{Prior distributions} \subsubsection{Regression parameters at population-level} In \pkg{brms}, population-level parameters are not restricted to have normal priors. Instead, every parameter can have every one-dimensional prior implemented in \pkg{Stan}, for instance uniform, Cauchy or even Gamma priors. As a negative side effect of this flexibility, correlations between them cannot be modeled as parameters. If desired, point estimates of the correlations can be obtained after sampling has been done. By default, population level parameters have an improper flat prior over the reals. \subsubsection{Regression parameters at group-level} The group-level parameters $u$ are assumed to come from a multivariate normal distribution with mean zero and unknown covariance matrix $\mathbf{\Sigma}$: $$u \sim N(0, \mathbf{\Sigma})$$ As is generally the case, covariances between group-level parameters of different grouping factors are assumed to be zero. This implies that $\mathbf{Z}$ and $u$ can be split up into several matrices $\mathbf{Z_k}$ and parameter vectors $u_k$, where $k$ indexes grouping factors, so that the model can be simplified to $$u_k \sim N(0, \mathbf{\Sigma_k})$$ Usually, but not always, we can also assume group-level parameters associated with different levels (indexed by $j$) of the same grouping factor to be independent leading to $$u_{kj} \sim N(0, \mathbf{V_k})$$ The covariance matrices $\mathbf{V_k}$ are modeled as parameters. In most packages, an Inverse-Wishart distribution is used as a prior for $\mathbf{V_k}$. This is mostly because its conjugacy leads to good properties of Gibbs-Samplers \citep{gelman2014}. However, there are good arguments against the Inverse-Wishart prior \citep{natarajan2000, kass2006}. The NUTS-Sampler implemented in \pkg{Stan} does not require priors to be conjugate. This advantage is utilized in \pkg{brms}: $\mathbf{V_k}$ is parameterized in terms of a correlation matrix $\mathbf{\Omega_k}$ and a vector of standard deviations $\sigma_k$ through $$\mathbf{V_k} = \mathbf{D}(\sigma_k) \mathbf{\Omega_k} \mathbf{D}(\sigma_k)$$ where $\mathbf{D}(\sigma_k)$ denotes the diagonal matrix with diagonal elements $\sigma_k$. Priors are then specified for the parameters on the right hand side of the equation. For $\mathbf{\Omega_k}$, we use the LKJ-Correlation prior with parameter $\zeta > 0$ by \cite{lewandowski2009}\footnote{Internally, the Cholesky factor of the correlation matrix is used, as it is more efficient and numerically stable.}: $$\mathbf{\Omega_k} \sim \mathrm{LKJ}(\zeta)$$ The expected value of the LKJ-prior is the identity matrix (implying correlations of zero) for any positive value of $\zeta$, which can be interpreted like the shape parameter of a symmetric beta distribution \citep{stanM2017}. If $\zeta = 1$ (the default in \pkg{brms}) the density is uniform over correlation matrices of the respective dimension. If $\zeta > 1$, the identity matrix is the mode of the prior, with a sharper peak in the density for larger values of $\zeta$. If $0 < \zeta < 1$ the prior is U-shaped having a trough at the identity matrix, which leads to higher probabilities for non-zero correlations. For every element of $\sigma_k$, any prior can be applied that is defined on the non-negative reals only. As default in \pkg{brms}, we use a half Student-t prior with 3 degrees of freedom. This prior often leads to better convergence of the models than a half Cauchy prior, while still being relatively weakly informative. Sometimes -- for instance when modeling pedigrees -- different levels of the same grouping factor cannot be assumed to be independent. In this case, the covariance matrix of $u_k$ becomes $$\mathbf{\Sigma_k} = \mathbf{V_k} \otimes \mathbf{A_k}$$ where $\mathbf{A_k}$ is the known covariance matrix between levels and $\otimes$ is the Kronecker product. \subsubsection{Family specific parameters} For some families, additional parameters need to be estimated. In the current section, we only name the most important ones. Normal and Student's distributions need the parameter $\sigma$ to account for residual error variance. By default, $\sigma$ has a half Cauchy prior with a scale parameter that depends on the standard deviation of the response variable to remain only weakly informative regardless of response variable's scaling. Furthermore, Student's distributions needs the parameter $\nu$ representing the degrees of freedom. By default, $\nu$ has a wide gamma prior as proposed by \cite{juarez2010}. Gamma, Weibull, and negative binomial distributions need the shape parameter $\alpha$ that also has a wide gamma prior by default. \section{Parameter estimation} The \pkg{brms} package does not fit models itself but uses \pkg{Stan} on the back-end. Accordingly, all samplers implemented in \pkg{Stan} can be used to fit \pkg{brms} models. Currently, these are the static Hamiltonian Monte-Carlo (HMC) Sampler sometimes also referred to as Hybrid Monte-Carlo \citep{neal2011, neal2003, duane1987} and its extension the No-U-Turn Sampler (NUTS) by \cite{hoffman2014}. HMC-like algorithms produce samples that are much less autocorrelated than those of other samplers such as the random-walk Metropolis algorithm \citep{hoffman2014, Creutz1988}. The main drawback of this increased efficiency is the need to calculate the gradient of the log-posterior, which can be automated using algorithmic differentiation \citep{griewank2008} but is still a time-consuming process for more complex models. Thus, using HMC leads to higher quality samples but takes more time per sample than other algorithms typically applied. Another drawback of HMC is the need to pre-specify at least two parameters, which are both critical for the performance of HMC. The NUTS Sampler allows setting these parameters automatically thus eliminating the need for any hand-tuning, while still being at least as efficient as a well tuned HMC \citep{hoffman2014}. For more details on the sampling algorithms applied in \pkg{Stan}, see the \pkg{Stan} user's manual \citep{stanM2017} as well as \cite{hoffman2014}. In addition to the estimation of model parameters, \pkg{brms} allows drawing samples from the posterior predictive distribution as well as from the pointwise log-likelihood. Both can be used to assess model fit. The former allows a comparison between the actual response $y$ and the response $\hat{y}$ predicted by the model. The pointwise log-likelihood can be used, among others, to calculate the widely applicable information criterion (WAIC) proposed by \cite{watanabe2010} and leave-one-out cross-validation (LOO; \citealp{gelfand1992}; \citealp{vehtari2015}; see also \citealp{ionides2008}) both allowing to compare different models applied to the same data (lower WAICs and LOOs indicate better model fit). The WAIC can be viewed as an improvement of the popular deviance information criterion (DIC), which has been criticized by several authors (\citealp{vehtari2015}; \citealp{plummer2008}; \citealp{vanderlinde2005}; see also the discussion at the end of the original DIC paper by \citealp{spiegelhalter2002}) in part because of problems arising from fact that the DIC is only a point estimate. In \pkg{brms}, WAIC and LOO are implemented using the \pkg{loo} package \citep{loo2016} also following the recommendations of \cite{vehtari2015}. \section{Software} \label{software} The \pkg{brms} package provides functions for fitting MLMs using \pkg{Stan} for full Bayesian inference. To install the latest release version of \pkg{brms} from CRAN, type \code{install.packages("brms")} within \proglang{R}. The current developmental version can be downloaded from GitHub via \begin{Sinput} devtools::install_github("paul-buerkner/brms") \end{Sinput} Additionally, a \proglang{C++} compiler is required. This is because \pkg{brms} internally creates \pkg{Stan} code, which is translated to \proglang{C++} and compiled afterwards. The program \pkg{Rtools} \citep{Rtools2015} comes with a \proglang{C++} compiler for Windows\footnote{During the installation process, there is an option to change the system \code{PATH}. Please make sure to check this options, because otherwise \pkg{Rtools} will not be available within \proglang{R}.}. On OS X, one should use \pkg{Xcode} \citep{Xcode2015} from the App Store. To check whether the compiler can be called within \proglang{R}, run \code{system("g++ -v")} when using \pkg{Rtools} or \code{system("clang++ -v")} when using \pkg{Xcode}. If no warning occurs and a few lines of difficult to read system code are printed out, the compiler should work correctly. For more detailed instructions on how to get the compilers running, see the prerequisites section on \url{https://github.com/stan-dev/rstan/wiki/RStan-Getting-Started}. Models are fitted in \pkg{brms} using the following procedure, which is also summarized in Figure~\ref{flowchart}. First, the user specifies the model using the \code{brm} function in a way typical for most model fitting \proglang{R} functions, that is by defining \code{formula}, \code{data}, and \code{family}, as well as some other optional arguments. Second, this information is processed and the \code{stancode} and \code{standata} functions are called. The former generates the model code in \pkg{Stan} language and the latter prepares the data for use in \pkg{Stan}. These two are the mandatory parts of every \pkg{Stan} model and without \pkg{brms}, users would have to specify them themselves. Third, \pkg{Stan} code and data as well as additional arguments (such as the number of iterations and chains) are passed to functions of the \pkg{rstan} package (the \proglang{R} interface of \pkg{Stan}; \citeauthor{stan2017}, \citeyear{stan2017}). Fourth, the model is fitted by \pkg{Stan} after translating and compiling it in \proglang{C++}. Fifth, after the model has been fitted and returned by \pkg{rstan}, the fitted model object is post-processed in \pkg{brms} among others by renaming the model parameters to be understood by the user. Sixth, the results can be investigated in \proglang{R} using various methods such as \code{summary}, \code{plot}, or \code{predict} (for a complete list of methods type \code{methods(class = "brmsfit")}). \begin{figure}[ht] \centering \includegraphics[height = 0.4\textheight, keepaspectratio]{flowchart.pdf} \caption{High level description of the model fitting procedure used in \pkg{brms}.} \label{flowchart} \end{figure} \subsection{A worked example} In the following, we use an example about the recurrence time of an infection in kidney patients initially published by \cite{mcgilchrist1991}. The data set consists of 76 entries of 7 variables: \begin{Sinput} R> library("brms") R> data("kidney") R> head(kidney, n = 3) \end{Sinput} \begin{Soutput} time censored patient recur age sex disease 1 8 0 1 1 28 male other 2 23 0 2 1 48 female GN 3 22 0 3 1 32 male other \end{Soutput} Variable \code{time} represents the recurrence time of the infection, \code{censored} indicates if \code{time} is right censored (\code{1}) or not censored (\code{0}), variable \code{patient} is the patient id, and \code{recur} indicates if it is the first or second recurrence in that patient. Finally, variables \code{age}, \code{sex}, and \code{disease} make up the predictors. \subsection[Fitting models with brms]{Fitting models with \pkg{brms}} The core of the \pkg{brms} package is the \code{brm} function and we will explain its argument structure using the example above. Suppose we want to predict the (possibly censored) recurrence time using a log-normal model, in which the intercept as well as the effect of \code{age} is nested within patients. Then, we may use the following code: \begin{Sinput} fit1 <- brm(formula = time | cens(censored) ~ age * sex + disease + (1 + age|patient), data = kidney, family = lognormal(), prior = c(set_prior("normal(0,5)", class = "b"), set_prior("cauchy(0,2)", class = "sd"), set_prior("lkj(2)", class = "cor")), warmup = 1000, iter = 2000, chains = 4, control = list(adapt_delta = 0.95)) \end{Sinput} \subsection[formula: Information on the response and predictors]{\code{formula}: Information on the response and predictors} Without doubt, \code{formula} is the most complicated argument, as it contains information on the response variable as well as on predictors at different levels of the model. Everything before the $\sim$ sign relates to the response part of \code{formula}. In the usual and most simple case, this is just one variable name (e.g., \code{time}). However, to incorporate additional information about the response, one can add one or more terms of the form \code{| fun(variable)}. \code{fun} may be one of a few functions defined internally in \pkg{brms} and \code{variable} corresponds to a variable in the data set supplied by the user. In this example, \code{cens} makes up the internal function that handles censored data, and \code{censored} is the variable that contains information on the censoring. Other available functions in this context are \code{weights} and \code{disp} to allow different sorts of weighting, \code{se} to specify known standard errors primarily for meta-analysis, \code{trunc} to define truncation boundaries, \code{trials} for binomial models\footnote{In functions such as \code{glm} or \code{glmer}, the binomial response is typically passed as \code{cbind(success, failure)}. In \pkg{brms}, the equivalent syntax is \code{success | trials(success + failure)}.}, and \code{cat} to specify the number of categories for ordinal models. Everything on the right side of $\sim$ specifies predictors. Here, the syntax exactly matches that of \pkg{lme4}. For both, population-level and group-level terms, the \code{+} is used to separate different effects from each other. Group-level terms are of the form \code{(coefs | group)}, where \code{coefs} contains one or more variables whose effects are assumed to vary with the levels of the grouping factor given in \code{group}. Multiple grouping factors each with multiple group-level coefficients are possible. In the present example, only one group-level term is specified in which \code{1 + age} are the coefficients varying with the grouping factor \code{patient}. This implies that the intercept of the model as well as the effect of age is supposed to vary between patients. By default, group-level coefficients within a grouping factor are assumed to be correlated. Correlations can be set to zero by using the \code{(coefs || group)} syntax\footnote{In contrast to \pkg{lme4}, the \code{||} operator in \pkg{brms} splits up the design matrix computed from \code{coefs} instead of decomposing \code{coefs} in its terms. This implies that columns of the design matrix originating from the same factor are also assumed to be uncorrelated, whereas \pkg{lme4} estimates the correlations in this case. For a way to achieve \pkg{brms}-like behavior with \pkg{lme4}, see the \code{mixed} function of the \pkg{afex} package by \cite{afex2015}.}. Everything on the right side of \code{formula} that is not recognized as part of a group-level term is treated as a population-level effect. In this example, the population-level effects are \code{age}, \code{sex}, and \code{disease}. \subsection[family: Distribution of the response variable]{\code{family}: Distribution of the response variable} Argument \code{family} should usually be a family function, a call to a family function or a character string naming the family. If not otherwise specified, default link functions are applied. \pkg{brms} comes with a large variety of families. Linear and robust linear regression can be performed using the \code{gaussian} or \code{student} family combined with the \code{identity} link. For dichotomous and categorical data, families \code{bernoulli}, \code{binomial}, and \code{categorical} combined with the \code{logit} link, by default, are perfectly suited. Families \code{poisson}, \code{negbinomial}, and \code{geometric} allow for modeling count data. Families \code{lognormal}, \code{Gamma}, \code{exponential}, and \code{weibull} can be used (among others) for survival regression. Ordinal regression can be performed using the families \code{cumulative}, \code{cratio}, \code{sratio}, and \code{acat}. Finally, families \code{zero_inflated_poisson}, \code{zero_inflated_negbinomial}, \code{zero_inflated_binomial}, \code{zero_inflated_beta}, \code{hurdle_poisson}, \code{hurdle_negbinomial}, and \code{hurdle_gamma} can be used to adequately model excess zeros in the response. In our example, we use \code{family = lognormal()} implying a log-normal ``survival'' model for the response variable \code{time}. \subsection[prior: Prior distributions of model parameters]{\code{prior}: Prior distributions of model parameters} Every population-level effect has its corresponding regression parameter. These parameters are named as \code{b\_}, where \code{} represents the name of the corresponding population-level effect. The default prior is an improper flat prior over the reals. Suppose, for instance, that we want to set a normal prior with mean \code{0} and standard deviation \code{10} on the effect of \code{age} and a Cauchy prior with location \code{1} and scale \code{2} on \code{sexfemale}\footnote{When factors are used as predictors, parameter names will depend on the factor levels. To get an overview of all parameters and parameter classes for which priors can be specified, use function \code{get\_prior}. For the present example, \code{get\_prior(time | cens(censored) $\sim$ age * sex + disease + (1 + age|patient), data = kidney, family = lognormal())} does the desired.}. Then, we may write \begin{Sinput} prior <- c(set_prior("normal(0,10)", class = "b", coef = "age"), set_prior("cauchy(1,2)", class = "b", coef = "sexfemale")) \end{Sinput} To put the same prior (e.g., a normal prior) on all population-level effects at once, we may write as a shortcut \code{set_prior("normal(0,10)", class = "b")}. This also leads to faster sampling, because priors can be vectorized in this case. Note that we could also omit the \code{class} argument for population-level effects, as it is the default class in \code{set_prior}. A special shrinkage prior to be applied on population-level effects is the horseshoe prior \citep{carvalho2009, carvalho2010}. It is symmetric around zero with fat tails and an infinitely large spike at zero. This makes it ideal for sparse models that have many regression coefficients, although only a minority of them is non-zero. The horseshoe prior can be applied on all population-level effects at once (excluding the intercept) by using \code{set_prior("horseshoe(1)")}. The $1$ implies that the Student-$t$ prior of the local shrinkage parameters has 1 degrees of freedom. In \pkg{brms} it is possible to increase the degrees of freedom (which will often improve convergence), although the prior no longer resembles a horseshoe in this case\footnote{This class of priors is often referred to as hierarchical shrinkage family, which contains the original horseshoe prior as a special case.}. For more details see \cite{carvalho2009, carvalho2010}. Each group-level effect of each grouping factor has a standard deviation parameter, which is restricted to be non-negative and, by default, has a half Student-$t$ prior with $3$ degrees of freedom and a scale parameter that is minimally $10$. For non-ordinal models, \pkg{brms} tries to evaluate if the scale is large enough to be considered only weakly informative for the model at hand by comparing it with the standard deviation of the response after applying the link function. If this is not the case, it will increase the scale based on the aforementioned standard deviation\footnote{Changing priors based on the data is not truly Bayesian and might rightly be criticized. However, it helps avoiding the problem of too informative default priors without always forcing users to define their own priors. The latter would also be problematic as not all users can be expected to be well educated Bayesians and reasonable default priors will help them a lot in using Bayesian methods.}. \pkg{Stan} implicitly defines a half Student-$t$ prior by using a Student-$t$ prior on a restricted parameter \citep{stanM2017}. For other reasonable priors on standard deviations see \cite{gelman2006}. In \pkg{brms}, standard deviation parameters are named as \code{sd\_\_} so that \code{sd\_patient\_Intercept} and \code{sd\_patient\_age} are the parameter names in the example. If desired, it is possible to set a different prior on each parameter, but statements such as \code{set_prior("student_t(3,0,5)", class = "sd", group = "patient")} or even \code{set_prior("student_t(3,0,5)", class = "sd")} may also be used and are again faster because of vectorization. If there is more than one group-level effect per grouping factor, correlations between group-level effects are estimated. As mentioned in Section~\ref{model}, the LKJ-Correlation prior with parameter $\zeta > 0$ \citep{lewandowski2009} is used for this purpose. In \pkg{brms}, this prior is abbreviated as \code{"lkj(zeta)"} and correlation matrix parameters are named as \code{cor\_}, (e.g., \code{cor_patient}), so that \code{set_prior("lkj(2)", class = "cor", group = "patient")} is a valid statement. To set the same prior on every correlation matrix in the model, \code{set_prior("lkj(2)", class = "cor")} is also allowed, but does not come with any efficiency increases. Other model parameters such as the residual standard deviation \code{sigma} in normal models or the \code{shape} in Gamma models have their priors defined in the same way, where each of them is treated as having its own parameter class. A complete overview on possible prior distributions is given in the \pkg{Stan} user's manual \citep{stanM2017}. Note that \pkg{brms} does not thoroughly check if the priors are written in correct \pkg{Stan} language. Instead, \pkg{Stan} will check their syntactical correctness when the model is parsed to \proglang{C++} and return an error if they are not. This, however, does not imply that priors are always meaningful if they are accepted by \pkg{Stan}. Although \pkg{brms} tries to find common problems (e.g., setting bounded priors on unbounded parameters), there is no guarantee that the defined priors are reasonable for the model. \subsection[control Adjusting the sampling behavior of Stan]{\code{control}: Adjusting the sampling behavior of \pkg{Stan}} In addition to choosing the number of iterations, warmup samples, and chains, users can control the behavior of the NUTS sampler by using the \code{control} argument. The most important reason to use \code{control} is to decrease (or eliminate at best) the number of divergent transitions that cause a bias in the obtained posterior samples. Whenever you see the warning \code{"There were x divergent transitions after warmup."}, you should really think about increasing \code{adapt_delta}. To do this, write \code{control = list(adapt_delta = )}, where \code{} should usually be a value between \code{0.8} (current default) and \code{1}. Increasing \code{adapt_delta} will slow down the sampler but will decrease the number of divergent transitions threatening the validity of your posterior samples. Another problem arises when the depth of the tree being evaluated in each iteration is exceeded. This is less common than having divergent transitions, but may also bias the posterior samples. When it happens, \pkg{Stan} will throw out a warning suggesting to increase \code{max_treedepth}, which can be accomplished by writing \code{control = list(max_treedepth = )} with a positive integer \code{} that should usually be larger than the current default of \code{10}. \subsection{Analyzing the results} The example model \code{fit1} is fitted using 4 chains, each with 2000 iterations of which the first 1000 are warmup to calibrate the sampler, leading to a total of 4000 posterior samples\footnote{To save time, chains may also run in parallel when using argument \code{cluster}.}. For researchers familiar with Gibbs or Metropolis-Hastings sampling, this number may seem far too small to achieve good convergence and reasonable results, especially for multilevel models. However, as \pkg{brms} utilizes the NUTS sampler \citep{hoffman2014} implemented in \pkg{Stan}, even complex models can often be fitted with not more than a few thousand samples. Of course, every iteration is more computationally intensive and time-consuming than the iterations of other algorithms, but the quality of the samples (i.e., the effective sample size per iteration) is usually higher. After the posterior samples have been computed, the \code{brm} function returns an \proglang{R} object, containing (among others) the fully commented model code in \pkg{Stan} language, the data to fit the model, and the posterior samples themselves. The model code and data for the present example can be extracted through \code{stancode(fit1)} and \code{standata(fit1)} respectively\footnote{Both model code and data may be amended and used to fit new models. That way, \pkg{brms} can also serve as a good starting point in building more complicated models in \pkg{Stan}, directly.}. A model summary is readily available using \begin{Sinput} R> summary(fit1, waic = TRUE) \end{Sinput} \begin{Soutput} Family: lognormal (identity) Formula: time | cens(censored) ~ age * sex + disease + (1 + age | patient) Data: kidney (Number of observations: 76) Samples: 4 chains, each with iter = 2000; warmup = 1000; thin = 1; total post-warmup samples = 4000 WAIC: 673.51 Group-Level Effects: ~patient (Number of levels: 38) Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat sd(Intercept) 0.40 0.28 0.01 1.01 1731 1 sd(age) 0.01 0.01 0.00 0.02 1137 1 cor(Intercept,age) -0.13 0.46 -0.88 0.76 3159 1 Population-Level Effects: Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat Intercept 2.73 0.96 0.82 4.68 2139 1 age 0.01 0.02 -0.03 0.06 1614 1 sexfemale 2.42 1.13 0.15 4.64 2065 1 diseaseGN -0.40 0.53 -1.45 0.64 2664 1 diseaseAN -0.52 0.50 -1.48 0.48 2713 1 diseasePKD 0.60 0.74 -0.86 2.02 2968 1 age:sexfemale -0.02 0.03 -0.07 0.03 1956 1 Family Specific Parameters: Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat sigma 1.15 0.13 0.91 1.44 4000 1 Samples were drawn using sampling(NUTS). For each parameter, Eff.Sample is a crude measure of effective sample size, and Rhat is the potential scale reduction factor on split chains (at convergence, Rhat = 1). \end{Soutput} On the top of the output, some general information on the model is given, such as family, formula, number of iterations and chains, as well as the WAIC. Next, group-level effects are displayed separately for each grouping factor in terms of standard deviations and correlations between group-level effects. On the bottom of the output, population-level effects are displayed. If incorporated, autocorrelation and family specific parameters (e.g., the residual standard deviation \code{sigma}) are also given. In general, every parameter is summarized using the mean (\code{Estimate}) and the standard deviation (\code{Est.Error}) of the posterior distribution as well as two-sided 95\% Credible intervals (\code{l-95\% CI} and \code{u-95\% CI}) based on quantiles. The \code{Eff.Sample} value is an estimation of the effective sample size; that is the number of independent samples from the posterior distribution that would be expected to yield the same standard error of the posterior mean as is obtained from the dependent samples returned by the MCMC algorithm. The \code{Rhat} value provides information on the convergence of the algorithm (cf., \citeauthor{gelman1992}, \citeyear{gelman1992}). If \code{Rhat} is considerably greater than 1 (i.e., $> 1.1$), the chains have not yet converged and it is necessary to run more iterations and/or set stronger priors. To visually investigate the chains as well as the posterior distribution, the \code{plot} method can be used (see Figure~\ref{kidney_plot}). An even more detailed investigation can be achieved by applying the \pkg{shinystan} package \citep{gabry2015} through method \code{launch_shiny}. With respect to the above summary, \code{sexfemale} seems to be the only population-level effect with considerable influence on the response. Because the mean of \code{sexfemale} is positive, the model predicts longer periods without an infection for females than for males. Effects of population-level predictors can also be visualized with the \code{conditional_effects} method (see Figure~\ref{kidney_conditional_effects}). \begin{figure}[ht] \centering \includegraphics[width=0.95\textwidth]{kidney_plot.pdf} \caption{Trace and Density plots of all relevant parameters of the kidney model discussed in Section~\ref{software}.} \label{kidney_plot} \end{figure} \begin{figure}[ht] \centering \includegraphics[height=0.90\textheight]{kidney_conditional_effects.pdf} \caption{Conditional effects plots of all population-level predictors of the kidney model discussed in Section~\ref{software}.} \label{kidney_conditional_effects} \end{figure} Looking at the group-level effects, the standard deviation parameter of \code{age} is suspiciously small. To test whether it is smaller than the standard deviation parameter of \code{Intercept}, we apply the \code{hypothesis} method: \begin{Sinput} R> hypothesis(fit1, "Intercept - age > 0", class = "sd", group = "patient") \end{Sinput} \begin{Soutput} Hypothesis Tests for class sd_patient: Estimate Est.Error l-95% CI u-95% CI Evid.Ratio Intercept-age > 0 0.39 0.27 0.03 Inf 67.97 * --- '*': The expected value under the hypothesis lies outside the 95% CI. \end{Soutput} The one-sided 95\% credibility interval does not contain zero, thus indicating that the standard deviations differ from each other in the expected direction. In accordance with this finding, the \code{Evid.Ratio} shows that the hypothesis being tested (i.e., \code{Intercept - age > 0}) is about $68$ times more likely than the alternative hypothesis \code{Intercept - age < 0}. It is important to note that this kind of comparison is not easily possible when applying frequentist methods, because in this case only point estimates are available for group-level standard deviations and correlations. When looking at the correlation between both group-level effects, its distribution displayed in Figure~\ref{kidney_plot} and the 95\% credibility interval in the summary output appear to be rather wide. This indicates that there is not enough evidence in the data to reasonably estimate the correlation. Together, the small standard deviation of \code{age} and the uncertainty in the correlation raise the question if \code{age} should be modeled as a group specific term at all. To answer this question, we fit another model without this term: \begin{Sinput} R> fit2 <- update(fit1, formula. = ~ . - (1 + age|patient) + (1|patient)) \end{Sinput} A good way to compare both models is leave-one-out cross-validation (LOO)\footnote{The WAIC is an approximation of LOO that is faster and easier to compute. However, according to \cite{vehtari2015}, LOO may be the preferred method to perform model comparisons.}, which can be called in \pkg{brms} using \begin{Sinput} R> LOO(fit1, fit2) \end{Sinput} \begin{Soutput} LOOIC SE fit1 675.45 45.18 fit2 674.17 45.06 fit1 - fit2 1.28 0.99 \end{Soutput} In the output, the LOO information criterion for each model as well as the difference of the LOOs each with its corresponding standard error is shown. Both LOO and WAIC are approximately normal if the number of observations is large so that the standard errors can be very helpful in evaluating differences in the information criteria. However, for small sample sizes, standard errors should be interpreted with care \citep{vehtari2015}. For the present example, it is immediately evident that both models have very similar fit, indicating that there is little benefit in adding group specific coefficients for \code{age}. \subsection{Modeling ordinal data} In the following, we want to briefly discuss a second example to demonstrate the capabilities of \pkg{brms} in handling ordinal data. \cite{ezzet1991} analyze data from a two-treatment, two-period crossover trial to compare 2 inhalation devices for delivering the drug salbutamol in 286 asthma patients. Patients were asked to rate the clarity of leaflet instructions accompanying each device, using a four-point ordinal scale. Ratings are predicted by \code{treat} to indicate which of the two inhaler devices was used, \code{period} to indicate the time of administration, and \code{carry} to model possible carry over effects. \begin{Sinput} R> data("inhaler") R> head(inhaler, n = 1) \end{Sinput} \begin{Soutput} subject rating treat period carry 1 1 1 0.5 0.5 0 \end{Soutput} Typically, the ordinal response is assumed to originate from the categorization of a latent continuous variable. That is there are $K$ latent thresholds (model intercepts), which partition the continuous scale into the $K + 1$ observable, ordered categories. Following this approach leads to the cumulative or graded-response model \citep{samejima1969} for ordinal data implemented in many \proglang{R} packages. In \pkg{brms}, it is available via family \code{cumulative}. Fitting the cumulative model to the inhaler data, also incorporating an intercept varying by subjects, may look this: \begin{Sinput} fit3 <- brm(formula = rating ~ treat + period + carry + (1|subject), data = inhaler, family = cumulative) \end{Sinput} While the support for ordinal data in most \proglang{R} packages ends here\footnote{Exceptions known to us are the packages \pkg{ordinal} \citep{christensen2015} and \pkg{VGAM} \citep{yee2010}. The former supports only cumulative models but with different modeling option for the thresholds. The latter supports all four ordinal families also implemented in \pkg{brms} as well as category specific effects but no group-specific effects.}, \pkg{brms} allows changes to this basic model in at least three ways. First of all, three additional ordinal families are implemented. Families \code{sratio} (stopping ratio) and \code{cratio} (continuation ratio) are so called sequential models \citep{tutz1990}. Both are equivalent to each other for symmetric link functions such as \code{logit} but will differ for asymmetric ones such as \code{cloglog}. The fourth ordinal family is \code{acat} (adjacent category) also known as partial credits model \citep{masters1982, andrich1978a}. Second, restrictions to the thresholds can be applied. By default, thresholds are ordered for family \code{cumulative} or are completely free to vary for the other families. This is indicated by argument \code{threshold = "flexible"} (default) in \code{brm}. Using \code{threshold = "equidistant"} forces the distance between two adjacent thresholds to be the same, that is $$\tau_k = \tau_1 + (k-1)\delta$$ for thresholds $\tau_k$ and distance $\delta$ (see also \citealp{andrich1978b}; \citealp{andrich1978a}; \citealp{andersen1977}). Third, the assumption that predictors have constant effects across categories may be relaxed for non-cumulative ordinal models \citep{vanderark2001, tutz2000} leading to category specific effects. For instance, variable \code{treat} may only have an impact on the decision between category 3 and 4, but not on the lower categories. Without using category specific effects, such a pattern would remain invisible. To illustrate all three modeling options at once, we fit a (hardly theoretically justified) stopping ratio model with equidistant thresholds and category specific effects for variable \code{treat} on which we apply an informative prior. \begin{Sinput} fit4 <- brm(formula = rating ~ period + carry + cs(treat) + (1|subject), data = inhaler, family = sratio, threshold = "equidistant", prior = set_prior("normal(-1,2)", coef = "treat")) \end{Sinput} Note that priors are defined on category specific effects in the same way as for other population-level effects. A model summary can be obtained in the same way as before: \begin{Sinput} R> summary(fit4, waic = TRUE) \end{Sinput} \begin{Soutput} Family: sratio (logit) Formula: rating ~ period + carry + cs(treat) + (1 | subject) Data: inhaler (Number of observations: 572) Samples: 4 chains, each with iter = 2000; warmup = 1000; thin = 1; total post-warmup samples = 4000 WAIC: 911.9 Group-Level Effects: ~subject (Number of levels: 286) Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat sd(Intercept) 1.05 0.23 0.56 1.5 648 1 Population-Level Effects: Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat Intercept[1] 0.72 0.13 0.48 0.99 2048 1 Intercept[2] 2.67 0.35 2.00 3.39 969 1 Intercept[3] 4.62 0.66 3.36 5.95 1037 1 period 0.25 0.18 -0.09 0.61 4000 1 carry -0.26 0.22 -0.70 0.17 1874 1 treat[1] -0.96 0.30 -1.56 -0.40 1385 1 treat[2] -0.65 0.49 -1.60 0.27 4000 1 treat[3] -2.65 1.21 -5.00 -0.29 4000 1 Family Specific Parameters: Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat delta 1.95 0.32 1.33 2.6 1181 1 Samples were drawn using sampling(NUTS). For each parameter, Eff.Sample is a crude measure of effective sample size, and Rhat is the potential scale reduction factor on split chains (at convergence, Rhat = 1). \end{Soutput} Trace and density plots of the model parameters as produced by \code{plot(fit4)} can be found in Figure~\ref{inhaler_plot}. We see that three intercepts (thresholds) and three effects of \code{treat} have been estimated, because a four-point scale was used for the ratings. The treatment effect seems to be strongest between category 3 and 4. At the same time, however, the credible interval is also much larger. In fact, the intervals of all three effects of \code{treat} are highly overlapping, which indicates that there is not enough evidence in the data to support category specific effects. On the bottom of the output, parameter \code{delta} specifies the distance between two adjacent thresholds and indeed the intercepts differ from each other by the magnitude of \code{delta}. \begin{figure}[ht] \centering \includegraphics[width=0.95\textwidth]{inhaler_plot.pdf} \caption{Trace and Density plots of all relevant parameters of the inhaler model discussed in Section~\ref{software}.} \label{inhaler_plot} \end{figure} \section[Comparison]{Comparison between packages} Over the years, many \proglang{R} packages have been developed that implement MLMs, each being more or less general in their supported models. Comparing all of them to \pkg{brms} would be too extensive and barely helpful for the purpose of the present paper. Accordingly, we concentrate on a comparison with four packages. These are \pkg{lme4} \citep{bates2015} and \pkg{MCMCglmm} \citep{hadfield2010}, which are possibly the most general and widely applied \proglang{R} packages for MLMs, as well as \pkg{rstanarm} \citep{rstanarm2016} and \pkg{rethinking} \citep{mcelreath2016}, which are both based on \pkg{Stan}. As opposed to the other packages, \pkg{rethinking} was primarily written for teaching purposes and requires the user to specify the full model explicitly using its own simplified \pkg{BUGS}-like syntax thus helping users to better understand the models that are fitted to their data. Regarding model families, all five packages support the most common types such as linear and binomial models as well as Poisson models for count data. Currently, \pkg{brms} and \pkg{MCMCglmm} provide more flexibility when modeling categorical and ordinal data. In addition, \pkg{brms} supports robust linear regression using Student's distribution, which is also implemented on a GitHub branch of \pkg{rstanarm}. \pkg{MCMCglmm} allows fitting multinomial models that are currently not available in the other packages. Generalizing classical MLMs, \pkg{brms} and \pkg{MCMCglmm} allow fiting zero-inflated and hurdle models dealing with excess zeros in the response. Furthermore, \pkg{brms} supports non-linear models similar to the \pkg{nlme} package \citep{nlme2016} providing great flexibility but also requiring more care to produce reasonable results. Another flexible model class are generalized additive mixed models \citep{hastie1990,wood2011,zuur2014}, which can be fitted with \pkg{brms} and \pkg{rstanarm}. In all five packages, there are quite a few additional modeling options. Variable link functions can be specified in all packages except for \pkg{MCMCglmm}, in which only one link is available per family. \pkg{MCMCglmm} generally supports multivariate responses using data in wide format, whereas \pkg{brms} currently only offers this option for families \code{gaussian} and \code{student}. It should be noted that it is always possible to transform data from wide to long format for compatibility with the other packages. Autocorrelation of the response can only be fitted in \pkg{brms}, which supports auto-regressive as well as moving-average effects. For ordinal models in \pkg{brms}, effects of predictors may vary across different levels of the response as explained in the inhaler example. A feature currently exclusive to \pkg{rethinking} is the possibility to impute missing values in the predictor variables. Information criteria are available in all three packages. The advantage of WAIC and LOO implemented in \pkg{brms}, \pkg{rstanarm}, and \pkg{rethinking} is that their standard errors can be easily estimated to get a better sense of the uncertainty in the criteria. Comparing the prior options of the Bayesian packages, \pkg{brms} and \pkg{rethinking} offer a little more flexibility than \pkg{MCMCglmm} and \pkg{rstanarm}, as virtually any prior distribution can be applied on population-level effects as well as on the standard deviations of group-level effects. In addition, we believe that the way priors are specified in \pkg{brms} and \pkg{rethinking} is more intuitive as it is directly evident what prior is actually applied. A more detailed comparison of the packages can be found in Table~\ref{comparison1} and Table~\ref{comparison2}. To facilitate the understanding of the model formulation in \pkg{brms}, Table~\ref{syntax} shows \pkg{lme4} function calls to fit sample models along with the equivalent \pkg{brms} syntax. So far the focus was only on capabilities. Another important topic is speed, especially for more complex models. Of course, \pkg{lme4} is usually much faster than the other packages as it uses maximum likelihood methods instead of MCMC algorithms, which are slower by design. To compare the efficiency of the four Bayesian packages, we fitted multilevel models on real data sets using the minimum effective sample size divided by sampling time as a measure of sampling efficiency. One should always aim at running multiple chains as one cannot be sure that a single chain really explores the whole posterior distribution. However, as \pkg{MCMCglmm} does not come with a built-in option to run multiple chains, we used only a single chain to fit the models after making sure that it leads to the same results as multiple chains. The \proglang{R} code allowing to replicate the results is available as supplemental material. The first thing that becomes obvious when fitting the models is that \pkg{brms} and \pkg{rethinking} need to compile the \proglang{C++} model before actually fitting it, because the \pkg{Stan} code being parsed to \proglang{C++} is generated on the fly based on the user's input. Compilation takes about a half to one minute depending on the model complexity and computing power of the machine. This is not required by \pkg{rstanarm} and \pkg{MCMCglmm}, although the former is also based on \pkg{Stan}, as compilation takes place only once at installation time. While the latter approach saves the compilation time, the former is more flexible when it comes to model specification. For small and simple models, compilation time dominates the overall computation time, but for larger and more complex models, sampling will take several minutes or hours so that one minute more or less will not really matter, anymore. Accordingly, the following comparisons do not include the compilation time. In models containing only group-specific intercepts, \pkg{MCMCglmm} is usually more efficient than the \pkg{Stan} packages. However, when also estimating group-specific slopes, \pkg{MCMCglmm} falls behind the other packages and quite often refuses to sample at all unless one carefully specifies informative priors. Note that these results are obtained by running only a single chain. For all three \pkg{Stan} packages, sampling efficiency can easily be increased by running multiple chains in parallel. Comparing the \pkg{Stan} packages to each other, \pkg{brms} is usually most efficient for models with group-specific terms, whereas \pkg{rstanarm} tends to be roughly $50\%$ to $75\%$ as efficient at least for the analyzed data sets. The efficiency of \pkg{rethinking} is more variable depending on the model formulation and data, sometimes being slightly ahead of the other two packages, but usually being considerably less efficient. Generally, \pkg{rethinking} loses efficiency for models with many population-level effects presumably because one cannot use design matrices and vectorized prior specifications for population-level parameters. Note that it was not possible to specify the exact same priors across packages due to varying parameterizations. Of course, efficiency depends heavily on the model, chosen priors, and data at hand so that the present results should not be over-interpreted. \begin{table}[hbtp] \centering \begin{tabular}{llll} & \parbox{2cm}{\pkg{brms}} & \parbox{2cm}{\pkg{lme4}} & \parbox{2cm}{\pkg{MCMCglmm}} \\ \hline \\ [-1.5ex] \parbox{6cm}{Supported model types:} & & & \\ [1ex] Linear models & yes & yes & yes \\ Robust linear models & yes & no & no \\ Binomial models & yes & yes & yes \\ Categorical models & yes & no & yes \\ Multinomial models & no & no & yes \\ Count data models & yes & yes & yes \\ Survival models & yes$^1$ & yes & yes \\ Ordinal models & various & no & cumulative \\ Zero-inflated and hurdle models & yes & no & yes \\ Generalized additive models & yes & no & no \\ Non-linear models & yes & no & no \\ \hline \\ [-1.5ex] \parbox{5cm}{Additional modeling options:} & & & \\ [1ex] Variable link functions & various & various & no \\ Weights & yes & yes & no \\ Offset & yes & yes & using priors \\ Multivariate responses & limited & no & yes \\ Autocorrelation effects & yes & no & no \\ Category specific effects & yes & no & no \\ Standard errors for meta-analysis & yes & no & yes \\ Censored data & yes & no & yes \\ Truncated data & yes & no & no \\ Customized covariances & yes & no & yes \\ Missing value imputation & no & no & no \\ \hline \\ [-1.5ex] Bayesian specifics: & & & \\ [1ex] parallelization & yes & -- & no \\ population-level priors & flexible & --$^3$ & normal \\ group-level priors & normal & --$^3$ & normal \\ covariance priors & flexible & --$^3$ & restricted$^4$ \\ \hline \\ [-1.5ex] Other: & & & \\ [1ex] Estimator & HMC, NUTS & ML, REML & MH, Gibbs$^2$ \\ Information criterion & WAIC, LOO & AIC, BIC & DIC \\ \proglang{C++} compiler required & yes & no & no \\ Modularized & no & yes & no \\ \hline \end{tabular} \caption{Comparison of the capabilities of the \pkg{brms}, \pkg{lme4} and \pkg{MCMCglmm} package. Notes: (1) Weibull family only available in \pkg{brms}. (2) Estimator consists of a combination of both algorithms. (3) Priors may be imposed using the \pkg{blme} package \citep{chung2013}. (4) For details see \cite{hadfield2010}.} \label{comparison1} \end{table} \begin{table}[hbtp] \centering \begin{tabular}{llll} & \parbox{2cm}{\pkg{brms}} & \parbox{2cm}{\pkg{rstanarm}} & \parbox{2cm}{\pkg{rethinking}} \\ \hline \\ [-1.5ex] \parbox{6cm}{Supported model types:} & & & \\ [1ex] Linear models & yes & yes & yes \\ Robust linear models & yes & yes$^1$ & no \\ Binomial models & yes & yes & yes \\ Categorical models & yes & no & no \\ Multinomial models & no & no & no \\ Count data models & yes & yes & yes \\ Survival models & yes$^2$ & yes & yes \\ Ordinal models & various & cumulative$^3$ & no \\ Zero-inflated and hurdle models & yes & no & no \\ Generalized additive models & yes & yes & no \\ Non-linear models & yes & no & limited$^4$ \\ \hline \\ [-1.5ex] \parbox{5cm}{Additional modeling options:} & & & \\ [1ex] Variable link functions & various & various & various \\ Weights & yes & yes & no \\ Offset & yes & yes & yes \\ Multivariate responses & limited & no & no \\ Autocorrelation effects & yes & no & no \\ Category specific effects & yes & no & no \\ Standard errors for meta-analysis & yes & no & no \\ Censored data & yes & no & no \\ Truncated data & yes & no & yes \\ Customized covariances & yes & no & no \\ Missing value imputation & no & no & yes \\ \hline \\ [-1.5ex] Bayesian specifics: & & & \\ [1ex] parallelization & yes & yes & yes \\ population-level priors & flexible & normal, Student-t & flexible \\ group-level priors & normal & normal & normal \\ covariance priors & flexible & restricted$^5$ & flexible \\ \hline \\ [-1.5ex] Other: & & & \\ [1ex] Estimator & HMC, NUTS & HMC, NUTS & HMC, NUTS \\ Information criterion & WAIC, LOO & AIC, LOO & AIC, LOO \\ \proglang{C++} compiler required & yes & no & yes \\ Modularized & no & no & no \\ \hline \end{tabular} \caption{Comparison of the capabilities of the \pkg{brms}, \pkg{rstanarm} and \pkg{rethinking} package. Notes: (1) Currently only implemented on a branch on GitHub. (2) Weibull family only available in \pkg{brms}. (3) No group-level terms allowed. (4) The parser is mainly written for linear models but also accepts some non-linear model specifications. (5) For details see \url{https://github.com/stan-dev/rstanarm/wiki/Prior-distributions}.} \label{comparison2} \end{table} \begin{table}[hbtp] \centering %\renewcommand{\arraystretch}{2} \begin{tabular}{ll} Dataset & \parbox{10cm}{Function call} \\ \hline \\ [-1.5ex] \parbox{2cm}{cake} & \\ [1ex] \pkg{lme4} & \parbox{13cm}{\code{lmer(angle $\sim$ recipe * temperature + (1|recipe:replicate), \\ \hspace*{5ex} data = cake)}} \\ [3ex] \pkg{brms} & \parbox{13cm}{\code{brm(angle $\sim$ recipe * temperature + (1|recipe:replicate), \\ \hspace*{4ex} data = cake)}} \\ [2ex] \hline \\ [-1.5ex] \parbox{2cm}{sleepstudy} & \\ [1ex] \pkg{lme4} & \parbox{13cm}{\code{lmer(Reaction $\sim$ Days + (Days|Subject), data = sleepstudy)}} \\ [1.5ex] \pkg{brms} & \parbox{13cm}{\code{brm(Reaction $\sim$ Days + (Days|Subject), data = sleepstudy)}} \\ [2ex] \hline \\ [-1.5ex] \parbox{2cm}{cbpp$^1$} & \\ [1ex] \pkg{lme4} & \parbox{13cm}{\code{glmer(cbind(incidence, size - incidence) $\sim$ period + (1 | herd), \\ \hspace*{6ex} family = binomial("logit"), data = cbpp)}} \\ [3ex] \pkg{brms} & \parbox{13cm}{\code{brm(incidence | trials(size) $\sim$ period + (1 | herd), \\ \hspace*{4ex} family = binomial("logit"), data = cbpp)}} \\ [2ex] \hline \\ [-1.5ex] \parbox{2cm}{grouseticks$^1$} & \\ [1ex] \pkg{lme4} & \parbox{13cm}{\code{glmer(TICKS $\sim$ YEAR + HEIGHT + (1|BROOD) + (1|LOCATION), \\ \hspace*{6ex} family = poisson("log"), data = grouseticks)}} \\ [3ex] \pkg{brms} & \parbox{13cm}{\code{brm(TICKS $\sim$ YEAR + HEIGHT + (1|BROOD) + (1|LOCATION), \\ \hspace*{4ex} family = poisson("log"), data = grouseticks)}} \\ [2ex] \hline \\ [-1ex] \parbox{2cm}{VerbAgg$^2$} & \\ [1ex] \pkg{lme4} & \parbox{13cm}{\code{glmer(r2 $\sim$ (Anger + Gender + btype + situ)\^{}2 + (1|id) \\ \hspace*{6ex} + (1|item), family = binomial, data = VerbAgg)}} \\ [3ex] \pkg{brms} & \parbox{13cm}{\code{brm(r2 $\sim$ (Anger + Gender + btype + situ)\^{}2 + (1|id) \\ \hspace*{4ex} + (1|item), family = bernoulli, data = VerbAgg)}} \\ [2ex] \hline \\ [-1.5ex] \end{tabular} \caption{Comparison of the model syntax of \pkg{lme4} and \pkg{brms} using data sets included in \pkg{lme4}. Notes: (1) Default links are used to that the link argument may be omitted. (2) Fitting this model takes some time. A proper prior on the population-level effects (e.g., \code{prior = set\_prior("normal(0,5)")}) may help in increasing sampling speed.} \label{syntax} \end{table} \section{Conclusion} The present paper is meant to provide a general overview on the \proglang{R} package \pkg{brms} implementing MLMs using the probabilistic programming language \pkg{Stan} for full Bayesian inference. Although only a small selection of the modeling options available in \pkg{brms} are discussed in detail, I hope that this article can serve as a good starting point to further explore the capabilities of the package. For the future, I have several plans on how to improve the functionality of \pkg{brms}. I want to include multivariate models that can handle multiple response variables coming from different distributions as well as new correlation structures for instance for spatial data. Similarily, distributional regression models as well as mixture response distributions appear to be valuable extensions of the package. I am always grateful for any suggestions and ideas regarding new features. \section*{Acknowledgments} First of all, I would like to thank the Stan Development Team for creating the probabilistic programming language \pkg{Stan}, which is an incredibly powerful and flexible tool for performing full Bayesian inference. Without it, \pkg{brms} could not fit a single model. Two anonymous reviewers provided very detailed and thoughtful suggestions to substantially improve both the package and the paper. Furthermore, Prof. Philipp Doebler and Prof. Heinz Holling have given valuable feedback on earlier versions of the paper. Lastly, I want to thank the many users who reported bugs or had ideas for new features, thus helping to continuously improve \pkg{brms}. \bibliography{citations_overview} \end{document} brms/inst/doc/brms_monotonic.R0000644000176200001440000000637115057751601016130 0ustar liggesusersparams <- list(EVAL = TRUE) ## ----SETTINGS-knitr, include=FALSE------------------------------------------------------ stopifnot(require(knitr)) options(width = 90) knit_hooks$set(pngquant = knitr::hook_pngquant) opts_chunk$set( comment = NA, message = FALSE, warning = FALSE, eval = if (isTRUE(exists("params"))) params$EVAL else FALSE, dev = "ragg_png", dpi = 72, fig.retina = 1.5, fig.asp = 0.8, fig.width = 5, out.width = "60%", fig.align = "center", pngquant = "--speed=1 --quality=50" ) library(brms) ggplot2::theme_set(theme_default()) ## --------------------------------------------------------------------------------------- income_options <- c("below_20", "20_to_40", "40_to_100", "greater_100") income <- factor(sample(income_options, 100, TRUE), levels = income_options, ordered = TRUE) mean_ls <- c(30, 60, 70, 75) ls <- mean_ls[income] + rnorm(100, sd = 7) dat <- data.frame(income, ls) ## ----results='hide'--------------------------------------------------------------------- fit1 <- brm(ls ~ mo(income), data = dat) ## --------------------------------------------------------------------------------------- summary(fit1) plot(fit1, variable = "simo", regex = TRUE) plot(conditional_effects(fit1)) ## ----results='hide'--------------------------------------------------------------------- dat$income_num <- as.numeric(dat$income) fit2 <- brm(ls ~ income_num, data = dat) ## --------------------------------------------------------------------------------------- summary(fit2) ## ----results='hide'--------------------------------------------------------------------- contrasts(dat$income) <- contr.treatment(4) fit3 <- brm(ls ~ income, data = dat) ## --------------------------------------------------------------------------------------- summary(fit3) ## --------------------------------------------------------------------------------------- loo(fit1, fit2, fit3) ## ----results='hide'--------------------------------------------------------------------- prior4 <- prior(dirichlet(c(2, 1, 1)), class = "simo", coef = "moincome1") fit4 <- brm(ls ~ mo(income), data = dat, prior = prior4, sample_prior = TRUE) ## --------------------------------------------------------------------------------------- summary(fit4) ## --------------------------------------------------------------------------------------- plot(fit4, variable = "prior_simo", regex = TRUE, N = 3) ## --------------------------------------------------------------------------------------- dat$age <- rnorm(100, mean = 40, sd = 10) ## ----results='hide'--------------------------------------------------------------------- fit5 <- brm(ls ~ mo(income)*age, data = dat) ## --------------------------------------------------------------------------------------- summary(fit5) conditional_effects(fit5, "income:age") ## --------------------------------------------------------------------------------------- dat$city <- rep(1:10, each = 10) var_city <- rnorm(10, sd = 10) dat$ls <- dat$ls + var_city[dat$city] ## ----results='hide'--------------------------------------------------------------------- fit6 <- brm(ls ~ mo(income)*age + (mo(income) | city), data = dat) ## --------------------------------------------------------------------------------------- summary(fit6) brms/inst/doc/brms_phylogenetics.Rmd0000644000176200001440000002741015053072461017312 0ustar liggesusers--- title: "Estimating Phylogenetic Multilevel Models with brms" author: "Paul Bürkner" date: "`r Sys.Date()`" output: rmarkdown::html_vignette: toc: yes vignette: > %\VignetteIndexEntry{Estimating Phylogenetic Multilevel Models with brms} %\VignetteEngine{knitr::rmarkdown} \usepackage[utf8]{inputenc} params: EVAL: !r identical(Sys.getenv("NOT_CRAN"), "true") --- ```{r, SETTINGS-knitr, include=FALSE} stopifnot(require(knitr)) options(width = 90) knit_hooks$set(pngquant = knitr::hook_pngquant) opts_chunk$set( comment = NA, message = FALSE, warning = FALSE, eval = if (isTRUE(exists("params"))) params$EVAL else FALSE, dev = "ragg_png", dpi = 72, fig.retina = 1.5, fig.asp = 0.8, fig.width = 5, out.width = "60%", fig.align = "center", pngquant = "--speed=1 --quality=50" ) library(brms) ggplot2::theme_set(theme_default()) ``` ## Introduction In the present vignette, we want to discuss how to specify phylogenetic multilevel models using **brms**. These models are relevant in evolutionary biology when data of many species are analyzed at the same time. The usual approach would be to model species as a grouping factor in a multilevel model and estimate varying intercepts (and possibly also varying slopes) over species. However, species are not independent as they come from the same phylogenetic tree and we thus have to adjust our model to incorporate this dependency. The examples discussed here are from chapter 11 of the book *Modern Phylogenetic Comparative Methods and the application in Evolutionary Biology* (de Villemeruil & Nakagawa, 2014). The necessary data can be downloaded from the corresponding website (https://www.mpcm-evolution.com/). Some of these models may take a few minutes to fit. ## A Simple Phylogenetic Model Assume we have measurements of a phenotype, `phen` (say the body size), and a `cofactor` variable (say the temperature of the environment). We prepare the data using the following code. ```{r} phylo <- ape::read.nexus("https://paul-buerkner.github.io/data/phylo.nex") data_simple <- read.table( "https://paul-buerkner.github.io/data/data_simple.txt", header = TRUE ) head(data_simple) ``` The `phylo` object contains information on the relationship between species. Using this information, we can construct a covariance matrix of species (Hadfield & Nakagawa, 2010). ```{r} A <- ape::vcv.phylo(phylo) ``` Now we are ready to fit our first phylogenetic multilevel model: ```{r, results='hide'} model_simple <- brm( phen ~ cofactor + (1|gr(phylo, cov = A)), data = data_simple, family = gaussian(), data2 = list(A = A), prior = c( prior(normal(0, 10), "b"), prior(normal(0, 50), "Intercept"), prior(student_t(3, 0, 20), "sd"), prior(student_t(3, 0, 20), "sigma") ) ) ``` With the exception of `(1|gr(phylo, cov = A))` instead of `(1|phylo)` this is a basic multilevel model with a varying intercept over species (`phylo` is an indicator of species in this data set). However, by using `cov = A` in the `gr` function, we make sure that species are correlated as specified by the covariance matrix `A`. We pass `A` itself via the `data2` argument which can be used for any kinds of data that does not fit into the regular structure of the `data` argument. Setting priors is not required for achieving good convergence for this model, but it improves sampling speed a bit. After fitting, the results can be investigated in detail. ```{r} summary(model_simple) plot(model_simple, N = 2, ask = FALSE) plot(conditional_effects(model_simple), points = TRUE) ``` The so called phylogenetic signal (often symbolize by $\lambda$) can be computed with the `hypothesis` method and is roughly $\lambda = 0.7$ for this example. ```{r} hyp <- "sd_phylo__Intercept^2 / (sd_phylo__Intercept^2 + sigma^2) = 0" (hyp <- hypothesis(model_simple, hyp, class = NULL)) plot(hyp) ``` Note that the phylogenetic signal is just a synonym of the intra-class correlation (ICC) used in the context phylogenetic analysis. ## A Phylogenetic Model with Repeated Measurements Often, we have multiple observations per species and this allows to fit more complicated phylogenetic models. ```{r} data_repeat <- read.table( "https://paul-buerkner.github.io/data/data_repeat.txt", header = TRUE ) data_repeat$spec_mean_cf <- with(data_repeat, sapply(split(cofactor, phylo), mean)[phylo]) head(data_repeat) ``` The variable `spec_mean_cf` just contains the mean of the cofactor for each species. The code for the repeated measurement phylogenetic model looks as follows: ```{r, results='hide'} model_repeat1 <- brm( phen ~ spec_mean_cf + (1|gr(phylo, cov = A)) + (1|species), data = data_repeat, family = gaussian(), data2 = list(A = A), prior = c( prior(normal(0,10), "b"), prior(normal(0,50), "Intercept"), prior(student_t(3,0,20), "sd"), prior(student_t(3,0,20), "sigma") ), sample_prior = TRUE, chains = 2, cores = 2, iter = 4000, warmup = 1000 ) ``` The variables `phylo` and `species` are identical as they are both identifiers of the species. However, we model the phylogenetic covariance only for `phylo` and thus the `species` variable accounts for any specific effect that would be independent of the phylogenetic relationship between species (e.g., environmental or niche effects). Again we can obtain model summaries as well as estimates of the phylogenetic signal. ```{r} summary(model_repeat1) ``` ```{r} hyp <- paste( "sd_phylo__Intercept^2 /", "(sd_phylo__Intercept^2 + sd_species__Intercept^2 + sigma^2) = 0" ) (hyp <- hypothesis(model_repeat1, hyp, class = NULL)) plot(hyp) ``` So far, we have completely ignored the variability of the cofactor within species. To incorporate this into the model, we define ```{r} data_repeat$within_spec_cf <- data_repeat$cofactor - data_repeat$spec_mean_cf ``` and then fit it again using `within_spec_cf` as an additional predictor. ```{r, results='hide'} model_repeat2 <- update( model_repeat1, formula = ~ . + within_spec_cf, newdata = data_repeat, chains = 2, cores = 2, iter = 4000, warmup = 1000 ) ``` The results are almost unchanged, with apparently no relationship between the phenotype and the within species variance of `cofactor`. ```{r} summary(model_repeat2) ``` Also, the phylogenetic signal remains more or less the same. ```{r} hyp <- paste( "sd_phylo__Intercept^2 /", "(sd_phylo__Intercept^2 + sd_species__Intercept^2 + sigma^2) = 0" ) (hyp <- hypothesis(model_repeat2, hyp, class = NULL)) ``` ## A Phylogenetic Meta-Analysis Let's say we have Fisher's z-transformed correlation coefficients $Zr$ per species along with corresponding sample sizes (e.g., correlations between male coloration and reproductive success): ```{r} data_fisher <- read.table( "https://paul-buerkner.github.io/data/data_effect.txt", header = TRUE ) data_fisher$obs <- 1:nrow(data_fisher) head(data_fisher) ``` We assume the sampling variance to be known and as $V(Zr) = \frac{1}{N - 3}$ for Fisher's values, where $N$ is the sample size per species. Incorporating the known sampling variance into the model is straight forward. One has to keep in mind though, that **brms** requires the sampling standard deviation (square root of the variance) as input instead of the variance itself. The group-level effect of `obs` represents the residual variance, which we have to model explicitly in a meta-analytic model. ```{r, results='hide'} model_fisher <- brm( Zr | se(sqrt(1 / (N - 3))) ~ 1 + (1|gr(phylo, cov = A)) + (1|obs), data = data_fisher, family = gaussian(), data2 = list(A = A), prior = c( prior(normal(0, 10), "Intercept"), prior(student_t(3, 0, 10), "sd") ), control = list(adapt_delta = 0.95), chains = 2, cores = 2, iter = 4000, warmup = 1000 ) ``` A summary of the fitted model is obtained via ```{r} summary(model_fisher) plot(model_fisher) ``` The meta-analytic mean (i.e., the model intercept) is $0.16$ with a credible interval of $[0.08, 0.25]$. Thus the mean correlation across species is positive according to the model. ## A phylogenetic count-data model Suppose that we analyze a phenotype that consists of counts instead of being a continuous variable. In such a case, the normality assumption will likely not be justified and it is recommended to use a distribution explicitly suited for count data, for instance the Poisson distribution. The following data set (again retrieved from mpcm-evolution.org) provides an example. ```{r} data_pois <- read.table( "https://paul-buerkner.github.io/data/data_pois.txt", header = TRUE ) data_pois$obs <- 1:nrow(data_pois) head(data_pois) ``` As the Poisson distribution does not have a natural overdispersion parameter, we model the residual variance via the group-level effects of `obs` (e.g., see Lawless, 1987). ```{r, results='hide'} model_pois <- brm( phen_pois ~ cofactor + (1|gr(phylo, cov = A)) + (1|obs), data = data_pois, family = poisson("log"), data2 = list(A = A), chains = 2, cores = 2, iter = 4000, control = list(adapt_delta = 0.95) ) ``` Again, we obtain a summary of the fitted model via ```{r} summary(model_pois) plot(conditional_effects(model_pois), points = TRUE) ``` Now, assume we ignore the fact that the phenotype is count data and fit a linear normal model instead. ```{r, results='hide'} model_normal <- brm( phen_pois ~ cofactor + (1|gr(phylo, cov = A)), data = data_pois, family = gaussian(), data2 = list(A = A), chains = 2, cores = 2, iter = 4000, control = list(adapt_delta = 0.95) ) ``` ```{r} summary(model_normal) ``` We see that `cofactor` has a positive relationship with the phenotype in both models. One should keep in mind, though, that the estimates of the Poisson model are on the log-scale, as we applied the canonical log-link function in this example. Therefore, estimates are not comparable to a linear normal model even if applied to the same data. What we can compare, however, is the model fit, for instance graphically via posterior predictive checks. ```{r} pp_check(model_pois) pp_check(model_normal) ``` Apparently, the distribution of the phenotype predicted by the Poisson model resembles the original distribution of the phenotype pretty closely, while the normal models fails to do so. We can also apply leave-one-out cross-validation for direct numerical comparison of model fit. ```{r} loo(model_pois, model_normal) ``` Since smaller values of loo indicate better fit, it is again evident that the Poisson model fits the data better than the normal model. Of course, the Poisson model is not the only reasonable option here. For instance, you could use a negative binomial model (via family `negative_binomial`), which already contains an overdispersion parameter so that modeling a varying intercept of `obs` becomes obsolete. ## Phylogenetic models with multiple group-level effects In the above examples, we have only used a single group-level effect (i.e., a varying intercept) for the phylogenetic grouping factors. In **brms**, it is also possible to estimate multiple group-level effects (e.g., a varying intercept and a varying slope) for these grouping factors. However, it requires repeatedly computing Kronecker products of covariance matrices while fitting the model. This will be very slow especially when the grouping factors have many levels and matrices are thus large. ## References de Villemeruil P. & Nakagawa, S. (2014) General quantitative genetic methods for comparative biology. In: *Modern phylogenetic comparative methods and their application in evolutionary biology: concepts and practice* (ed. Garamszegi L.) Springer, New York. pp. 287-303. Hadfield, J. D. & Nakagawa, S. (2010) General quantitative genetic methods for comparative biology: phylogenies, taxonomies, and multi-trait models for continuous and categorical characters. *Journal of Evolutionary Biology*. 23. 494-508. Lawless, J. F. (1987). Negative binomial and mixed Poisson regression. *Canadian Journal of Statistics*, 15(3), 209-225. brms/inst/doc/brms_monotonic.html0000644000176200001440000055571715057751601016710 0ustar liggesusers Estimating Monotonic Effects with brms

Estimating Monotonic Effects with brms

Paul Bürkner

2025-09-09

Introduction

This vignette is about monotonic effects, a special way of handling discrete predictors that are on an ordinal or higher scale (Bürkner & Charpentier, in review). A predictor, which we want to model as monotonic (i.e., having a monotonically increasing or decreasing relationship with the response), must either be integer valued or an ordered factor. As opposed to a continuous predictor, predictor categories (or integers) are not assumed to be equidistant with respect to their effect on the response variable. Instead, the distance between adjacent predictor categories (or integers) is estimated from the data and may vary across categories. This is realized by parameterizing as follows: One parameter, \(b\), takes care of the direction and size of the effect similar to an ordinary regression parameter. If the monotonic effect is used in a linear model, \(b\) can be interpreted as the expected average difference between two adjacent categories of the ordinal predictor. An additional parameter vector, \(\zeta\), estimates the normalized distances between consecutive predictor categories which thus defines the shape of the monotonic effect. For a single monotonic predictor, \(x\), the linear predictor term of observation \(n\) looks as follows:

\[\eta_n = b D \sum_{i = 1}^{x_n} \zeta_i\]

The parameter \(b\) can take on any real value, while \(\zeta\) is a simplex, which means that it satisfies \(\zeta_i \in [0,1]\) and \(\sum_{i = 1}^D \zeta_i = 1\) with \(D\) being the number of elements of \(\zeta\). Equivalently, \(D\) is the number of categories (or highest integer in the data) minus 1, since we start counting categories from zero to simplify the notation.

A Simple Monotonic Model

A main application of monotonic effects are ordinal predictors that can be modeled this way without falsely treating them either as continuous or as unordered categorical predictors. In Psychology, for instance, this kind of data is omnipresent in the form of Likert scale items, which are often treated as being continuous for convenience without ever testing this assumption. As an example, suppose we are interested in the relationship of yearly income (in $) and life satisfaction measured on an arbitrary scale from 0 to 100. Usually, people are not asked for the exact income. Instead, they are asked to rank themselves in one of certain classes, say: ‘below 20k’, ‘between 20k and 40k’, ‘between 40k and 100k’ and ‘above 100k’. We use some simulated data for illustration purposes.

income_options <- c("below_20", "20_to_40", "40_to_100", "greater_100")
income <- factor(sample(income_options, 100, TRUE),
                 levels = income_options, ordered = TRUE)
mean_ls <- c(30, 60, 70, 75)
ls <- mean_ls[income] + rnorm(100, sd = 7)
dat <- data.frame(income, ls)

We now proceed with analyzing the data modeling income as a monotonic effect.

fit1 <- brm(ls ~ mo(income), data = dat)

The summary methods yield

summary(fit1)
 Family: gaussian 
  Links: mu = identity 
Formula: ls ~ mo(income) 
   Data: dat (Number of observations: 100) 
  Draws: 4 chains, each with iter = 2000; warmup = 1000; thin = 1;
         total post-warmup draws = 4000

Regression Coefficients:
          Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
Intercept    30.01      1.35    27.35    32.65 1.00     2541     2370
moincome     15.73      0.62    14.51    16.96 1.00     2355     2370

Monotonic Simplex Parameters:
             Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
moincome1[1]     0.65      0.03     0.59     0.71 1.00     2937     2336
moincome1[2]     0.26      0.04     0.19     0.33 1.00     3204     2810
moincome1[3]     0.09      0.04     0.02     0.17 1.00     2516     1670

Further Distributional Parameters:
      Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
sigma     6.37      0.47     5.51     7.39 1.00     2753     2597

Draws were sampled using sampling(NUTS). For each parameter, Bulk_ESS
and Tail_ESS are effective sample size measures, and Rhat is the potential
scale reduction factor on split chains (at convergence, Rhat = 1).
plot(fit1, variable = "simo", regex = TRUE)

plot(conditional_effects(fit1))

The distributions of the simplex parameter of income, as shown in the plot method, demonstrate that the largest difference (about 70% of the difference between minimum and maximum category) is between the first two categories.

Now, let’s compare of monotonic model with two common alternative models. (a) Assume income to be continuous:

dat$income_num <- as.numeric(dat$income)
fit2 <- brm(ls ~ income_num, data = dat)
summary(fit2)
 Family: gaussian 
  Links: mu = identity 
Formula: ls ~ income_num 
   Data: dat (Number of observations: 100) 
  Draws: 4 chains, each with iter = 2000; warmup = 1000; thin = 1;
         total post-warmup draws = 4000

Regression Coefficients:
           Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
Intercept     23.31      2.33    18.72    27.78 1.00     4674     3299
income_num    14.96      0.85    13.26    16.62 1.00     4684     2988

Further Distributional Parameters:
      Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
sigma     9.39      0.68     8.17    10.80 1.00     3867     2855

Draws were sampled using sampling(NUTS). For each parameter, Bulk_ESS
and Tail_ESS are effective sample size measures, and Rhat is the potential
scale reduction factor on split chains (at convergence, Rhat = 1).

or (b) Assume income to be an unordered factor:

contrasts(dat$income) <- contr.treatment(4)
fit3 <- brm(ls ~ income, data = dat)
summary(fit3)
 Family: gaussian 
  Links: mu = identity 
Formula: ls ~ income 
   Data: dat (Number of observations: 100) 
  Draws: 4 chains, each with iter = 2000; warmup = 1000; thin = 1;
         total post-warmup draws = 4000

Regression Coefficients:
          Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
Intercept    29.81      1.34    27.19    32.41 1.00     2967     2441
income2      30.93      1.75    27.52    34.42 1.00     3066     2764
income3      43.11      1.89    39.40    46.81 1.00     3368     3194
income4      47.43      1.84    43.87    51.00 1.00     3334     3081

Further Distributional Parameters:
      Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
sigma     6.36      0.46     5.54     7.33 1.00     3929     3018

Draws were sampled using sampling(NUTS). For each parameter, Bulk_ESS
and Tail_ESS are effective sample size measures, and Rhat is the potential
scale reduction factor on split chains (at convergence, Rhat = 1).

We can easily compare the fit of the three models using leave-one-out cross-validation.

loo(fit1, fit2, fit3)
Output of model 'fit1':

Computed from 4000 by 100 log-likelihood matrix.

         Estimate   SE
elpd_loo   -328.9  6.5
p_loo         4.7  0.6
looic       657.7 13.1
------
MCSE of elpd_loo is 0.0.
MCSE and ESS estimates assume MCMC draws (r_eff in [0.6, 1.0]).

All Pareto k estimates are good (k < 0.7).
See help('pareto-k-diagnostic') for details.

Output of model 'fit2':

Computed from 4000 by 100 log-likelihood matrix.

         Estimate   SE
elpd_loo   -366.6  5.5
p_loo         2.5  0.3
looic       733.1 11.1
------
MCSE of elpd_loo is 0.0.
MCSE and ESS estimates assume MCMC draws (r_eff in [0.8, 1.2]).

All Pareto k estimates are good (k < 0.7).
See help('pareto-k-diagnostic') for details.

Output of model 'fit3':

Computed from 4000 by 100 log-likelihood matrix.

         Estimate   SE
elpd_loo   -328.8  6.6
p_loo         4.7  0.6
looic       657.7 13.2
------
MCSE of elpd_loo is 0.0.
MCSE and ESS estimates assume MCMC draws (r_eff in [0.7, 1.3]).

All Pareto k estimates are good (k < 0.7).
See help('pareto-k-diagnostic') for details.

Model comparisons:
     elpd_diff se_diff
fit3   0.0       0.0  
fit1   0.0       0.1  
fit2 -37.7       6.2

The monotonic model fits better than the continuous model, which is not surprising given that the relationship between income and ls is non-linear. The monotonic and the unordered factor model have almost identical fit in this example, but this may not be the case for other data sets.

Setting Prior Distributions

In the previous monotonic model, we have implicitly assumed that all differences between adjacent categories were a-priori the same, or formulated correctly, had the same prior distribution. In the following, we want to show how to change this assumption. The canonical prior distribution of a simplex parameter is the Dirichlet distribution, a multivariate generalization of the beta distribution. It is non-zero for all valid simplexes (i.e., \(\zeta_i \in [0,1]\) and \(\sum_{i = 1}^D \zeta_i = 1\)) and zero otherwise. The Dirichlet prior has a single parameter \(\alpha\) of the same length as \(\zeta\). The higher \(\alpha_i\) the higher the a-priori probability of higher values of \(\zeta_i\). Suppose that, before looking at the data, we expected that the same amount of additional money matters more for people who generally have less money. This translates into a higher a-priori values of \(\zeta_1\) (difference between ‘below_20’ and ‘20_to_40’) and hence into higher values of \(\alpha_1\). We choose \(\alpha_1 = 2\) and \(\alpha_2 = \alpha_3 = 1\), the latter being the default value of \(\alpha\). To fit the model we write:

prior4 <- prior(dirichlet(c(2, 1, 1)), class = "simo", coef = "moincome1")
fit4 <- brm(ls ~ mo(income), data = dat,
            prior = prior4, sample_prior = TRUE)

The 1 at the end of "moincome1" may appear strange when first working with monotonic effects. However, it is necessary as one monotonic term may be associated with multiple simplex parameters, if interactions of multiple monotonic variables are included in the model.

summary(fit4)
 Family: gaussian 
  Links: mu = identity 
Formula: ls ~ mo(income) 
   Data: dat (Number of observations: 100) 
  Draws: 4 chains, each with iter = 2000; warmup = 1000; thin = 1;
         total post-warmup draws = 4000

Regression Coefficients:
          Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
Intercept    30.01      1.40    27.25    32.74 1.00     2385     2054
moincome     15.72      0.63    14.47    16.94 1.00     2073     1925

Monotonic Simplex Parameters:
             Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
moincome1[1]     0.65      0.03     0.59     0.71 1.00     2573     2446
moincome1[2]     0.26      0.04     0.18     0.33 1.00     3616     2583
moincome1[3]     0.09      0.04     0.02     0.16 1.00     2620     1386

Further Distributional Parameters:
      Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
sigma     6.38      0.48     5.56     7.40 1.00     2731     2276

Draws were sampled using sampling(NUTS). For each parameter, Bulk_ESS
and Tail_ESS are effective sample size measures, and Rhat is the potential
scale reduction factor on split chains (at convergence, Rhat = 1).

We have used sample_prior = TRUE to also obtain draws from the prior distribution of simo_moincome1 so that we can visualized it.

plot(fit4, variable = "prior_simo", regex = TRUE, N = 3)

As is visible in the plots, simo_moincome1[1] was a-priori on average twice as high as simo_moincome1[2] and simo_moincome1[3] as a result of setting \(\alpha_1\) to 2.

Modeling interactions of monotonic variables

Suppose, we have additionally asked participants for their age.

dat$age <- rnorm(100, mean = 40, sd = 10)

We are not only interested in the main effect of age but also in the interaction of income and age. Interactions with monotonic variables can be specified in the usual way using the * operator:

fit5 <- brm(ls ~ mo(income)*age, data = dat)
summary(fit5)
 Family: gaussian 
  Links: mu = identity 
Formula: ls ~ mo(income) * age 
   Data: dat (Number of observations: 100) 
  Draws: 4 chains, each with iter = 2000; warmup = 1000; thin = 1;
         total post-warmup draws = 4000

Regression Coefficients:
             Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
Intercept       26.27      5.71    16.06    38.52 1.01      849     1233
age              0.10      0.15    -0.23     0.35 1.01      808     1017
moincome        16.98      2.66    11.42    22.00 1.01      704     1087
moincome:age    -0.03      0.07    -0.16     0.11 1.01      683     1067

Monotonic Simplex Parameters:
                 Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
moincome1[1]         0.62      0.06     0.49     0.74 1.00     1169     1471
moincome1[2]         0.26      0.05     0.17     0.37 1.00     2478     2075
moincome1[3]         0.12      0.06     0.02     0.25 1.00     1284     1427
moincome:age1[1]     0.32      0.24     0.01     0.86 1.00     1457     1820
moincome:age1[2]     0.32      0.23     0.01     0.82 1.00     2537     2500
moincome:age1[3]     0.36      0.25     0.01     0.87 1.00     1817     2428

Further Distributional Parameters:
      Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
sigma     6.40      0.47     5.55     7.39 1.00     2828     2151

Draws were sampled using sampling(NUTS). For each parameter, Bulk_ESS
and Tail_ESS are effective sample size measures, and Rhat is the potential
scale reduction factor on split chains (at convergence, Rhat = 1).
conditional_effects(fit5, "income:age")

Modelling Monotonic Group-Level Effects

Suppose that the 100 people in our sample data were drawn from 10 different cities; 10 people per city. Thus, we add an identifier for city to the data and add some city-related variation to ls.

dat$city <- rep(1:10, each = 10)
var_city <- rnorm(10, sd = 10)
dat$ls <- dat$ls + var_city[dat$city]

With the following code, we fit a multilevel model assuming the intercept and the effect of income to vary by city:

fit6 <- brm(ls ~ mo(income)*age + (mo(income) | city), data = dat)
summary(fit6)
 Family: gaussian 
  Links: mu = identity 
Formula: ls ~ mo(income) * age + (mo(income) | city) 
   Data: dat (Number of observations: 100) 
  Draws: 4 chains, each with iter = 2000; warmup = 1000; thin = 1;
         total post-warmup draws = 4000

Multilevel Hyperparameters:
~city (Number of levels: 10) 
                        Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
sd(Intercept)               8.19      2.66     4.16    14.46 1.00     1505     2276
sd(moincome)                0.91      0.75     0.04     2.83 1.00     1400     1695
cor(Intercept,moincome)    -0.03      0.54    -0.92     0.93 1.00     3727     2121

Regression Coefficients:
             Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
Intercept       19.84      6.58     7.82    33.92 1.00      982      963
age              0.08      0.15    -0.28     0.36 1.00      960      902
moincome        17.24      2.94    11.07    22.65 1.00      880     1014
moincome:age    -0.04      0.07    -0.17     0.12 1.00      853      864

Monotonic Simplex Parameters:
                 Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
moincome1[1]         0.61      0.06     0.48     0.74 1.00     1485     1678
moincome1[2]         0.25      0.05     0.15     0.36 1.00     3505     2694
moincome1[3]         0.14      0.06     0.03     0.27 1.00     1640     1381
moincome:age1[1]     0.32      0.24     0.01     0.86 1.00     1733     1390
moincome:age1[2]     0.33      0.23     0.01     0.82 1.00     3460     2759
moincome:age1[3]     0.35      0.23     0.01     0.84 1.00     2391     2829

Further Distributional Parameters:
      Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
sigma     6.49      0.52     5.56     7.57 1.00     3861     2787

Draws were sampled using sampling(NUTS). For each parameter, Bulk_ESS
and Tail_ESS are effective sample size measures, and Rhat is the potential
scale reduction factor on split chains (at convergence, Rhat = 1).

reveals that the effect of income varies only little across cities. For the present data, this is not overly surprising given that, in the data simulations, we assumed income to have the same effect across cities.

References

Bürkner P. C. & Charpentier, E. (in review). Monotonic Effects: A Principled Approach for Including Ordinal Predictors in Regression Models. PsyArXiv preprint.

brms/inst/doc/brms_customfamilies.R0000644000176200001440000000670515057751077017157 0ustar liggesusersparams <- list(EVAL = TRUE) ## ----SETTINGS-knitr, include=FALSE------------------------------------------------------ stopifnot(require(knitr)) options(width = 90) knit_hooks$set(pngquant = knitr::hook_pngquant) opts_chunk$set( comment = NA, message = FALSE, warning = FALSE, eval = if (isTRUE(exists("params"))) params$EVAL else FALSE, dev = "ragg_png", dpi = 72, fig.retina = 1.5, fig.asp = 0.8, fig.width = 5, out.width = "60%", fig.align = "center", pngquant = "--speed=1 --quality=50" ) library(brms) ggplot2::theme_set(theme_default()) ## ----cbpp------------------------------------------------------------------------------- data("cbpp", package = "lme4") head(cbpp) ## ----fit1, results='hide'--------------------------------------------------------------- fit1 <- brm(incidence | trials(size) ~ period + (1|herd), data = cbpp, family = binomial()) ## ----fit1_summary----------------------------------------------------------------------- summary(fit1) ## ----beta_binomial2--------------------------------------------------------------------- beta_binomial2 <- custom_family( "beta_binomial2", dpars = c("mu", "phi"), links = c("logit", "log"), lb = c(0, 0), ub = c(1, NA), type = "int", vars = "vint1[n]" ) ## ----stan_funs-------------------------------------------------------------------------- stan_funs <- " real beta_binomial2_lpmf(int y, real mu, real phi, int T) { return beta_binomial_lpmf(y | T, mu * phi, (1 - mu) * phi); } int beta_binomial2_rng(real mu, real phi, int T) { return beta_binomial_rng(T, mu * phi, (1 - mu) * phi); } " ## ----stanvars--------------------------------------------------------------------------- stanvars <- stanvar(scode = stan_funs, block = "functions") ## ----fit2, results='hide'--------------------------------------------------------------- fit2 <- brm( incidence | vint(size) ~ period + (1|herd), data = cbpp, family = beta_binomial2, stanvars = stanvars ) ## ----summary_fit2----------------------------------------------------------------------- summary(fit2) ## --------------------------------------------------------------------------------------- expose_functions(fit2, vectorize = TRUE) ## ----log_lik---------------------------------------------------------------------------- log_lik_beta_binomial2 <- function(i, prep) { mu <- brms::get_dpar(prep, "mu", i = i) phi <- brms::get_dpar(prep, "phi", i = i) trials <- prep$data$vint1[i] y <- prep$data$Y[i] beta_binomial2_lpmf(y, mu, phi, trials) } ## ----loo-------------------------------------------------------------------------------- loo(fit1, fit2) ## ----posterior_predict------------------------------------------------------------------ posterior_predict_beta_binomial2 <- function(i, prep, ...) { mu <- brms::get_dpar(prep, "mu", i = i) phi <- brms::get_dpar(prep, "phi", i = i) trials <- prep$data$vint1[i] beta_binomial2_rng(mu, phi, trials) } ## ----pp_check--------------------------------------------------------------------------- pp_check(fit2) ## ----posterior_epred-------------------------------------------------------------------- posterior_epred_beta_binomial2 <- function(prep) { mu <- brms::get_dpar(prep, "mu") trials <- prep$data$vint1 trials <- matrix(trials, nrow = nrow(mu), ncol = ncol(mu), byrow = TRUE) mu * trials } ## ----conditional_effects---------------------------------------------------------------- conditional_effects(fit2, conditions = data.frame(size = 1)) brms/inst/doc/brms_multivariate.R0000644000176200001440000000511515057752157016633 0ustar liggesusersparams <- list(EVAL = TRUE) ## ----SETTINGS-knitr, include=FALSE------------------------------------------------------ stopifnot(require(knitr)) options(width = 90) knit_hooks$set(pngquant = knitr::hook_pngquant) opts_chunk$set( comment = NA, message = FALSE, warning = FALSE, eval = if (isTRUE(exists("params"))) params$EVAL else FALSE, dev = "ragg_png", dpi = 72, fig.retina = 1.5, fig.asp = 0.8, fig.width = 5, out.width = "60%", fig.align = "center", pngquant = "--speed=1 --quality=50" ) library(brms) ggplot2::theme_set(theme_default()) ## ----data------------------------------------------------------------------------------- data("BTdata", package = "MCMCglmm") head(BTdata) ## ----fit1, message=FALSE, warning=FALSE, results='hide'--------------------------------- bform1 <- bf(mvbind(tarsus, back) ~ sex + hatchdate + (1|p|fosternest) + (1|q|dam)) + set_rescor(TRUE) fit1 <- brm(bform1, data = BTdata, chains = 2, cores = 2) ## ----summary1, warning=FALSE------------------------------------------------------------ fit1 <- add_criterion(fit1, "loo") summary(fit1) ## ----pp_check1, message=FALSE----------------------------------------------------------- pp_check(fit1, resp = "tarsus") pp_check(fit1, resp = "back") ## ----R2_1------------------------------------------------------------------------------- bayes_R2(fit1) ## ----fit2, message=FALSE, warning=FALSE, results='hide'--------------------------------- bf_tarsus <- bf(tarsus ~ sex + (1|p|fosternest) + (1|q|dam)) bf_back <- bf(back ~ hatchdate + (1|p|fosternest) + (1|q|dam)) fit2 <- brm(bf_tarsus + bf_back + set_rescor(TRUE), data = BTdata, chains = 2, cores = 2) ## ----summary2, warning=FALSE------------------------------------------------------------ fit2 <- add_criterion(fit2, "loo") summary(fit2) ## ----loo12------------------------------------------------------------------------------ loo(fit1, fit2) ## ----fit3, message=FALSE, warning=FALSE, results='hide'--------------------------------- bf_tarsus <- bf(tarsus ~ sex + (1|p|fosternest) + (1|q|dam)) + lf(sigma ~ 0 + sex) + skew_normal() bf_back <- bf(back ~ s(hatchdate) + (1|p|fosternest) + (1|q|dam)) + gaussian() fit3 <- brm( bf_tarsus + bf_back + set_rescor(FALSE), data = BTdata, chains = 2, cores = 2, control = list(adapt_delta = 0.95) ) ## ----summary3, warning=FALSE------------------------------------------------------------ fit3 <- add_criterion(fit3, "loo") summary(fit3) ## ----me3-------------------------------------------------------------------------------- conditional_effects(fit3, "hatchdate", resp = "back") brms/inst/doc/brms_multilevel.pdf0000644000176200001440000110206515057753141016654 0ustar liggesusers%PDF-1.5 % 1 0 obj << /Type /ObjStm /Length 4381 /Filter /FlateDecode /N 78 /First 659 >> stream x\rG}VG+Q$Jlm&%Yv@H _?ff J %ny,x !|dapta a,\!r/֢t!OPڣ,TBK\-,8 e@^]7pFB *cPHSL!mSA[E 8f<@!(S(@<%&ʥX4a:;](4f APZ`Р,h*:sG+g tei MA(+ 6bS0=se1Z9 Zem* (khܷlzbc7?^ܧ2YƘ?XĂ[G:jf,ש96MVb5\'ެ[a=~^<Oiwҿa1JnJ>Uݺ7zPG$&DƉeFh[@}Ee..3I|!2(BDg-ŔYpFg8imW&&/uVsxtB~'kDlr>&r!7u~&'oF2$5J$!uk1pRQ<4w晞D'2= ۀ~4Unu;ǟ`JkQ@OL@c*Ox6b4ǟꧧ53fO0@ !U Df6ָ-4i%¤4aЙ4%fk܆IϟtvU|ë'?3x?Gq? dZ?L(#Wd;M0N㷣~j(K@~K⹕4d OR!h=Zzc`F}p:A]z(/q aEPmT$5M-A-2+­kլW??8~3ղr,OSǒ#tlSRfbg|ƺؗbh(+j/k 1յ8|ѕ$(/fZ63tĩm / o6=_#(BWu7jlQONǗKԓ6gs.t~kS˹~'jaޣx! W7B餣B)`@}HuƕA딥=]:CaBgGȱV42X)췹V\^\욟ȅ[V5m2Atm*xj\KSsijNm?М)e83:cM=ҔTç)4JTTK y? uݙ"RdfM)2?EȵVSr=G";$wo2 |3== 5^_*wFqͻQ/~AgT$W,AOd5䢭RJ!s;[JO|d0`Kєocjcݡՙ;tPnaJn)/{lZٻhoa}J٠ǬSkz-WR\Zx=%۹\_]ٗ0&&$XΗ_(A;+* uw[ok\fU+WwW~.ȒҲ/P*26VvTAeHky)y!Va16EFU!j) spRRa\ Q!4zUx|]pR2ti݀۰8ҾmH\I"'lΌ~mASܗAȗ'I ]JMN:-PX-{wMz0̱m<|lR9v 6%Tsp-NSu:6Ӑs uUo[":$0ǎP M /7؜(`!jbi+ЀYTKpYZNX)*w'6$)haXd#nmJޟ#ky17os7xEײ3w'K/$F.^Cxֺ1_Y7"n"r1%<;21Ҿ씶HXFB}֙lߓc>ME 5-6vZGPiwΆB#2F,X*:l2{clJ" vjHdwn.6p N5Mk.K U2L(@@>fҐڦHJ"zk YY3R~4ʾhJ@k- 2Qh} CkV#(>CF}ӂ=y6O];.쬄W fl22Y5{ܘ>]>$Eh`T k"Fg8:OxrzL8.J.)m#o/;^̄4]r^k{a?t'5׿)}ۜ")P4_B1ߔ)q?DQhv#ꏸp7g <2!3/l+ݰ7G'^'GW1}Vйl]TjQ֔L%r 留4`X=%VJKK=;jLdح0_IU_ yz[\b4خ)m:ݫ0 [ <2o8`V]ϒ#D(9Mb2<$/ȝm$'Y[9”nd?M(D BJo}-$X-!PV- a FU xyYqXr ,ZS[j.%ɒv꿘_t鴤 DLȭRӫʖ. 9Qak!KzL#DrV> wn&@ lnf]zwLM0?tfp 1AsbJ"`̜߂ׂP1lӿCF3C\jwvt??&Ո^gg Oo=a !y "J/?*)*!o\qB|t'@T 8 J{endstream endobj 80 0 obj << /Subtype /XML /Type /Metadata /Length 1821 >> stream GPL Ghostscript 10.05.1 Bayesian inference, multilevel models, distributional regression, MCMC, Stan, R 2025-09-09T09:25:20+02:00 2025-09-09T09:25:20+02:00 2025-09-09T09:25:20+02:00 LaTeX with hyperref Advanced Bayesian Multilevel Modeling with the R Package brmsPaul-Christian Bürkner endstream endobj 81 0 obj << /Type /ObjStm /Length 2647 /Filter /FlateDecode /N 75 /First 657 >> stream xZrF}߯Ǥ8%r/wmǑrۤ@U$8H%K% 3tt0(&X Q`vlDgXx&(%(Ϥφ)aJGsLYoXLy 0ȴ³ic@H-PL{q"0#(1ÍgjA?Ҁ`DPJfEg+m\Ye#IzqgNx20GcHqCF2g1T 749&PeK1 T9jȥH-pKujQ[AZ&Ն)Xڱ@$pJjҀd{ЀH{S̈́ ZKA/ !BTҰi)%*\6E\:i"*$EHOncūjl<;`ś1`Z᧿/JVp̪\Oӗ/Ktٶo*9{L+ޕ2xQbU3+ٓDmm|BBC.Hax(?82DuZp0>p&Pw P ( yrjm2idrqV$;'$0F>¶V52 Ώ;lFF#$H7iħ㈞u47:kδfBf&b6p9)xDno#t!@2!;p-ʏkB/xBtUp!@ΖuDL&},,v¾ /rZ?A6Zhf?(Fק߇͸)—:izOKRo+tx0]<?>-7b  6mU}JVdTWV N~]$BС&y1mY]A) I(h*_u|kV#<MX+ W¨޷~G|;rBpx1NϺGLDvMqmRl)0l|Lxh[L>j߼f%J.SӻyK?Ps(V!l#V9ֲlѓ8(ɝ&P w*LFYwaQg;lJD`SR v |}%l was:lZ9= lZE8coo_ɯ 7f#uЌE("[P\[3k4ɤ_0 b# N9\>m!UpH: ҮM`",)jੴvY}ض\ "&"j{ ba7y 9T]QD)tel88ikg=> ܜ(AG=!^+[V6# 3N{+p 3i⭤n_jbWD:fb9^{x=6:o7%l ;@)Rgt$Щ7(ﻮ 4y-CC^⢺hT l9uIX%ņ"vN(S4#C.]a0>'fR%˪L4ܻ49hKh8L>(=l-NZv:kos:,yȊ^ 4ռn9kwE1Yk],B|8-*[e3NjcuZM?Ys>6MlډGHaA(jڡ {ߝ`:uJTuϧlqf/诪9/ΗU%R;8UiZkN(|XW~4D)\'QF2(5u{[)h> stream x[rF}Ǥ:J%v-2J$)R9pA$˦!^}oC$S.1c-S^2Ίq,93.P$V23m# LǤqњzA&E@ΠrPxj4Ó ìt2qE<MYOlT91,EɜL=*4A9KP9T@ʎg^@ybdXjwąE?I1,(Vx`i6eɱ 7y`jYPSb 3Ŵ,YL`Ӝ4=,VWiBZ ;05Z2BO1c(+`U aj0TC9c蠨cH4Xka in\hwha"jX^Y dK,ư61=5zBe04CD5K< pޜ(隆N_?`0tIv':Yg]M}g_TݟuO?]tݟU2x87#^geoC8G8X-FhA1NGŘL<ד(keD|$')ǃjnk5lrIXC~KXޟDOzF<]?/ʋ˦w' O8ť 1Q>'ų~bLr R~QA8?g~a0q1{W_xU im9Wiɱ@9|_]iTFICq,/;Ip,v~dnkgћORH}Wf\%kK;^NmlSduOI hS3!^YW?}ttX k0c㩅UnΦCBHbg[Iܣ1]}PB}?Hт26s\Pc'TzL@9/./\_Q/@ _k|R]h4q]KXOh9! bzVb\',?hYqdWig"HRϲ6 jC]=(q_ .QeRsFeRn^˞\f4b|-viO=- Io?d-b<`dƗYvi)Nm._m29Yaծ|ǹZ/^//Ļi R;T9 J-D#Bk&Qd:a/r^*78`;bF KV~*2T9֎kACqZϠ%fja)#A4oj 4v1X}Ђ{Z <)$6c1،Kbq3lQCB}`#&K\Rʸ[)pg"yj3Wר6>U FX ƒbS!qO(u:lO:qP8ǖ,w4q;c#&΀$.hǓkih:OJk`"TvfhlCF4t넁EJvTP%bJ!: EkjoM5Z`\9}4T*N6/1_YPpB}fvK \ƜqJslG]!/fN'pPr2Grr9=+G'bqUjcOա-4䔙(PWY-jv@\bu 簚kb: &'˩ɺrVraЅ~U^orY- O6aYDt[(BDdDIT4'MҥY~:|PtI\].]PZCx ug^z)#Q\/gsd_BrP[Q(&H)QT eIAPZMŧ*¶x Uw1ZDYr!0<>~4zWr-y0dk2߉k, Y&ԾEtLms[9:|6IO?O LPh6_u.GwSd`]R3}R^\,\OMR_{_\NQFk1Nh3ܒNˣ{aL)Im1$q.Ĵjv)>^$*XTEԦڒ>a/\u ۸.r <é*r/kR 5ŵ2Vu_,N 8k$;o\Gnwǜ-AZN $)>,6wXA9E;֎+n״`]dF#mFa.}^1M&}ҷ `_Rn(n0!&v.e 0TN[Z<t(4VȈB1b)Ivj!-9}̷&/cs/o% ǦR/s:C9tԛ2VgQޏ̀IU %fH{sNMhg>w1f2'p+ԞEX;sl]DU Zkj[OAZE{ngh8NͰ<\wn紼Muz|U޷u1'AYKP0I 542A!'"뼶Hڲ%NmÐkg  ZWʝd}~̬ǢI뼤wMoXR$Rj]2Z0ZŎ a K'y1*AdVPA֊`Q;RB_M߯\fp))ͪ,3WTNBe ȪVV*+9Y}Ghs%u"yYydK+endstream endobj 236 0 obj << /Type /ObjStm /Length 2851 /Filter /FlateDecode /N 78 /First 707 >> stream xZrF}߯Ǥ4k**ŶYlo"! ePЗ|e )q 093}&6pMDϴ̅b!Y\5SFi JMM*P1u܍ ; *)(>a yj }8Tfe~=2KCHfmBi=z^3yÜLT̩ sFb,Q ,>04݉(XXA@=\D00/ix+<&7cx"ӣ|x%)aA<- F˂ˏ >?,DZ 5ENb1/,Zz3#A/IS,ieH2( L%Ē̍,, tof)A/nHd* OI멙G+zP :A2ĔQ%R@Qh*A1=h c?n7+dYW_uēi}xU#ާ;.9F8o.fxEӲmQ2e^ϚY١# oʏz;?]eg5$fq 5~RTT+&55ԃNiHx>vϺ+27iJ/dkv!Kpk/ ±q>Gvv~do(rCo5X?tۍv#7/?ڠ 6}%T<'x!^ſkq*Y* QU|(wd\ؕ}'y1b&E7g4Q3ijOq3Rd@}^Ląޗ{B\Y0WUYJ1)VLE-.E#_kWy\Z z]ht[}t|"fm9=hDw5+K}h\q9kGͬQ|?Y5WX#zR\ 0k [pI5)z7oXL?۳/bRIɎ7ūmenBu?nqy-m_K x0 M.WԢ6[p('s|2?$ٷQ~#xG뚉IfO2#3 U> 5=6*Yb(g ΘMQW5WW]w~#D xVhRr<efGU}1At2>n`КhV"^ik꯳_Y"fLilS{rQrIiA= ZPI Noݰö{f-/xlӦ_Hg=3OC.k1!k[R(&-n?9fjhr;LrP_TӲ=caIq[B -/bsl;#mG2@K~PKX OqF\IYE1.0vͧ$3oj>** D;frq3B>yd hEDAE+dgE*Cځng$-\pF> u) ؜<­ kCu%RѠ:rS~ [pDpVIkY88:b8ݎ{=o_!'n% Mɖ]8=\It+\#]WJ2܂/a*0[ <߈қji7p[jI+ոt5tUz(![rn(5Ayd!Q5S"bsj!3'r⊲ܖ6IڒG+Thk)BD:!=yNjouX޺aȖY *\@s108>Z(=$DqϚ}NsxX=JD:^ &C%~[Yeɬ|#ć8m|\Q3Z*'mr\OiY:g_u IS*wnGVGİdE.9omWOE< J "[\]5_W'Hꋨu6 @NS&rTC$ ZXQUg=8 #<)Vf2`łڃmF d-6!|]o4 h]X=ˆ*Ęx0nOS HDe=^J ob:"OD)1t07|񴺸(,bbZ3CӇDm.endstream endobj 315 0 obj << /Filter /FlateDecode /Length 5331 >> stream x[Ir'D:DO3cxGo1tX$&sHA@ܿ,cbY]B_ˋ}#BZ ZJ-ںpDkklYW>I}YkS{ R%^ONkk. iۑ^({J8݃o?pWnң8L>XDw1lfUS[8V853&9^եS't}Im޴`(_'d.rg 9R:j[yrBl۳'CdV5[PRѕM @&!XFnajK x`7t^rm- tYA`X SHeU[JTSuMxѢp[֛hj?WU鳭ݴ0 s y=0: 'GKF\~iо-Ȗ e`qB_Usw5jKh:sNHw "r39|ɠ VEw 5x``8 LIN# I`/a8-HKQ2'xN3,LZFe @] W=nINws0XWp 4_j(Mf< #V邅lea~Edߚ3L4e~.}eVo27VLh aAS:)V]b P:5"QBiJs׶'ǨT.='zxZZCؓбҿyLᨏ ((~F.P imt0ƙ KJ䆈2eWT)Z:M`3N47|y 0+7 ~u2þ(-bhEvTcҝ,owl0O p2O=TFi˥Wh傲[Mbb> GIEBJ58~A@z_hU$r3V8cLRc|3 DoK83!xР3梋".RUK6A gE\r8zH탞 6`ƹ2Ѧ {NEyM<;t$tvu<"~Mt[9i≝+y|+c>aY@-?dKs463i'Hh쭥l g~ L΍6=ɦv.KXO!Ljf F0w)p [oC"S8Ku`a)8Y=-o)NE_+u㼠!B542T!`I󩠂ϾE8iD5/UoΠN N齣4v8H>u|2 Å aP&t!7VTa)ĶILQ c(ljNv ^28s1:8\oj)"EЙB]itԒC!~1,đ*JU,#М~<"E()? ̩KHE b0E3=(,:Səf1>ߦȸkx m-}] ,n2ǖJjj_~Y3׭š׾Q!yDdY8'UJҦVK"jB%aQ.)`9+Pm {u}z 60mhX@pg.0v=\Q QZl II\mUR 4YP&z0yN]LDZ+O~p5Uz.]*/et학+&;xӫ0$[BUh* !M$ƎM +ĎM|}c&]+meղ ,3ITBK3PF5IaNWZZt%um u>A}˵t ve1ڰ̪&Ru&\+*DiH^ AUg3>W"S82gӿ9s r@ex(֦=My630<)<фe0ʼnl9$ DiwտgJ)hx\.;k'?B+e5RbNybtӆ| eؓ٭g9$jjpoLM-\Nq4 60u~<.0@tE-[ K2?7l5 dž-  V^_cP860฽kRu<&]RCJǘaZO~)Mo3TzU{WjuQ_Όj`|8?D乻?QA׈ȫA&ބ8 4 er*_aHʤ/v& Ri ^hP7A Eh0*wHC"0lra2>*1Ac*k8C<&}r\{>ۤ8Bb}V9R@/Oqcث3C_B^Tf Ee8BM\\c6\Ţg+rh9CQ>{s߅}{ AK- ³C2a1 ٳi2-t}-B}nwsԔU)W> K jS~YJXUN/u= rXm ϒ]f֡J"\fqA./wEDm d6q`H|{uTgƎkߖC@#X#Łaư 8gT} ymBtDM9".xr$>s2Či/1#Ô2fjQʘ_X\k$xen<]c-úٗtNtϓ̲9Xl1`,vTZ977 ןY;" ++tĴ/ _',>my~C nhyPۤU(tȞKh 4i (ވc-eə-iTgi-h;<gJXk/WXph ;HoG$YU|mERW`TO_ECx(aӅaƂ[! qbcCvo,v|MN4Ԋa,[&Ljor$E&@|0I 9`"gVL}5R25$A)d,򕶖o|[';qUU;dC)p|IBbk>Q]~9s&ýCRb!g=B+)!6]!CAy=pWpgyA@IE@j &ȀQC=!7kj Eͽ+y.<݅浧Oϫm5/w EK0]M=|`=(nPPЉ HCHxa14k[p/tЕhMk^36BHiG.ޭY7ii)JAxۗ*c2nA-]6o[fȍ9.! P^o3u΁Q6eT0kHL2KȸP1lOUTQ> [pͬ>ftD l AëBM@zÌ!0&^t0cDk^?+BuT۔e̯|F+l$&T)VŎaeNOX>4%]d 1j)L\)ۙNOgɰXwK4%rt0zƑ^mt$ l.̟"MH_U:q Kr*w D. d٠87ŝ7/=d@EmmWyi'[9nt> stream x[sƱwX9MiAO \eǶĊ#1TI9%Xc9g;2A0?{{<9_Nӛ_N8=]N_^1ʼ' ?JgҨBY)i&lRj7˳\˂%kң.}]gs)%5忣:jrk?Š`hE0Vu8a.y2W t.ufOX[*dhlma9N {Mʰj&LVZأ&m#*tFъmC/T"UP6eYfN ?.Y7ȓ<8icdW&EYfr:۰VH\sW0jaYDS(V~(pރu7!#pBM{>}pb(5W=ex㹀*Yι4tw;IBjsBgTJv %H:Y":G+٫l<VOF=Z&A»aשSh5(`0@t8@Σl6 8dHz(M"*QbGfiS P^QoߙK kvY%8> %xCe :JOF?5vW"tN/a dj1a4-ғd)>d;ɻH0( 0"\$>pt$ Ryh.C`\$;~rW 5!DX|U s+FJoRTDHv=qyz(n`G1u3qoȆfdO9a4t=JXX9ڐDsʟ;pp[A8]3CROX$'8VAMa:-G([m3nCRPW]fWlS9&]Hp3۳z-!8JȬ(E8 +(]ƾ֕EmT *3Ptxg͕u5xjXj(,/SMjQK ФT&'{g3Vɓg ce;UB΁Th)481%[=ܺ:J?qRЬhRSJW|X4]R Nz]Ρ 1㊜,jk,աXc>;1X}MRx)wX=Z\]_v0F!%Aa jP;&~rɘ2oa&݈Q2 }..ZR0p]Z@A|J731.Q|bw`$Y.nV5ta}T.nUk .sE}ecw=Uh$MT r_N\ڸ!x7.G8#Coa fD Rw {A܌-zp{J rr}0#+67Ky~>/#R''8 Z~xA'ڤ.&EtL8Kb(H+txE@CLQb$L(У6#ЍTx?6RG+KOwDs@ .@XD4N6% =|6LݓZ.4ߨ;v-#](]'ȋ_wwUe]Ԕ\cRb#fuޝam5c[/cutT\$`GǸ?jb?ԋD)9,hw1|<&7ߎ{N+?H3yAHDW"0irnDSB>5, y ҇%^GWr}U _y,G痣4ƼO{z%XirS2:sm\5Pe `]ƻצ~0l( }OqaDF5:?:sD{"R vjJ$?3 kNG%0ʛٌKwe26TtAv׭)71W?W3@hKuJe6P}v7g/)8x|"LOIQҗT%sqP;{je4E%{,9EpzP0m žO٦}~\].ƹz{Snd 2nk8CME@# *#$<`9 ـkW07ML(%u>#45\DOxjZ~y`1nk<{;)ȖA_$:J4gH&8^ )J޷3b Qy%fϗ0z}Uo~lo~81ԂoS/\Iyc2 ߇w%@+@% YlϾ&3my~~l^,kZ"]@a/`]hSjT+dG%e9Uϓl2Jޛ&*fz; WBP9` z4ieod]Cendstream endobj 317 0 obj << /Filter /FlateDecode /Length 419 >> stream x]R@D|ÌVZdY,!ƃowG=xzY`ewp̗zkӼ[8n>/վ9_~Hk> k{ַԸLW~NeEכy,6,:4M:LS2۲zq4X%)Ii6)%-)@#IDO ЉCR048048048TӓOoI!g4 k Đ^zrTpppv]pu:}\._GRAD_WgggG_Wggg?&x$36.#u^ N! lBFAM(h 6!Q&d4 ؄FQ(`2 M?I+a=uܶ\EKhʻjendstream endobj 318 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 4542 >> stream xX XWYBw F'nc{DqKPӴ"@lO&҈ 4.%&QQLl '!\ef_STս??V0Br`/O^]4VrVH/ZH#@v{Z ֖m/o0z(e ! CwEqy},]˂).}FlwY>eC#!.>A..vlrYx˒{zME=aIC.ܵ8,|ҽ""}tVm6 0(SSl+а(loy3L#1<#͊UJkQva(1@\Sx2h6N0c%@-s{s=!>5d1>+c!l9-:b>8Cd C|'ЍYA+H6qI̡ v]LvmO1\”GsSd6w ױ{[G<NJڞYiV[v.H,~T{a󍫞Q.2-f,4htY-8Etor:LKGܱ\kb $xb!f DõC0N#UۭRCq]/O"<9EzMb5mOx> %R"3I{ts*roi8H8OќδT,Yη3&|GܨQ475p~)XW>wE<8x\fbeJ!\-? $RB }3 &؏D۽IbU)1NǟUwش3TH<H#,#t -լ"GO %V]>,GhaS{]Ԫ]ntRgXLRF>:*ڛ]'f6~t@>!>ܩl)4i] 'g~y6ѴKT]Md&/<7m}}K߰|c}.<0 i6 0Kt3F${3:Ɓ.-{;m0>:C,SkڙiY!} O@3:j٪'A$h^uɬcX nk,.ˉ2&S!ds,cVAF5 &1: oYlđaQuŬ7x9FE\eɈOO X`|zW xC0}U'ˊH(ZuC5Nĵ46A'kKƎ2Bx(] eo-lQIQIᱶ O>1TY4ֆyo %{`'K'/8-~_ $0+Pd!'JyIIILM)y }1ICb"z,d}1&9SxipPxDVw^zL'hFupR84(.A+O!C$!!jR7*𮀓\MCtȺjHT!ULI9aO#6s=XL-%/~pj-rYr˗F2m;E F@c!iPIX}zXWNE{8k-d SW.z&U^V+rC,x&V˛leUAK2r4BF} :]:Wbj7|>b-  eb嫙 Ѧ.T^N/c;Á־$OMIv/_M'ΗE,τʚ{[Ή>-^GbG\~pǗ3OD7tҐx9d s%tfƁpU]SJkZ ckTخ MyTCp .~Dpꢏ5~zA# UٽA 3s2Ko'_I✯>A$`q( f-H|dKqՅ>\<|s"TDhuoTlr&ºWZ}QT徥9[}x=k_W.|bL0x ҴYT } >ǏBbsŠ"cJ 1\ѨǏ dD.tu,K"RS_C~8]n~ DT|Q~>Er2V3r%.L)ŒLЗxzpBW:4EcRbR7"Ba$|x#=.aL`.rG~FV *5?qS8= uekIg)o0I4E.u:#A؀8#}fEm8ڎ,J7^b+UWK!\;!iݡ ܹ]W\gjzE6523zU/Γ>"Av0=9] G>?7/R ƞ_r(91:YNƪ$-˧~ʙ/[)+!ݑuR^I'mpZdKAT&6Qnt,ɿ"mZ*=uM_L;;ϱK ?_R^"bx.\;UwoP#Wh߷J7G*/5K9bٮ<՝|25#,bٻZS Y3Ypo~*m4=7T4uE!sCсS hfd6CZ'%s y%SWڒ gh? Tj[{9E c pO$?kL6~Naɿ_PߕG ~tȷ3 |wFo ,.pJ#Z<E:!RQ yӠĻdp xeP{XtoCJE؎SwTFad\rt)yOӌ9V]N>p8`8YF_w iБTO*=N)j^?`ʘOI ?AOOQ%z΍> stream x]An@ E0!0N$MɢU0Etŷƶ> stream x}VyTSw}1P#,ݩ3SEQDPNMD {ȗdwA0EXr:ֶu==8yq鴵䏼~߽J(QD"q[N9ZL9iuꄬtۓiD0JHQ vg&8rA8sW(DMKOJHTΛ3g2&OGHIRFk>>$ FNNWjա uAw/)gdfGĩRR7{,5T 5ZKQ`*ZJm|eG-VPoSPj@(gJNyPvT$P2$RИ5P&UjSU4Eo/VM(ʟ\6#Ňf{'A_'VAt5*RP+ljoD>{JY,z|sq B 3 ԭwa,ڮmGa5)8딎.8O;{7țKۋ ɫ./^[/|qZ4j LԡzUTsk7!JfWM2p&qp|x%D S\h;38KbM }gr4C}>=C3Wч3,;zя>Ǚ F!6E:aͺvi?uo%qo y 66#u@a`'?#,<:,pK&N%"{D@zO~OoBn&+С>N<߰*bc׃.Ia)BR;5&w'TԨ3qߍ&X`*of?T)| iqd;_Q;?}[v(RzO&0 Wϕ2sɀLйPTm&rWmO{ v9|rA '` A9._L#G7:Ϫ୉.˓ ilZ9@ d}CSrf Sy`&y:BcH4m32*]PdD9^FlH-{*w =C *Wrk NJL*dCsIgTZL.9O{HKήc]MT֘3B@)z\oa-+? 41=8 =:Le8`& uU_'OT`CEb5){c1R'9GՐlL0y>ѕHnMWSE626#Ok5:qWp OW*ZqY}ے.GW$, -^ٲwA>{ 7$`$H0سmEe4/VA2 geCWJ.FG=ñElb6dJf0B+#1Ҙ9rݞ-^Uū*0_xa+bu5X 6>Ug]DX lQL'Xx:z4$Ę3!cIfYy (bhv1۫KȌFxŃ}{\knNPXn\duۻpםAiʅme\ٱ]PY^md[+b GXJy3izECM}J y{ȆYPX|9\<ͱ˗!`#wod<.9tt^@~p,<mWmc^aPƀ7d/Wo*JOk8e'vlr4{,y$e{@k*EmIzleX~MB9Fa0DsqiV'*5=bp No&UJgх+!+KK߻<8.%@/Z|#pgũ!ٔb2x% ^5[۸G~R+GpgCl$!6(/Cam:Oy6Za.j$S1 5,[\=}fbVۂ KM^X'6%Of!c uƼo;zf6o0wm< {~JtI)Bz&BLBҸoSBc4k[}G=eQ?[@0KKIp>iz~>Α )n\>hJL$ X,] vJ>ޠ ڭePPȑ{ɫ*b"N"a;ZhqnzCh4VW7^47USetKQendstream endobj 321 0 obj << /Filter /FlateDecode /Length 330 >> stream x];n0D{B7׻2`l4.I. ST” Enٱ"x2|&8^Ni}gqJm 1?)eUS5\%+x<҇;f8Z狀7ck V1Ʊ5:81@u[jkc` pp_=aW+ ]YY+tw ŝBIqIv:;K01AR~ ABP).TJK*T_\>Im]c8?)ſ[[9^endstream endobj 322 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 3388 >> stream xVyTwPDhٴ \dI@5]QFQ@M#Ȫ" -XE3y<'hF-9jəsU{w',Q2lآ+ⶅNa>]eAH 2]&k <; m) lͦ9qȨd>>ӼLp$acRbb#NZp&ERerj% 9:j.5 Q>3j!FQSBq%Lݑ-5者ŲDn'((Zt!Qh3Uǐ{GI&ͻA^ ^{4‘mpa lzEP#~r}"xrmF{#ҧh=<}Xv_J o1DŽ =/(Z\g3n!EHU~y1O'3y*J%F(^t \xu`W@pdjaXhK c#vI֌Xb;*e+!XLly,W8#%@(V*wU.QU `= `d&|(d1oP@xe(9&)G2oVu2wf(+x~[B;]q@'É{;Upa)T2E4;:Tsbۼ}[[ hmY/qh<ظ&`Ei|Ml`3з%dž7666WupR)msItmow}ȦM ݩQG"c >)\Sjg0TS jt%BZPUmdǍQm{;Mڻ ) }ݻ Lhy" PaX]}ɘsppsNQp>Vy^DϏI[7j8lFvqe`UBDlx&  {A C$XmxEI,ȪF=])IctRђv9MAAluDanи=y}sy'E5ʴ$FŦE W]v1Xx!uTa߆vh7٧b"Z)wn>73KX>-z8:]ϮRݞ1 ScR qq"N"S(rN$A|(أ&s #%:4I${^Sp&uUA^ڬKʅ8Dtfl Ai6H u^QojF 4uE9%a"la`B+%2iM-$b/<](.Ћ@;/fd }M /Qӈ;qz28U[įY?Y UpSpotTǚSSŶ??ObԗCiCm_"f]gyUTCCo~iyҫ;r yi-#K{%-ԤgtQ![_JƬ$ pxs2!#]GL;,bz$%|{ q#+CH Aq ktln+ؒq?z*ĐZXHDX0c/O==p#XGyPedD NםߡAʑbѓf/s+&u%RvGFEFuwvs㉏ȇIַ4{?fJLڔ) Xh2W+'/j{XYåka#ј`:Xy.Dlɘby׿Daw Wﳊw4&1t$f6#xG\DKz5@vaKɌ*%gIvnHXYٗupZ8i!f*anp(,7M.>]1Fb!:8+L9U 8- 9}q|nyoCp$HGkpzcM.C5i YMm=u/5pGNo/Ϸdh-6V.CFP `5G-Euuɰ)ϗc(oQ&k+?@d$xq&ݐ/n^#LN"#*/%^S8ǘ~@TK.q#{J,`%?%^u1*#9%ǤEu%tzثWֆ/L(ʒZ ey ;y f'NZR^65v=&k~ /~@n<Nm})i-1'7!aJt#C9vAĝ0_TTu.={j#s񰍉koovݝ 3g} $ݖn?]x2"O=ķv4Cby*.6]ԃ@{:)I"羝EŌJE 傢?C:%m:eC\x1࠰￸42*nV]iɸ$0Cڝ6v=å8BB;MRg?*nRhZa!2oRra%HJ4 lÔXđ?+%p"}ջ-M7T( \gmb4 ycW~F=Myendstream endobj 323 0 obj << /Filter /FlateDecode /Length 642 >> stream x]=n@{7}? lc7.I.@QKC)A>3#;E!4" ~{n^_]_-tkܺc{=aNtߦfmsmhˣg?/͗S{NsMknzVoG<ʌ0Wԡ*'V jA{\Q*~س;}UPuX#\TbclUAmKUP!y(gWT3XԑTFŪj+,,+,,cPrErEe "B_ i4A! &H#i4 @h4BMFH i4A! &H$bZq)b\a!bXi)ƥ8Zs)Wu:\]N_pu:}._uȹ9S0bBAB#@a1! F! 0{(D BTyhF{p쁑{`䡱yh'F{r הo7M&\SI߄k7pM&})ߤo5M| הo7M6|CZWY_/_^7nmiCr[ Mendstream endobj 324 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 8379 >> stream xyX ;cWƕE,X; b)RA췻^ KH1%b \Kbbΐg4$7}Qf(HdrIpWZ[V1?u<[D 䎿 nԫ>H(G4r@4\RV3}Vϐ1Ly4N/XQWQA%O(BRĎy8o Zh)a̭7YcCևt&0OϐT>s h[I?U (aP8Y}bsN\POA@ЈD(x)A&MnU0cDC tdk4,8YaՁxݩP h u/P q&Evx0y wF5Qm=6ۭ TӦl~!CN.<&s:aȂ}/FuA\ x %|6)pac@H|tZ/KݕW_HPtV`nC4Yw7BWm tȣ$!mh5 vkMp yG*+yL?z_n@E 1dUR  1HPyǥ7 (CTZ^=dJ/v)C݌$3RQ8Ciz9@7}Sb +ݣ/2p$P%cGytpӐ6׶;m4`6[f%FWw72Ev NgbF쮱t&a넢}ȱB-[C.ǂY3Q >{crvpΰ^ [do-&R? 41b9URl\ʭ޳2D^P'y!w wM~=%,}T>x謼k:|0o3̦K|;*_jΌ&)`g쌦݊!\Ʉ|9O7~LP 0P:NU1佛ߴ妖(>!=GV&i[̟tBh۠"c90 ;wJ57&↴Á|+z]ه$) +2C.;dύpkׄIJBX 8ɾ`fl `$Ż8CP2R*4G,RGkM_e7,-J ̔,dn2 hKBY^- d!M;cIzD{;7ٯaJXvĩ~%~rvaΨrlnضx/9Mia ݔWKFno 5֫ JHN3eQMR(*D:\6@ArVt2'=|:NC%9dŔT&VO@* Y_dQx#"ڴԼPGܐ0^kY >D4~7 [Boڤ鵁JŮéJC34z4hTY.)]QUTRXM#;];鍪E>vn 4jˑG9vkJNJY͸;7ԝ8܊f/~$ 4DRdq+Py?ivd!}@ q[),4bP7 eFCNݙ&9ƒU dWAFw|}SQ CX֐m֥ёƣgiVYa\rҔ*jihGmcl-$o۲vMr('UhyM|r_e(r#IW3LJW VYr3Gͤ.kEZݎvicn&j@_nXh)':zruw"tP A]xlF9r mN tdTOcIx(ލ"*}!I? ;S4A\-/aG<&0ٛWaE.9/za;oQ|ؑ?.MQ:91f$V˰铲SHU4@ (ׄ[[@(OCS^qjZ(̭zRS`FV$6< SQOiV,'*9 c܁Y? fk>yUQ'wQ)} ( ()ƏpIAEɿ.**_b*H د *F h:(Pw^G+BFJ*t)H[!y]h OMh0vc`_&t "[rqGvCxWfr!7TNzڏ Q( dHJ'ǃZ%us<:K, -PW ?l[ iz R>$1ȗBR3dnm4$wE&yhå3P{xdWoY!U¬*"):Own_1Ư&w$J2F LGNMԨS¸:hǵteX61.Yy \7gPDOI1G~CBH\,_8V޻o,V^ Ih^,7ew!.3oxcQ2fm&V$pv>.MSAgL:줓1L؛P^ v1 7-;7zn5u:+TVNh9]Ji~56˺}; Ȕo 0ON@=r$4gV1miǸ+!7O)ɃJ"/",`9_^-hfgB_zhCqQn Ii.עP\ fH섨aI#!?/+= U9켢lm%H7ƪyeK#U !vhLML#1ƥ'F쫊?WiXh!(#iJCK[C!*|wR8gP&=.G;^ovi46q[qqP`TD?I 9] dݤkᰩWK OdsOc>hSO\vq t`Q֞R-R&+P<Ϯ>z13flԵnhOǯTU.655 dy ՟}wLx_nG6َon?|p?$L3%J*<zޢ KvJR>j gKBD] A'HpiB:%9„#R}3C)xɰOja?㎶vtq\mzJ.%쎴΋VWv&?h P8"=a"yAN :dnN8eRRg㩀sI-c$U1ʔǟ""wuAb7ӯC]:L՘e35R1hbx!-- , eZ<ޞT 5RȞ[y~?HPnf 0YZ0`~(uҒpp AqXjq-aa '(P-D>Ķg qds:iCLcHuTz:K؎\[\¹$+ U]\VVf F,䟵XĿU-4>"eDF&"B+Z鵠&WBlN[JԤԜ;wͽVb ˃A{(@IZy幐 "]|0OwWGP UqqI{ FʁBD٨HO$1q$ $EETߑBwq+Wb:7(׷<ژ]%|N LETRlhH$GȌKqoO%j\$_ѷV*M)MŶ*p[2kqLn{pͰp*=}p#%ibŞqv>"O"\3Ũ痙Y0VDkz 3^dUv\@6[b*xGQ%9*|B}19/Az#H<[h?'~~3|k*8'$lݓ/z&!xa$>f+iO+L`=8{>Ux%SgA@KU@ Qzp Bmh=^B;r]jD_}b+-4 6`gNU:^52t(I5,yYi^EOy]"LoWI-C"oLAB`=}jz%l! EƩG𥎝ިxopFuP\36).^KJTBwsS۳hY.zWׅYxs$md#o^`jS6,S,M~mn*5AvDUX氥Ru\a[x]}t,Gq:ҵ.p 2" ܵ;`AA;owzE0ZSg-46L&gKeӯAf%y ԣyI\KA^SII^VZlQI^ Vt:#d~zphLH Z=`h~l=d;H8I;X}0&֨_fN= f6^~l&c)%Y= 5Rv{n#*~%\RGPܮy"wC[5$WhIqܤb&P +ȼvrp`3o8~ Z'SO5fBֱy+hؽw=fgd}/B۱+۶7i2?nqچ\iTj3oì ^(Ω ?M\WU~UF/NMݓ"=?ns  eo[Aϟ;Q]DXz>D{'>9f*Z*"ax_h`̣ 'sSБa*+eAIuDoje]GOiu5U.]H'h :帽a=NHoqeO4 #Ze]&61!AmZ>,Uu C y]8wǽ?m,~"|ZF-pq{TV\V6%;tʴLҬZ;k-øOaSl[f>-=}f'vzî"D Es * v/ J3:ߒ1*1KGvDW$sD.\ensڂ)ܤ1jڽ\11HUq"VƩ!bLȜ~zUV/2Y+n?Hߡ)ϭL/T;=\ps&`D7qA!9E hG*>!zaA!NK{r=h.ehҥit:]jZJP+> stream x]=n@{7)q1$ȥA˅o"#0rOߟ~wN{}cm/eYNxL ۟Cyx_?4^ c݇6+y.M]ne1} ~+huR4ƱhGƩh'Z4q.D|9]+b_4=hV4E>1A V6lXմqe; %"cTd,(`DkfRgTgfRgTgؑiW]ɤѤɤѤɤѤɤѤɤѤâˤӤt8t:\N@ s:RCbb`o3 tzPo7 :C@g7 !A!A!A!A!A!A )I Q(A"J%hRDIM(II%4)$Q&E$JФD$oc̃h}MN Z0uS- 6endstream endobj 326 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 8074 >> stream xzxga1`1BYlMi1MnI,Y]#^d\ell0` !!=@Mrd(O!lf?~1B#wAAAO߰93=&㹹Ƥ^ʎ bbesX*F`Sg DQ/((2)kEfVAvJRrn輹sϞ^[|Nژ8Q8GvΆ93Ŕ 1i[nyK"̘zo -ؾ 4Smqʠ-7nU&m6BV96́2 ɠ1("k'tE}AKP>]ݳ…F6{'oE\(*_wj_#2`hn\!uV /.ѧ|4 ACg/O¿,B4ǽ*Ľ+xI {6雨--m~/à JnX; ~qc'&rS'_)z OF@tdQxQ;O:ـxgK[yiODW-D??I``%V*j*vD\W-dDHRwrz;@.M\ U@~`悽:0tJ{ՇfS'-@ ?3:)%*>UЂTIs(u7 Uш9DBiǜ/Ql;vG>: cOvh:Assaہܤ봘,f'} mr]uv7b~}?w?+ص4?s0GŝN۹ye̋@N~bO& ??0^c*^EWxb`0yrU&J^Ї@M;Yc:${,*+:GL^L KwI>"WfLmUUfY$~ 9jZ_Dsc{lL&G(3d[ 1F|;rwx}\pz'7I;L|uR7[N3u ,Hp6hY$ U4ml'ك6/ )BަJKa@DEC%H N~)TK2cf3(3'9kɛHx~1+&Wwįh]9$8lx-!:(>ZgBcC@M[,p@~ ˯ E~n-3ndmM9!_xWpzdNS6Cm8x0o i-8t^a |76qk!k_D캟yg҇N{/Bw4.w~u=FcmOr/421?,B\P\ *P(:i<ꋞMkJ9};Qfa{A$|3m--mG循Βr47ZPpxp]7p}va hK,?}:֌ l]Tz5UPp颻s =Ke/x!h/efڷ"/s7glS[^5H[(ܫЯ{7{포ͷ< |KkQ&1BEn .w]¯72M ,b!^e61No[}4WWh(hr8AX A{K^B+7!N406/R;]]}ak}C5,͜DiS-~5 -=Qm{r^S) 9L%B{i˩CY"jyA4ΐ?^ !iRtFJrDT!fq {n8Z{ّPVIjц[} :L_9م0j Z\`qoї<h$SǍA Aoi:MnTM@. ~#.3谐I_ѭcwڪv48s"0`%t:<6cOP]NQS7:*1@JNqm虲ӍB\Ԧ;%J*Ng6Ӷqcr xALܸ❪D:wtm d  Zz('ù=wTR5O([@P 4 joF|ڱ5͇::|8!8(g}x()62 %͑@|(g\v tQx kd%Q0'8N+CZ.Ƌ*4v1gd)s8Ɉ YR ܒe{vKia}F kj8^%+;:?b6G7jjyB ew?k'ۻvcwh!cO5vXwJ~aOTb @g-]!cT-b^rtײK+wZwRDhsmKؑ ȩ||ivs+Ty0{j} Qs^3}t;5wH-356/Wf| Sk}BHʼne zLRaGZѡlț.*[[}T<nSu@nG*4kf-$4ΜR^ ]'qU5<( ior=7 %&1ǹ gHYj'd!LeGɃ$rK-]z:[ŃsVG(I$`ȵ6a2]ڱji 1wyh,5 5]ЂV`ةPnmA*{,V+X,l2 MHdAgnlo*YRSg,p> gS}" dZtV(Ʋ!X8MNs#T]lyAw@c͖* 2?.p˷KV9PWSh2h[-5wՕ6N_8sjg11]2F oSUgCA[ԫ1q)5RirY!'C޷8\fӡ=#Afű쎣Yv ,֏A7(O֟? [/Z< q sgKNÙOEJ!7Ϊoh ѠFKvP GG _p8蛋<:-J]&*^qO$C;kK*d/JOY<,t\iNp > NrXC-gLIc xxvҬ6{{&O=vȡ=xs G|jygS{SQ;SS^KjO9^0\r/7"ܽxXM,tM}X*8{obHZifX\j61D:p1zL [Efڤ)֠UrޥdZc[&^q/Aczf70YXLV2UM*[& dP$Ʃ$ՕoE#ZCI]\aihhX MB %kR>:tŸʲ<Y5Q/# V`**+<|j(&sB[.q #7jgإhA(x(`A!STx6v>d,Gz=pN߶~5QwAUwƌ@޲5E%`4j%ѷF>% A2M-'¿~LQPyʟ%ݒ/$4 Fy_66 $rj`(_rSctC=N/!ydl jTmp@!;ǒ]+g\$MNx* mWcg=PWZ)JMO[UrAn?jدyl?CQj-Sz}mNEGX(;~6:~}dׁu¸ѳFk<>.b(|9<ք-nvſNU5'i2]@ L`-?ao?Fqz3"%;'#8B})o:k tuI E%hу".bWLwJIxW(Q'Bs>2 t%n.ja4J.tR *b2#qbmFvZMYhzHr@KfLAgSՁh&q}aC/NbCzreh^t]c36-J@ݗ3E 雝,dCI-S1 nau1F܈=v3Mfx`h:=0zH-1.y3mN}K,dNu' hi\4N > RєjƦ̬ȨUB`IvL^0RJBU)*Zۜ8FGOF{n4qX`L< aDAcF1@P'ɤFGr+MmV߀ uءZ_Yr)Ex5? 5z GCY'yhV{'p Aee&Co>nĭIB(DW_}dSvE=Wy۷Wy={Mە=u11*?V=Mr2~UprhfLF-F뼭"kpE3(5_*o#{W#26GOU?w=h U u F2*[ٲuNq;Al-*UWC}uYy祝7_Rϸ@߅|ܿ{ I̯STq::|_C@뻿`F;ڀѾywВ?PoCofFGg巣8נ!3FexRz{ 2֭VoEkHNoCK쪫9qv>ܳ1U0*qW(UTqP,ߙY#wP4 `~_n5yYY9dۋJV[UcTǯ*sSPɎ?%?> stream xZMs49)9,AF8і$hI+1Dg9M&[>"ׯ_74)Iz> bw:;yskxiO~:UPY"su32;۝'$,$+&ifR`~f25աd*9'(<샲nr8 F$tR'L?OJA"?,1y~~qb!Uhqp\s|G&Rn~$YzGSK-?O,)P '(4[Cƽp6+'؇=OD>?hpTb󧠳m[mj5l^O4 C\گM~ڍaBf4G]\\`+}L,vO\&tk0C@aW(}Um14Qg,g(""&qExDpcˤ-89C@ [&< ;$M22渝qsLe~SdٲBQ)r\MaB)#\  F>[<Ɍ CS!\j eEn& mq>^~#rwTN:el5P _?CƫrfS.8[6Ղ@7*,h:ۦRhf rF SpN ݲelޯ`kic{2nDbGcϖ'FbKuȪm63xc[WkBB Eaثɔ-0l]x i1 @:? ~c8X\_;9._yN"W eEGhEf3)!.xO`u JþU w`a~aa\ӼR~N rޯL>pvPbo!EDCx*[T ߣrtz^:v*&ȡY(4lhN*Qh+ jFShtqy됇  |.f?@2AX:g9+`#e-Ht}a8qq`f $q Ifi1 27.8y[7ΌTNar rAc p@ *}=€po/k^,]pp)XBɗ?T1./rE8|1Nj] [R@U**ƛjE|kKН#,t\$BSiz55, >B3B;/w?ܶr1 S곕 @!1|vuEjkhD%bBҰ9?E㎹{WUmBK|T=8Yq)JPb_chFen#ۗ?ytgGкX>jX=DnՃ0K:UYMJ}XӏDh*ƉfE[7Ǹ${/(A:G0Y~D11.x1Q!5ʘ(#$RJ$/m͛w%7Q(\-ڤnoÚʼn57N/bpjǔ7J*X!`32/]?O.,/q2 |NI1$m,)٫ܕCR (je%/1v-%~_Wh{}/r݄Cr6m|p/n,LBEaLȠ9L tRC'&홰P )sy9tIIr mR<$luIeGVÁ]9 "{lS X7WYR]G]P.`Z?= i+6 AZ.kƷ+{-m2p'im@ÙAs'Hu4'viFp$E6vKy sj-gMy7EQԫh},kDd6qEմdOS'Y>5IO40T ]>^} jMےGa|u|UٯM/^MRG,wU6R k}!QE@(0>QDȁ`W 򕰤4>-If)"@%ʿИCr foLj: )CZ@gLqp׎ I#"ǀ-OU kpuȗM h-WzT9b$<}Ma{*Tm7w/Oc! _[?4R`$Cl9,a4K2kQ7}"ufU[ &JG̀P"VDQ+.)51m -O:;qXnb(ocZ|-Ja1}ѕRW0>00ڷЧ,fy!$}(~_[Q?nF$Z 1y XC|N@s>sBu@ \>pP 5`SāorP6ćI<'z-V ›#QN< ]Ji㐛}"~ n3/91l R8щ,g{nSV{_ eؾ]u\ Ffo &.,{0n!=FDII΋BA> 2k'rH(Zp+_<ɞ]0mdњʒg^WMmUS=@FI)0D l zv2RޒxV˶*wG"p6CS\,v+ .P6"!T3ٸdWV qocȸ6endstream endobj 328 0 obj << /Filter /FlateDecode /Length 4079 >> stream xZMsȑ$tuk6R#,i4ˤ=&9MXAѿ}UnY3nLLh|U_f}RN':$s:yv!5RIh'OW&ǥ/j~{1 Ӳ(0~U7>8c|:R^Y ]Jee^{QxylS^@ *ka*LQy_0p;Ng87>[L}=\2f?]Wop~h8}aٮ444ȷe&/8z&u -/5H: ŋ`%MYiggm +/aI߬ء1sKtɛH쩩V?8k?-C5Ϸ+ߣ4q`g" \Ūh? o0FXVҰܼ vD'3."lЖUSgŔK~?* Ly7 ՚mood">Y.EŽ>δWIm 沅%f 6:U]n^U^L߯P5!KMEXӋ!v5r,N@M۩5MmjĔЯ)9 ٢׋M{qc wh=hn@Z.L kUᬌ|t.=ݿU@&p8͗ B\g4W';) MQ9d9@,0cE4ڟ]?{_zVde6gr\۸a&8+ ? fBRM Nx,؅o2r ++= ĵ[ήFZ/[TBN4;uլvԠ,H*rRS.-zyfo2;eAH 4tsYa j }4yMqX pfVuATF0l 5PY5G̈n3bP1_B&"-lm )a %>| R`rz(ܐBp_BXĎ^dоp#N9yeͯPwO\9#̡y-P:d>~A\wDBmjP?уlW 0dZKԂM\;aT p,AA8QꫡC#c* UUgEr . .[9 >[W/6R QZ qQ! xʮ@ IHn3B &~p9Xm{qx+'~Hfh~&8sklQE[]4bsFټ!j* ! -?'Lr9皦\ܵyV `Z7Ӡ~Qz@BROB ZOGh TOQv"tYyV-%$JZ :l!_1j)xM3WXSBbi*h%J.YySpIg`(#h>0=ͧ,$,7@.I3H%7;ecN< vVM=ғڊA奎N]p10fwcXKU,yV d&-'I޲Շ"8B9n7*)v2SCSbONμ/2zծѨ).C;v%3ܩΠH>X<#O4ÜU@@F10gQ@r ɝ`2xDeYY0m/!7X~ʂ#pb@ %4<LoO :8ڏn7A"Ȕ.E3~ f例o}Tپ{CiCiϓ%=E'Ȱ#aL4P9wSedjl@qRmRcty@8С%XYlWe=aRu<= zemX:X؄Fo PE ;xbK/2N.bAD#?$G)`IZvj9c_W?[n`wRv.0r^ZBU=dg("q@2S1O0:yjHSdwQj0帇c!uJ _ݥ{|fNQ\adžW02PfZWPgSnvv }a[en}vpX컪godZҎkkjT/%Xb;/&}A[j~ᆇ]08 &V9U?50tdX 0vL1'աfw g*D^h5D8_`H25?ˡ8vD lg%>\f|*K)KBS]"c\\˼b#'mSoOpܱ@Qy ?wCeoƾ|*chG]H'%0zi4\Hx;D4pq vݟ")IS#zp7yendstream endobj 329 0 obj << /Filter /FlateDecode /Length 6969 >> stream x]KsFr/Hۂm=iHbWpxMg|T+ΐ 32|~_y(?Y9_śo~~]7)Mm;x{9U--L^8 _~;=WРQ:[yau].?~uenߟ/)ɮRk;SgoZR\5yQZ~W^N9Զcw^ТvZ4?WU\ed_k(U?_xeb]:{Ë8o*]^m:6sn J3ySU2am*i u[W0.¦+MO?*n0?¨i-h*>!Dl[bwf]ԞvM4,KlUh 65>n'?ui01dlOp9= aTT=G)MDAZ4U}(VejՍgM7MX:)szUÌ~~Nl_ٿ]] +wJӋhrP}ߊaʟ5۠P!î,p*.E+xCVUфAXlTrkҹ"{teky.|eUᘾp /M)hQ uxQgmBs~pI{)miLX3YYtUQI9ύήv#|G?|C_OCJj~s'u!WȄMA}6)mnIND.lܹXnTa dݴCcr1G!oeU(mڏG؄ƷX>Ei)@(񉏆*e-7I F)Re{=ĊȬ{ ݭTm&l^KӴVeݤ 6#1}%ߋly J^)v1RpdvZMmn 5ފ! n3a;LـZEEFêr_@wj\v)+桫&؄W ?h(jW\/ȌZ*=9H0VBwr^0hF/*Oe1[9"_w@6V1PbB[Ÿc[ Lm #qm!q-l>HӢ`.PJ׹4oeS u0bUDZOyq}'%7= f<]@A>]U>ϧۇ%V5b ;ct44^ӓՌ2L w +0c{3> oXA}KdC }ꪦIB`1u7NX?Ҵ!$?|n/#^AKgANPgsINNYpof`0iM0wqjbqF{86N +7c!dx 1zt`Ҳx Jv fm<ˮ+CAjYÔe:m{y?P륦A~bw9!buw}f$KV VpA"%YE 1KrMe23\۵VxLnhe &TlIN6^=q/_{.B=j āNUӁJ)u`R\(γ[1YO; L&qf *n|T?$ȩ_UUF-(\ Mx̿ OL* W96 G.s ] *l?~J5p#|Ǩ,+wLPYUV%rbV*w W;ⷩM#+@dCXO#՛٪(h =J+YR!ׇGpTzc }vOu8fbh*bX!@`+,f@7y?a 3e3E [AUMzvӭGf۸b N~ܺ=)pIP0HiKTiݷ1RñLDI NVyIs^MQ݋N⻱ON%SϴA~'0ɀ(ecVNy)߹ZN&TQq "/ZDU_}U۲x#)ў[gory qwF9'aljh"'np//w(u ʍkƺ pT s*w!Y#kvq2A/Y^YFSa?làm񗋟>x548$kPt)qb5O<@(@ˈL^G@.#d 5]'@=p5&I'Afxh`!T,Y jm9 =ֿ/iB /B3`} H<+z?kE~UnЩ.YsX"Fq*p ;};dh״ߝ4p0N_ҽi4 =;M𶻉Ka&0#NQZ_ O͢z%ǔԨ\JyNi>`j~MjK='獔a h8*slۃpf&70gUS E#'V/9ФyS3Bf),חZ ̛JrZ,'[@E5S8p\SßH9|M pOO\dgŽsW9A],yQ[Ct&VYb{Hڢ[@S!1dxzАM}Q  y\j>м~nC6 _J'RLF8]{!|^? #~+,:dfqȤ Rdtan3Lpq+62ԹՓKKڎKT-vײ/M9} IK*,RZZuaQa{bBI{8\99)Yؼ{ދt`ҕߺIɪȩ5,BM̏7B!aiV[.<ӂr PRyBd+,e,ѥC 3DOrXpi=X(6#ǫ, ӐT+D)z uxzse:* 2s鋠&(3$0fi\EV!͔.4 πvhL,Cc+ENJn4dEHhƔWNDm<,-E $UZ5Ge2JdպDE"{@~bT}j$OãO% | cJ!_P#\ѐ߇I#*|-`O/|!"KU"L|(!RU5,a1u*NW t<$|"{eCTmZB];>\Sry^T}!PC/+CJ+Uoʗ@2 HG&R;ظ$\ʛ >_tyb U9 =ZɡL}7guGf5BTI~H /Jىʛ0rzn J^}8q iJTekMۗlPscxν ,M}d b.L;g. c Xl3’+JnNvF׍=pΗ0V3$Y7$nN8W~ 53I5WS62{ n9/I%I<2Zc9+|?R}ŘLZb*ya)9ӆTV ~[HuYfw%/$ ,>pCeg9$O_Ȁǎ*v$fHbޟmHG9I-ciIDl'@x8{$NJcQI} Ymk.絍I5| 9cV0*-,@ѡ!/\72.&iTKwGVOz;H;GS,:~KzFEU h׾x}jOL x?$=J&n3U topwm# ”\#A `I!X``:v7ݴ٩qHK&u QVSJ:!bJ.F)6X:gV~].0%HB*]`C/IЭJcb9s>{t^WI֍X\Ll13D4?X+ QAW|L, XĎFR@pʅt%SJ C+N M W*4]t[ .}fˮt"yc䜮 W33/HTԈ6yɈ&$͕=OphmJ\;?eaimLz raӾjZWtƳ"-]ݒb!%`$(^ESKNJ؄>N 9å'AUR!<ljp63lbCm&9Vj8Ħ %#a&') B ]шA1QQ}xQ(ںxɗJ;fהɛdg( ֧RY&Hެ}X☡0 U+I5zz!:\|/#&Bj{@Ou&O=sWItLtQjؕMyLs)S}pGEPStP7xZ G1u]s EjFˏ^R뭎㨼?cV9GA︼u&?7ӧ[e\I!uy|Y[E%$IV'ZRkr8S) (_,M qAN?}:81Pā N=] 6*+ ' @Eض:GtOr`GEד < C'PE Y+?3ͷZpmW=& SԫVioE`ʎS{i0K}Byu#fwQg ReLYWO~>. u] Dsi!Z]4v*C)/mQwn+-HqC;y`gqyДܦ Z۲3Z+/C.%H!zߵ?M0nI4[NnwUnUtK Iw:LcpNxYS+z tH*N"*6iSNa^'*@H*Qx:ThN(~CUΘl6k|'mr9TO@VP0@b!su>L|K\5g^a.9Ji8#ڕ¥X0_ N#c%Հo[pt5&""T]Bt ^A«ҿK2'sK)`/aVvv曛n_7w~<_Z*EU m?7#w0!)%T?ǰ endstream endobj 330 0 obj << /Filter /FlateDecode /Length 314 >> stream x]An0E>oHlEg\eg.#=7L\W>ey**&|Oj?Ni{tW^g$H?Fhw/y'Y- I}UƐ#[Bt]cK-Zq^ƺv[&LEGEuvc`ز*[x` xd 88(&(-@Ard$ ALT H&I*I$$`T/33ALT2(.ݑn\n*eWV5˼h#2endstream endobj 331 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 3191 >> stream xWiTTWTyUD½!m[8# (2V1T[e2h1 j 1Mb̋/t^ve>>>MV[VZ[;{}ߑQ>^L& ظi{FZlz*6=gժlϣ@ 27X|gp:Ayd fdg&p 5!Abg؟!dSH<4/#=(.1%V#qwPD+Ãm5|~ ǫEqd>͋͏ߔ59%uj|E͡PsT0N".j7^BWPjF6PMmʏzJd YK}~&JB`qz-MΘ<6u.@ߋ&M;=S7Vn-'}+@M߁},_'  b|ilAbH[{ (VM /Q'8}Z8d?@/AUJV?)pKr另_%) ǹv~՝iҏl5[jVQh-W! 0Ђ;6ʙc4~vJe0EmOhD{p Ghązz{Jױ+ǧW>cZ{xทBU| %/? ڕ@KO*C[JboSHv3 {ϲ Tj^^,TD`vmU0>_Bk6xm%h҉[x&IXgh2iʼnz]K.Hߛb y7ߵvzr怳ހ^#SMH\5v-pːT4Um%/ݏbeXw4:$t7NqV*55lZ `Rլ;vY[oŋSqL*Gx h) ?K #w i4Sii:C!*L@^,ghLUt9q Ib^#`[ PcnA!lã 60IFeh,rA#Z=,J29zgg1e㥵8{D֮͆wyA".3Z⬆gz"-DRj3mY.çcW2 :\ % Tj̲|PQ0&&{z0WܥUy} - B7ؖκ.g ܨg]LUV] - /ݖ#FKbm=z_e2J^PmW"5:0RUo_[-Ʊ[+oo0'nU"k,aUY-=EkǏW%Knt\U#>U0=@ace@(ѧф7*V w#^b{.seyNV{?Vߌc#ITBC^I -=u±dy9צUA 45XL5+=,\<#?y !_S5]1!$ǍC7Q|vW:Z5}tPdxdgHzOv͑?_><*xB & 3VnTh߽0ۭ5۱iQzy> A7rFoPHBo3IJG7r^~XӝAN!<9?+s1scR<ޮ]2(R*|f#1ѰDI۰Rwt[}EM2͉- ~rE_3xH9^أ>[3bQ"Ά/yEO>C-:轈SRB6w}OUy :т.FVAn"$/K_g^9iRlе'TGR %+ifbo}3>]^eKlX'tf;_ gk~0frض׶lH**sn48;Oպ=e=S=F"Ԣ@k J _Pjp&ĔҐ۟]̈QM4#Vk>0gǧ*"^3-U QH~ RKYT RK] [ɴ3~8K~Ʃ6~Cl*p?SeK }bȈL3f=[/-g~琜<ƮG9.8Mk5% R!;ÐtdNhn37?$d(kbsFPHsCdI3h`2X"jOF2i| d@2l6YU,1j*~&[Qe9`DAd1hUrߗp y0>|rr]T>߬ gw< 3i44-h jCvCN+L>Ȇ7EPhESQ#4Kh7*~jX] ѩ4MFXem>B (wEQgendstream endobj 332 0 obj << /Filter /FlateDecode /Length 223 >> stream x]M0 F9En?тTy3,HPmYx^bWϧs~ʄ4/t^iZ#Ϋiś˦:~dFow8Q RqJfkCC\5%}J]semAamEwD{PX{QE=(^@a% +lxɠY4tv{PX#fJI.1;> stream xTkLSgJ{U(J+n;2503X&S/\DF`[6PxSK) t2D.tuFٖmf.ˌ!wf&s~yyQBjݖ9M7ħMFz1V! VcB*JW}FaJ4E~Q*{-%Uek6lo*~K='rZdsy] |T4/Z̼x 8{[wIS2R_Jx"NJfK5f0$$tl!H"F.L%DEuž0UX2Z9Ҫ?Vx@ =%uY|7qf/lcOcO?Q%!͐nce9ݮ Д^Zz\|xn ׁ?C3GnS=.wB<q\8GWuFP @^M9Ʈ1 |<_BGF:| CfShϴg#(Fa$1\#4{3! Hzn1}牴N0I^g1fDf,@Eua:tNB0綕GG*pґl^[_]}pwVպZa\=ǻi>wGء_3B"$U_+ ]٠Nʐ# m*:m7wy==^a2 =0k׬ #/a^@Go@#vcǣ0i^= Cof}@K9鳙Uquo,K:l~πJmVaLyOatKx"J6R>فIlf_IVC[ v}?tLHoX_.sU_4m4qudQAՏ4ɒUlpA1:iP",Ua4FpR.O(,j%H!qc$+₦}L"Hl~^&}py9I#E=åW]xVTS\ɨmewM84ě!yys%'`Bp<|տgG@^ƣd+|l•W;B> stream x]nAD| Sm$k.ŇDQXa|ߧsȡW*ՠY?<,۰q=Ͽm8õ?s6pomOߦ?> xߧYv?42:-}8xl{WG>gowS0Na+8+؛+܏qq<E31> stream xYXWמ̎q%{$% *ޗ^{o]h,jjLD|&|/?޽9Ҡt{7,v t(nM+4XovHOi{Má8\}BօJ||#L.Ylb#3 $:<=cH4g:?$=4k6gk'g Nmq^`gƮ) ٹ.t}$|CDm]{}CG[||]-Xfno,y3a+VjޙOQʜzJ͡3BͧQ۩+AYQ;ubj2vS @ImleD쩕HPR5BM,itJK JDͤ (CʈҤLQPbjeCRAiQ/X-0ѨYs7Zjh_Wѩ3Z~OrN^]?zOONdʆSOMvizgo3fH*"ߙʹ?fs  m1/0n3uHS&47"ٿeт66k"Ty(0#?% <7L=" D(z# R232RP"Ԋjf|MֆtlmhԌj?5S6?'àE\)S%A$?8f>w*OΊZQtS_2 i#/Tlpr]bb:199C"} P^`-e6Owh|9bý޸qvK8T&<3QW8z6 AAY< 'KϛêF)A ѷQ6$]xAvK` vd_"rd ͥ/0@̒BXͯW?k^)ΏˋDL/jXXZb3S3(;Q߾~bm& a&0_?V%2xC7U :)S"C>AKxu@?}ё]܌xOv#f"k;뵾rwݽl\!9c؈cWG+=<SXA6ƓX[KӠ=03X6cUv:⼸V'9cO{4nkj]r*?x)?SkjK[ܒ?w[)7% {H s9\` @Qctxt <%TW!?ndFPx9" RǁӬFOqixBb9hW>'_cS wX~k4W_A%]b1ք4ڳ+a2^݂6uY}"Z&EXP0`C9ziaePX>5 Oٜ[!;b=$팷=e%\f0('^(GܾrBv;gU5dpR&8"VtHu88vَw"U{E`FWLK|;=܉zal@Φzq$VPh\n )XJZ88D ARap!z$x΢sÜrwEl6`f&] W>}lIkPO7M¿(;vc6Z;tuʡ D8[S5'GjD G;D:2A3|$ui,i9H' Bܯ5 :Ԅz@ ;'gLp{l(l6 +WgƤF\AaA!fc% y9o9~yp,?2A5~5B~3rXHdžMPމk[O'UR#=1w0ɡ]vJ<#Px x "?(2:Kke-r+\еO*H+EW4^aΆ1Dܖ韓C{@2SӹĘ=YַgI4RŹuf47tܙaeXjFѴZ2K +4E Ps=AijF0'58#T[ʙeP],AR8+#%f;Hus#Ra5l"ܐca²ױKAbIDWazQZyz9@%%E_AQ&w$Vl &24e!p Zpn@C}n>1:b8OK~+ QOP=bƊ Q|(Rڿãz?2"|<_usFy["yߪwo=֍[]0:QDfWj ɡ=ԓ6!2"~!4؏dUV"#bEU!gC MˊI"wlK A\ PЛ~3yxS~ "0<[Ds[4()}oF Ep<;`P|oolM9ےâeHҐt.<}ͲWʇ=ԛZRXȌ&o_]}ſyjΝj 0eB5O9CurK7U2Rr]6q%=|o]$g=i)mqB֯6ە{,/}x޽tUrIaʷ^6`Q|o(jږ+o/Peu{MXƿ*F c[))M"3rڐlG3~c-MQ_mo"ƚNC(-/eJ\ӈQA^e#yra1uvĵ77T6BLMSyoĚ"'77mg.pK'O~pP,ϛgqdmiww=R] fъѲ9&".$?h&w~%+]^OT;L ҲB PIj -c_>꫓3!aJpè}҈v1 E#;TP1ך?:BF Yk%:fܲ{VJ"\?k3ų& [PxV)K,QبH?a'?#]9Tq4xmy{W/:Ü?{tqecjɌ Jթ^x7o| u?amfX= > `~atl?_ld|8$]"K<p CjQ G2($@ehzO>QHe6cg5UqX*#{XKv{rM}{npH2 İ B ,IHID LZQtKC(UMeI^'k(D<,x%)|,O863oۭXxBB` MyC "}N_:\a~I*Εl ayqE1c P'kukFklcb2* ؂-I( >OrlQQ*A=9er2?[my1U6@-M>D%&t9Ej6%L"r1igIȷs0f ɟJ(t쁹E$;gDPW87Kpt0%+6E3 Uq5?] n׌~Vv5/5K}K ~[ 6]xjj#38?69V7WUq7\Jƛ/2¾O,X|9)X: @^1q6e"<]k:0_ܽsk7~Sd0%Zd/ђ] ΏHJV&dDeFRYUwIn|P-Hp6pcЛ{O:kVnOihi/ϬH-N1C]fkaԴL$5 lA[OhewvOo'1!+m{EXwHVf纺n+^}6FɅ+2ѭ-5>xN-?| z^a@,KikFs~qaCQeBK&t X?#vUvjhlp(ԔupJv6/0'%x(+u]lxv]bVǺX5Nw~Ʊ-6m0^tL'VQX9`/vWE6Ϋ8i\vڷO.;*k 8#uQD*anB~T;jA5 ^yVh_) _;}Ēb|l W:ԬT)gjFb1Bdt{VZ+oRzk0f/&93ބ1{;]C`$^yxAWiK4> ,.E\J͈Zf8-3%35_堯C!ie)k2f"&>&)"%vb򓜮t$.4?!,-RpÒvUĖi_#Ze)ɬ !.ź]܌2~]-+(e:r]NG%Doґ\Wa}A^oC^Aqn]=&S#endstream endobj 336 0 obj << /Filter /FlateDecode /Length 23070 >> stream xI&ɑx@Rxtv3δNw̡B \ Y@Cd~FSs/#*L҂J wtyOUMyꇯ~UWo޽w_o_J+%ʵݗ^_6Wi~?ye_G+#:O_)Ƚ>\7Lˍ+o$?(~Kۯx?}%-js9^^!ߓ{wWWOί~qLm|'O+줴\ښ-UN~Wwo'~tx'|?|yDzk{^#xb9W]\|',2'P}/m*dezy'~_Z'VKa@X/^Zq/k]1vLc+Jfͺ: f6ADޫV?xd ׈vEqaϑ?*F!-]E5Wq͔E6"kcd|XRKv;$[u8 SYtVQZ.d2T+%֑ T% %SjϕIH!Mftɘ =5pMts5 È诮Cqp$#3-JD&m8\3}VceD>\j {BLW+&S]a},9̀DGyŴuԴiQS%6țw@e-phD7zȪ"㸟z_FjX(FDŔHru23o׈MKld@ ;̤znzM b6 BpM=8څkD.U#C+%|X5=Vujzͤ'bU& Bd&`&K J|2כ|)o2hX5~)FgN1(og7Y@z 6*X(QT`hJ&e&%LwU2 ZmAp{ABQE,՞jċZ;&5Fw]Ϩ0ѣDmb6RPCg 2tsV<ɫbڊfQ]PnD \["U{`+TbE[8[p,ʶ{z(% T_bݷ?Ԣ,s܏&ktqt\DxLg[AsD_[.E<C QEpƼ`)Q"))s LY@X%VWek 8][m0/gز8 0svr8a .3c.4tM-[EsɄ FUmc:"Or G ># DZ!jj(R'k8Z'9TC]!i #r䝌k3Q XՋ?W[= Z[&dpuGa!b4P_:^JfSpP[. 0=Y0gOQMq?HGI@EtDm ?o7}"82* K2r PcoLm'S8Rԫ ./)s`q9؂U(:6mW'lf|3>4d|}DW궵4uً@Qy.v8X֔-*5ޡ+W'f}ydg}#:Zo'nj;=Yru&s"ya}/X^>}xva}UQH`Uk ЁD;owl&]h4Z{@fY1qI|&}R"7)1O~|>ls4. ,FycaWe5I6{{;6Ɗ]+Ý#ufT7)1Ի(ԑpNC$192`NCVl00!DQi`h9#*C:c\SFב ''(^/_*N!'gCK.`T]H)qiR/WX~rHXFͤKSJnO\`zB7AJnDzoyKQf\4WczϨ0]b`ͻ|6J]Up9Ʒ"e+ƷecnQ+@.LyTVy=FVcB{VzNErk~GFЕRfr܆hM id8F5uP+cq-/(Z &(V޷x^UX/bG̏gTjҋbEFP_扢HM²hĆ(7Y ։QEnBfg/@1j 2/ZZ$-# ߡLRTifa]CC"t$ߟl+^ -Y +̌_ƣxG}YjA3b 4F+ؐ ,βsE5E7QRU$g ,T;MVpZ$t+2'C0oٌl[NHc$K]QfS2,#Kӳ W^e4=rMWF#ЌS}xGFy(ASC ily25ŘIt-OvF5ddP/#ቒ!}< L mt\SHF3]Y3ۧ,I:2@ ųQw"!Pg6FnsӜ LJ 3P$i .Z'#fAjiEЬSF"</dd~03EEp!4qJ3T5,wX~2Y):p'?s4ndS1@r.lZ)ӎiW.דKXߚ@5HR2+r4kѺ(LmlE(QirA. B8b@/[[GJt`&d6Ba'Ayxw[jãĈQ ,beXRCGFYm\en1;$r|!*ΉwA۰8pu8G!!~:bORsN14K4eUAѠ :9N:HVojH$k(1"KsB&Veџ H5.O|Y\ޟвOfg9QsqJsis*UV׭F\yX?Il=&ն2)r娧lCAkFTv3ԚPlmSh,Fh:\b`dŀ 4D᫱pi7`6o(贋ka;CPFڲc'%o;x+nw /b:e%'[t(6CΫ'GE?6q'n2L%o6w&燎o%'FpsEy>~D$^vL7+.mm\]hO&Vn6"%$$ظ;tn:1߱!`z l=!gfoA"{W=]fI|JQ1FvqAH\y..8\("hj ePZC٣Ćk(WpG5E9P`KQgL7 23VTل= ;lܴ$vZMXӳt4u{Bl>67e@̆[$9z(?"~hD'~q$m=mc a(&s鴎ӱ= rN 悃3>1-cQ̩+.Y1>]`??f2eB<}\]0ZL(b(2qwHƺ6MFKD6DfŴCqs)8+Xy5ȱKMNw1hYrwa9(@fAa}gm{͎9g^cTZQzTcU%&[Q4K EzJB0fo=L AoD|X}/NrE xrع R?0M怾P_n`^e:;@ ū3Ⲇ:QmǤk2Ҽ|vr t/-Dg3sKn˒t7ͺش1&V5'Ch78_amVu43%ifڍĜ|Q?8 |C#:qAݿO0ź$qnup:h'rqZc۱yٟ(pSrXqs PBIn J9bb ~7%Zpq9A 4$)懽,'ɣr Kkr* vaf~+e #S*Adch{M/!tK|DLU]ml[!0?EȘKy Ǜŋ26&fYq+"ĶY,/H[12*9@#*džpGO5zS׶o[rZA1 }N.)1' (M$)-D$.\(lZfzCc:v\0BF%01j0狁V0DA>1ܪvpMw(Zo]!1I C4lI Cc )c2R C4GD73qEI!r DCC41[\*br 6mT D4=wD舡s2cLek4lglgdi#,~(:ďdd?gOAzϨ<'&rql :1\V`F.3D.s!ޤ\]dwl@Q8}HPCo8mͨz@: wŦרgۺyNY I+&TLVKJZw3=B=j. .v6Ѿv7iܒ]]%d3} tϏܴ%/(ގ';tdϛҁ˃C#<On&e:TʹglǬe1dZZgnlD8hE$q!4oeʬa6K}z§|nqxHwUQ'DF:&PvSMπ; `,rY;<:e~,"Uۅ/څž1 ~RW/<! ĹFM{"tf.E W $hb.)`hMI83`kYPvnV.UD kF?پfo(y߶~ ;P3xGxNz:Pl1Ҏn_}_N a5\1,pBr[1@n:z*xz5ߵRy*"=ub/8`,{ҍߐ ǪΌqd%w*C-Ƒ73)[jw Q\2 d fU'v<Mn}ݰ4v`#-koE_5cxC˒,;9@/Ԯ~ X<;n>m-{@ ?Zc@;ʑ ōee ( B;K^E!n+e ;[xSAEm, pz7[7-U^.l.HVcmsb5[nQAPkE tVڂ6Z( d+TTQa3DҶV$I8Jx(w7dg5iEB53ՖMj⨳;a=C2ҵIgw֑atmEic{*x:H,T]J UK٥j֞u-@}Xg#z/TěwV$y:ڻT5͂J5lM+aZnUZ⍁ؚYo{b#ͮٚ&TrZOq?"{=pE -K='j֍ }!K*7y fͺ%EJPd> OY,bvd  U 5E?P@K/x w.x*,2n::*?5[u>Eh^CױG .mT zo:?boKH-qS|7!0pic({y}F dwO܂XZQFc4b $`l.\fq̀}𓊷 [?g!ngzvEh@ɻӰEEm4hh>m ̷15s;5<$mUC_r 78izgۭ^0֭6UѰáZ~=1EPM{ 9:YP0mXN/8n:D+mrͷCo_A_NB? : *S"~ܽÓGoS]7Aվɑ$62 Վ@W X8)w`M#vh8%s;$@!>bR3;n fo/F# rњ3\O;kxU;GCxѪjNw&)R#dD@y,l=H,Xts\7Z+8U8Rc]58wb:u&mՀHyҒH ~Uڟ<>?sxs&pތ>_oZąi֓\; C'UWnwF -~j)ӷ"mцQ5N#ZvɮjA[g;vmw n-^Z_ei1N3'/qK5pkK~%v?nvDgB{ӈw$pAQk7KAs]cFS=x<t>hWG.} Ip `rD:~ҎMp&̯e3“bNW=2@BPHR yA.y*t7ئĀ',αtbĤт.ޟ(|ڹ_ғD$ye/7'"N2&+_!*}o6c@Ɗf嶒͜`ʮjz=f`8$Iڬ"e$=yi(_Gp?՗oY_[_ 5_Q _-:S{؛Vc{xï8*W+(Eފ( zڽ{ ivb,kEݹ͏)z lLz|-.WXWc(Wa_Y_+?Fh^E_?Jiz|m iYqz|-Oǯg'i|-E.}0p̊>ZqoR3|MՆ9{QgK44 MvkOf{ >_jK7$gLo Ge k񞥯;ZS錇?[Ú.d oܾVG2`n1Hgn*NGpdv^1ې ݾbܾ&ɉIk܃o%1~_F~ñWd}͒ڌ~[Aegߗ+tߐ>g0~+}Rp_%3)n_iU5?%x}0y}r7DUחy}MdERTu,^>!b$aW:V, 1ZL?bȷQ CzM(@¢]HT2'oñ4]p_0_ 1683vx=F>r1Qo bxD@=KQJD!]WSF,jBczr3)~R hzbDGjso[l`[Vzԭ 掼hژz:fg!zA*-"v%J0"ErGFq͂7~Nf!/lĩv\jr3V4Twf#^}د5P8.֖XQ;1*}p"/Q/]u1PXX/q%HV~' *CLx33u'$I ]iӎh]:+2" @:jΞ؍XG-Wd8'vk ,:kWl "6KvZ 2jƺb'akVP̢w5@)Tv3fUU+0a9vz(`B?bXvzPt3^Y lY{#dra AZqdz6HS& m|* m:=:HbY\; e<AZ͌cXC*n|Kͭ4>Q&B"ê}}UE] ʰGA=[w@VqJvT֓IݣiZц*)'h ,>3h]ܻI YMuZ=mY<\k=kƪ46G<\oc=]ZKzh?ӺɀnPGym7a8#-:[w3mgRn[*,''꯯R,lVz+Bjw4@i<_oh(Ѱ743#8Uy8iwʭzvG%k,nq&!|nԠvGC $e+Jh?P{ۅS37RquqڶKE#3viDό72乃Gw|([??k oE hGR=*MEƫYrH:#,atQX0Fjū<6+}#>m"omǑ#ȦmG(}&d&~FlH6{H|!X ni%Gm g9BGA O*G ͩh d, )blvߤ#-0$2Myצ?(&1 2F(-9'bi_$kaHVyOF[&#<fO" NN"}ϯlLlMSC'È =7tǽ^{J <&"eI m~ &v:`&8``Ԗƽ {?S7֟Ŷg'`KփyrwY& ʧ{UO:l7;Vd{AA4`MwB|fߚ40[Xh 7 ,v:بl` o&Axw#[fO9xN8#5Ϭe9n*La^f9koDr曵ex-FhVYOeT|h'(s߬5‘kot gt )[&f-5e2lݯkfW1p*vA)1ݧ1R[:f-]37`&(#g͢c %D-9=  X1Ǭ=.1k;/7T44c`Nfώ0h~YO3]u|rCC{ [22=lY#8f&u2@YPsC؊ϳ;f1ch!ߓ_nUYbdV/i3Gq]*q`Bq,KxA67M3|5LE|͖vD:rIבh~Iewْ|ͿiXV14[y\yBۊ#fMn ۮ8qKs%ri3 L'ЧD},b Q[KET I&+c@*1km]갲iq%w#=HFGzĨZFw U"dx"()mcrwqb\*q0|ABe@@i4~14[qTuY! dD82䈡يll@~$ƀ)I*tK P>'+~0>|VDI$/Қ1;U?n+V1@Z Vi"j,z!CbUQϺ3wOL.O^?sI^vS>;YYoޘd R5_VFX`TN18+2 4bs)Cf&%1(!&H(l׶J8Mk* CބƵpxc֭8Me!݋npZߐc7.৳Dr#Ffſ8AuCrgء9FfS-&3-UW?Pc>Eۍ(Ѿ;D.`~&Y$qx`c¤ȳЋY \^c3f۱QnO`̒Y5×|7BdVw K{w r- Ii13.6Dqڻ;=75 v{5z""(@F8%h`\8` -e I]kp֭$ۓxn#} )"7 D cFr* H[=P|y(>eS@t)/?eL9Xysɛ0hZ6wA_R;O%P|-Fq6hx3v_㏟#jyn(_#zR*t^\wC1 GY[+K_f«V)>'IĕHx\Br<[lv0/!sDq}k=]lջߩ7vM6`? KHlun?E-g{]}M= x/6o4?Zm k)Fяe?Y݇ݧ#0SRO[υX}2YiؖWx?ܽ :ֱ"UPP;>E?=<=| Φ?<<u=\uk3>_e>]']}xW9{Wo )L=x{xOv!w(C"b>4o=:vr l~hKܱXH? *^nU,/klLûze׷5j2CPy|J՞z@  |o k]PΛuF@,e&}&HW&]r[>/E;7O6[ݏ*ػ C{BA@1ex/!Vmuw^Ny Eyݗ%hs/m}}Hdw GY]{xrq<&Jќ4jhj%qd .,Z9T9+8vbr؋(^]E,B%臿o;urj0o{k8nn/,vTeY|NF/Ő`yo"yk_`ͤ^ӛ+udz475av|p B@:Ѳrw]،ߨ`sZWM}Ή>G<95ivۇOqM>Q7Y`]|g~eܵם?E/2Jy2|{LWr1p9o<94swq_KhI*t10/+]v%GL2A=1F$D>[/W!OfOVnN [gdJQdTS+~. 9mDrM"DDE޼}|ቘGD7-:OI2yEUgt/K-՛˼bPO-\=;Yx~><|Ң±x]~8{dXmR}gzӜ9*(mtWAPkuO߿ 7ziR/meG'YS}eUa΄ Mo{OrAP! ?D8}a8}s'qUyi0ˠzi(oN|cY}cVn=1YsRQܼٿ|ofj}wyt^vqag_K7=c77(^H0̯8cdAf<*§GgդJ9/xgևdoDsa㆒o";rCC UkOo4o>J|Q yDAj~g>25U-oݸl=yí$q;` }%[H׫'োoMbAH]Cge Q2=ͯg>Z2/*wjǶI?? +5q^,8@b[ ϣ q~xɩY.2x3 1:[Lt)5{>*?a>ug il('!|x:Y!- Wxܶ%ÓԨWg34ȗ`O`(Ƚب}gF~RŔOxzwodz|3n W[K o\loyOYl[X||Z|*Q5\FPk|ym#Eꮲ/A"7T6 9B<7?H[$? ϑ>#z x53Mu)ALI7 OMHTEDF6%CV+^Ac"jjކ;kB,)2C qhoo)}ǭ!-KٻM{"ꃱ_ƧO{ p6~zzp >!e|ӷٿ~%·>D/%)tR4V _t\7ygO| A2~Cm$/|jHfx^iZQg ͏>FPP831 ۇٹCEtc lgkup~xZcv VhCE˩8?SeᬭJhlh; Z7N^h!?>`[, w5J̿QH k?9TXendstream endobj 337 0 obj << /Filter /FlateDecode /Length 6287 >> stream x\KsƖ/$nF?ē멸R7QUl!ɺ}sR„GE.. {U\l_󕠿^>.~zWe/+􊻈J\ڽdqy'4eԸp:\_p)G%U,¨dw_/WPVf\)rǚT:{U^Bō e;'҈KCemR9Z2{w\|ºh3qfm7 禄6dnw񱬔tR+k5G[rfDBD 9)~}t 8|kںFp,U|Bg=KrntF58?,SUZ}=2J2!=gP& l^WU?璱ycֹƣs+5}Fe|VZ+ˬN<\/B33}g]'ak:hPϯ.axGq7FQDC Ѣ$uh%lczH q\3s_Dv% %û84P,k@E6<jcqRQrXZe2HwAvyDD贛a ]`oJ7 y?G | @cRDgONIȔ)sum=eK[59vA[o&6 #O$ҢI֍]*"al< 0 T&.U۽ώF4@7~4izF+LB ğ,Tn+u*ת<7EawSwI8T_`Fi?7joVJ /hzK]h ,R p_HĞA%]X:6UF)Bs>!JW#WYOA zy4uLJ.725aah&inX  AMDž5)xb=-P"|w3c'`Z<$]{Ji=EeUn?Awp1١mtڎmjإ[T4{?b0YoZ%v)2d$Lr 2-1yioYSXXB%h+:"'ILhu`]1TT(99QkYR4Eg^Lp <0mGܡrCnOœUIVh+SAY%)NUcӡռl@9䩞ezxx%*a1;yjVf!/ *o΀%9Miz {^1*%eS}_ #`Mr䝋Dpoc#5z 5߻:B3sW xLN }݄|yq-iٻϽW p. @nDk>8r#jBڜaG) QOsX%Pp*(X7o 5,y9:-+W4cy*B`z9qaVƊ7e`מS BWjaD 쇴ϐIκ3 Ūx=@rg']C0 'I8D\ȉ&ZOl&6Kd`xo K x7ۇ! 2Rr9bOtR@f"i$8M\IADFp\<>ޡiuKZ, KYfg@%E *,@} ֒׈a$Є>*f $0!,7q͸X+=X[姐D'GYBmJRwdOikU%_B ~4vh76gZΨ*}2}Gh"8,Mt;$I:td2V'F#>4Ёx/Lsp P,Fn",F ӸBQ 1,D1wBj<<`Um 'sr-:Im=_O;DWOE2Mf|Jl[k-xwbiJChkYWX6gT- gT$C.(uh^o_}ޭpY>5b?7m_'+C(-|x 9;hwv{ӟߵ/Q)/|+!;XWg[G2z 4-v=X~Ӥ.Tt6&rSJQ',O(Ƞ ҈;t40]ސՂm#R)9",# EmtLy N%qWrpA/o}XQ /Z<*ݮ7~etZvM/=7M$㸪=* Qw{F1/"zIg(ht]k*hf 0v^i[63:c,H\”,e9e@)&%(晔V$QZ+ b7}Rvhͻi3^؈@7zЋV^?gڈUxW)7A 5!( W*1uWC~B $!Ƃsp'&9Lx; :\~Zoᤝ"WawHJkŹ$H;kҳ CK7]*>iНJ2'f"ENՀ4M ">V_&_8X ʐx%^ hH{,iZ |7-?ňV><:|D.@&]?yۼ~I=Ld4Ê/ /9)-˅\q?b3J TYdAP(ΡqdXu{FciJtv0=ʑ{LSB/ۥ's4u=]=;|gm`svc$kΔ`g!\h@  .}aVO)si0)ac 8L]Wtr,U!q`M\yCq!Y2A)T$-ȷ[7ߤ?$Yq%w Eȃ9{j Y]]ŝlqs=!jsϩRۉ'KT%h8i l^VjPoq4n\&@;La16oYKD O: m~;=㾟%ک9w&Cv% /r-u0i .bz_4 +8E3= ARfݐ`M] UȣkמXfL6r!Ji.% Qoxa@a}tcSOח"qCHruP&7<2Df7Xm Y8ٳ<"8cW N*vuMt-nQ;k/~qIaKL޵q@|joу& wdS5rvӚ -/"ʴngLZ* s8#qpI.X7U1 zj!oC6/HϢj8UjVX1:TDq\Bsblv;B_%#CfU]9_nlƗGTHCWu~oqZP|wMWtWM6|nHa49 ufTvM7!LrmTa{R4!2 \'ȧEZPm8eyl)ᙕɅDUi8IKԟF[\F߄}+]  ȥ*'֧1c`hcQ`Z#yu=}_ L)L5?A$guY' j~(e{_tiNK>=OB9wIÝ ߽jcnݐc}"T͠i翵Dɤ;X<`-4GMsB+c[_5f'߫v(! gY@@byutUƜF.3FQGu3r9 Vg1nzolCK qZ^aȼz8v,r A`鑨qg͒~)P~x&lCxZ~嗥hTt9K ژ?@ o9=NU>8hw+|UPV|-_r#TIGyׄ8HXE֢Cs.ݝW`KA'WZOt |ψ%DB'5`P4򎾋(w(b@8:Rom0R (tnSC,Իݏ1>.|~U?o Y׺k"Uw>ذ73W 7`U,{}HƇR>]۟*FZ/|zry ۦ۰C w9,VƤf/WGYKgƠ4E&*ͫX:GUȵ]oFCՏtQ׽(h(2ٍBq鈡Jp$/D'ʃ֎$m3ST[qQϰɽiv} v=jȽ&zmj6{6wrQۂ-&1|õ~3 0  fkeA&aj""1q9A:\e#Nзe9Rug,6 b29#endstream endobj 338 0 obj << /Filter /FlateDecode /Length 163 >> stream x]O10 iR>:NNI[;ɾ;,.|D/J`H#48U aڦ8 dw :Hy8˪ZC MA#EFOݜǺ-Pjߕ%sĩ4-Mr{&S@|2S5endstream endobj 339 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 364 >> stream xcd`ab`dd N+64uIf!CO/nn}/}M1<%9(3=DXWHZ*$U*8)x%&ggg*$(x)34R3sBR#B]܃C5P\0000103012_i eO_^Pw*ˋ T\)S^m. =wnw6/ i^O mӺvKc?{oi~}/.cA<_qsg.a][%${z{&>&20}Sendstream endobj 340 0 obj << /Filter /FlateDecode /Length 190 >> stream x]A EZk6vMa!Eoa.?y0'kk³G 7 fF :|zى\O*Xf㻚 {I4DF`1F2pU5f I$K IX$I4x5M}^cPJJ~|H]ž`endstream endobj 341 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 698 >> stream x]_HSqMlY6Gzw=hn*EDӜ0]m9l:4E$`3,!C4\R-$!DrĮt8~`0 RJ4FYI)at,oKO 8;q A2 Lɦ:^WZEK 11L=?tg_i0gdiW?e-ŀ3#L>o5<VBՆF%*i"Hf9+L7/ۙ:u5̀dZ݉qZo^zx'߭Ku1("Å#ꎖG+2JOWKdsoꥆ8] \؋r&6lv;ݾY)؇_5endstream endobj 342 0 obj << /Filter /FlateDecode /Length 4163 >> stream xZ[o[~_hx'{Cn $ hI"Qv ff]20D\,]Q/+/wgjqsf->;?!zqLEҋ|w6<C [PY~ _}YF.4'߅1*6/?.n93*QwI9,vd [xb F$4$d8AAoϒF!Xאh;&I,qT ,hM'fIcYϣe} c>1:Bh*ZoGlM71$ !*a^[9L>{=juIBᖠ4Yia/xDOn Ͱe0 Z,Ha /4){:.I(p170h B̤E0pbDehTlИd]&1c4c:"!5XI0:^t豲 <qsGjPGXQUC+BHrd"K5u2pD)c&dO#mdMĄ!ވ,HR7JCK pi\ >L,g@C7Dٍ@!@ & ,H5 HnH$SB$wʐhG$HhBRG,4`0..I;(DhD:Q)KPd2k I`"M"ANRGڲH= )@" uY8P_UAHd\=DH29($^#Hr`U{͹\m Iٳ!U"DU5a}Y$Zp D#eX X"A %?Dྌ)+p*}`+% 6Q!15C$&8)  iR! |-whD BE4 &+$&4u*\RξT,T%i9xSѼw8+j 8CW%g2FMՆ TV-Rja ~|DCsnKG| I@RK,كs~*cz6j!%VsKrL6cD iمEpN iX1]Kdj!DX$ɕjUdr5@u|/SN$VyydB $Lqe)"(R TU!WlRV|^(1*K*Xe>CױDepWˬ AGXeo wPۍ,@3ltuu^4rESt*K%|/wS}'49^/\Q#ܨ8K>0->ozщ_oUq+j/ëv&u'7(QnyÃ{(}B;|*^W0aZڇad)V+dg|%Ftдuy~!W\Ha/ltYg4EQ ZzZAҰXf=l,sَ\~:3 BwCX6=r/9w7SfY <("e |={ۮ`GQ^;8](i.$ q^=v s iדI@Ɗ/+s&FUjXݙ_[gJ` 0GgLÇAWVauz|᰾Xkb1OQWS:СNߟ}_h9)Eo>_^,TP ;:=w~|n^ْ]ϛ5(Eъr$؞<.'v%yQO{rКRRfiTWڶWu:GYn\ (dѼdo>x]UHwOaSq357RSh"p(OTMu*(P~͵1UVKD)+K yH;&X)6gr+d$&*R9jq>pLz y8 #և!-tcAK'VgDĩd*J`\~v.2Q.S]۹7z_?(abAMMX(<͡9OmSLSfOUYӼ_Vh51kFG} !z*7%[DcaMzK)^<sϿ{ ru;e#DSyn;AEr5CV^ +?j/zm~IPendstream endobj 343 0 obj << /Filter /FlateDecode /Length 3338 >> stream xZ[o~_h .C&@@S}@닚(;3$% %?x%\ϫRWlϪgޞ7ξ^xSʋ󫻳0EWzz=+D7 |i W?$̨*֫r02zQ4%>Ԣuq;}X.R׮ $.V.J(>U/K/} yY;#M߮D 3/6lҧVsZp%d~u fv4xlÏWEMb0!m0RI_ 2emm>uj"{Ԯ+}^EӕKm.ؼ8N| R_f=M4TX~m K[]~7Ya-@gLGlc:i]"V5H$[޲I[$* ڻ$uqt.HD/IN%*^((y~7qCs4g?9|mvS%>JNc'7m|i]f@u`P,3H~}bsRF6S6&&yDtBz`| B&'RR0N3̥',l&QiA䨃|l UUhK YWMl! yR5P!0\s(N9 K9Lsӳn CV/}w!d#}45Y) Cb\GdȑHSP4,4iڿ16Jxpf$ii^gIvl(+HYk OC{ZXʼnDRs.qUE2#,7$Z]l ܙU9+ ˉ7¾֚_Zb|kVVl-/x=b+JƳMy\@Nk`Oy>B5`#+{.t y0ssPFׅ:S0~ s)laJEj4@5בS̓dQuSF"AtYCA/^KCL9,S +Bq TU/S #_ȦDóJb6@YT")FM5'F$]ḰDQfȂ*~N}"m`Ir&XTdq uixS@J !B=8 }/@w8P@@: U/>!H6sku6}}!Beu6(_ׄh&CJ STnp1PC)ɵIBE~Y*̇h:)Pc5;W42[Z_~/_]*)݂JC"%v(?moxUhq.DPe+6 >pd0Vɴkd8^!{[|&@T @罳TW&KT W98PDݝ7w|c޴֤OLK&)u D76Mz^qdsLv i$Hg9_ʦ<#M0ߛ\8iRfĢ̐cTs (ޔHjh]J'~U蕥qP(!_ QJY'/6VX;!gNn{48+ᨋE7ydVPB `޶=,^LԍŘP-O%6אLLVT >}aX- !X4gG,p͏)r!XG 'jOlxMa1p `a%wʼ;mhf{oT MiT hRs2B.v5 EQdxqJau?IcK4BY˧7`UAbm+%͉9rj vg13 !vY Q)LxFςs#+w< P.y8{c`jmA爐~y] W [q Gy^Mz Bx7ӞMxmI(qN'>Ep1JP*fOѩ6X t%YtP6An#6ǗB4endstream endobj 344 0 obj << /Filter /FlateDecode /Length 2217 >> stream xX[~_!(:jW,>4k.U ]EV /Cϙf>Hw3feAg%=|,[/7VixSƳJ̴ԅrloޓsf[N,J5---^nݣ7Ts|a>j0ο_ ,uELBqV-77_@C͉BUQǶojLY9[0QQ2|O^Wm{z1_H&rPy!NV@8MqWHOQ,#4c==Oz^ l5P]PÂ6xj6HrnE9wutQ+%Pt!Ce=5J]v-m$@i%95cԌ2Ebb`FN}H|15M $GRN؋@XDɷToU_5s%#'rĜyh|0y&e/ϟt0CbR>3lWoǡ?\4$x%ռL8F{ߦ: %OfH!7m~bjWc,؇T&&ѺY1(LqXC* }9n#%zdBF?Tzi[=@k'4b@+RamV'XUM&,LyNH:iR 5y8,?)  V6j}u8koCrVzntshhKJVe[!9[-ƅ0炷*ck~p)Dlȱe\(n[3UX)6Mq !dJ;iѐd:1KL‚;fzz=C4.[)snK j5VON*A0 !/T,UŜz)X4.P8f:xoتuh/CFsƇV?O,Z*c[&]19\ k|jJwJqiosNSprElhŲΉSI@k[R`uTP<s#WsЗr'=DL-V q:x)$^zޟfbZ6i(fIpGC =  s\/Bg8hfu Ŗz~<,=3(ά- W€q.LzE4lB,~#rr1 +T BѥsCԕ*&9ɳ1H ?dGǸTl:a&F>E}N92f+~rH尯7#t |}J-28Cp9wkBى~HkV7+B>&>+]Wîi-]n+j%ۺf S~Ci!.[P'x/4Xs^>~49-LaI?mڹ˂ >"[JZ81@ N}s $m^JZSe.0f,l M/x2X<`a$Js 0 lqpyJDp.T:TʴtKV3>ƛ8S+L%2uU.YA KX fgu84Ǐ>NTrt}XF$AP)aó3_)~EQK\_*ù/]XRaL`(.FS_E UFh`ĝ76]]߮¥.|y~KӅ/v{nKxq}QhNnW['ѭ=veYCW˛Lˢendstream endobj 345 0 obj << /Filter /FlateDecode /Length 3559 >> stream x[s6vFеoԸmқ:iu#6ri9m])Kv7~Db?~ۤ,Ŀ|qPN~;$;_L|r >'O'&Wl,\B+\eLN+ʒK:Ya(yl'gsЇ0Fѹ%x9d1t|/}^:*UY6Id?0LBY;d'ahN Q +U|ɇI,''$;>:>/ߝ2M~{QB^n8Х.ތC^/ޠ+ ..f;Ǖy cZm5|_޲:Z8M$r-%FybٞNgZKUI#+P+z<ϿP'ԂZA|I1&AR2j*@ҌmX|x?RP%&`6ʫB T1vXO#,[;R4hɪyl5|7 prm1= 0,A͔tu#nk`ֲTdĩo#rk'f/V?[P u<OApCT@\XW'>wՊj() ^Qh僎prc@IK.Zgn^͝)~Q\竆Vِu` *0<=uE4~^RCF+sQAq Ypc\4j'E\GH6n[iI,gT_ФE'[JٰFҳ "n@t<6 LX@ wLV`-ڙB WKv v /7W'.oWf':1uBKWauJ] ♫Q[ ,GeÆSF͉g~5p%J*P]kHItS a;tlC 3 qN"ŐhD\8KY6܋#xiJjFn7^ YKJ(gMp;42Z6#gQ)E{AUH-*Ր*D==o")B\mO?W[|45U IΌz% m>vT"4&Y0$Eܠv:aڷTyɰ\q+BVw$vt0'J~̜LQHPg˦eBv%]ePoDArq"\l*TŎ'kB,^!z ywu#9#6Fo^׹45.W;=&@DUAR#}azkeyHTc-> "?&qIҜ}tܕr-yhUZ֬45/;c  Քb1oaK?ڱAūVUպs8`u(Axv [3Ԓ9$yA#+8/U^?%:pEyix[ucrQgeg@8o҆rf|+F}bUbSJ!ѻs]IԻ0 |'̺'SlO ljVX-I ~8.^'{k.Jƾ G[uԹafl񼡻 cum]6)4gDkqq{/:,dM]cҺeU(~c) Ux1ns  ,B,l=i)?$RQXpnId^#Pu_l9ںBep{>~Id3C*(=i iJ@Brs@57\fP^y,Ts(g^/!;6Z!BJ^}bg/~&Av9|⫮^SF9U C+3BԔ'5a\"r-rE؂+d!6ʃ/ 5J"kzi Z`쑫H>% |;fԡK ؐsV;4<<:[&)C{*5 ZeA|%BvShURz^O=UW] ;0]onғoBgr_Up‹R]!5w9wST7$Qp$U~nMs̷{0}@6`gAva2ZUW7${\ODRx86]<3JU!;@vuu,8U>1OŠ p2~^5} ng'RӢh/њ%Ԅ@FlJY#w17,QћoZ!!.YI}S`έfPx`O]8j[TWjex9?#0Ӹi җ@Q2iE}qgLc= I,S+@&Sl/| 5CCjλVIU9mﹷqei!8l}4z<ɇ-0M뻦0^uz7>&9VE0Y;0N1+51]zt1ȲЁ5襰'*gL(w>׫סTPm"ϊ FpaZw%j1 <)]N FOXAR6W`ts9%[PFoSBVu.>CS&=PRCWieRRi2f{JdF 8fSf{6VɾHl/c7!(daC3% h(Cb}}vp?Z,}<oP9-mP2R8{ĝL!x@!P6;C+=XT KTUi`eM8 HF]dC9$Us}l .2YU4󆦠V0 a7M > *3'Y?+{Bp^HH(Qe5mޥ>.SVr1@|endstream endobj 346 0 obj << /Filter /FlateDecode /Length 6123 >> stream x\K$7r7| X :eS䛜VZYJ HؑNO=Zvdfjs.&`_YUYjvٗW6Uͮ#lƥ*3L鄚]os[V‰>ͫR°WU9imoǦBxV_5޿FmW~jxp? 3qK-8zyUb*n8=[UZƑ;usFSΘMpŭ xmTXVU⮬-7LJЇr~:_*Y/9&,qVJfۉzɶo" Ÿ WjfiH{2PJ;Ä(9eŻ9װA֤=k/6o9sRxq=>hSo؝SI a]JWӼ߯zv\܆3ۯכMdȅ0L :dcU%3SRq?X?$J^ ^"M F2q⇹+8NgOFLcx~N"9*inm{Jw~~#mu10 :~Kn/7Uǁ/s [Fo"{39e *d6iOp&̍I!mTZTEttVZ HLiԏD#p0CG̟V )Κ쀢&^0 d]8$s/Փsxu7 IىtŬ Nh"Xwk_LUM.}w!= 'O%c2dR>)(Kܥdk 6Oh.=#dA\5oqsG\i4(ݛFШ@+7xcK#6:əq]>{^ugxkڒ[T!Ovcެiy`3mI+ޫ =DO8o4U8;2<{kκUqOM[pkȧ8 $ o x3,0'f蟹(J7K}HF Na}:D8Om6ϣ/Gn 2~4BҌ( V$F5Y ɜ='%aJb0,N]AE}RG}bTзtsw$p2dA_KJ97D QКXP*IR|UOa4*pFt (`ǖ!ssvF]b-Y1GHʄ.=v4񭑴P4q&kcCgDPD)LHC_r^I<*Ǻ6  Rnm?NNJhCn6.\ibMZ#%1vA@vfgC{JppQ]?Lt;* 8X 磞9JB@N{~d KaE.7 $9,֩t Ȱ5Qˋ هtu DK8x0.q9LB4y`) |J? K@*A8=2ߧ!2UO0}vF28D:2V=4"%mYAvGY$A<;E@q1 qI=5aV` /1ֺ/Q 9g8:\İ6ۏDxLeI8s%6b;Z='(v%p9{;kB1ǀ%q;ࠡ2G;;^ 2ޅ(46+8A}N?H]|&!P J[Ă{jz =K@B@F#~! & bKJ4D6T:Kc?e"`A sB'O:a~q ¦KCZz 8"!ĩ9~L[#J|@QdІ`XKkMgȃ]2膵QI-w4'8eʔʙHL(?Yzsc?U`08E3J´Fd'/h[deJ, &#pp^Iڽ'%5!qEFL(.D"&Qy 8knwbq0?N0~:PπAȃk4=9>-:!jηqA >=2fXگ<'i!qhNlFM٘$&UG u4($V iuc2N-Ƭ^Qy6:kXq"_86yFj{yL`a"-\^GT҃Xl`2VZ6.MEMRK3^w:Oe aSfS՞;,ɳ@=L#RGU;EtX,reďĚ!7DѶc57Cgu g 6gF^ZQCJmBg@9Cڑ 6MP⋬*ee_7k:52 iDZF!aW:Dppޏ3:X2BVXVC )C؈хT 8!7P͊?{ ̨@㓄Qр8~yUdKr y|NXu9ḁ0ݎʆa抁@Jsֳb9߲r{*\9Wn WYP YBCD\;9;.耐+P/ؿ$G/9,,\Cwx9/lM45ezcsB sYgD7 GjjSauoD*~,M%)#~Vusp!$/1WhT;H"\Q)eӍ)u?&uڴj4Q<.V0X9.T&Fe.WV.y ֧n1Ҁؙ{5}}uo D.ZՓEz&Ι>OkRFǷ21PYZAƺYw"fј` n}h Fl,mW ,Wť)jxb n+_e$9 N;xtfϬ^ɷvT`$-~ϕ TBqeWHqE6_sh][\4(/0s^Z@SIn-EW  deя'GbZN k\A$lŧXX~/!t=[K`- _{a`O(@$? ٥3Nw|9 |q2]h lWz2\3:Tsve+&JBX%{ wwyLR|;5_ ToT>Mve5 uod/p7LmxCX[-5ht2z>+6srh"P4y n%BJ8LcҤ0k*}>M sn+R4KCϩt5q)D"3f#4BPwA]*wQS:/h q]O3vo܋skQÀCOG掖wrUG:VjQ14 Ӆ¶x#%ePdݻ|o|Xo' ϧL!}%$]`uzU?(D[1I\)њ%;"UE&#ɭ/4R[>H1Mr?AfOcӿBBŀ('H}ER"%wU-𨻩ůPZeMNy/pb>R֡!Ѥf w&ShDKc}XKPhW2o}{?cjkvu;׾;C ; $L"*BF ^#|OvZ[rt oTرYe:,Z. &D X~Zm#YįZ(AUp˞%typ:j#hyĜo S%4 ^7tk% 7LV?!|Mwp4 /Ε< Y/cIC(Ģ'BODdd+Vl9ӷc$ KnN֛&O? #4Bo(ɍ؟o_9eE_ &B 2 1 VaeR+I3YWhPi+ӛBwzIkMĬ=1qޥAdOh:LcKA03̜/C 8ʔz3 X8殕E $)mߴ6&Ќwd_+7$*;|PUI}@^|vރ6}seA+6_WO_Qڪx] phfK!9b!Ж$I2eC). ;'S;o BgOxJNp8m @9: ow& 1ޱt}mɦ6κC~z>0+|φ]49v: _ @5#Ɏ,::6~fhwfpCpۥ)LS. PY/ٿݮlKVynm]y|bǐ^g>it]ׇC䴃}vw"PVR׈\041endstream endobj 347 0 obj << /Filter /FlateDecode /Length 201 >> stream x]= {N i,$P jgY5Ef>x;#ikʓG Vn,4FX r=)ϒcw5A,DEG>4F`1F2pUH$ Ib1$> stream xmQ{LSwmW,4vl$آ[ S`2RJ2,ʰ0TD#- :1t٢謓L6#~w&fa,;_rsr}GH1D *dJ-UϚQ"TxQ5؟irP@r;*TDPF&H-VrMK 7B;"M+(*l[Jقb6-63lf)*WL# X]ΪvM;u9ѱ%5WcFXM a:,Sa<"12( &%IziO%Fƣ I54z b4]4h^FeஸBm=ݳ)镡K7ҬT xTsI}dPHHw Uw 'i 7W۷1O:Nc^cNrn7?}gs-w2HJ om%r"yuv 0Y».,oi&pOFCK.b=#z8|iE>P^CFm\G'MPGPxgڿcg妨uby\Bޗw= e> j%+P1Ubjs4á:i=AGI3y3͏g4T&lEjx-U')mx%[듍GznGtRVU1뮬&l# ~ uoR/|JHY%H(hH UAӯݐ NLͿ$C^okOf IՌ(7ry+7&Rx؆6A.={!DM17ٔ:;|F5"NJ 4;GDO};`')(ߡut4: vFѥ6ՖYHjjX;|?Pi5n! ŲHWt +=ލthN1,Z[[/*>nimݭðendstream endobj 349 0 obj << /Filter /FlateDecode /Length 187 >> stream x]1 E{N @IИ"L ,}`)> stream x]_LSw^u̥etpj@BMBކJK =-Q "jfb6Ftfd|38E(9\ee9I{s( Eifk\o?洶#J(^ ^iY JPg|k4hƲڅ~C޴eKј68/iZ=MeKִ . |E}_ie{Z^Q3!DTh"z $ sQz8(S)jɅIt+ٻژ|s〓\]ZA?w$EG$8Rr} Ե|4z21v?u)&: ?U嵲~6c]/~6֎wkrs  sww2hH:$)FD<E9SόB_K[OwG''?~^a4ߎBeESP%B84aD%vͿ#j, #bq%"BPg&‘po8ϩ՟GDѾpt 2~ԙendstream endobj 351 0 obj << /Filter /FlateDecode /Length 435 >> stream x]An@ E:n`ɦ0I6Y(^@-" wE_K848sxzy~Y[{_˯zke~Km/uYNK}mܚӷqg- |[=<=S?TS}Rq}͹ߖ}ME`Y']7j/Bendstream endobj 352 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 5103 >> stream xX TSW!Dվ0.[cZ*"I =? @XdX n][:6Vs2v;q"j%FX 7308NmE%F[ eXP1 thr{tkJC"Ѻ`2rGthpH3fMF~sx_@2!&,/bӝW&C'*#CA 5>^K<tivDgnA-X֥)JF@6*k}(kWӛU9G_;T{T{*#w-/GΝ*ݰɿV}hI&ۣ!ͣo~ER[7'z3~թ=J'M͇VZ?TkϮێDaRHo8@>-TUnj 0h9g;`۬7}bjC"i՝~S9%E.4+ QE-vVb{D48kuϢp6X4;bD4p.9~wrJA =䂣WII`E+Dֈtk䶂 iӝռ٥g_:`a%wXNT>c~Ku buIM;J$ᴴF1LdMR]M]y3gOQq2! 5ԊZbAFJ@Bc\]EeQK$R F9]dSUoPTNQ* B-X۾',.Nުؗu8pnumRq)Y.2>ciX[L dtd tJ.4?ӿ[m"|TH좢x x']q_.%qW`-lb`-=CZ|mTH=zQ;jAGo=~!~ӧrH_#GQdٜ0 )Z<ƾx+|_kR L UBz^K"-Xay"+J+`vdF_ғJoz"8x|Yɡf4 %2nOM^!jv}U`3y^GNP4$ 'PP3/@e.5NS4@~t(#D)?5zssq r<wiJG4+hDQ]>1Wox I8&>-N&m>t.By.Bvq/*q[՛@ ROI{'DAVeX(tj UOoj@D@09!S\0$RAFMY6crWn/N ?5@)`٤K[ Vg 2HZ^@ݬ' Yַ@$HU<7f6sjXN4a1I4Cz9C^I^Gޓ*r0&=ӑWo P 4ٟ_LWȾ#=\C`}p0+Mշ#hY\QXUƆEM>8K,YV5A[8v_~Sp(ӹr5M^eӖC3V Ԑ Lh"gƎMYVI`.hA:"m5$o~UѓXgYM<`e@Ke<5@DG@Ţ7n(&5++M]dUqlPXJ^E= ƄM(S2aWnB"c8t~=g[)ӏ¦Qqa 1)5(bAz{g: *޾&aw*5 Mt2<gpjhKj$"9Uc$E{ĭpshH*U.yW+ ;#};|z'/i8w"$z,!Q&H{b4DjTvMR6+󎠉hƍӥ4܄`jvg웅GNq#$-hX7?[HxyJt,N#X V.*Ry:$qokmZH0_׉\#HP?hI#|XU7Da2+sus M!k@VދK b}#T٠: c^ >f$0B )vdMx ~y N<BT`+֘ElRbrjF&"hնGb_4cر"nW8%Mj 9;w&8>gޚڍRu^|#[Ƅغ -| ЄЫr9 =OJ$obz`ׂT/8M/^q[ܾ+X3֮>>y+lSM;ẇ 73ڇz鑇kNܶq'9AΉa'!uHJtM:G.̒Yр7xF 9ZYl{qgd7(I.?4T> stream x]AnP DNțdEX!޾IEc%Xwq<2ů0vKM%Ma6e q}k6sVߚgN9>Hߛk*>ͣ)N]MLK3^Rv}oYGG??-wF ;vF;d09F1P5F F#*V[F ̚sk+B@FK(`5 uF^~ f F[G/ nA0 4n ! \!҂J I(POCFHݑbKyF˒ƕs+wq4{We뾰endstream endobj 354 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 2438 >> stream xU PSg1TYbK{oVG-XVmc+XU<$$!<B@TNxAJ, l+ڒhTSZN{{(ivg29;w/$(H!8XY9v.!jn.%⟚?-GA.&7ISn)x7? _u"hvi|} FV)w*/TlKb&QThb_WmYy"psHX jHQӉ=)ZX8:a|~< BMj FS (j @BRT 6R4ʝNyQOSJʦΊ^ULjuⳒI #tT'uʵuO6L vM[V[+;gN$0;POzjYXV6l)<YPǷC=8t:_r;p5-;Hw__]J(KRҬD![0 l8dŎMv19#.gq'w%w;\˷o ~0|E@ۆM}O>4o$"*#1cviO?0OtwЃ[=cQ:ϲ}:S;V *%/2%1a k~K8a 3?0}}A#}g]> dTTkiXdu ZhKIv41г?y;;'!ࠋw, N =O\e}/ܫZ G:Xl>QB %}^VjwF~7\.$!Է^zb`:B9{G㸇̽m_<KޙT(OcqjU>V%5ta-ōP ̵9 ,o8n UmVAGV!%-YWƮ7aWht׉oiM6dNz=̛-KvLWHleg2+7;~ 34Ū`+s Hi8^xA|&z*VYͯBl0x61d&r2{BܿS8?|VN覿}x}'b4 MZ?X#gxn˜wuSLa.ZubM f`׍  bA`|?]ޮؗd58`|V/V֪S8cfn2$CT``ԁ 00AzxsM6@"@A6g~ȩ1VZ(vC?4Z2s-5Eu:a45q$akF?^6r|='Km=8Wl,᫿.ݯKUm;OP9><dӶu!V2)ul:ed.,h[5ViZ,bD@OL6&spNAK7].0n9;&d xUa fIԘ8Jgps"촋<';lh tyU8\r0RtomHW FXzw~\r 66_8dΉelp8DWQP&m(= jeRZّɎkԋr5>=Ř[˄Bȟm24U6VxE|֣oQwEWHR i$j1v /~ y_K.%Ro][N1⺪ h lD#d޼|}ogB\ ̬ʼRr ՞F7hƪ|I 9MBidח(TTI?ǎ CCnxތFf[˩#}'Q^ZV L>sMKK3Awߚk!o FSͯƗMm} ;YXCTTTb:TTZT\ZR` /endstream endobj 355 0 obj << /Filter /FlateDecode /Length 341 >> stream x]1n@E{N X{Hhq(JrX€0.r?)R0ex_|~MƔw:NY~/YvɊk|}/)i⣒{St_ژvqNa,MW;i=U5kR-@!zOĠ#SbELjqUϷx;*Us>#W P87q.9TjR#/Xo`o8H` V a  &5)3Ρ !(i5 bB PCNjr1 `lbC>oMy.F뚦օ[2NoyaWd?cendstream endobj 356 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 4058 >> stream xWyxSe?isz9eAȈ R@)ݓtMfk뛽ڦM5[JlBYv\;s|Ǚy$O9y~c`3b0֤,!g0)yEYKOEgD,bRgUτ8&8qRf1{+jPZ&-p ^zʕڄlik), Y% oJZTL/r$dqJv%F΄)w'|zO YMl# { K¶asy|03aaX6#b3 cR1L匵3Ϭ/vqxΘ}q~4O9cJB+B!FūH5cIz5}_A.Plʇ 䪥Rnv0*b 9~Ǡ.qw$ -~͠ԭX ݅ A#MN#(`6cӽ\&pIi,E`͋TLI~T*nqm Sne׎3eAU+(qd jr\0[l=ͭ#J P%phW\uĨjT p%*0&$Ё7WDbсChA>A׏1<0F8$U\X]yy'6蹷9RrMl?#N<Ȍfȥ\+Vу y3v5`=7hLbE($]N2#CѺj0̆*#QS1~ݐxMف0[g^v4{z fXO 9^'}ZhG WSKhw>80\(Pd2QW_>>? >@"Nֱ2.y&ѣwNg~ECUMb? m&=~y?&#akPX*JL ΀8ݬ<'Чi3P-޽͌hdК^FA!๕ݽ!g{Emͷ/-T]JC CɵT()|I *vVcdWS7w6S de'+t j^Q#/.fI@({fDJZ5ЪY2Kh|&Z'4fF ͰVJEZ#E8cIl4=$џ) p.z#4_$C!Ե^;3>߄QYNYׂ\ ՄI)2HP olvޛda?;Cv9)szDޜT>7$MvP=~!]evW7h/ s`!9bΌWSM&H\F1@ֲ{8}4`umY%]Rn4(-C'N=N%&-+_8LnMB52"ix9 ڤ [[$<)rqr6 w\`=JѤDN4˂ooEIjBaHk]& YoĻd66ڱ"񞡆mgirrSe!.8vz~?YΓcan=tqjyߤ3˩ K%~qzChŗQo/F+FYx3Rօj1nhXFs6wtY1Uj!+o$bO{mr4o$GOl /69$みzϚM޳+N1PvLr\ؠhl HM߿E~b\DӛXI8pI|prhJ\v>ǽbQ5wb`Kg)uwm땍eҜW?#‘GX:BIGNG}YAgN2M-Qx$ ܝ V eZYKsgs'zB->ZOsdQTR-0(Ag|/n1X^v@CLiaMK˂6B qxRIGX#NˈY|Ÿc-%%AII ni s#FJ*Z.fDjR5oՠ`+j 8 ׿%A/"ׂQ{D(+@?ISK}_vgXc9o_P \zdzxQIG|7uzoDU^'[l.ޗK6A[#DMiیV#c֨eoܪ9ѣ oR_XhNuhf,cq) ERRa`-Кso|F{6VDQvQ`x-7-7y7{sv~w~6Ok6E :?ZZ7b O)fd_Ț"r)ER>J2L1?C 4"xJɁ3#tnI٫I,#Յ,eż y{8<9*׏Cٓg*Xm6RgkҢ꤁X4-endstream endobj 357 0 obj << /Filter /FlateDecode /Length 258 >> stream x]1n0 EwB70mYr\%ClWܛOnD> stream x{tu'}jl|D@T(. bMۤM4Id&w&I'ihBZETtPף><9/8T|ݳgΙ?~sfsW`d攔uFuNyIުE95O.3V%dxH{&i磢x$\`~FY))*V+V>˗:䜼2FUVȩW$HYxNK*+9 e"`b{ں4ņ-۷-]尪DYQPaQm/(){ bmXe`˰guz,ی]/qJAT:$bNn}-F*iudҜN.  '" AuĚ'_rPf,|{|Ҟ"49Fo砓 A$`dd[ys(& J Ot <α>3h[!B و ):'E\9|!om&FP( `Fpmy)- 7ih08|&C)l Re\O7Z 4j$Z"|%l2lwҿt&:\@cIt4a7%C-pziOrX׌ZPyޱW>B.V&FE>I64 bOlٕ[QIԽ,jruVNqBouD`&ݼZev+)]f-cy 7v{yG󢨳0&~g!cM>9)ZE|"\uG6Op||`~_dfI>Z;bQlh=YUuNVgZKɺՅ}ruFDChGuOtxagДm ׶5tt D?aC }tk2lia|v)m9vcJSFlj ֖*LT]s`'T&})}?chH%R̚G9_F(&ZD&2|FL.K] a= w)"z>98*YTj\Cf 79J$ӼVE3!凌t5EF^?"jK/jqHDFR2,m0OU {gdx9/B縷}qX2'_>u!#YJU!&S$ӗb9}kX4s%N֡oUWW*j[=]Dj겙&On2yzp``_//GPZߟ^yͳ'v[ u` XOCL5hO֭/ ޣ̃#de it=|>=]~|!:WYeQ]屈d16BukPx)+v(6 zö`ARG[YY𔊙\NN?0pph4GNV7[%P?:gN B[_; '>҂I枟G̍KW&8힦0id9 14jMendstream endobj 359 0 obj << /Filter /FlateDecode /Length 171 >> stream x]1 EwN C+E,钡UĘ!zh÷dyp6QvNG\鈓u -OW**_Tx̀W5#Cq 0*7!FvHND Ǚ%t(hwcv kR/`:|)Vjendstream endobj 360 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 389 >> stream xcd`ab`ddM,M)64 JM/I,ɩf!Cgfnn }/=S1<9(3=DXWHZ*$U*8)x%&ggg*$(x)34R3sBR#B]܃C5p8M837d& e] ̌,:g 9no<}{KUA+vus|><_~ -ߴm3fn9.p}΅}N׻ga_fte`9endstream endobj 361 0 obj << /Filter /FlateDecode /Length 232 >> stream x]1n0 EwB7@Q Z%Cl > stream xe{LSwBJ{0"0YM|xbCy)P Zh9 "]K#lx-n1m:L0sYٲG~~Dws˲Ks>R( [YTSiSf7]}^CIsR D0Nԫ@CF\Ud. CpLDS[y%Wۻ'{)!!).N\J<6'7ȼ?/S[ϽYd{Bn1/Ǵ+m0nⲳVffq3Ӳӳ  - %$&G#6U(-A0G3F)@eS*K͊:./)7bFz'lL]lam8Q&(3v̳L7-o^"f=Y:P14dzH(a_'?b0cexGHډȜ]21ЏTOV)\u簠;p_kml4<$1YNf`kmnt^_ĊvL=V #"&c}Ѹ:_d옏D=f3Qj9LI*=aP'ث r%^ftkW{q?῎c8YMr23ΎZz݆y.>iR3>UC2 ˛}M\=q|.jrXmYWYvAzOe~p]8#=+- zVvQ˜oYb>h;:`0'/էKgu.S]ہD}I}J>܇S6)5>if> stream x];!Spe_>36^a0w o̬ZX$.$0vۧ8TwQ|0Tha6`}Ν13[Ŧ;1 &6[lmk؀Dl-HĖفD=HĞ`.A".++$A"zM`eb2DLj2Ҕzowendstream endobj 364 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 1511 >> stream x]yPSW_yy"*kF}j*֊Z  &)V'De (Ⱦ bDRKqTk}L?w\akCx<*ߵڭ׵Q #$;ن‡a:+F |>>ZD)gϞʝ )nqZ}b\"\EMZ1Z""JV*Jź k֮ ;Avs~:  HH 'b"!#b,aKwyɼlRd Cm\PC>hQ ] ErKXmg""]B7|WK?$T2\U,j ڹZ oϿ}9>ҵ6L& 4$Ɨ,%/^_)4X~s{ȉ=%9 Lgz9bolɱ; LNr_;Z^!>Ԉz⍔v T-+}X{QK9= i5GJ Mkv;/ՄHoUWKٝ;nP)?bWWZ&]e\65/"g/QHja8YXAr(Hڙ#G b1Nv% 9P,,Hp>Y`/f>A:$yҤi)h82 pC(A.xcZLNfD}? >ػK%=4# Ĭ.32SCyLˢsCa (sa[#Aj]󙦜|YÍ͚b}J\9f#V(rC ǁ5ӃCH7|PJ[G&Adshw_jkaTmԪ-o:;Tո 1tDf't:y6xJ%BU)auB{ڰMuP&0GS0٢a 6&ߟsPJ-h$sͅ7K ӫ"1#/a$bwOY9ELs;{ B!N !RF8=Vtl6 O \iK+K-1 koXȞv:o8ZÔ%Ͼú2lMx9CB4Xtω)K?&rW2_/`hgwK.lI`Qơ:vȰrN:8~ *>gl7,Œ!W$u\b֛MC]Yb&3jň49(x@=TSѼ)]3tю mǛu_a[b\zN@:^zp>b%5LOai.J9VVG2粪l iI3* -v}c;uZ1uƑg-豷3kMMyy?~IEendstream endobj 365 0 obj << /Filter /FlateDecode /Length 169 >> stream x]; D{N hƅ(Xqۇ"Ŭ4 z6X){/Tn tXҴT+ G4PW RZp0H;#8ւU&'WQyJQ,#L-c,nM"_Vendstream endobj 366 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 544 >> stream xUohqir\ ϋpD4D7ZC,n"lWۋbe*ՂAoz;9a]{ÇBf(r0,܊g<a2wxJ;dV, A 'NrɁh S|;lj<x@|4#ng&p<ޠ_r8YHcXÃa<CH !dAȏ ڐGf:F;tj zC՚Ftmvg+79K'T]C~^U~Me8,G&9pe[ԺP+.ϗDݩ;reG!sQ8ie%3WJRnv!g w^o9˾ xN| ?&; J}UJ\Ձ(3wuGkVEfm)*S%O fڽos^gnm-Ğ.+AYeI*/JKK[,V+\],+2?Pendstream endobj 367 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 664 >> stream xuP_HSqwnӦ1P7 Q$KCbܵ8M+}۝1+ô7MC Pz! EA 'ߵ->}LB$YpX=F갗4͝6uN-R9(-碩J$( L\u8{\V\,-TRFa*L-{uYn`juZÛ-8LLinjhdn47kzҫv'2mFGo5QCF%AH G dDh&@>A?۴+2][2=Sw=(Mw)aD0 Ѵ'P|Ź{7nM}:{Y1M,4+@( g,y=A8<в *@IM{[]tm/ [zz \M5k5h49v-oͥ%|i^-[Aԁ,2(Wx^IRH Q]~K*LѸ[L`p xs$>PA`(: j0G b^**X rA*qH"0>A;h NH熅2dʚʌɇXx$cyrғJў2 ;endstream endobj 368 0 obj << /Filter /FlateDecode /Length 162 >> stream x]O10 XЪj8(NߗNN>ˮGֱ4%"@cQ8LT'n:?`5滞H>K]VBoh)jI4J 6> stream xcd`ab`ddM,,IL6 JM/I,ɨf!CG_nn߿ }O=Z1<9(3=DXWHZ*$U*8)x%&ggg*$(x)34R3sBR#B]܃C5 E!L 7xgjv'`Q]G{M&FO={GwK/ki(᨞^h/`ziܵ QeU)e yݾykM{1ǂ9e1!s~c_قSM^m5n9.|Ε==}Lóa֢){20{Cendstream endobj 370 0 obj << /Filter /FlateDecode /Length 5785 >> stream x\IFvw\4(I3Ȑ0Qن6 Ve-tg&KLfUz%dfZFI-Q?_yyU?]qw%~{(ohʫwܥ+g\כnnZ':/o~ʾTСTya+&{o2k5}cVJvo[RmSyQJ6>v0*jNjgl7v2v˦yX-EYe?k،lz n|?Ϳ5Uepl *תRmյ2ym-lxV%P ~mev\*LZT|MjkS?£bG@YpGJ}j-t8 cny,"k&cp(4U$L/6Ʈ?D~]dǕ zПTd:idgL>uG?kin$ڗ*7w7iM+-rPl MڪIN90 lܨ5|bJnq[-C 3I.yz 2e8C,Uv-~s/~;P{ d6s/*uH:d X(P#geyw$/AOcנ/x۔ju5kR(uԒBG`\=}@rȭ #P9WYMI+--Ue9sMf"v(JA3 NvI`kw;~ ;эyXvL&kT*qn=XL]aC2qnC;- F [ ?쇘bKc +G !kyf `,۪jʜW܌uQ4H&^u0aopMdʄ-<bDm;q# j'ϷSWR .rXR(R(le ٹݿ@^#):&M]%&{=~s $}h77$MaL DYUΫTEn tqsMMm^:L6Ot4i |M/Z:mK' keYL'_pwTU104"/㕕0ԠC:ayAIHY:2%/y2{UgPkQM n(l S*2}֫kG."PeI<iX2e;jUōpɸ& g$x&ih BZwԁ"}? h8}xm >i{zVp܌$ pvз[SM{Y"LfLɹ/xxǰ u8Mdv-w\;^ؔ5 vR{lm"0#gDpr'??><(=Op*+A @N=BI4ʸm"e\UK/0dg#=G)\s+Zz3?M~ oߚΣ}{]G~!%u֏f:CÊ96:b':ڢ"DACKhkXK"?v/zȂkuYn LQܢyTIF "n1הSߧ,sy]!CP LrU؋- Ouau?ߏ`5T3?WQr8cU=t9 >uj_zi2ؾfv&߭%fm5ܽyGEG'?tP@lkGgJ#>niFY=Jπ.Q3 hޥ t YY-bJ='tt [T5jV(}^%4}Yb+ Jo;|&/upl¨s)ӯVX/OK&2?oϑ]sHKGX ̿\A$*ԄI#M7jAL[@+S? ퟩSоs< Z2“uQ=c%.$Ia:yH uq.)ov/los[IJ:ʭ6A>_D *4h즲%·xark4:,)q b0!%>$<}\=?M!](nj:m9 <&Ap!c$`)T-+`9)$3iĝF߷dw@SaCsvw$Yo?mYq0\(|,n$MX(y9<##y,Z@8p>٥RDC'x5(4jwo9`G -]H% 0I Uяѱ]&5 i?~F (|x'sJa{ܴ>(BO`QF_R|< QN<szb#gď0@4n%KׁI|[n*9Ni1˦T"81h%K>[wPq"~=}! VZrCS|OR㱷IπڴXl,,[h/d +Π Kbw~7fޔQ+PO^-'1Iy2Mgd0e/ <w Unė A>0; iN%{ ԊY ㉪&Q &8rEAʗ$+QQh8&!= rlJ_"ܰfjEw~Ne%;n~Z1"L85^|M+D#Ǻ,˒(% wJB'>~I4tɵ^\a ٓ~q(|5øv5yh_$,x%wEr+:A?v/RVsxYb(– %k΄~aDBN~r~؟vj?!Jy.#U(\]dpX ~j Ԣ!c̸s*e/.V|kgqO_T+X3щ5G4ihVPmͪVFJ}qat\-ou4tȒ1&c$`jM%7׎w@c@']p*?)eT߷&@O}cu C6O/nXss9sF2tc$ ^݅_03ΉFUZCRVztĶLAK_f=g`௹OUԦwJ a)*nP{F٣f^=H:Ú QAJtJf*v&ݓnrEnȋHÛ]nyˢ4o0y Ke믏c;n;移]oOz{C%;B5b]!ܞ-&b #((՞Ѵ6˚t[x.j: i|G3H,J(֨=^?DMPZnphQhi6JK!\*Xx\fsqM-ʲt1LM_f7Hn85UbJ-ߧC#&AW x%9 V2ePqZD⛥LV&m/XԩZ;)Z>B9 ٥2 w885E"Y('ܗ1_Vb`QvL4EJ`^U%h d˃b.x-k*\5ke&w sUGhs'D}Ӕ! O QOfsNj -y3*!oK'^3(^_!>x j2w'k'\:Fқ8 u^BXtYߘ_Ěq(0Ľh*x5n\Lވpendstream endobj 371 0 obj << /Filter /FlateDecode /Length 3468 >> stream xZݓ۶3BK| C:[;_N'Nl$LQ>tw%]q&9 o~73>?"]okd6|vu{PE&dV[\Y.dagy! -,鱰,YRJ8_w?"zswE 3-Hu`v~_ 4 %dVr5["+FҷoU_}:_` 2k v;>loe9oKڛ}=T}$ȯ$ႛb2+ۛj{ H2 \Wn9VW(މg1}mYǔ<.(G:gQAeFe4۾8ݷ~l4F(K*$a'/{|f%[C_RC 6m{ؐ{zmxبLrKKnbF=pp\ ~]NTzY߃6x-xxE B7FIx̭ 2H:W0! 9~uq$;\Zd,4wydE"X 8 iyG!M('@y`bd&(c5x"NО&2?4?DpY4-=I(D5XJ#KyF@LX|Q&g^G43]=UW߹;$zs=!E ij[.D,61JvUdVh(C=J}vr1ut};d{ey^XeղoQg{j?Hzͪ-Gt"uZM;gf 6|϶-}5JԁnE ^4Ƨ;Ƃз;HT m9* r%Rt1pCw cX'{ѹz֞a^.dTr2L.A;HICm~8_%7WpɫSfV™ dFυA-B j\Hĕa$ F-)n{)W1A2a'5 ppB"4k$~^9!%ZG^aN)69 QХpMnEDײjښ@${T(ygT ~(v/@umyP^1dgd+ﭿ6WDu]RA9bᴋ4z#-N&qӁoTy Wi&>[&]$u+NTKw=FN-~LDhn6(l.8$Z;Sy>XxԶ-({"ʼxv.h̸RDI}^(ͦUpXMB5I- 0KxP"*nvQ79 #UG-Ǫfdꓨ j|ؤmc.=S.hn?zܻa^`z6MHr F8k 5aJh𓖊UBrj½R/O i"^ om  . a ɚa2_ZZD#5(qy">-2i$b8XE@/30 7CO2b4{H*E&uM>}Se'`o6ѫq( "LЈCsͱ|JV) [hdEFpLp m*F'40& Om 5A~=vZ3u߻rz7ZR@TU& λqO.4Ez mx8ڍtJoU5Ac[M2IP3ߎE1chV6UT$$vg@7 l9$"3vp5+-Lyb^"/Sw4֬jpiP?l| ]IfkA9`~~Al<|E2W wTZ-{a['$B7dx .J47$/8t˾9 ڌ*>UB K̀A"3IPMpzZ2]H>sy4h8ؗ's@W,!].=4wJ5{vm?}w#H0YJqpJ;ߨrG *de.?9#8Ǥq7ħd¡wfTջA$: CEs%Qcd(: ^)LaH13;Nin>\_3[PTxa~ l4)Ip{ATR[D9U>荳48uQ@G2&,ZWu.8;ڎ `J7*\]J1J[OF2ii:;Nܦȑ.[<ᄾgkRq۵[)UAU_yNj >p8THvQǸmKIp ͓+t#C%2oVھee!L6N?THm{FiA#5;I/qqH7ΛC_;EsmcoJz/YA |џoB?ҶSt\",q9ni+Z Ld>unRu1`S4P&OYB} *3AﶧlZ|24ӵ2qr;Jz%=1 &gVб/̤JH P!Ku-OJ_fZjy$>H'ı[*>xLT-Pp5ț],*+UL+*trN/%&"L,Of JTA.gghpi#uVO%U nl2;`+K*VBwBWpD WzSI9Y 56+Mpru2Jft7X0n& mb*m)h0a--bƱ6ሁMUgE}c6ZFAzexL ZSܹ/xd* p72V^^Z"^ KZso`|nh Np?/מ~6,[ꚹ;~]]aendstream endobj 372 0 obj << /Filter /FlateDecode /Length 51450 >> stream x;϶[߅D@Ju> 83[`lvO{̞CB>c!8! $@HUU,Ԛ}֪U:&￤Od~헟G__-kiuk_QYOz9o_'gmo~ş?~\k=^?exc?sE9>F-窾/ov^o?Hj}͕|U]#o~k[_s__3V'e2??aOG]{s^9?پ~\?zٗo?槿sgrWz~ïkw\@;/l}I0E<417g m߻Bmӳ_{|W|ݹ? /s;?K׼GŹyrWooMƆ}%^:הHKfs}!7o?3虼Ǭ_{;ל:[kmAϿ_~)}}t%}Χv-/1׾J_ReC?J$G@>V;qJkHԹ?8?rRvX|׾YSwZR8>lG~ 5|>&/?_Go^ s/Jϳ=~uS}$F?G}<{8,$[KIOh\!inHƹe<%{ս@2?g6p Gysm6/ǖ]y~djMNrV.4\Ƒ ?J^>FYxB;KSƩOK_sn~yy<|y\W_>w?\xq1b["믞۟w6q <,%hwl{F%: :ߣM,#غc:K4C4vCǰ=M:ϕ{&[)|Oǚd`+d}ty,s`HVI}^sLlϩYrևH/7Pɍ? ǹTrnsk?z5mʖ$;E9#&Lɜ5w$DE>yٮ:Co%$gɻd7ʣ֚WU5S&ygNH6\(VIK%sz=P&;JHܹbN`QARsy`[_ `ϊ["u^[<.}Lל%|iyhvͮѣ9yxy֏ؒ"YX[Q9 -}E{wy;AX[NtlJϵ6i ;>f$UG2VHs"Yg(5y8%<HpI#;|TF*͈,o:]ɍp^yB2ΪCvQ 8VvAN%jcp3ɕ䙷Z|W&ϳtsgEɻOׂ4;n:\a??C8x`RUKu;z ʇ4# "x7.xc x{x4&`H33'GHZPY< rb66%#GRאK@<%3/&YFH9汞CG2KE(4H"ṣjvɄ;D1HG2C#xX(8UxǑFy0)Hw!E!;s'2G#M(ĺo*z$|x_3K$QIExу4*g S5l9#3w1pBcŹfq 'Ε@1X  cQ )RNqȓrXqĩz2fTSb8[c*)1X2bŐq`_z!2ʡgQƃ/7)!8]3ϸ\"vp"  ]nz$r"8E%v088;yvXT3CBYr3C!{eܖ{"/e M@8n6SJ~Bpֲ0m3$㨣 sڄ"|>Ad̩Iy oGjHM+y:v򡜚p$PnHDb\"KJW`bbӑ-}( Z]Jp&=Jq=x.>̚l(^z`–Ab$ɋ \ҰUߒl#`w 9M0`B-p-Mvp$KYpNrۊ0`%nY>*+Rs$&I?m$ dJ}wh\"&¯3 c/!}G@]^aH2 rHj{$ t4h=pphan$ !q}H}=JhIxdPU6P= )Px te{(ޏq.R3=7u3I6#X?zy 6W^S#J%IX7fYȱ8`VO5EJ&D@7R+bNN?@zപtz6<#)eѳ> +M$gt Z{#,*9Yfj,j,:%Wq@Zw0%sI<$O#j繭9)QgЎ ss  =SOPƹ=Wa_=!BHJLAIs1@*k~RB iVC ܮZܸ8ϝ $?McqI8BHQ~ؑ:(Ww |׳8&qUO8s㚞/]Zwd/Н]|D: D-V"ѵKt= ^~D sEjq~L6\$ppmS"]Ϋ%K"]o M]~Cв<JIר9HoJ>gBHoW}(~lYo_g}xJu6GUtZ)Du{g;A7+5́hf,In.x)XbhJƾ ٣H@ )"c~Sq|'Xe Ƶ KT)VaoHXIooEA rCcIv??(#jJieM , ?4,R8Jw$5I3,Ψ%IyɭF28pܖ@-0j$,f9J7h k fxN_^YvSdxR=1&D \J6%63$ 7Y'#I9lRA)j<ZpOߏdʐBqR8-_ӐS;{Q( |4EvyBHG'Ob]D#zѶ~'p4 \=<'p|x4GO$ۢ_30`E\KhΝk3}+kW/f |=5YRO6|MG5{lb9X8W昻fڽy{jKWfL/r̕7jZ=sƮ'Fkk2* h D!ƾ=Zut k X.9e _pE}_1,(`-0k k!ɛ-\DXqK<05[ʵRks l!-.p'*kKi'ZrZ * v;"v ]bH}$WW2m.i+R`y9/gi';*\u;7\]IVTd=,/khI\={ꂫֻ\#TUqjV՚dg]#̚jr@ <+gZ$IZ3^ UZs\jH)N,+RH6 '+WOqoj7:f iqt*r!D[T V)>l>|,0z4U=v>M4IrQ ^MCv֤#ɲ/9Or9}:nY/N8͒64wͲpD,|"}uľ'zWKlW+\=4 U"vʕrË/5K* ۓӏv8x2(r4pf|q ⸊lqI`NmhCU<WlU*(wi 3*!_&u\rGj-jO "Nmm={uZ5bB[j"-VdSYճ>)Yv`@. ^:5R6K^:Ux&PVҩ3X8OiCF 1,c/Eo){ZEwedv4n63fgNlb˝84rzHIT.矖q`\ΖIU rٶ1DR}AsdM8JfDL|ȣZظyEC'KS̥m7Տ1#QclʢdI©)Z`ag듼Ɍi"VԦ I)"9Fːcg2XO|^LO~>f"yBqޞT`i=/ب+Ojq= +IH8}B(G$QC`WʪHm Z#6Obh]Lϩx nO?(!V`Yd.tk'ik.t;juWL]Y  (~RE @)<4 /ͻ@6GFO 7_"`8 GC9LLM>`xTKdPdPfegPGU6֝@{jr _>X*xՑfo"#ei"~XxUx/scApQ#7rŢzkK`d+CbAl}cV}+$_ Tvxߘo4 ԥOXҼ!ѥNj |x|&cgJwQVIwh`齱KB4;4ScXH@<>,bPpB߁b<;455$)Æ;Y@kpy kw 2x#y՞R7M)>AUF>\Mlw> N9u6OOS EEDS@1,j0]ꝈgZdFoMEzoXFV$>QxKoر˴n1{#( 2c]@JHug?Y<OclFe @|N] UWc|Zhn3b9,քHg~Fְ>ο,a= lA>dOc-Shl&'&@%9o o~$ד\Pϐg |i:hU(wOeNhq{j̞zt5@_֌e*&㮳5Fa@Ƭv=5bu6&٘Lsgcz:ؑX&rgcI*zK }kw5&C1k`z5Fט$)5&3akE57}֠/smu iw61@c l6Xz 'l6vm-7Ӣ@m͊Cs7@gA`MNwcs7`Z0|s.Z~\[9a*/hY>9 d*BsQ][U;"FOñzsH|e4t8"3;7П0״HHb XER?_WoC7ؑ ѴHG`?  -V)_tX}nxE7-YP>c 0U∇o.].W;(^ܖP oDAu/ON2=o24KՋ&#@yӛ@ُd,⹐otĶM͛[$N/Ṱtja^/ϛ38.qZ'΄‡ڌNoO W*'ݓ@#ГT'+{XO4'M%]Ob-B'a]OF鎅oss7Fe)6t#wcP.e-s#t1ҍ2Xjyn$|I T GqHGOS #pc@L+D?I$G@?.# ySt# MKlR1ļDpt݈V%NܭOF&枑ݍF4oGq}m] fpNmG'W3t_3 ~R"7}r>8(wc0}btRo]>Pya]9U0ѓ2X¨ `#ˀ"e64Nt@bLN5(42:d@D%r>nÑ-AIjO[/SYH`x=[|b﹌n.\V.GO[7xvs!nWH^f62{ݟӇ _fד=}qby"ұ͉?`(@qa>}B Oxb7o՛CB>p.lfsZ'L pyZq`T/]?. B:{JL*Yӆ.iuݜ&t#W' b7իJدKH .AcZK7#^=أANwwf#saf\ =.z}O=>oKE\z :CFb+==6iz=btx#蕃Y`ϝs %kOϙ%}޺;㌢;0*s/tx1uUm9ߺ7 @/ѯgZ(qM_a}BۤX.݁5t&̎لmi7 -|nD&Wn Mx`bԞ(:8t+=5t&E@tKYKt ;}/\z>Navf@̇Cts`9z&=T2tÅpsVvdY*7`u·ʋ$n񗊡fWu `$rpӡ3]ܼ#lolX>zw  .*x֓cܛQoG?GjOF=X=\nt@C`:VwPh9L\ROSa?0W#gY ˵"rSмf\7N;Vz.k9>TN;"%Kr}jEn|&P NXD?RYsfсQ{?PS #lL,4 7ܿ(b( %\ )1\Yޖs '#0nE ;cA|nQ4bnlcD_27cBЖ{ o5Dg}v𿤁6G8S?k]-Ӵ~c ɾC\JF_^e@_}#蜿-r.99sg{d+EsU6AC}aկy=`ߓMrG;fMW c7KX\2b | ЌLz#5P$@?5= G[g0鵥N}3y҃6 G?h)].\)--cкڋZ֪Lد6~DF75]3"[ċ HtOsl`0(_.CL/]0)W%o*yQ~WBGGĕdWnX/\+3+*omM p/sI% uqqZ&&*~Ih x{_;oWĺVPК %p:bAG&3!mfQ)ZY~sTjRX];y׭jpúp1pǠ޾ԁq}+;U;?:UץG׃q)&YD&Wpkj1mt Yh#vO(A&#= ߞH5}Md|ҩϑ\df;VJ2a+2ϏY#drlL%{N/t>w$$?19,26 !;֧,Ӄ:k 3|#M[ O5WڕJ@se?\ٹZ6`7i45ŻL >*7M*L _ܛbφᛃ&Շ M˜z븬.IU ~ lX<) bV8T/;BC&6r,˨nb9T3i=vXn1P蜍<T@])m%.ǩ o}nN[ rTj=KKk/8Jds9토C~*tQn8QypHGq||򫭡.fqTnɌtut~rh O <sNl~/NIlɜ^9>؁ձ}04Elݖc; 9oOlçGctlǣ$*{+!L$nU x5`ζd?؁~x,~0~T6$ُ<`~'љEC>9/;㠜 |f?h{_gceŸ6?A bo}Z|Gw=$exF|&WgN0Ol좇fVk]KRgwl)s[f. yl|g`7# wZq0ój ȍ@J;z< ź(^ib?Hrmv&ȏSqE.H#^۽v-? mc/]F/O%Rcl'yOa\/7 1~nϏF|Ⱥv&coo6'Gvmy3 QAi.Ij/]g6@q&s: sa\Q;Z)ow (2YkvYPxpm.o%Kׄt]"mxsܥÒqupvl_{hEib&٠҆pطr!/K+]M+7/ F?NͫTҼF^r;?&^4LjM֗rפa4ٰݺ岫ٸ7Be鲣q{/o*邱Ӄުإ_b'wD}.qvf/eԈڬmeyGV'͞E*򋭆w!K73K#q I}mJ-ې.y8[1x6-.ݎf%C|GCw'ΎoƢ(SAjz=r"l!iY39Y8,FYɽj'wMqyܱchNQuv7o0X6F \ XQ]A5Br!ON`QwqAyHxD3,2?/ҧ G*6 n[jU2.f?=It6ڬEbv@ٟA:G$wIc}|j&"}_6N?{Ǔu}!{J;6%al,ĉ&h&ޗke^Lj#uem~;Wͻ@m.<]}=%ajziV`j:id?շG{PEjCu<0ՕPl ՝A eIpTǰC3Y}L6Owu\@,xl%6&,-CuIm.)-A}} 6#zwx4#\;[U4qY}[aOnY2V1}MΖ՞?I}ppZyUmX(f:]6&m=d; =i+)gwl欎JSk+s NȓO2x:٨}D:~m\屐WKO~.I}3([lJ֓(/EZ&>>SLzd=I2"H:\d5퍲ooXI2^TS=*;? t=Q>ŝمYS*-=o/}43Q}ZEYh_.3jV6՛U^֝U9´` IƓr/6'wV]:'gfpEމDޘ!CtgE#O/l7} ?ѽ7Ir>~%$wΥ{FܻUkEf,uouoO6zuo{ȞJE a#Eϋ V{jB7Sv"m[fXql*y7m잳d.̝5hF.3MA~(4?&w.w7s)}Wk:xrw)]Fj݋y'^rX x\f_ћ@KK˼/h4mV^&:[LU= g੣xJ1Ine0ӌ bVKJKn,x, !?6Ҟx@{l͢vvFZbDv&L[)S k2;X9KTdj[3416|o]%i)254{׃0ghЋD}s!+252@75 sdzy5XMpHwaF(@zZsa8 <'@Ҹa!p7זO`5\7j=O7>-gF0Sv VTȀm "kƀ%,Z.i!F K/.BߠV#ǧ')pW.766md@kVNj-dJHjT tR#'ZFhP,h-f(ڪ  uĀX j]i/ >$C`FB4ˣ%IW@0C؝ !QȄ): #NXx2 xɄhoL~B0c‘*)Y0%@dO38b t聚1̘P(}(̙9&(P81BRp3@rB/r Ќwh}/nVa6-«b.q18xk/᫩SWXc+LnWq@'yr&N`!q!kmČ ؎s& n&g9_AdVx%Ê1"_AbG_V2Ͱ@ Dlь:Ϭ(-fq>۫]ֺZqボ8,@$-sѬZkhz=ØZz@X44=Xh H0h 1s`Mdw7<-*-h)T]sӞx[rXؚn Ϣ_Ko1fx'!xO5fyby75Y39uZ~<2"IL3cટgLvEWE_7%Oc_A m}4_O/͚.=fv,UTFjW42 IG"nfg wIԽjlb=IXy#??Z1՗ jQEyh>)15};n=66= #@~ܗW=eza ZYF S_DG|4| tF տ߸UmN3cMC ՟ޮt<:ֶlQ-@uح|V\Los媤}U)BFi `TҠCPȦ*ܻ6nruV\PȦKV \1~yU0A4l7{f[Kc gޘMGI1H TA#[jP4-kVGjDj{5iV;rmY[3q p- hhp][W@]/k)5]u0硱!rP¦r4J+{|NԹ9Avh^?:WB<ѕcڋA*ɲot_7mx4#k5h7[bڣ4ASuWыK#W/ZP*AW O!1 V!PЁoAi׬"SSwbƫMvsFWYeE%H}BkST ^Xd@DTU-*ASj:jfWߙ~ӫwS7*/mwU "3}Ma h@+޽]k;S-1X%Ϩ\D GOnFKMa*7S aWaͳ͋>zv)/n6֓A*IoD N?@EF9/DHyPTHO!4"I\X땸 RIg҇ Ilfs]d#`&- }^|#j"®q!t!հl#zM- J{-|ÂB(lnz xt.$dwyLV,T wP)@bwV6`n [^r^> +q7yoݨpj!mAZTsTO8H~ iG9ŠvLY9HJ#U 3$Ur(,Y~LuYXU&y^)<7?/`Ez =u׊i}>:%UVىU.bv}ՕW\P9Z皱Gߜgf_ζ&[&50ҿc (߉/etT`c|z!^~KOauE-K='/_~'|~_~ww~]_~_o~''/?WO~/~_57Ͼֿ׾_7??W/v/_wOo/__o?_oCB9Fi_g͏=;mrY~|^&RQ2qql6$?9yG$ݭTп>epL"**{6_<i`;o3 +I޵== 66fY2wywLq$U]:H@ɓnI{ܵݭM #, | ߺJf%.(l޹3ݞZ!pgm68ϘWڤgV9ԗԤDT: fK8FIV.»?)IS12ZRXvoXKr?A3C%-}Rɥ7ɯp0$׫8jبuV>Yì2ҍv_ %1l.9|d qG3h8kݣb$uAAHk2~Jmɘd&g -]U/aZLdU2}R)mR4MhF2H) z~" Ue 8VA_{LkZIJFe%:;+1p>% "]r& "|MUi]BԊEJO*(oVyԢz%(vx?+^-Ҡ$M)%[j<cdG]-a/i~ &MJ:ͭ37{kʬ9q.fTi Κ?cnï15A ?_bΔ_ $kƟwCF$黆o1B&AELzG!'P gre㾘 $4!4׹\RFK/.7?ha0]5<}͞ZK{(\+=jiZ.@~:+zjG*2e% u䩕kE0g}]J[`U5.պ_[ҮsĮui[!zgWx|-}hZ`d4,Bb׸O.-̍ax$[t,#zd9~:vGEփ5I\nMMNkE iܔeOMGRz[hKKܘ4kpIDX58bD֫\HƏz&nv(M Tde1!\B:CıﮆvFWdZNx͡L1gnp Vrօ+G]H }L3Di-Yk21T}JMҚݞFtUJRF4iW*OĤ ڦZU'fUbvZ) [*Kk-SI1Jh-B[7=)srD tZ1Jw˩i50&wj\`Tu^ }s*8ji[%%i@Hq"81r\2"i?4, au8;d[0EXdFCxs%a\/يQ9W H-3wQwUpuUD$K0)!сXyB3ʦ Ij-"Y1RJ]R؏RJfsC/Nnj&1O*o,H(lEm23v$ڠHp]3K3rJ= SVj# >7=>۾a퇆teI\:GH;nҟ 2 [G/ilUp8rH]6X0Vj RhBQ3=F]8N3FBDQ6:F ӭj1R!#jjҔ R *$99H+5f2wM- DCNɲhqiP;:Df E1%JRuɡt}a㳗%CWpIaAU'U1 4cU^ku4 #vԚ* ʅ-M^bH~*itUiӁimܜ=ڑw(Ǒh#Zxr?Y#P/Pɯʱ'$Ftvk<4pnv|w RA]PK$=g}Tm$?*5=.RױT%`hX?"pH{Qvƨ~? BP\@6CS953uV9UXqp$hJSb/rCO,hf:ov;f:.6.H_4쉇#D^ 07Iv>RޒˆZ_D.a0Pi)Ks=v#NȶWcj4mX~J,\~Sp d@ʾmmzV:fws~9 .6V!n^]/jO$;(!3.L`# `bSwօòHʄZDA YCN=XC؁iwG254E3E u{X/::.mJ}:5ͭL!ٖ.rMkIE|NM7H<[iSBHV~i0O6@=&AnV#8Xmzjvf . EζN/_%JY[(L@i "7a#2<kFjlI:;bV{u[pʧmM//DR~`5pc4N]+]wſZ5d)AW֭cҘ\}C~Gi= ܗD8u.U氶OG/$dD$n/Xvz$SoIx"| <>GV]7QL #]`EAJy7HUbh~jYCsdQCFӥ~>+y`nXjn]Lve5b.Qs*%+[gDl %hphrDM4Li5ŸL]ǑvLmq/@w҃4[H]'mXČL>+#瘅բǰmS.@Y̱ZwϱU)`l:c]^7H˰/:R߬Nd';AMU&ЍcϜbd]'hD 3Z'?cq,rF qyr_z7UD7DS+Nta6͂ sY!W?T!ډ9S$39 zmE 7cP;:wN$tfwΌ9/ƟlSt^KaZy0lg%b3R/A°?yp\7Hz%w\nˍoْ,ݻ]rgVT>SX:@)p45]bTyAeTrQ`SroXL}_l#T$dqv)[;{|3R\- .;@3d\=D\ [V4]{4Z%^pb|2VUYFE 'p8-v>N+O:Cc}W7S1To'=W4U>/OZrY:0 0;txBF|v`nMCXMc_FqTM&e]I׷u-W}K'1dlmy= "'1$p-na?߽̌q C=B^Ob6{z \Ob~0=9xzEOb=imѯ'1wSJ7D-=dE!탟0ם],۰,o@OoXUhZmXs(~qm؉@a{)߰8X1O/r?kh kp'q}6&]5Wx[ nkEO7=^43zjEiItJx*?ebhqz\ &mi(^@f"2]ژ BB!ž=i6NC݊o4HEm59K5`N߃d|] 5) ;4`Hx^L,2~M_C!58 &;FV瘍#NkmD/o8 ^Bz 0Ylq!Ŕk|Q1sԏC!7*wPx^.C񏡃P?y]z/=82sc̺qᬖ7O$#4ŧC>k &婕yfIħD쏜[Ge6J-ſ>[ߐ<-^:[P]݇ӀBOzjr)%6n+%M\Bvm ^%໮)^ZD1GX#] PtNz_H'7Wv(x=ԟ+eKu>Pw#[w ہNU_gwy˃A9}!w+컆ǧ3+:=;sٕtqv]=yRݗuz)v%i. VܟI$qQh4]qp=V)ٟPj'Uڞ^s1>$Iݔ;}P$n>GʣELM'ioY Ee)DtwrJkD't&V}޸GOuм&zdq?_NiO'Q|39E07^NU믗{B:ܧ|6%lwai2Ѥz9J4kv"KGyA/W{95To2UroIx{Fׇ{9m> @Ϊ~tҡ{9}ʞ^N'e3ش>`KUs/]5z9k_I}k4:=iZn ܹS9 ,s{IC[yS-667\Nr<gIOLߌ蚹[SҫA; )C SlnukX^Mݖ|aӴj4J~{9P>))p'gRK&NE0)5.7{vT\irDW!(D"QNuu`kO^QQGRT27'v},9H蒎zI7[(E?%ຟ4 '=>;:ݎ[ӗ%cזPyקጫ(x^]'-,5 ޔ9 o٫6N:]zos^io[YjpS* YH6Oٚ3_)ۻIAښ:TY'JCuSppZ߅~vY{]Ja*8TdX u?e xtPE C}W*{ϲbD ž&rDmZW q$ DeFeQt >o 3`УF0GH !1`8ZY{Fnՠ2{s{=ֳb'^"ZIՓaY}ҭc9}昡}ߏúP[TsWylçʓ]Yq@ 'x5b=M#f3Bc43"U3 8fD҆ G퍹t+8ne1؞Bxa` #VlCVZt塶 bƭIpRl?mPpV3(*#TnXlC@ԉd=!\an[K(OK7+.Zn[EJ5vﴬeo[Oz:w@2Mzs6XMטކP zjpn'هo6ݝmB\ O(:RIKlUsTjS> fz-R;+A'T 7+*]a _c,vTⶂ \X<$5$YGQ0vc=[92cXQi= [HPKBRѥZƢ0ӕ0+s`Pj2 ʮC:R!;VJ- +mqk5ne6bI1֎\ڷ.}لqÎk x=0Q'j !&BVq1^UH#$7NEb-G$6}PttQioiQ&RcfȒ7?uoDt6 ~kam<(,: -O(W4 dܻ-IL.t&cqE[gbӦCR3QR/ A-/19 "AYR&; HS@Wh:)ٵ+XcMkC?WceKm%tl 52JpYs}>՟  [EE˸.M/=Jå Yc[ٕD^Ղ]ŷ"uc?&{?+? ,wUYϴ8BtS]K}^%p㛜^V90njybĈ1TlZr^;R w\qɜxQNLH _EH ZŤ.QLfmwЖn|.Q-k-]L#x4{ftl41<.m\:6mtM>QS:v tdZ>~zZRbIe]GP#lUPw w)(SnԻԎ>H]4ɭn&󠦢vV-n-dMExo^TZvf[;byDRbwn R<5b+6CRNDaxZn!]-37Nx9Eihd W-(sFd•2< ʭ\•zf*Lz1h!QRP69kV݊>|ՃܡԮ''kf*imcm>s55%>r(1Wg(<Fc6Wլ}<$|#.7fRjgwSz=,D]A9(\)qwvIgz\#vکW0/wP9i>D;-w$g%#Q_Y>=..-\BJhZZN#WY>p.\iϊ \^!~ =\8ߞ ~{tn3 8`Ӻhx =[[i~{a+oϕ~{=o,j]$Xɟl7v[*IWE߁m)S 'o_Tb]v;T([S̫Az切ۧɇkpcͰ):(8Ċk@94 (x1;͗ y]YQ 6IN3P*8MtsO _!]5/Fij?; dH2u75o}$ґ20:MNȦpw3m$0I?%)%;$%ZE^(Qbk]zodnO^kItۧ+VDpO'g(87Ļu֞KhC<'yh/9>w]JXLٯa[kX#G=ªNm\w溻#uA9@\^U*S'y#p䝤y)i{}R~cM,4b9 U KT6h&ŝfPw Ё9Pc׭5kw\BOJLx@.Ga5zKR=yޅ9-bU l)iH)0uT 6p-faͨ^M\E\Ѐ%5Ih:!388OfϽxf |f=@yf):#u_j \7 ]19]j;"8ǭcd}Z74~b,k?TbQqq4A_y+8/y)0CeWPT:yifruNmd?u62uCVmd)ZkW6Pö+Cs7WoZȧ8Lt9]C3]]ge?wM}OFo"43ֲU3o6slXAP/=ҵ]->ddZH 5D4vm #C\OCOԭ;E/+~ˑ: XGGR#sJ$=\ ʟ­p1մȕ]]c;ꥊn }P-K2!Vз;Zm Mz7qQa߳d ݌=1x ̎f,,IA1LFL\Q;bۙEfLo RI!5 W }TSqmP(hs7( Ž m`(E ~y lPH|8o84v>"N<zaOrўM ȵGֱϮG;Fr aibtd _Fl׎4Z0y"K՝T;9tAE]+;K,Գ%=bvCd *%4fvAֹMp6oz[G,IBgT' t:72)E먦:E{ $!G`%}?m%X#l,9$ y^#>U-d8Z,.qnVksl!OCq>NW8mt\sgisڐe?Eٷ-?Ɗ8]H$p x3NY:tY0rH * @TGмЀA48V< Y@t1@ GE5B@;5_̄B FI+R"Y`KF91- I X%q8נJ:֡0%>m颗PQVcQ74 P m D%Q$Gʋ U7Lc27A1p1"?IGGjϊ\=Fa =5_߹F*ƥxqԴ 254p CKKCxHǐH |]>zmA1LxmZ}7S {f~k= tuXW%/oVбg. 5Fxa#Jݠ5Ye055B ,THee /Hf5"|w9 m@ 8a}{So ,@lRӱj!6IrC@QXi= T&DpŘެ(xU#@5P9nXؤq/&ξPHFs=BGRb"A F,›dUd+Զ`x iK[lJh켥} K+AG;ibN|+f3ca{_{6wUHlo,óLc]cj2=xLgQ2N 8I!Agˠ}iD0nceSLLv{vB;<6(N+ˌr{)Q XiI.3) :ZG.VB0d_F f&L;V\f=)̲hSeeJaCkVd~#Vb##օH=<dIJ7:GCu D%#먹wone,^iRDL`#.Xc`,v"uHNwaEbJ*ǻ\YA-!卯ßn,x'(e]1*o{zKzscNFOp 2y_\zo Z8Ry+-B$kӓ~A)-9?)[qIa8F/{);:|Pڠ qIo^:1| `ۺ}\78?h&,Rc@K x6$>qzTrO[QInEg&ܐ;;ve!;iDWxWIj%m 7)hPzE9ž9U9>YeFxc ĺ'F@vX&pRnTje TCvT'};-qxDߊ0aL^|I&5c"vi;F=6EwdP~A8RA3>ڈ>Ln&LflRCR emXPYlH,:⬆De\#f5k)˘`H?sJܧr#!=Aiѓ6!>$pjR ّDq{p>M]a \ƀEfwwaF. ^4v D0Ӧl0FhY$5IM3 fZz30u`{a c߯2SFQh"ZaFjDb \w뿵9jԅצ9rm8 n5#a}͟W<gB6v6,Jϝ-]I&,D@⫰{h[)lz?Hf p=;$iӳY d$hb8s'>4_*wZL2qU*yOtMw)@w!tObu@Jܼgxr$ޑ#Ttg8q!;Mx"z?nd$Z"a4@Y-+=Fe$#VK3CGa>i*b ʆ#ӌYd:RCq9L዁=Hf2uDff^{,yXz="<@f4ud`۪of iшou!c4bBl R[B*c..Ukw6 "I[S51tBc1n @E^`Fhdk6s؄Mi}Mh:G/!2HB4<yaJ {"OY$Di孎>IѤ˩MF΃JoڔZt]y Sv}TDDn/o:-ECp ?!$1E*VB&ÛɌɍ7pNU`$%6g+{:  F!"B$7j0GQF6"酞$5蚤]ML&I}$B2ѥŒ(#0!S[P]էD"9HqrS1BJjZf6DVi98HC,zHkov,S"ZTU%pdBRMcztn&n"\?P2 PڛQw2P֔&d&U G!K˿N>(QȄr}fBvv+d9?2!hw917ͽ]ro-JPҦBv?ѓ7R!+TH5Btjp">|>wB>fV'y06%؎=᝽|^koEn^<""pC)"?KdRo@\>ad|e08;k@4m^O=?MN,ߴi 9mݴ{ڪM{5D#EϹӦEJ!b).+&Qf".ө5]&Lt<[Y}u3ih=RN?k7;6IㆩlR.8Xť& r^:!}`nH?< §̵_!@ 3;Nڑ M'=R# UM@{4|iN d|\| V93cȀH7 lQ*#pw#O#?v5xuA'CS[@%|jЈZScçH1dO}mɞS{u>'#{8dO>L)YGMee|SӧJ!%|* j9[~Gns:nz[aV'l< o SVt',z +Hvq U)S11xWTz1gȢ'R=~(6hl4D Rɒ9DfD Vl9.Obg/'4 ڔ 6ʉD-l-dFb@F6d$R*aGa$RI.1Yq&M,29͎[6irT©H"YͤQ(TVXtP}jᤤ#k"ږvce̶cl$x3V&`eaO#i3(C MtX7 5Y+01zVQv 90r$"ce2#Dǜp a(niaYxQ#9!c aDe2?aFft_aHƨdr^Gqd?/d#[S$b28JD:0^c*H02cipqPMZȼ\GQ*F0cJL5ǐy:*] bdEj`I` 4!^E'+R6uU.zU6rUz^ӘԫZa^(1Tecy`6jP``rn|u+p"/EVzCbn u ~kG{ &?N")e 0cpńXJ1XW`[[] u%c2bdp=2c,up`LzxG#j15c[Πܱã` #l^ cL2!9g"0b.#bEvEVJg #(Cb3L+!;þՌprvVNH$e8˖5;\ 2y!Ơ=6{7.DeX*u`:')+ͭglIێʪ$ar 6u|w ybEԈ rϐi3vl8ekՁ5$,]tGONm#:3 ʊwuI9OK4o ysoMPmHvKn~$wrJeѝѳn1ݑُDyp;3,:{S:JY1DtNΚDˆ1̦tNκ;MtJGt|5ۜK6c1p7MaLJ3Yz@;b3@Vd;Ոj'j"G9Hnqo9H40%@.Qu|n@'ףq9sV/Ӌr>G -2KN,!wrfV'+x69Rfxcs%|sNk4!Dq8^(~q"0Uא<8B4EhAu89S2hTU$8b34NGl։Nє:<ue "IU/yئqI?lIMXFR- |?[4Μ\NyA[u4 ]6q8u8N+%MjX&{ύ5ϡ8`|&!3PsmW|c)U`tC|YgH|1gt<:#vLg*TIetha<2ms$fSx']^uҍ6Izg W=hp!3ۜO!gb5gkB64dX$tDbi(̄,_+F\qLb<$ȺvCý 'G ȎI29Ж47;F +aL9Å۝2$,+{uD`|xnIQӿш83Ϡ?D ys"u_){ϯ?_}02uFWglx7e:":Ow36&tB@6ޝk;LXy6zNؘyqBƜ;9F,y!`c%G~3-ȯuk4"m 1ĂW#|B~FPخ1JEGNȦ" aa'5P,"U3T[vǦݞBg*ң<\EpbAhl6B&0{9(LN< 1pB!(DP6-_J68%#R5.)쉠x(L{kQ)qLrN3VtGPr#D.G#sZM.nP,#9-w_aK#D"#%αQ(ޔf63KD#A29L`rFͥi>>0#3vD~u0&DbPg ";AÖCP1N70[bliŞˍ7+%kt'E2*XhE47F]H?q0Ks$sS!J?ZEٻ 뱏t먼uX=]pH\VܙnHڈtP4Յ'6\4DBj_Ǒo,M7̅ ]H:,-|!$bK~R=[$ 4҈ r-)H#0SyHC}ؿY\#$h@0gVפhYY{=ҳ 6wÙ0GRN]>itFKiDzR-cc#Aap9GRIi<+?:%E{!D{ UUhlUAUҹ!#tT34/G"H:&? UmH$(X͕#CGsKAF"|O^#{mHAc6|4jt bYs&<36{w+ц51UijX@cS 9ALFXŖ(Fܔ/LI)`dM |"SDtTwx"8x){)% U؍Z8:9BM"oؐ gb i6x`ݶ}X&9Cħw1EQwC>ʖ9M='ͦz.$ἼT=S۠\V?H6ۅ07㤵DB37}a1cVEǾ%5G@8F0m#%I/7̲wV#~N/1^#FI/uUإ쑳ъ mV9:3*U&sX #%@HN+%kCXga`.紲_r8&Ő;yAjk^/եm~@O =ҏb*K_v7(&D SY/m~e_W_EK~yž7ܯ"PrH>7@_ҿWeg#R5Gic4H#9>D#-VG-?iAHsZӑ&4a#aieˑhE9?rjN餿ə,!L31kGcd{q0H\WND#2yż"xe(㽅xe=dlF`)$|^KS`;Τ a yn@rydp9PQ+Gg 0y%==7ts̵6$t#s`ٖWf$eN0%b{n=vMa#ʮ0 /;6lޔf0Q>RݥP91c,Ӟ9u`i3r1f3ٝaLhF1%vaGG/JT%LތiY19=)k;,^LDYWM²}7gp4| _>Y {^,,DWV;Ã)]ip<9b]/H<D9 \lD0-ge a~GY̌2@Dh”~0B8/Kq8GGPv@B;9xGR4Sz:&Ipz?y.NiĴo ʍj%d?Y o 9msy7.CgWzqf.(p: \97nx%(+Y!IYvLYepwY7 .;5ϦF~ OHw20U~o )bl7@ :@0LH8*ӈXølp @4$ uћj #YMU٩9TJ2 X6C%ao:m'A do eRĂ@۔ n'Hcc=2l"OY‰@ 5Fk!w @, 990 baE H:slbQ~FHO ?Ԝ:!( 9z$8 p2Áz{ 25:,bq}@F !Ӳ ; 2 0R>Af]S 3܀8a:4hջvlÔ',f؂ax#IKWDb1wBF"A.A\@oiRԱA(3" r`& ry f6DFQB%-$B@Kkn .]\P*?7M- ؠrbFs#. 8hɳٷҹAg90y,2~zHM# d-;6HI_f\&f}CgxZ2&#R47< 6?0BS {U0b[6G˕_ W!zZY73HޤE8</F(+ 31b}*O1GbDKG|Qۇ%xqa@e p0#br4G~ɮ}4ަJB^#60,HG5 ΤF] VC 1tӏJ 3(.^] :M0ĈxȊ;|4&Qc"9&zk(nQzmn׆Y?1SP4`E t̾;3wq1HAO1ku6'\, :T\3mDMT&?QMk) '|#9ATD*آgyܸvyߋ-pgkhO([Cϩ.)HuLO*sZ&5lTHH4VT>VԟeyOd>RB]mXlrt"MWdird8>+>Z rt^ވ% 9eק7 x2K1kM,ڴ1ic=NXXQ|-%[[BEPRscKSmLX QXIJԱ+53Kv:vںwt[`HF(Uޟikn,6rw9{޷FASĦƔA0lW/J &jyu݉JӨU)h`K^vV.ap;Km%l6y6ӡM˰*B=`*FLZ  \ԫZwط2.!LoxcXpǐj[T $n{xQŤ(b}ff8*cJ}{-G=R6kϚWTt;(W;;40p2a2) z Ѷ?`/2\SaWe|s_pc?cRڎݨWOvϸ;+%LJ=jJeFC7=]&{E+a7_kPie 5E',PjକO)5ft Z/ / U#g8;dEa-+F`rfH9N4iAm6., PX) s:/g'6qMT׀Bto3h7EsP,8f&=$j&I:>; fB?T\D77DU쥋ߦ8A8u c{g1XQ^bYd8ёZ #R9#j%Y#GO F$'ԧ5~^xP|㓼':DBְyFΧ}XNt&e1aSU =$wͻ^4i_ړMsyf֪\8qȉ kӺ=i8٤Gڡ;NbZl@ю,$2=Lb6`cbɒ|A>+ee{.C;&1FE|4ߓ#=:9e=̝G0H㞲tf?X$sObYO8qnIܖF:p CSlUDT\/-EvIDI$Z&ȘDY鄣- =& -eݯ533vb^=j7%{]3= }yg sto5<G%FJE0[u MG|b|iigrI4O4~<|sO0O gGӹ&Z ăJʉ# ~i~Y##ognе<6V xxeZDjK~5/>|!OBڕɛ<j/]w?_5Jfw;ŷ8uό7]ӏ wFIqc2I cR9NGm)lYa}VIϏ7.iR@ F,h??Cr^Q]-޿z~[f{g_~Cu582&RuȤWA9=/$gU+Dyo?{WI{ݧ_az_ q9:>%%E26KcWHӐ];mD,xxʌGH}6" @B,޾ #Uc-āH fGQ.(GkNC./y_JO࿊&ꝑk=D_?Ͼg/g|=[}g/?|ǿ;_W_rݛ}/?o_?_տ^_//k_gg{9:,Y$0t!~='=X]H}{48g=Gob?ۗc\ߒ '?O}뺞>~oqD;g?_h7y: b~94IN+Q0͋U_nWX9f~j)O/d]⬣z^)o?y'[/?TK=Wo?ǒ}kg}/ӷw6pX׫>v#pO׿{%Z?~M^v?鏎kmx6_oNj G2#?g"zY.{z<oݷ8Hy/f~%fRn"k)}oֿŔwhO~-ړ~TjQrt5?EOo?{o{TIXO?;w_^ӯO:WM\9\׾|>>?9W;nf:|xS<|4t+0?.k7?˯_}ݷ_9y(_׫c_>}|K{Ea }_וy?/x\. [[n*&76dAÅS#;|`޽纹W-?g$2]\н<φ{Q?/\t~uugwa//ÛLfƼ+3|{^z'ܭE?o$ZI7KeDWgȯJ\Skb ^Q?8 _O4xvZk'vH-+_Ԏ'A( e$o}__L_v~øv_!+?R~gG|纞=-W*g6^Lq/4v?e?y 1ENvy3'kXF?m0~a깯#y䚣;׿wA7?h١OQ=ѯ?ƿsT "Zjzpu)뤆6[)ȑV#sx@X@JʋQL ~?)(r) UOT'~?G9VxZOԫcQSx/pkut?WgxW a/+j$Gt:M)M\3 @q;R—P9ba!T?!TΈwg'Gai^G?~I?oNW+rh_jP,4)!9nM=N? ;|_yQȒx9- @/+.I%wQW>*J>B<|ek' p%P]yYn? BT4?:$@˹ )i=o]!pxK~ݱ?zxnTx+ov\/?-e_8a%&v}jxLul,ɟ& >^Sqiߵɤ,pv̺~nls/Y^yVuN4y-~M_=0 K>,q<&J0hO ԖnOȧVA[9*?śs h?P5W!C{~=᪽[wD"w>B "H(^9T_ 0~#yYEtfɘΡLLAKy_#޾u{=C8&'܇+Ʉչ8.X 'GM. oq|/ї_#7Ǘ\X`-@u4ywih%]W'O ᷿_|}?Wo? ,oKUs_~ỷ_}} ~{o^Kۯ߼z_*Ǜg]߿z^-7"|vٸj ~4?}is{2^%u+w%ϤPa?ۖ ykROOy/3j_y'_[Sx-*kMgn|u+%> stream x\IFv_ Yv'I003ڰ`̨ >+MDAч.&X/U)+]UW\ wûo R6U#]qq]kg\wB߼xֺJUcw뫟HhPKUo2ʉ)>6hϷ7+Emb_oVJѮC]*]<Ⱥ*҇O ˲M5vFsw#Jhb4x#m4V}mŕO&L|O>.>uw\&^8)҆euN7 ݕ^)SrvkUCN6E:нsW*=NA'5~aԓ3NjvڤC|G٦q)[ٞ5 RDu׺8ȴ#q2W"ݣo.l-.6xQaUdawv/-LvUA}RW <0+؞+ Jy?p7eJRNje5fNФ."4.oVZ#MJS:[5ܴ6fd/`3bQ;;rкDqCҠ4n"Hƫh%7vzg#R]u[_hߜ z4V`? m%kXo/`~Yէ?\{LP:.h1lrq^o{2hg^d5ۜLXj:qmdq8FrٶTW7+[)0-M7fwW8r vk7)}ۇ6݇TɂIRJMXZ<#d8S"1y7_*mIGqb-SəPw )0y!(z,`7j3ՖLD^MMœ{"QЛ a  {(YB暐`}|¨K" k 4(qq/ {]k;L8~9 |_ݠerd;?C KR:9bгei=&6t;;[\̚}h\ %wl+r.`hH!8,J50K@BᕘVaS]XZ Kp`%TYp¨p3']f4efqCFM,?Ȇb 'THxb*ZÛE"%ea%(сA1Lۯ 'Mr(ٵ^"*dݗ%Y:9 !ӈm1jg)icC/(WD{v{P/Ijed76aƳk7nmeE:fYs(=bzGJav ; ;Z+tVN~5%P -o\L:p` LhoSA`i]fS}1!KYes8 -\J",V*b_yq{M8ӊMR,:ׁȬf{SO4Q, =̔߳4g= 4+=SK:8αjQN]h'i)~_@ji}OȌ*O4>^ MH g[,: cGz SDB6-&k U`vzJnUm G:[Euv4eh슠*wQE|с,Le4K$uM~nAۻ\q!_[&+Ѷj 7Tsc< ucR8DYX? f!{cšƽS}! :snȉL, ngpTэS\sl04c۷iИAh_gh}^h<*FQ; uCO,RR|BH8@誢DB\f.0! h*;sßAӳ\]9_Z4iF9j0ϔ\9q *K5|cx ᗮɫAD&0"R,x7!=<< 8-nψN딒MC=zD!_WRa ERY(0&`j%=*lBL$' -#0e4|2Z1M<NW,8&d)6)+/Ya'j1BH8 s0l2A^O1{Ǘ ;SƔ A6QO ያb&Y)6q~[tcI*qM3JP`_0M`]hʹ$21y,GCgJaitCVMMlB`& ֔C^_~W:a!g2߽t<'~Ò*;J5S2rh9V&eB>ugӘ^!+/_m&O0cfGF'E j-PlaC|d#m%bA`DҜ:x[ {IVaG(tEE(OɈJe&N+AY(6jJU,~}ݯT426VaM|Q,*h1¢n~̥aOK92۴(˘#ԓ/I2־ jʺK6{0" %8C|nA3@h!1$ۄg9e=z,{ vYh c'4Oͬ?e:Yu!2lgy%L <iWg i.:tAsS#ci: H J֝rstdq̅'&n]i%vvd&D3ƫ~ߥZEx1zA 9 9#ћsxr|tRC&R:qdiiJAo%(^vƏ)| ˠ01] 돞"bn Fpԛ@h$&zZ)16|+4Jq-qv\9$tH 'JnO<8RZʞ(">YXa>9a쌅<bm"Ne)dNCbhv`З?u} kɞJx$/9X/   {P1I,S#+Auĸ`'ԀK}w\nZ2h !t)7!3Yĕ|<§0’c|rsɅZbW"z$9dC 3~йeҋ5Ҡ8/ W0MKQЇ1paISkHFkAV,%ҳN^"s+~,S Vڋг倹\Y%jˇs&WDF\?AapMI[~ہ&޷ }Ƅ|{B3D?kvDz),wۙHXMc"+g I*6Xo g*(-%]ȁ{"+c>4sA}Iv/Zd[3j%$[aI-!:L3~cvGn W( ΟβNRC*XeZs§-IiRD1IxƗ;Uu_]*>-g89+9d ))/Sn EEV8U2ԼgZtB@s>Λzy/ҘHmq XgSе?¦8>#|xҌ'?9{>|wl]UFi0 kT*§`VΎPˀqx}x?]f\|U 30z۫u !?*5F֥ML[)^ JA D:oз*S>|棢t6 >B{.?IPe!TqK2t fQs:ƚ \qkïϖ +-5]1!v>}o\1\$CKtw~@z!AA[ UpNEr 5QAFko!= e(`| = +*.OŧAY@OjRIPKHQ"(yfK2+0/a>w~o=0 fA,Ө0K}j %Gm3xęVn,1B]w@XzMG^:t8'?0 6< =[8 > Eￒ7)5~jbo>h&:n7_7ԅc)lE+eᩢ/-B+/ XR P7ta߼ȘHY֛=2̐Hts?фR 4 =;RfTUhi#U_L"ɹ 鍰`b͘/AsWb&̃1MDJ .㨘G̩}`]*.+K0/1ܘfp98v]%3Q􂧿,ڡs> stream x]=n@D{7g6v"A2Th33S#{Ů^_mXX.ӯ~N2_jjms^{>OOG߯ԗq~fS[_/Wwl6xzSP5MA}`}l #ԑԉ#ko jg=5{m &YSP6&#dd4l jVSP&_k5|Wj5\MF_q9.ߥTp |SRp*8x]NfI@pa00kvCgl9s0 d2@ RBTAlv m* BCAl%SI` 2 LA&!)$dbԒ%)$s C0$S I~J!8srM(iI%6)Qa r%`A$X,ȕ`Q W, JE\I(X+  r%`ᤗN{JEMO;_ ^f_w0},Kot";ߥx\ՀJB~endstream endobj 375 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 7181 >> stream xY \LǥUF&b+U֭VuHݠ.(**n $$$ jk뮨 ָUiD_> ;w{8PQ׬])tOxkfl?'Z3wq_pƉ=pG>Ƀ7GhH'4g͚3cuoLW=B"1!A{z\;u] Nw'45"M+6nr]qfM_m7HQmoE.Z2fUlGtO5_u pc&͡a>L6}]3^Z9ϝ N\%oNzʋZHM6P/SI&j2MM6S[rQoQ3rʗZAJfQרՔ5^RkyZj5J Ség7稥ʍIK=OQbj4LqrP.K ԋ8j6 5:LrDJwX3x;xkn7|=4faM>;Ygo=6aDĈ#G8꿝JX GGpCoI1^c|4']$\;l_0㋩ㆌUj{8A=ė'FOm@Voo6msfF),䒟_ հ5(.amF}>wZ|@N_A4.FB6<,I`H[y!֩s(T\FrGchȉY#N Ep N{&b[SNHi'📝M4ēe4'7jc1ģϴj(; b+Bۢ0j{/M^Mm]ULRX\w6͑7bSK (@I ye^^~ASk+GGw.)k6Wʫ8N_l DPU %E) X  Þa.<O]E h+zՊ. bcS~!Ivp% ;j0BCfRiVE5 \N݆9l r$[bYwjl % {,:ǎR\|z =9ܳP qW3:#CCSET 4r&hAuh.Y6YG`G`ѷ4A+H1A7NِVcl8T7T6IPӡ F[S F/é*}|ˢ'+7Y`x˕oݶ} ;&4v"?!e'ˆQyaqQ@ȈJ+9\NDq"Ljem J}Y}N_'A'Se3݊DHGG[ q iCؔa brd+ _~f, J3;?5͇:ccmMF~ [3ꐌ (uN [jzJjzw(;!j@&侐dv= +CIBnm%~RCco覨Dpc)*@RF[҂\c:iu :cHc3t.hsO2i|9~13/HiTk*)II^K}M4wq|l]}aN%Eg!Rȇv0V"uqn۱p+ a(*;(˻k<v wׄɪ9ٹYYمY$-?xsdVRq.p1Túdӈ^a@d Nhɤ/|ؖ*T/[=:hyQnO>'X!'?+kuaoG>o}_6ӼZaeĊ4Bc̃W=v=\Hf JM`IJ5Iتc} 9R<qpG}I/~,Ha|?vWsFWg%SkLW ZRESˡl>#j$JktI_/\iKܯ7Yij#w;)GxdtѺu?֥zJEoٶMJo,߫E]?|nRz?-?w k#Ӿ ? 9תZR YS5vu~|Gks3kAzAm~賏##^$Ru2+Me<8gr<9דq-;x1.k_>{NO-CZ WT/~WZuu&,N[+_.,?@|E ;yy>ВnBm!wSEb-ɶΛ643ψ--"YvM(VDFANPpI4w;{֧lI23۠j="3Ēl8ƻ{}!x=7%nBkDhM:ʻ'D{4UV+4TnZGhٹ}TtMfB`?o9PҴ43}y)!e;]fn)TReq0u%:G`bN2o \tԮ|0gq<6/bc$WBJgbb!a+efd~qiX 涰KНLq)!(a?3կqv) @|C{}vv<<%aVZ瓏k ua;n74f4=#j덌Hv O~َgKNjgX-!\z&cpӅ_ݻ!b}MO`@{h։p1ZdC zj@&ވOtuts= QXOڀH񈫯>C^9q= /#+!G'xZ Sӟ\@Ä˙=Η ӗ>`wj~ekti0@HJD~ըBKH^* y^?^D;SJ!-7d>I&mIS J–R uKH^Kx1,L!+zB'- i5gV6Sb&ܐs]81Krc !.Ѱo#OC&L%UF-x3iz<O]-P@D^^@OѠGDh6 5${A2Ⅎ켲|Y#Jhj 9yz<2hBv0@z uNN O{rFԁm$(~Fn2DؖO D^>axS=y(sb yAD&D_M 9YQk mF+%'icϔAO#OrcN߉{>tWo ]c4__JPi%xb"" 1zɳ9THvsڣjCB5ڨf8Mݤ7b?[b}D qx+4Y&dkʡ,EG+9Kqdi*I#@t"Gؿ& 7J@c':OC؅֠)h7nUw&~b e:VQB:C}v =Mg s+6yc#^)m&{}रKhӮ. M]5ºwϙX)iEpX+_ L)k.̰hMW> G҄DE6d$&ҬZ!m5H%5sIwnN.&5:Y<43tt.8X^,#VIWERo̊ PYtRlrp6Q'˗ ,̓Ƿm*-,jԗEʿ@u=| }%4!u. MMb$Ň8EjN+U窚6I)YݟҬg)tA^$4jEuɊ`"B%?D=vv5R e61#Jh4[ZLYpDzM8k2siq<0TOmYߖ!| D;bJb bܻHfwރ%Dݾ P0hS$%UsGJ,x&~6ڇ? `)sn| )8[rp(9}4"FI_"dii 6TrMDZvsa!Fᝯ:P/oJ/)ȃ~4?V|#gUG>-?uh?גq4%w"]%צjc 7|f,F-22?EK.ˈc ꏓ9?ɐk2Ǔ Δh:ޞ5 _@M9T7W쇼ޖ=vE cgr;(ڶ+} ߋ>n'84B <q&$*[iT/g`D;MtBAw>ω nwv wK]Ұco2HZ@ZJ}Nj2UڄYAjxɣUɢ7f0*.yal^N 8z!|8/6HK9$1j,Kǹb_L#G(L;L-ȃCWG~NQLbJʗh3eJxNN&RM \2;LNEʎ+|9; t K]ȗADdR]h"5~]D$dXv:OO"YJLXmB^E,؃W\%'Ɉ-Ji*2YLd?vc?"A}$$%hzҼ\CvQVn&ɿpۍR<鵺m?T L-CK yum؋C{G rؔ%3LÇwdedYΘ,ßcendstream endobj 376 0 obj << /Filter /FlateDecode /Length 5571 >> stream x\Yqsއƾ%MQ̓ICaa֪={jZ6ka_GDfdV̮1tgd_YV_vwS>|#_~gklF=.VjS*okS2w++ը=2USl׿{Gh犾{vZ+-qn?kZB+HֶJª67Yf5oZYo^m)aʪ6[QRT8V|8s`blŰau}X]|W|-^?у6vfTS;?UvZew#a7ݵfpFܮa*B%`zj'\١gYW vJ߽(Wk[$w+`>!tBNڡOwŇnxOF{Pk[[lFDžl,->WM1 )q}'P+ʺ$# 1NeNйۻk.χ~xs<6y]t/^UڡpΏݒ氅v3;.5l@x"ُclϔC1.5H4KBn?Hi6U$L줪jˏQ'DI j-ls+|\i3ݶcŶ]n!;k*Bi:q1i %h5c3dc Kh~}7|9ēiHe!"kKS0϶eunp=*pCmcd<ʡIk8 s&p/(;q vC?h -T0J{2NBh)tǕCD&0[07]V 1=:jBJNc=ygh y5PWLKD&{IK2 SUEyye]UK90ѱ?!7HTM my^!¤}1sEOG8LP m$ u8ںD#,`k cBa gV Jij T]HUVp y E*HZ[5j;# #ޢ'T f|q`^ˆڡXR_e{[R^ 9:\#`dnօ1Tߑo@vs!6jP:Ɂ#* <0`CIwU855扄Kh>RJE#vh߬={$%==q؀an @Wë́q6iA8gj[G~e,zcVzL{tCrtO?&_%GνM~ {HXKنNˏ4L:ɳ攣*rn5 }\49S_Vdɼ3=ipZZ%ěM=wLR?[s%$Fc4z\nνO~E^2FaK ϥC*)e]'찏Az^ &Sut[rm A6&Hct2}孓ŵV@稔lXÔh@F:?k~|bwJ>KEB7W셂K:cMV÷i6,u/C% )#RQ"Xk m}4+`+Ee/Vv%a!%\<Il 3ƥ#AHwZЩn'IcLJf$Hgav|FBO q'REM܎U[Mjj(;*.nPxOsT>,'!d/._ qjh,s&/5ᐵѳIv}]ĩ1(@s.Z^3ͳ>R6ƭ Ll6`Jx& @6 ?0k]0 (9o)._gCgu n$6XR,/`̏fxBwOJC9s;Dz;D5s;Y ;?S6` "x17E҄Ɔ ~6UBp5z D~ XB5w ?06a:#^_YѾjYNsY <6-ύpeBQ񧯒3[<Q w:>Ikx;4wȷ|`YH(O/ñj:| Ѿ|0FB lf!JcZ0O<3d§b6:H %4f(_}F Zc(TǮgpC* fiUXT&fYH&_$+r9ܞ9#s TZl|53p]saT=6ف:)Kw֕#.PƸen ,o|ev9qk>ʣ m-~ @#z`!\Lͷ2M,1HK&*csCc,@(Vx_f8m]BךJ)yHVR8M}oJSDg< L@(  Gp k:v:Gu{b@}`čaU_I]޵:iYY?қ| }I5 2kO@d@|ԍǏ,Lų7)/Q&V\=8 #d*8-bt?M]T9=oY]v vYRH"ٜY(X|Q 0P5I?ck2ҫ+ot)&(/ZН# ~4~]$ex_9O3U=ƯCptRx%|d,LTtPcԽx:~vCdY駰u7^vIWDR'm{!L-Tv ?Mm {â*+գo@Ļ=[LSptjc~>֚ J:YIfʃJ2xJ6D⑁9 a$0,WFE3`ЅaBsZxaՃXa>ǢTMY(( |)8PʪLJL^c<aD2yЅޱ0͡ןr ^j=,GCxT}m>Ɉ4MA/3"g2 Y  &sw)sE"^.&DL )]zOnDWpkȭ%yc{Hoqjbe| CS7">ϊ1aiש[g`Mn,aL5+SˑҸ>8u^JlW,?d~L߄I6ejeLehEt,]$I1jQD$_CoQ05r)f V?U<5nI\Ǜ O"=Hx̍mrH_]$b>P3xJ\9_qP?(v+]{!l\Y<9\,ۘ/:=Ƌ㡵X>6/*a}.aWxƧ% /t0~؇&]/IR0>$u f/JʲV|uV Ō̧\.:׹R ~xqTT|A˨W=m6a4&6ƗsXZG=Z{ i5"Fo4PNΧjyZ~dR8?{7K1A=KUxTܱ yL& x7?l2AYj?"Bcxw`~݆5YۯEZ5<_ROIojM"ݖQ;ܟV`k ?&DJDÊШt ߛLOJow!%hG~ kh%9%F+@sӵ7]'v"C W$-?$-n,BUDiؚW *idھڳǗp4$8LN $}j`5xgG *_Rz\ Γ`%owcuQ#{mOK3_؇.ҥŌ4EV,$wHsrݠt4! ٗS\o b4j(|gF ma tQko}bI2ƍM>'E1-q}ϕfu&0uOSL80ha84~ga]`."Ȃ>>\Loa rpp)RpuVR:[}O)u_ZB? x;[endstream endobj 377 0 obj << /Filter /FlateDecode /Length 161 >> stream x]O10 b C 8QC_C;ɾ;,ڳK X&었Eu0Sat@vz"> stream xcd`ab`dd M3 JM/I, f!C<<,{$ݟ3#cxzs~AeQfzF.THTpSJL//THKQS/ f*h)$f$))F(+k; g```4f`a`bddY} d)_k^}-];0ÏEͽӧr=7QešK]tnAܮϺts;]l!/,!IzZlfv*Px4N~S8/*ȭJ]ƻWp=lqqp;8φ=zNe`袒endstream endobj 379 0 obj << /Filter /FlateDecode /Length 2120 >> stream xXˏ0 Jc 7![6렇b!Xl9+Vo/ƚWۙ;B攋I>WBej?-ha*N a5;*4sPŒ1g%hoX. hpFTL2 Z63gKa],Ҭ|@îrXJt\,Tz GErs8Y&mz3 v:AЋx/ssi$oFsԩ|l>KA9+sPWo0_]_C1YT6EVmNm LX&1ob:!2i-ʡnWNPS'%SX*AC2SՃ"¨v`ɸ`z.1Q>ƐպhjPG ȕ}G?0zr8*a.'MQ'ȉpa`e,lp"ג.KFRcF*(Pq@5,%^$[/09}\PSR0$}>.)撻 ҮKB{T͕>/*pL 4jfåݾ&3J(c:xK3# #I|cA?ޘRTPi3؄IJi4HINcRPhܘ'y+ |z1м61FzŮ] ag%xD@nS焵\};z_HIn95|1^ж,?\ ohx,:$jը}ʘHnbmYt87`Ԯu麁dQ3A)<[XUg Nˇj2 $۸^w۱JBCÓַynfEڡww[Nڏa}|<AS.=rUg"VclgK})c}Տπp_6N5"STj{cg\ntr '7m?5ūh.NkTFrzF?5g-_O2שI~Wݽb} *76F=T}d)敻>﫢u!zؓ;A1_G<+@ҝî>NEwlaQ;j\12ߴQ)\Ks]{B,%ћ*5Ihǒzoj!麶 4K->6~hqz~ 3Gow8ǺL}{0.S6Liy׈JVӘU0HH.M2쌗8!~D3P$[h&,tlܯN3W[T$Yp_uwա Ājxm߬fn*endstream endobj 380 0 obj << /Filter /FlateDecode /Length 7986 >> stream x|َdIr{D _FeD=CpM R9}13U=hT;f~ozٻٿoWrzmWW_Š}]~J߾ڕW)O}_^}77~YCvKf]Z04J*wㇷ7!}yw27Ņ#fE~/yu1"4O7>kMqN^T>ѻ(: λOMlINot>x}}I \O~8>}ŵvGp g}4?~c,~wlGL "+uw:>՚E?i]$sx{x>>>~woΟ۽?毮aŴMz }v.W ]?\-+\گz9z}"[Ҿ\ߡ!+l%KK_?_a\[[>iAR[߳ qNw\}`\f.,K `-l -1I{3}! Tn- Br*.iİP8pQ~_d SIv\<,{/'W;` #'s5RL> l (0`Rh"YWNKauM$QMq8q'ӕggb(O>^GZ'zþPЦƐVd -uG;-bhB`K1X]ŽwBcOWXdlI{@& '@"cJΈ_u93$j3O) M VEͤlwF$8ʨq.O aBh&E;zHIhvjLI 6ilQ5'Juk3]Bt6@[y]ԃ+ԹUdbb[AkĪ 8Rf) aA+RZ`"l! ]}jmCk W*Q(@g܎3Rzą – o4um0Ig* ֊ө#zB*g)V=BUK@/i%dvh $J5|+]D#`m>yiq+].wI .AuDIj(V<< A"- D^8',:N&-N #0%EG: 恭HQR#eNZeNGaF(>9b(RD1;Wk|}`fvOW_e  OX/Q` @IPJ̃aQat \iwMɠ=R3xSKYi x #fLlf *fprD@XVzTCLlRG_0A1 6d0ΐMq  FȐP dҡ2BPv`*ea$&0fBVT 2Tj؜s;&p3;AZ`SQY4V;h')1([pȏݧ) ZIiq%b-``1鋶11ؿ QE!VHRh+$aqG [ՍӰR{VA)wnD.''83r,IadKLjsrP^թ55FH-YcZcQը'ټƥFO#' r#UO݈p-67_h:8/>Ҹ{+$i1.2w]Z-8:e -#!jKkHp>Jzz sSUZ,b@{fSr׿qE10t5悄uHOi,K$#B#ԹI1:VWǥIy5j&` ZDu2(l1n{mDkbKռz"q8Z^Am%Y{"a-t6 p ^a5D+]'m@Yvt4"L)t`n4wͽOhD$eı:|]ڠ j4Ƙjnyk@9Ŀ= @lLyŸNJE eża #`zdў$|$y#,94xkF& #ɰ eBL_N)Ok$ ARQ:Ƙ\M:F2ALQF2XMA,8keA6zJ,l b7jFrI`rr@UfO LNW,ĨQn~-h۲7e \Dɾ%K2Ibs@ P=A-Ze) L[=Ўgzj!2O>X~JK<+S:25"r֬в@r.cjӨ"U#HsA" {fJ##`|UZ{K +l1|bf.`) Û7u (_ڹMyS`ԉIA"aáG轘_^29Z^ @0&%Y <;[c4#A=`NaԐwj CfgSo:<#p soP MODC (&uqE<Ӓ"1e#vg+w}˾ùt)W1P@  K |q+M(8ڑgNV$!nC+/'@ H`3aANg&`O5R VL\".~],:4Ф%{ -$2o&*2TYgNB,D>juf;7Dg=Dd,KDd+JX ^E K41D7M?l}RDe VV_+ؘT4"ˆl,IZ-o3B'BX,J+ZsԖ$J4KkF,,0@'!M'J_JVmM6I*_hYf#0@W`$=00BcX:Irj1PA@a,gҼHrtɚW4)P@c.@7 uHˆ,^OdQZu0d\AUrY-ly<29G%XI0@{,tF[\YcmPe^GK$ӬHB•^t g#UwxK +0 M"]]H#G$]Z7B<[X-tI+C!$#]8[ҥVZxI gyXbC!_T+;$t:&X]HsD-V y$`ۢ)R$dJ_b bE#^\aX54=$Ȟ5 ykid~6s42 :he-6$KBrGF>Ңkъ2} 1VZ4 3O5mkgi:CL$ HyZ.!c{^#7dIJ&30Z tݘrӌdglful7`lQ06+6eԥ.V8jJ+?Ӓ GJ~ڰ?d,#Datat3 eBBX!]C_TOm,MA51Ndct7Q:-06o-xe a=0PqcFǐh[:j#?*z3D}YFN3;KيܒD5*1^ԟٸծT+gEV8ei$4Uȁ_7sNY<"E|%(4:IBf('x:-eFuev"۵c,Tk*#' 5xծj'-C tuNR1V*^?/5YhAf8҇L;R ,4OzTMC,U|G[,D/YRyC॥ER3+:ND ;Zv.mĤe`ghDNkiZq9߲m-ޮ[Ư*W;a-G{Hv9Lsm~ v^}oHIf^Yvj%n5\^%np{K닗:8}aU f:Skzfy )wTY?;MFTH̿rftHiIUS}-ܯ1mz|^d{;-  <)_Oӫݚw#n=ouq{7BXV9Ke#*յfVI\|n/ze`8S_5:¶Ռl莘EW⛫羱4ůY_\ش- oG w᫧Oޏ;*~s;^|I|֨&doMP[Ӈig/"]:Ώ6~ɻ6kf@6MO[ǛVz ݶAϳ0T-R:/?F|{Nt1Z_%.Ozj<_0󋸦gS|jͻ:YGKgoƧp6-ח%:q].38(lɯS?r̄?/ DW;v?~NLJ8( bwFOף^S y !Ň/Aí=Y~e@l g[k#寺V;؟T4ʄt2bƿE <06}/(Jdw T9~PҦ&*Jѣ& sf X)>\2 X p-ȜDVmO>+b}!" qil]3;޼Ac`a`ӧ63<Ƶ'@l(7>?<|::Ϭ6_ڏn;mLt-W ૐ~Ae}޶,٘Ů$U1 4w3Z VȚVbU2bg86ƿtZS牔Oߴg|0=qx~y:%+:yĖuԘi  B̚_2 SlthM["ѷDe·_}GvS| ޶]-?!RcoO}FfkVuNg1Qyt6bV?ZƞN?>'d8w Njwɝ)A0U\gy<1>Ģ"%@g~HY˗ /gkV,(uoB_-e~DыrVQ֟϶E|iZƅZ\ZtW_~;>Xj& @xx 1 7=h |^^F\\oR.ܛ=}:mʴ(y,&o<[z5N ah8.3 >>_ aAgX_꾅!אrp'(;3Et$J*8pז|Kne!\(r}*xN~7\i/v f䛙 sA/ijm I݃UR|ټC|c]C)o5 3N _p.(Y 8.WJ0fI-W?QZ&Xl3NnkDïX-@_~ezQqWPendstream endobj 381 0 obj << /Filter /FlateDecode /Length 2535 >> stream xYI/^R+>Ȳ(%۱@rK=Vlv*8Q[-q]YeIkSɷl26W&&o6-h83[hH;Vs+ڨ\h03U+䋣l8iu# *n˰H9vfh}`$n@q/]5M:jC.'\Jhɦs&0*E`XijJDV|ek%\Uf%pp)2Eq2q23z>+<RTpJΤ0A 0L8)XkV 5gBZЋ٧֌PQ};AW H\R5N+)W\2 O:)5SwʐAi6@'B 1a|"~ƒ.z4ǿ"R H]?fy9[4i 0 l uEA= Gk:⪧r  #2_oc:0o=[ Cn%Tơ F\kЧ`֝2wafsM}a{m_G}u?U Uא(IBVbhLQr 1\3[ 0&K>Nn' 9 G# eyS2cP:ηm>,lt j5u̙`{GP f[i$ HTa1/Ff.[Pm>0.-9s'GE\XDcK-n Qh`3ļ!-sm q=0񽿚3h1=Vl_3`sI!4~I,4f#8֗)-obV!*ϧ3 ofw fλ`H6,s!Ы.x v'azX V**F޴>f!Sf>F/vM; Ʀw \e}."/^p\{di>bf?iw} |?m] ~A\Pd J₿lY)ckp{fmWłrc!^$#?g4ٽtbRn4w Ǻa/fe)* 5?Ŕ]X&aD  %1 +*PV{ P],&]vZ˂֦wq%Yc'%8Hk!9#H hXAQ ›K^ `rnƀ;0tMOϹԾntG,ҁ:F"n v Gƹ gy(w݊;Xw${l[An%I?@7},C |M\ QJa?$M} +23.|OUK=1hY}/JX*76MqL!," [SB; -|媞)͎i\mY(knwKG"U?/U\[Ufn}Ms:k(@ ûP><=VmLEn4U_|Uꊁ7Pr^& iwAȧ>7QFy) ?6v},=* [7ԿEQ;x(/҇ȿm+wb:E=3 ֛yɏ8q=5BS~xhLw=hb Y p̘)B-ZۮsEMyw'G@xw?1 3Փ$vn՟?Kr_zT>5yqۄR글´rsEQ@ϐ-HXύ%u$ SR`Kƥ|d HarV*S-=lսLMLMLEuTWGf0N6 \^1PJۼ"m`cpB0F[@O\4{ZIj^ǥI|.8? staG {щ@LVCYMX2R],!c;H~M+$0̲/@a LLs0?Lendstream endobj 382 0 obj << /Filter /FlateDecode /Length 7873 >> stream x\ndu}_KĪ;!vƆ'gȃ;0rv41|y$Yn gxܗCq3o+}w|5o>EwO_/Cdl^߾*8ml__mjeg.8wwWZ O+|5%TnD&mzմ,W2K}k#͵n:f,<-~/n`ClYFjviW^烈÷,Q L_}yݿ+~;7ÏuT^ֻlt_@{fTE *j_f/럖?}q{jwtg?}qw\:nɲ͞sY54Ŀ/j5Qg:2Nܜ??NX7Wo^M7w>UbJV"5?4ӻfc߮Unnooޝ_߬#zhW+yGvwײ4mXkwhj}x+}L]-ݻ*Im:ww蛩:0N?Y##]%y ]_/PB)b%d(2Xcaxlw9Q䱯^ʸ䒔_4!S_PZR5fg2InO/-&U媽ŤA}KF۹ȇqwVgeɥ p԰Lwk4}v6֏aa &çATU>,SCT5{8e.&qC-]Ҏh{gVvХ ؍S쥁h.LqB7kk4K~b܋ӃG9۫dO/X ;!Uk~pSÈ5?+aډH$&=ZSNr%NݝK_E%U?eK?lMSר:}Bo:a$PZt/ꩳs2\_U/}F|싽\:&?x7 p&ot ԻSTTsV퇥T& ;Pλz1Oo`|=rλ ޗGݳ;xWFtCnv"qdb&A cc8!?ߖ4XEmr$~3:.fuߍ-.:V[EZKv%] ?+\Wk  fKÂm9[[f,>?0sfQw]efDPGt# 0*k1F]}ކf S!|'q0HCC vOÓ`x('tb uIhۧӋf 4āςxP#y85!"HD`"sRZ]$`[wZH@ܨ 缎PuKtG2n/yJX|04`h>Lw2L`s9?U9HȿE~+-p0mZbH8?~7!LĴڬ-ś<1G3BC2J^sZrx:|F0ex~wYZNM91+<OR ?eKUIPbTyZJ'?}8zNvri+N?ЛWd.X={o'ץGājǨҡ/sF>~y1F ?ީ_06Wyd~szy–RiC,ca+~v{P:PMء3 W7XviN mtŭ?n֬ 0h:w 0(s:j˗ ~FSQ xpuY?if !"[Dc "F9lksjDذ5vc[7GH476ufslaA@J[߆h[$plls_6AZ #+8Jvl,fҕdDb"RƺQe 9es-v ^zrs_XLA#l"XTIL S2ٳ k& ҕ:s`3N:3*LDs w4̴EҘJʢL\N5 bg[ HL/!!+C36h#z*KWLY Ms8tQ=j^I.Q<VXvV?3gX(ӇH&:LF I% >JAKlFbv}4>h&j2ku\t5K45T 1|-}m@5̠n[SΌU7 ]Mo eZ5 -irW4O3YCͶ3 |& ΨI{|S;XF95vWhF;1(<@Φ#3z2s7)tfNbzfJ 2_/=4#'O_Oa0tGC +YDp{pR1!skrUd@7dK6;;ɀ+U#뀰Q3`d Y+ ^t/ (Bwnu(/*(tJe$XDnF$hyNe#d,JRȴ;z-4_8>WqTw-~k/Cqa %Xy؁ Í VTy Bj b-J@\vqI*8gAR}e%lKO-aT-`PqL<3a^n J\_ $[DU޲)5*,o)+놬 2$T~B04@H̀2RQŠD Q  } Ὴ*tqW8)+$Wz#3fRWH %ʱ* l99=F W8Wz%3?ZS,J $PQY JR\X 2  J;p p $ $H\^g.#3HT-$V1c%Aia!…HWI R%bH), (Z>yʖ-Dt;䞝Z6f^vLѪü${"sn~d$$zWȱw7?U>&cD4hFЇr?N0NQ|* v79/pp&Nʈ9/%["J(~]"aU+Z(dӹ1鰼NZ,+$k) kUҕjgI(r SK >?(rT Dp՝J~‰;f$%nBdk$(dxdxp#H"0U\vmrZibyI6P)lKAMH{A6!Mh;(5WJY7Dl s#QOBT`@S]iv4@@uKXe9j_f!m.3qbLRBL#g<;MQ'f=;Os-% 5;=}{4\ \f~bGc-pc^SHA휠)K%&j,lx'T'Qbk~(qd)a|oBֆkf~J5'[^jOdK\ƚkR/O< DoT ,ror\.[ C!ZgS[3nĨL| ]nlv $hA6B! K+)%p vRql=ܰu 2 T TS0[AkalF8+8SS{6HL6RhIb ?i@Tv.4:+e d̵VL*H+M9r]-|`Zn0|JF\ΑHsa 67*8BC Bo D.ڸ M#(Lw%d!w #2e>DWpM;k~k٫sH, &,:璆\ǮD0Jyfzxf A22n5Ǭ< *VN;TX^Wh6bٓYQZUV= EV̘RE.ceBOnz ui$p._$P*VJcXVȝ +\L ybzg0(k3$p֛^)hTVوW cXc5Jj|,EO倳/(%]J6)*,֛6)+l.` dcrzd;N\Mx7VW]a˼"9Fa o⩅5<]tzC^V[+O}73h:*YZBY9GivOǓ#Uܙo)2&YkYr.kt+gm_IR^>&N]UL#㧁/pcrdpӕʫK򋾂_W1cXb z.s|UH~-VuN'c>/GxB)@JO{IH^ʅw R}"~}~r{_FzO!W[F"]A aT6Z0uH;MoKdŬ?v'y&^z'&.Lش@pnx;| 6c o ]kϿ#[m/Soo4ٞγy#> D׶#6>4fZ[\hӿy>Uuendstream endobj 383 0 obj << /Filter /FlateDecode /Length 24909 >> stream xMϦIvb+HҳAzO]12vO6Kx=2YYUi?YFlg3"4;$" ;lys[veF^qƯﮇtw_~r}O|}ϟ|úV't7ha~7>zhu|/i޿ܿxz=\}oGW 2ˋJ)=Szۧy>\W*YauVÏ~4zz _)ۧpWxx+@_i=t}m_{)~ϟ%M=ܚV|wi]Zx(˻{$_͓!/OIW{Z{P;Fw{$K{d_xU/6ԇ#m=T+Ȝ4C)8ԇR~U|GCvˏO~g FDv$lמ~yWD#s_oj}nhyQidN\DFC^߼5L VCů#a쫷}rU[~yO5[lCw}t78ף+dVSHƒȔ\!7dd}mvZCoY2kl#E@[Dua?ú.*X_"+M3`~s-yd`voГ-W+:5tc`R#'o[O\j[ITkkOދ푽 'p}bzc`BoZ lG=ޯ_ymrמ,)W|s!|lN4} 'h]}?J d^[f"Z{rdunm92Z{wlSgwuYf; T77!ӶV~e6+oߟW/e,"tT<'Z2Iҗrg~t-<)icKږp[6~!%CʼLR6{u67{3$b&$P2aw R6{Fn{dɅ!ifύYk0}g{|4Hwf|hs9o3\a3Hg~qM?!XZo%u6~Xg&* ޅs~9 EA` z,XHɱ ^K 'NSp{6Hu6cLa3!6|p%B G;SfAdтJ%[)oQR8ZPd+EŸskOɥE+d셺)r,'vy) G'p {d;oJF>x`l]K1s2;֧c$cR&BE#tcu{v CY4yN:{Vy{'j/'|&;8מ^sDɤ`&1i$CK+{EX4vc)]ct<3~7DDJƠs6pt5ba :=BA K|*9iָ.0# K}LsP L.f EG%pW%BqKXj^k[Xć%$oxPrJADž7PBHqD=C =Eha\ B HBtB pD{0dM=5ߕlq! GTkCB pc{4"0uzVqU\(VNG N>;*Ka3&Lho@hICi F}Yh(NdE7^a:1Pt^P˽ 2FŁZJ jyNW7PRXwm?fqR^5JXLeZ  4W@_z&=.VOwaӢ7HY>E%.@;W/G[L˽,#,E^Qe%A_Vd.Eh_qɠ [NF!.%x-{(Dr dҶc8ed3W vN(V:(XVFf݁ǍeiK28pHdlTX2aWt2`ј]1y$6;t\N ~ ^}G`$tաq:#B#}z`nѣ:'5:GD4$/¦rcF Y=B!jLHEwb"P4pUnga_&>B>DH7A_11y*c70W]I"kj au*KԠMBM *#rOcO*>`G':d `hd]aYIH# %Mû䞇+DWFD찇dF,yS1C}xr"ppz@QN<B$(0\ K((BGQ (*5LNt-2x d,Z-np8>r>JlH9FkíWc`B B#qFo_!n=@{D n1Ъ{uB5lK &9C!oRN(_7>\}m7;6 E)Up.LE jʱHσMDfrH$+ 5Hdu857XU;>,q2^FDA@=PQ7#K9٥*(97"r)<[8(o_ڜ@rY2U]̜ mr Juq2 C& KmG rjdT4a3]kŷ~e^@.3oS| qX N.̳eNgPے>>O`ʪG#WzK^123uh*F$S2bM1d%lZ<'F q="lo$zDyxP{0(bddM0( ʬPfM!  a40Q&GXQ`Yf(O2ˤ>-&.>SP"+n+Gd{rv'μ!XG$? P >6xdIؖ :(۾SOmRPy3rRp! ox})D;{`K9V˃.wF&%~{Sr[m9VH y2UHavifka| o³gZkrⲌϏRpl,=2g1 /y;Kzׯ0 ,pLgӁ: |aD^*g>;&0)5b8Vc8|m +] _y*d&pF7{ x{HQf_a ^TRqPKRMe|)REդ|FZJ+!k Zʘ>1/1KMJ 15Q,q0&'TA…&$k‚e0Wi yU|'yQ3<nU,cJfqSlƏ%#3*>{_FqO\u 3/6G G!LuS*S1$a#1sfE@r3G+*R 8"IT<#veCř' gu,{IJ ȵ!^+ "b(p$O-FkHʭ@Ctn0}ut?lה$REA;68paa8 EAA8[nvc 7:d , 37B^|zY]i18j n)!Ya`s VqPˬ47ts(G&y }s~&O H aQX!g U~!\la$W6% b]DUav_ Ł sGr0CLR12)J:86 F2, =^ѐs=RAz-D_ÃahC|_)iiX̞ Hυš9z( ;e30{.9}3*Tse\(LiIbtJq\]]Q#GJijj~ >9 vIPqESgHf~pGLcĭj!}Ȗ\,a P!+i0J|IY/3R+q{&vo)tR$α{#US$16Jp8H zԄʑc5TGK"hx>GTF )bJ2i#RhY#BP8Ӑi1iKK}¤{&(S)hOcR̠\sH W )դf4U$Ŵ@a?]zRgj#ƠHtXb$ѝCP ]C@1QP/VP̐Tf.% x9 J}M?U!\K!7BXTLP .%qXJ޹;GP5Dۖ9* >Fexk5h ڦV(vKTUG` y2*S.nT7!bk!¦UVtZŰB\*6݀~* !F Q(\9cQy);.ReN`|ⴴV#3';9,ڳxx@QWѬ3rTUE#u̓ 6Įäyfx"?5jH&ՊHM+Qj^RkN^(8L̿{M,[G3W (cjNr7CS!*Ȓ+'pQZ\ V.?WTJ@,[*8ZI{rm\C}գki쵷ɹ{e7As&LX{xU b ɭ! 3Y|jW=D_COCh,AcWabsqL]SO<0XP29v x| 0URQ;,SQ#:**Zuq\8r+sUDxʌ\NM$͠$.vsUR3 읹^ӑ6s?8/Og.qyxlYA ?S$i1B?r¤Mff o+b̃MK=XDlx HtB$ **wM3喙*"ޮ & ٺd@%M&TnIfi>7C&oK;.oƄ<ߊf]8Ƿ f Jψ~kڇK 5å$&~ETTi!Giv%Q!~ҲJi6!C(  GihA}3 *joidG~,29n}t G#0]_ O=\TC|y y#yEd?-Cʃj#Ql+ `| y_S`o67#+Fl$a{~m|#iʷHS օG| L#U[)Ho|ϙЃbnF2]{6yك Y!#F`hE|9BPI~%v/U$u_mRG4 4c2WJhUQ ד9@xaZ7<6@J7"@)<ĐA3V8X/.16Fd{101C#69z6ebĢH91(*VȾbPCĠےbP3#1܍vmՠ@dAA[-h7fߠi 7 4,>pp;g>ْSa0Cp^ԡ)d#wQ,ݛQ&߈J`:`tБT1(4J, ,-(кF:kіEѵqY]*AEOoѰ<Cke|"a>P(Ӧq7Z7j apx'vY6]mN2گЍS- K`u- ycb 57O:ćekySjM>\x96_\ތnU}pQ8KT~%ejOІ8ņn Bmjͬ}MI| zyI K5rj8L0 Sf&dik3Vj8,qlA7rgMZs;G*=͋qmOY"v?$t4ϦDgpoyѼXQ!bz5$>YZ)2n+W,:WSb5薾BTx\bpx- $t~kOѫ)1Tn{p@/\P P" ~&lj;-)ڜU_6tDj^pRa+[d*X ?gޣZ RqzaRhvX]iϋj$4WC$ ,p]+,I2q\j?.V2jE:V],A{:xW;Qx q,?Ph"*KC:RW`^:Rndnvv] yLpJY{\! b)p0\bakCf%TIM;Nnav~>|5 @l9!{ ϵj,kS0& c`R&v )J3M>n4 (эVC&3hZze0֫e#5Hb]j+$%l$B.zd,{Țe/j`+; 326*tbgs v~}7ZH y4KbwU5{VO9#s`,s%QW 0X{&N^aAu0SBUFz:5B sHd3\5@9[h] lz[@}Wi lq%yTl)tU,4:z$-;# p%@q`޵M nh<rW_H}{&&{g{3*L:yϲܡ=-!x3ܡqV|eo8^q5Vb0R=k(HeX22;a2cRx\lti`]\ 0[CuHQ -##wK~NqswQ$G^ ] `3)4._I(#+lMĢX[X;Gf9bf_ UyʯIKVZqoƒBحA/|]k9W{&%75G˚&xACuSZWIq|ۧiA3/ %;xn3/v ~3@2_:W`H /GRzcjкz ︅\F_ط/c|\FZ8b0>ޅd}O^t>C }U DA<2BLJ179^eͿRƇ< t3\`宭*ѯCJd-I # ( (cZ ѯ*Z|D0zN0JLiAo4ؾz+Cr2JJ(4f׳Eٳp?,7ԥtq7܏Iʀ| ;_U.<%˰go1[]B%H;qo)//h<)*&'%+ţ7pκCkavHdROA{]uX-Z/±L֊{JxdN sA!k3IÎ$Ƒ5s2;m*4is'.s*vK #iev@]{ڀsHPfC!:yKXrH+OT2_iF2`B,D 3S6+7 =6hHFKw*Hd̾FzP JeH}5"fy_ÄCC1{"xEFS^ٗn`azx ;n|LPs9#Gxf m$ GD{UcyWo5xy`:H(/ٗ2[OiDEz3 r-64XʰLl|I$eObNe [Z+ ,LQl, }I𛤷ftɹ0жh9qژ ΐp3Go {Ь+&ͧE{.#z㪒?&t%t%?mblٓ:(w2Pj?1lYo ̿ɍv 2_iӈT_E lW_α64+`jJfjLCz@g(]y9yl!YM&@Aft6[' 5%{ sI/f4M1#UQ#F@ӽh9]Q]&~c2" ϙf =۳+7zxaf4ۤ@s1>G Ц|Q- >x0ډ $ԭ_Oe9P?mή#:-bFqpf@M:\GѐfBA]G2UGs0"UlLz4W+@wJXϑ:|^!OExݎv9&w>XnC%-q:2v>/MS)Tv/`ߧUP(uP;zTGEQMd`H֌xS7Bcc_V@ީt:mG5(7t1uɊrpoi3=g!LuQs~ˉ97z#JJYz߱'K͔ٸѹR?RN;tΌi[)yJ=PeHcCq~5R̡b?It`jNP\Սҵ[M9WG"3u1TWoz3PF{A? ?[_scs,ZYv[IK2!w+˄l9VGC=P+i">':+<{wO%[ q#\C0%j̘=⬃YCcP`Tcf+󓊓b[(=4^8:~h@E# ]d-h:|'A%i>5 ̿R#%il Mb!O0C#ⷝčqďzmwHw=\qE7_waȏ]YǝC~$8{|\u>?R0ȏ9mc S*K{Kp. ҪnrK(So@ zhDN,Vɷٓ_2 `FO_ 39Od_}7"M}q9}Һ[e O9MG#n~i#{1G%GKȞ~HǙ76m upm cq^éA)#rd-nhKJa)A<\PR9 q067#PbȾPJ,I,ւі{a0gj=_Ϧ 4b6й`T>(ob77:k;EtX(aJew ǥi "GKx ZDYH"x1OTKlO:T7OUu)" ԛTC3o.! B鯏Z 5М]l ${ tgţR%Q~gqjUjϲR eЖ (UݴȸnlG'slA}cLh jNߝjӝg[}d079LO]R%yobgL X>lE.~b5<8F&niֲ| (‘=)t^ɼ1lMo(M]AƔ.,J Zsöݡ4EOm{]#Fф)#W7[૕m~΀+{fkՍ;(ns.`!ڥ Mt;̖8:B&6:hdф2YvMo$nn1iM Mwrj7],7 ~o.s4m#SLa8FcBCL,zKh{,=v~#u c4̲a[<;gUā4Md`I7Z4DZ@2.l}Sl#&@N&nΫ&\cHVU){h&<btxZ8d9܋ɝ9'b"񠄔sg88|Oop!{Hr/QR$k_:$fƢ|Kؖ<.j'1 BH`Hp6؄@h5SG1$?j,? ڼ*>&⣝rU֤jk^TdteDPq5C]aeik4V쌡P@-:OPCkAQQQD AUWh(eʴK Z%ة+N;J{'Bmk,1) hZP@#qA2[+A#sPzMQi&RVjWz`[2(3ͩA)=զKw B+=ѦhS`gQz$=Jٝփ6!IOو,~DBIN!'tN BL;eW:ouԞ(TC*:'tSwC-'MArTZP0LG輋Dp^G&:d:8 Nt).7tWLbqz3ݺfmN0Rb$Qr:ێymʕF4-RGrIYSf[>ȝ23ݪa|LU+`[2ߪf > 9(6'֤Tr#Ly5T34mbPCp^IP ^nUC_9>镅*); T}F8|0 .q#S+">m.6b!DRN{#GWK@7J|8jil˅wt꥖O><JY% %n6ɜu(!v$.ٕRZ%-u'<kd+T-l&GWÉVjTyGUX؊« L)D)a[1`e*2mTu+%l!w,rBrARVrG5VZf5E4j%tl:4 4 %7i7ThR4G5Zba]f`Dz@z` w;G@Rm 14=ƱUfKK[]QrzQd^^ct4*&+TԎ&P R{τFk%i9 P-tR]u qʮ7Wr[AM-\K$Omc-NnXْ8yI\rQcYeL9/ E ai!+,)Y%@6csr[T>AV<~@!GnJzA?` :l%*bUS#KE*T"Ӗ;]ۢ"FZK&8 k`| #Vݪ#lO.RT?n~Ug܇:zzUC+ $Q#YM}^֔v)q:Y-j:6+YR5v53GzW n*K]P}j ݺ75w`Қ4"P"b`X8/+Jlc59hVUng-Щyժ)/I'US |#z )ZzDѼ%8D3zhFh)Md*6]MX7-#ËiW7 cknj&9n#a8"e3if $C4T5^L&^n#AEZ#BJQ'S#GvPgCJ *Gk@aֽ\vwd*6eG"G^n@MvN|FkhŝX93G|}w&6[{){i9nЀ48BP_!Dm&,섡I.LT>m Gx^vaR$7ZITo, S"KJAc.X3AYx'(Ep&@T"]RBm,ݶJ!9B6L7(r0l*UDcI7DgDb ,j>!^J UNִ~##RPɔxr/rV&J 1iQ(%dH(-֥K289d'L.mmc,&@{8SI%R.1ۍ<\$EL\爳ĭ8\S;zѥ 4ޣ 4=-4Ǿ.diKj2,yᥲr%4dxSG6I,fL^|0%%2%)ы/䞭-Wa aUHىe餗 SM'$^he@=RʭLʐjNȪb5Ż^H>q/AUSI5XX~G ӺDBYS RۃH&}DNH!,KWuQB6p][$H$ȯQ_lүH릳& UCJ4i]Qpx TC YG DzC h HЉki ?R'?t5atkmT[H'E@H-,tw',`_3̊ɨy0sA&vdj#-$y&Dm 8"si lMT^64.ii*=K%Ꮔɳbaΰק 6GІ'=kb5nɊ)xqh,bW,[M~Ŧ)ob .  08U V[[9g:YڤY"K&mLEl˜*ݜBUIr*r+JF+X*p QS@[*J4!m&apkSfkK$T4k3IYY̙.$80[\J"Oxuq"Dݣq/ݮE;Ol5_g\yX)4-,gRq({zlC{( ] PmV<+=u$q [%Sꬒ[k9$q\LOeD\&7sˤTns9222_-ܢS:ٙâO$DD85h%,#* eքo,~NA&օP~Sa"XgeifU.ƍРZ`0$RHfKWcݬHxW0τR y39a8}.v#k*Iܒ'WGOH} ZHg #IԣO -ȁ"Ha9LܸB}W'Ov ߆GCs=] ~w/HzLyrIBZiNKf"_:W}䳟f@iϿc]qm(k[eh=sģ=gE?|HkS{"=O#xJ;J6pGV稭K19JGQ";JFQ[[.U:2_>?m(]jn7hs^ejA6b(8p;D*wn`=<0 v ]~Ӟ_ZƽS}"sKIZ}s{K ҂aEA}ݗ6}GʠI͆1@{iɏ~?g?~W_O䳿KO>'Ξ|䳟}x'ggW_~x.}߽~?|]?z?~?O?Oy7_o_oŇ/ɿoOGO~򳻿oE{s b0A!E6C42e?\[w0ѷ|`@`?t컗o>kDt{IB*} [/yLa= #($Ocb=t$1Q2p#-l)>6='Gӣ |zy>=?uOϧGA~x.kg?Y:¦hkpW_r3 %q_gw`| PWϿU6u{|WWKLOȰ~<=2BCD3WZA|P#/Ň-߿׹i7 -<߾[Oo_D0_zNB0>U8`}v4ny?_ʥ}nӚ(D.e:I1 :tϲYl0W_~Yݟ<0Uz*\?_zݖz=C~gpMYϾz_@px_fۿ}o?_?lCX?o<^ 9Y]cCW%S刖OQtwsoΟy{|o^NKv_D׵?J͒<[>9=O{h|߅/m^>ly_ΫSgbzӄo{+Wzw=Jr^C|{ShϿ~/("|ф n&.*xk͚SN󴵭~GL[ӳ>Vfi~o4UN׷__"8Oߋ}V'XE>Mօ=*ݜ30R$z yyƟ{?,߽+vaKB(K_i5|A2?EIV{QL7(JI1>cox={CYraO|fgj\eׯ*(@1ϸ?y^5>Y+9??Ͻ[^U~X1,Qp|ma }g/PO Ͼ{wrq}R}0ë״ dO޽{N~xnO~vi?/QOEϿyAD_j/}[H-NZ 1M_xt{{]Zqך¥R ©ZĥD@>qyli \csպ{3V/7v}lU_FD{bpJ%wDq~jA1TE'?\B/mbAY7v'YkkU-?{HSpMaqKWx'6_,{(O7`wV{jy2<ͯ{Nj:(op3 }՛>ezJ± ɴ={%ߟ[SUL0c=oW;! 5E|ۧhιG5X >cWoboݛs{3X\=^)\Mt#  ֈv՛Am)wWs>^]h&CD|_d)N lz 8,r~?/o?L~Kohq|[ōx=i:}< Yhqo,5L[Nx^Ϸ*F9Ōn gB5!jVOys6{k{\_7;\2#R;.s*,c-~w=HPx0xf%p =pZ"& ;@~?"d4$tT$=| YT.pJ/ѹM _ KK"6d{O&Iy b hhKUcluq!7k=cJ>|޽ސ;@ކyo}oPnm*OmfIp ;X|kc'+ϭz iʐ/-x^GAPGI+*~kiȕ7<[Fɼ.c~2,W!?E\yAΰ)ߛ[ts?6^|#?lzHa=?<×u]?/RVW7N ^*5>4{յ'ҍWon"* ?N67ۆlH~8/V1EHl:[,d>/,!wHde|wv BQ|B@C:Us˳/n<{bm0ON`endstream endobj 384 0 obj << /Filter /FlateDecode /Length 4754 >> stream x[[o8r~_F`lsyAv 2촃`Nrsq/߇TIE }$XWEj#+;~8x WRo5'g|Cwix]+ So\UFWa3ZY4΅v{ZV|lPnBnwDUjT:YMF7'n* ։XzM=jelS7RMUD!:'!(Z 5 k{+ws$!ܢlz-1%oNKɀ#B>-Iw|~ajq͒z쀜8'}"TN aLnnB `ݱB`0 :U* m{4(d4gzb1 A C9iYؖ~s@~!/`STaNRvms=]GP@>y g-qї1`))-M@Rn3HrD2L'$Bt; T!Yl* Ovl`>º&>vtW86:ĉ́Y1.*Zq́~rHziX1ђcVJ`% 9lF´c[t':`mW(pW"XA ՖSBCKVQY`$9֣"<'}[l13e+p{KxfLѲ02 81nK@[[>HR<%By'nQ0j)IWu>#ĥ{ @aۦ iI @|f/Pw؛违UY!HC"mĥ)w`rPY* X=2CvI?,4 XvM>?Pҙ$.W,Jn MP^`@qW,I!@\.D633Usܞ!`-[Ǵ 82<Ip:3d0q?tմ'',ju SJ;ā(N#Z6iqvTK!` ,'Ǯ|smA+`Δ FBOuQbޝiZ /_^%, D2!.5-BM]0իh:BiRNhKr8pkO$CPQqXO20 2<'㦡w ޶&ALP42KN S@<1mZ$pթ VXggE w?;gSmс+kslIܷԇ_ġq/Twb>Ln“ZڙbzjX{וH;Jk,䠶=loQSE@t p*"!Zfe=4E!:h@al K-ͨLa)Pwp06JM !D݆B&md {j% Z z|dƳR_WQqCm% Qs{}jY#FYgpQ SQ06EYӝsDzډE,xg6uCJ̠"fznt؁RBu kHdfvڹ}7ppѱFimЉ#c>l7i#@qS枖 6K痞2.|.Rx,c>3⡌o%A(ͤ&.9Qjlf1JuTp_HF`jŁ=L&PVܳq#>czl{؀7]q2I*ءi`! H[o襼B'36!q7b~[=:.nyqv oȑ EHt>摔lj J[eeYXqcW!& C<=Ϲ$()DP|}ܙx>(@|6en|jȉ]09d?ݛ$ǨݸLm"܈ӳ֧ G?i}z):Ux#bd%HNSgrn㲎O 5t:q!Cu7ĥ|v@Ȟ[Z蘪*35ɘ=5zzئw/94Wr߅;w2)<]]ݓ{SՉ]\WqХvF7/ ܷi*9aL=!u[r(3FB}ty%ƒiS-Oˇfd% 0Ed.߳auW:a YG-A U}j# ֞H8%GCm:gwP:(X| id=H2tB=Zݾ\[q)H8YfžoVVFAQrd郉(pN^)q Q.^AUM597ÙtH <*[w*MaUIix2Lt7FCAԌMlYa.˩^VW3J_ȿU:aFm1pmO&Uv~ 1}iW.&$Fd|ݫ<}?t[l`k,Rf`oE')~qmEYzpsfռkeqg`We#Jq u@tp }1L? 70?D2k}_ae#Hj^mi'/lq/l#¬qۺ2`thWo͗|thN"[jeubMЕ®]MȤ>±X J<-%Ó`]ܐ" x45DۍdclRf辺 fftMMsF;:٧xO0z:}@5#VXH6VW8ZO7y\CQ#xvie,ۇD!~ צN}5b(bf ov/eT~ )nn3xp^.a?_6o,_BWBX'/=.|*n}$O`Tiot/by wÛʧ"鋞k{OFtӨ\ TjjfR/eV$z]i;^pt6zP>0¹H :|,)/Pg߮0fӲMV+P֥`n7@!+RCL !9K=㝎Ycp"s v KApu~*xF^/5Ss[Ǔ]gi/-_Z X8ɕJ($إђ(IWwtnbe zV񾘏HFyZ}~v5@kO} ?G"|9} y*g*̼endstream endobj 385 0 obj << /Filter /FlateDecode /Length 2125 >> stream xXm_!-JO L{.c=)Ve":Krwy:AZٝg0O:OY:}Q;;?ajka&ӜWۙBLȄ+1R'9aZ,IyΉ9/$\4'ӝ\diq^Ew Ȗ%2)ظ;@DLDqVrPBKe`n L)}GCb)LRɭ9&H56屫U|Iy"Epޛ|ey/aTtZl;+ά-|{8(̡tNj8^h՗E`Q9Zȏ.bS13$m{\/χe[o}[6wcYT'4cg1Ӿlg ؙ^2㹯`Tuobi~SF iPƒݮl~ wug|햱>FZwc5 % k^A|tMlh4`ϧ{,mYt` !˓O=:Cئ_JNJA'Ι _Ɗ b%3]u{0>(#9dd@>dgo{_6Mc\muP6 ]Y/a"rqu: .XBWw `sޔס4a~¥%#.p7^zW݋4(qxArs.lMՍ(iʽ]ո]ܖ_AEnIfcPuǩ~H^8Hdwx:"Th qid[u7V>nMB}c8J!J=%k`&ď(Wg!"l@[F?mSq'B[pzM8< ISXhSߜ|OՔ8L3 #+YDJE]ײ>h1~Oˏ?1^'Cc҇G>-s0\vC5INԔ7[jx˷/^e֮\x!Q (*/.74}ݭcQ/ `D^yӞصsz|9}|9Ls,`hPY ڌ}&!eR4W2sl fptWd)jɃиNZ$ILx75> /W [ 1 3 1 ] /Info 3 0 R /Root 2 0 R /Size 387 /ID [<48e115737649afaa46fa84c344e0de5c><130e1f7c6af408195a436d491753f570>] >> stream x+q|g vK.\ 'u(uXI(-.%ࠔ IjW81ë Running brms models with within-chain parallelization

Running brms models with within-chain parallelization

Sebastian Weber & Paul Bürkner

2025-09-09

Introduction

Full Bayesian inference is a computationally very demanding task and often we wish to run our models faster in shorter walltime. With modern computers we nowadays have multiple processors available on a given machine such that the use of running the inference in parallel will shorten the overall walltime. While between-chain parallelization is straightforward by merely launching multiple chains at the same time, the use of within-chain parallelization is more complicated in various ways. This vignette aims to introduce the user to within-chain parallelization with brms, since its efficient use depends on various aspects specific to the users model.

Quick summary

Assuming you have a brms model which you wish to evaluate faster by using more cores per chain, for example:

fit_serial <- brm(
  count ~ zAge + zBase * Trt + (1|patient),
  data = epilepsy, family = poisson(),
  chains = 4, cores = 4, backend = "cmdstanr"
)

Then you can simply add threading support to an existing model with the update mechanism as follows, provided your stan version is at least 2.26 (whether using rstan or cmdstan):

fit_parallel <- update(
  fit_serial, chains = 2, cores = 2,
  backend = "cmdstanr", threads = threading(2)
)

The example above assumes that 4 cores are available which are best used without within-chain parallelization by running 4 chains in parallel. When using within chain parallelization it is still advisable to use just as many threads in total as you have CPU cores. It’s thus sensible in this case to reduce the number of chains running in parallel to just 2, but allow each chain to use 2 threads. Obviously this will reduce the number of iterations in the posterior here as we assumed a fixed amount of 4 cores.

  • Only apply within-chain parallelization to large problems which take more than a few minutes at least to calculate. The epilepsy example above is actually too small to gain in speed (just a few seconds per chain on this machine).
  • Within-chain parallelization is less efficient than between-chain parallelization. So only use within-chain parallelism if more CPUs can be used to run the entire analysis.
  • Due to details of the model and data-set, speedups with more cores can be very limited. Not every model amends to within-chain parallelization and an empirical evaluation is in some cases advisable.
  • Enabling threading usually slows down any model to some extent and this slowdown must be offset by sufficient cores per chain in order to really gain in execution speed.
  • Doubling the execution speed with few cores is a lot easier than obtaining larger speedups with even more cores.
  • Models with computationally expensive likelihoods are easier to parallelize than less expensive likelihoods. For example, the Poisson distribution involves expensive \(\log\Gamma\) functions whereas the normal likelihood is very cheap to calculate in comparison.
  • Models with many parameters (e.g., multilevel models) carry a large overhead when running in parallel.
  • With a larger overhead of the model, the likelihood must be sufficiently expensive such that the relative computational cost of likelihood to parallelization overhead is favorable.
  • Avoid using hyper-threading, that is, only use as many threads as you have physical cores available.
  • Ensure that the data is randomly sorted such that consecutive subsets of the data are roughly of the same computational effort.

Within-chain parallelization

The within-chain parallelization implemented in brms is based on the reduce_sum facility in Stan. The basic principle that reduce_sum uses is to split a large summation into arbitrary smaller partial sums. Due to the commutativity and associativity of the sum operation these smaller partial sums can be evaluated in any order and in parallel from one another. brms leverages reduce_sum to evaluate the log-likelihood of the model in parallel as for example

\[ \begin{aligned} l(y|\theta) &= \sum_{i=1}^N l_i(y_i| \theta) \\ &= \sum_{i=1}^{S_1} l_i(y_i| \theta) + \sum_{i=S_1+1}^N l_i(y_i| \theta). \end{aligned} \]

As a consequence, the within-chain parallelization requires mutually independent log-likelihood terms which restricts its applicability to some degree.

Furthermore, the within-chain parallelization is only applicable to the evaluation of the data likelihood while all other parts of the model, for example priors, will remain running serially. Thus, only a partial fraction of the entire Stan model will run in parallel which limits the potential speedup one may obtain. The theoretical speedup for a partially in parallel running program is described by Amdahl‘s law. For example, with 90% of the computational load running in parallel one can essentially double the execution speed with 2 cores while 8 cores may only speedup the program by at most 5x. How large the computational cost of the log-likelihood is in relation to the entire model is very dependent on the model of the user.

In practice, the speedups are even smaller than the theoretical speedups. This is caused by the additional overhead implied by forming multiple smaller sums than just one large one. For example, for each partial sum formed the entire parameter vector \(\theta\) has to be copied in memory for Stan to be able to calculate the gradient of the log-likelihood. Hence, with more partial sums, more copying is necessary as opposed to evaluating just one large sum. Whether the additional copying is indeed relevant depends on the computational cost of the log-likelihood of each term and the number of parameters. For a model with a computationally cheap normal log-likelihood, this effect is more important than for a model with a Poisson log-likelihood, and for multilevel models with many parameters more copying is needed than for simpler regression models. It may therefore be necessary to form sufficiently large partial sums to warrant an efficient parallel execution. The size of the partial sums is referred to as the grainsize, which is set to a reasonable default value. However, for some models this tuning parameter requires some attention from the user for optimal performance.

Finally, it is important to note that by default the exact size and order of the partial sums is not stable as it is adjusted to the load of the system. As a result, exact numerical reproducibility is not guaranteed by default. In order to warrant the same size and order of the partial sums, the static option must be used and set to TRUE, which uses a deterministic scheduler for the parallel work.

Example model

As a toy demonstration, we use here a multilevel Poisson model. The model is a varying intercept model with \(10^{4}\) data observation which are grouped into \(1000\) groups. Each data item has \(3\) continuous covariates. The simulation code for the fake data can be found in the appendix and it’s first \(10\) rows are:

kable(head(fake, 10), digits = 3)
g x1 x2 x3 theta eta mu y
382 0.496 0.623 0.069 -0.262 0.510 0.248 0
578 -0.748 -0.300 -0.768 -0.903 -0.032 -0.934 0
772 -1.124 -0.161 -0.882 -1.047 -0.551 -1.598 1
774 0.992 -0.593 1.007 1.578 -0.045 1.533 2
729 0.641 -1.563 -0.491 -0.291 -1.460 -1.751 0
897 -0.085 -0.531 -0.978 -1.296 -0.929 -2.226 0
110 -0.772 1.364 -0.629 -1.351 0.124 -1.227 0
248 -1.441 0.699 1.284 2.072 -1.020 1.053 1
754 -1.320 0.837 -0.137 -0.237 1.452 1.215 3
682 -1.345 -2.673 -1.628 -1.146 -0.388 -1.534 0

The brms model fitting this data is:

model_poisson <- brm(
  y ~ 1 + x1 + x2 + (1 | g),
  data = fake,
  family = poisson(),
  iter = 500, # short sampling to speedup example
  chains = 2,
  prior = prior(normal(0,1), class = b) +
    prior(constant(1), class = sd, group = g),
  backend = "cmdstanr",
  threads = threading(4),
  save_pars = save_pars(all = TRUE)
)

Here we have fixed the standard deviation of the between-group variation for the intercept to the true value of \(1\) as used in the simulation. This is to avoid unfavorable geometry of the problem allowing us to concentrate on computational aspects alone.

The Poisson likelihood is a relatively expensive likelihood due to the use of \(\log\Gamma\) function as opposed to, for example, a normal likelihood which does is by far less expensive operations. Moreover, this example is chosen in order to demonstrate parallelization overhead implied by a large number of parameters.

Managing parallelization overhead

As discussed above, the key mechanism to run Stan programs with parallelization is to split the large sum over independent log likelihood terms into arbitrary smaller partial sums. Creating more partial sums allows to increase simultaneous parallel computations in a granular way, but at the same time additional overhead is introduced through the requirement to copy the entire parameter vector for each partial sum formed along with further overhead due to splitting up a single large task into multiple smaller ones.

By default, brms will choose a sensible grainsize which defines how large a given partial sum will roughly be. The actual chunk size is automatically tuned whenever the default non-static scheduler is used, which is the recommended choice to start with. As noted before, only the static scheduler is giving fully deterministic results since the chunk size and order of partial sums will be the same during sampling.

While we expect that the default grainsize in brms is reasonably good for many models, it can improve performance if one tunes the grainsize specifically to a given model and data-set. We suggest to increase successively the number of chunks a given data set is split into with the static scheduler and run this on a single core. This way one can control the number of partial sum accurately and monitor the execution time as it increases. These experiments are run with only a single chain and very short iteration numbers as we are not interested in the statistical results, but rather aim to be able to explore the tuning parameter space of the chunk size as quickly as possible. The number of iterations needed to get reliable runtime estimates for a given chunk size will depend on many details and the easiest way to determine this is to run this benchmark with multiple number of iterations. Whenever their results match approximately, then the iteration numbers are sufficient. In order to decrease the variation between runs, we also fix the random seed, initial value and the tuning parameters of the sampler (step size and mass matrix).

Below is an example R code demonstrating such a benchmark. The utility function benchmark_threading is shown and explained in the appendix.

chunking_bench <- transform(
    data.frame(chunks = 4^(0:3)),
    grainsize = ceiling(N / chunks)
)

iter_test <- c(10, 20, 40)  # very short test runs
scaling_chunking <- benchmark_threading(
  model_poisson,
  cores = 1,
  grainsize = chunking_bench$grainsize,  # test various grainsizes
  iter = iter_test,
  static = TRUE  # with static partitioner
)

# run as reference the model *without* reduce_sum
ref <- benchmark_reference(model_poisson, iter_test)

# for additional data munging please refer to the appendix

Graphically summarizing the results shows that with more than 8 chunks the overhead is about 10% and increasing further with more chunks. For models without many parameters, no such overhead should be observed. Furthermore, one can see that 25 and 50 iterations give similar results implying that 25 iterations suffice for stable runtime estimates for these (and the following) benchmarks. The overhead of up to 20% in this example with 16 chunks may seem large due to the scaling of the plot. One must not forget that when we start to use more CPU cores, the overhead is easily offset, but it limits the maximal speedup we can get. For example, some 2 units of computation become 2.4 units due to the overhead such that on 2 cores we don’t quite double the execution speed, but rather get a 1.6x increase in speed instead of a 2x speedup.

Considering in addition the time per leapfrog step of the NUTS sampler shows on an absolute scale similar information as before. The upside of this representation is that we can visualize the slowdown in relation to the program without reduce_sum. As we can see, the additional overhead due to merely enabling reduce_sum is substantial in this example. This is attributed in the specific example to the large number of random effects.

ggplot(scaling_chunking) +
    aes(chunks, slowdown, colour = iter, shape = iter) +
    geom_line() + geom_point() +
    scale_x_log10(breaks = scaling_chunking$chunks) +
    scale_y_log10(breaks=seq(0.8, 2.5, by=0.1)) +
    ggtitle("Slowdown with increasing number of chunks")

ggplot(scaling_chunking) +
    aes(chunks, 1E3 * runtime/num_leapfrog, colour = iter, shape=iter) +
    geom_line() + geom_point() +
    scale_x_log10(breaks = scaling_chunking$chunks) +
    scale_y_log10(breaks=seq(0.1, 2.0, by=0.1)) +
    geom_hline(data=ref, aes(yintercept=1E3 * runtime/num_leapfrog, colour=iter), linetype=I(2)) +
    ggtitle("Time per leapfrog step vs number of chunks",
            "Dashed line is reference model without reduce_sum") +
    ylab("Time per leapfrog step [ms]")

Parallelization speedup

In practice, we are often interested in so-called “hard-scaling” properties of the parallelization system. That is, for a fixed problem size we would like to know how much faster we can execute the Stan program with increasing number of threads. As nowadays CPUs usually run with so-called hyper-threading, it is also of interest if this technique is beneficial for Stan programs as well (spoiler alert: it’s not useful). As we have seen before, the grainsize can have an impact on the performance and is as such a tuning parameter. Below we demonstrate some exemplary R code which runs a benchmark with varying number of CPU cores and varying number of grainsizes.

num_cpu <- parallel::detectCores(logical = FALSE)
num_cpu_logical <- parallel::detectCores(logical = TRUE)
grainsize_default <- ceiling(N / (2 * num_cpu))
cores <- c(2^seq(0, floor(log2(num_cpu_logical))), num_cpu, num_cpu_logical)
cores <- sort(unique(cores))
grainsize <- c(grainsize_default, grainsize_default/2, grainsize_default/4)
grainsize <- round(grainsize)

iter_scaling <- 20
scaling_cores <- benchmark_threading(
  model_poisson,
  cores = cores,
  grainsize = grainsize,
  iter = iter_scaling,
  static = FALSE
)

single_core  <- transform(
    subset(scaling_cores, cores == 1),
    runtime_single = runtime,
    num_leapfrog=NULL, runtime=NULL, cores = NULL
)

scaling_cores <- transform(
  merge(scaling_cores, single_core),
  speedup = runtime_single/runtime,
  grainsize = factor(grainsize)
)

It is important to consider the absolute runtime and the relative speedup vs. running on a single core. The relative speedup can be misleading if the single core runtime is very slow in which case speed gains on more CPUs may look overly good. Considering instead the absolute runtime avoids this problem. After all, we are interested in the shortest walltime we can get rather than any relative speedups.

ggplot(scaling_cores) +
    aes(cores, runtime, shape = grainsize, color = grainsize) +
    geom_vline(xintercept = num_cpu, linetype = 3) +
    geom_line() + geom_point() +
    scale_x_log10(breaks = scaling_cores$cores) +
    scale_y_log10(breaks=seq(0.1, 1.4, by=0.1)) +
    theme(legend.position = c(0.85, 0.8)) +
    geom_hline(data=subset(ref, iter==iter_scaling), aes(yintercept=runtime), linetype=I(2)) +
    ggtitle("Runtime with varying number of cores",
            "Dashed line is reference model without reduce_sum")

ggplot(scaling_cores) +
  aes(cores, speedup, shape = grainsize, color = grainsize) +
  geom_abline(slope = 1, intercept = 0, linetype = 2) +
  geom_vline(xintercept = num_cpu, linetype = 3) +
  geom_line() + geom_point() +
  scale_x_log10(breaks=scaling_cores$cores) +
  scale_y_log10(breaks=scaling_cores$cores) +
  theme(aspect.ratio = 1) +
  coord_fixed(xlim = c(1, num_cpu_logical), ylim = c(1, num_cpu_logical)) +
  ggtitle("Relative speedup vs 1 core")

The vertical dotted line marks the physical number of CPU cores on the machine this was run. The horizontal dashed line in the plot with absolute runtime marks the respective runtime of the model without reduce_sum and the dashed unity line in the plot with the relative speedup marks the theoretical maximal speedup. We can see that there is no further reduction in execution time when increasing the thread count to be greater than the number of physical CPUs. Hence, the use of hyper-threading is not helpful when aiming to maximize the speed of a Stan program. Moreover, the use of threading outperforms the single core runtime only when using more than 4 cores in this example.

For this example, the shown grainsizes matter on some machines but not on others, so your results may look quite different from what is shown here. The overall speedups may not seem impressive in this case, which is attributed in this case to the large number of parameters relative to the number of observations. However, we can still outperform the single core runtime when using many cores. Though the most important advantage of threading is that with an increasing data set size, the user has the option to use a brute-force approach to balance the increase in walltime needed.

kable(scaling_cores, digits = 2)
grainsize iter cores num_leapfrog runtime runtime_single speedup
125 20 1 1260 0.92 0.92 1.00
125 20 2 1260 0.50 0.92 1.84
125 20 4 1260 0.34 0.92 2.70
125 20 8 1260 0.27 0.92 3.36
125 20 10 1260 0.29 0.92 3.21
250 20 1 1260 0.79 0.79 1.00
250 20 2 1260 0.44 0.79 1.78
250 20 4 1260 0.28 0.79 2.79
250 20 8 1260 0.24 0.79 3.26
250 20 10 1260 0.27 0.79 2.97
500 20 1 1260 0.70 0.70 1.00
500 20 2 1260 0.40 0.70 1.77
500 20 4 1260 0.28 0.70 2.54
500 20 8 1260 0.23 0.70 2.97
500 20 10 1260 0.26 0.70 2.71

For a given Stan model one should usually choose the number of chains and the number of threads per chain to be equal to the number of (physical) cores one wishes to use. Only if different chains of the model have relatively different execution times (which they should not have, but it occurs sometimes in practice), then one may consider the use of hyper-threading. Doing so will share the resources evenly across all chains and whenever the fastest chain finishes, the freed resources can be given to the still running chains.

Appendix

Fake data simulation

set.seed(54647)
# number of observations
N <- 1E4
# number of group levels
G <- round(N / 10)
# number of predictors
P <- 3
# regression coefficients
beta <- rnorm(P)

# sampled covariates, group means and fake data
fake <- matrix(rnorm(N * P), ncol = P)
dimnames(fake) <- list(NULL, paste0("x", 1:P))

# fixed effect part and sampled group membership
fake <- transform(
  as.data.frame(fake),
  theta = fake %*% beta,
  g = sample.int(G, N, replace=TRUE)
)

# add random intercept by group
fake  <- merge(fake, data.frame(g = 1:G, eta = rnorm(G)), by = "g")

# linear predictor
fake  <- transform(fake, mu = theta + eta)

# sample Poisson data
fake  <- transform(fake, y = rpois(N, exp(mu)))

# shuffle order of data rows to ensure even distribution of computational effort
fake <- fake[sample.int(N, N),]

# drop not needed row names
rownames(fake) <- NULL

Poisson example model

model_poisson <- brm(
  y ~ 1 + x1 + x2 + (1 | g),
  data = fake,
  family = poisson(),
  iter = 500, # short sampling to speedup example
  chains = 2,
  prior = prior(normal(0,1), class = b) +
    prior(constant(1), class = sd, group = g),
  backend = "cmdstanr",
  threads = threading(4),
  save_pars = save_pars(all = TRUE)
)

Threading benchmark function

# Benchmarks given model with cross-product of tuning parameters CPU
# cores, grainsize and iterations. Models are run with either static
# or non-static scheduler and initial values are set by default to 0 on the
# unconstrained scale. Function returns a data-frame with the
# cross-product of the tuning parameters and as result column the
# respective runtime.
benchmark_threading <- function(model, cores = 1, grainsize = 1, iter = 100,
                                static = FALSE) {

    winfo <- extract_warmup_info(model)
    sims  <- rstan::extract(model$fit)
    init <- list(extract_draw(sims, 1))

    scaling_model <- update(
        model, refresh = 0,
        threads = threading(1, grainsize = grainsize[1], static = static),
        chains = 1, iter = 2, backend = "cmdstanr"
    )

    run_benchmark <- function(cores, size, iter) {
        bench_fit <- update(
            scaling_model, warmup=0, iter = iter,
            chains = 1, seed = 1234, init = init, refresh = 0, save_warmup=TRUE,
            threads = threading(cores, grainsize = size, static = static),
            inv_metric=winfo$inv_metric[[1]],
            step_size=winfo$step_size[[1]],
            adapt_engaged=FALSE
        )
        lf <- sum(subset(nuts_params(bench_fit, inc_warmup=TRUE), Parameter=="n_leapfrog__")$Value)
        elapsed <- sum(colSums(rstan::get_elapsed_time(bench_fit$fit)))

        c(num_leapfrog=lf, runtime=elapsed)
    }

    cases <- expand.grid(cores = cores, grainsize = grainsize, iter = iter)
    res <- with(cases, mapply(run_benchmark, cores, grainsize, iter))
    cbind(cases, as.data.frame(t(res)))
}

benchmark_reference <- function(model, iter=100, init=0) {
    winfo <- extract_warmup_info(model)
    sims  <- rstan::extract(model$fit)
    init <- list(extract_draw(sims, 1))

    ref_model <- update(
        model, refresh = 0, threads = NULL,
        chains = 1, iter = 2, backend = "cmdstanr"
    )

    run_benchmark_ref <- function(iter_bench) {
        bench_fit <- update(
            ref_model, warmup=0, iter = iter_bench,
            chains = 1, seed = 1234, init = init, refresh = 0,
            inv_metric=winfo$inv_metric[[1]],
            step_size=winfo$step_size[[1]],
            adapt_engaged=FALSE
        )

        lf <- sum(subset(nuts_params(bench_fit, inc_warmup=TRUE), Parameter=="n_leapfrog__")$Value)
        elapsed <- sum(colSums(rstan::get_elapsed_time(bench_fit$fit)))

        c(num_leapfrog=lf, runtime=elapsed)
    }

    ref <- sapply(iter, run_benchmark_ref)
    ref <- cbind(as.data.frame(t(ref)), iter=iter)
    ref
}

extract_warmup_info <- function(bfit) {
    adapt  <- lapply(rstan::get_adaptation_info(bfit$fit), strsplit, split="\\n")
    step_size  <- lapply(adapt, function(a) as.numeric(strsplit(a[[1]][[1]], " = ")[[1]][2]))
    inv_metric <- lapply(adapt, function(a) as.numeric(strsplit(sub("^# ", "", a[[1]][[3]]), ", ")[[1]]))
    list(step_size=step_size, inv_metric=inv_metric)
}

extract_draw <- function(sims, draw) {
  lapply(sims, brms:::slice, dim = 1, i = draw, drop = TRUE)
}

Munging of slowdown with chunking data

scaling_chunking <- merge(scaling_chunking, chunking_bench, by = "grainsize")

single_chunk  <- transform(
    subset(scaling_chunking, chunks == 1),
    num_leapfrog_single = num_leapfrog, num_leapfrog = NULL,
    runtime_single = runtime, runtime = NULL,
    grainsize = NULL, chunks=NULL
)

scaling_chunking <- transform(
    merge(scaling_chunking, single_chunk),
    slowdown = runtime/runtime_single,
    iter = factor(iter),
    runtime_single = NULL
)

ref <- transform(ref, iter=factor(iter))
brms/inst/doc/brms_families.Rmd0000644000176200001440000003401714275414730016233 0ustar liggesusers--- title: "Parameterization of Response Distributions in brms" author: "Paul Bürkner" date: "`r Sys.Date()`" output: rmarkdown::html_vignette: toc: yes vignette: > %\VignetteIndexEntry{Parameterization of Response Distributions in brms} %\VignetteEngine{knitr::rmarkdown} \usepackage[utf8]{inputenc} --- The purpose of this vignette is to discuss the parameterizations of the families (i.e., response distributions) used in brms. For a more general overview of the package see `vignette("brms_overview")`. ## Notation Throughout this vignette, we denote values of the response variable as $y$, a density function as $f$, and use $\mu$ to refer to the main model parameter, which is usually the mean of the response distribution or some closely related quantity. In a regression framework, $\mu$ is not estimated directly but computed as $\mu = g(\eta)$, where $\eta$ is a predictor term (see `help(brmsformula)` for details) and $g$ is the response function (i.e., inverse of the link function). ## Location shift models The density of the **gaussian** family is given by $$ f(y) = \frac{1}{\sqrt{2\pi}\sigma} \exp\left(-\frac{1}{2}\left(\frac{y - \mu}{\sigma}\right)^2\right) $$ where $\sigma$ is the residual standard deviation. The density of the **student** family is given by $$ f(y) = \frac{\Gamma((\nu + 1)/2)}{\Gamma(\nu/2)} \frac{1}{\sqrt{\nu\pi}\sigma}\left(1 + \frac{1}{\nu} \left(\frac{y - \mu}{\sigma}\right)^2\right)^{-(\nu+1)/2} $$ $\Gamma$ denotes the gamma function and $\nu > 1$ are the degrees of freedom. As $\nu \rightarrow \infty$, the student distribution becomes the gaussian distribution. The density of the **skew_normal** family is given by $$ f(y) = \frac{1}{\sqrt{2\pi}\omega} \exp\left(-\frac{1}{2} \left(\frac{y - \xi}{\omega}\right)^2 \right) \left(1 + \text{erf} \left( \alpha \left(\frac{y - \xi}{\omega \sqrt{2}} \right) \right) \right) $$ where $\xi$ is the location parameter, $\omega$ is the positive scale parameter, $\alpha$ the skewness parameter, and $\text{erf}$ denotes the error function of the gaussian distribution. To parameterize the skew-normal distribution in terms of the mean $\mu$ and standard deviation $\sigma$, $\omega$ and $\xi$ are computed as $$ \omega = \frac{\sigma}{\sqrt{1 - \frac{2}{\pi} \frac{\alpha^2}{1 + \alpha^2}}} $$ $$ \xi = \mu - \omega \frac{\alpha}{\sqrt{1 + \alpha^2}} \sqrt{\frac{2}{\pi}} $$ If $\alpha = 0$, the skew-normal distribution becomes the gaussian distribution. For location shift models, $y$ can be any real value. ## Binary and count data models The density of the **binomial** family is given by $$ f(y) = {N \choose y} \mu^{y} (1-\mu)^{N - y} $$ where $N$ is the number of trials and $y \in \{0, ... , N\}$. When all $N$ are $1$ (i.e., $y \in \{0,1\}$), the **bernoulli** distribution for binary data arises. For $y \in \mathbb{N}_0$, the density of the **poisson** family is given by $$ f(y) = \frac{\mu^{y}}{y!} \exp(-\mu) $$ The density of the **negbinomial** (negative binomial) family is $$ f(y) = {y + \phi - 1 \choose y} \left(\frac{\mu}{\mu + \phi}\right)^{y} \left(\frac{\phi}{\mu + \phi}\right)^\phi $$ where $\phi$ is a positive precision parameter. For $\phi \rightarrow \infty$, the negative binomial distribution becomes the poisson distribution. The density of the **geometric** family arises if $\phi$ is set to $1$. ## Time-to-event models With time-to-event models we mean all models that are defined on the positive reals only, that is $y \in \mathbb{R}^+$. The density of the **lognormal** family is given by $$ f(y) = \frac{1}{\sqrt{2\pi}\sigma y} \exp\left(-\frac{1}{2}\left(\frac{\log(y) - \mu}{\sigma}\right)^2\right) $$ where $\sigma$ is the residual standard deviation on the log-scale. The density of the **Gamma** family is given by $$ f(y) = \frac{(\alpha / \mu)^\alpha}{\Gamma(\alpha)} y^{\alpha-1} \exp\left(-\frac{\alpha y}{\mu}\right) $$ where $\alpha$ is a positive shape parameter. The density of the **weibull** family is given by $$ f(y) = \frac{\alpha}{s} \left(\frac{y}{s}\right)^{\alpha-1} \exp\left(-\left(\frac{y}{s}\right)^\alpha\right) $$ where $\alpha$ is again a positive shape parameter and $s = \mu / \Gamma(1 + 1 / \alpha)$ is the scale parameter to that $\mu$ is the mean of the distribution. The **exponential** family arises if $\alpha$ is set to $1$ for either the gamma or Weibull distribution. The density of the **inverse.gaussian** family is given by $$ f(y) = \left(\frac{\alpha}{2 \pi y^3}\right)^{1/2} \exp \left(\frac{-\alpha (y - \mu)^2}{2 \mu^2 y} \right) $$ where $\alpha$ is a positive shape parameter. The **cox** family implements Cox proportional hazards model which assumes a hazard function of the form $h(y) = h_0(y) \mu$ with baseline hazard $h_0(y)$ expressed via M-splines (which integrate to I-splines) in order to ensure monotonicity. The density of the cox model is then given by $$ f(y) = h(y) S(y) $$ where $S(y)$ is the survival function implied by $h(y)$. ## Extreme value models Modeling extremes requires special distributions. One may use the **weibull** distribution (see above) or the **frechet** distribution with density $$ f(y) = \frac{\nu}{s} \left(\frac{y}{s}\right)^{-1-\nu} \exp\left(-\left(\frac{y}{s}\right)^{-\nu}\right) $$ where $s = \mu / \Gamma(1 - 1 / \nu)$ is a positive scale parameter and $\nu > 1$ is a shape parameter so that $\mu$ predicts the mean of the Frechet distribution. A generalization of both distributions is the generalized extreme value distribution (family **gen_extreme_value**) with density $$ f(y) = \frac{1}{\sigma} t(y)^{\xi + 1} \exp(-t(y)) $$ where $$ t(y) = \left(1 + \xi \left(\frac{y - \mu}{\sigma} \right)\right)^{-1 / \xi} $$ with positive scale parameter $\sigma$ and shape parameter $\xi$. ## Response time models One family that is especially suited to model reaction times is the **exgaussian** ('exponentially modified Gaussian') family. Its density is given by $$ f(y) = \frac{1}{2 \beta} \exp\left(\frac{1}{2 \beta} \left(2\xi + \sigma^2 / \beta - 2 y \right) \right) \text{erfc}\left(\frac{\xi + \sigma^2 / \beta - y}{\sqrt{2} \sigma} \right) $$ where $\beta$ is the scale (inverse rate) of the exponential component, $\xi$ is the mean of the Gaussian component, $\sigma$ is the standard deviation of the Gaussian component, and $\text{erfc}$ is the complementary error function. We parameterize $\mu = \xi + \beta$ so that the main predictor term equals the mean of the distribution. Another family well suited for modeling response times is the **shifted_lognormal** distribution. It's density equals that of the **lognormal** distribution except that the whole distribution is shifted to the right by a positive parameter called *ndt* (for consistency with the **wiener** diffusion model explained below). A family concerned with the combined modeling of reaction times and corresponding binary responses is the **wiener** diffusion model. It has four model parameters each with a natural interpretation. The parameter $\alpha > 0$ describes the separation between two boundaries of the diffusion process, $\tau > 0$ describes the non-decision time (e.g., due to image or motor processing), $\beta \in [0, 1]$ describes the initial bias in favor of the upper alternative, and $\delta \in \mathbb{R}$ describes the drift rate to the boundaries (a positive value indicates a drift towards to upper boundary). The density for the reaction time at the upper boundary is given by $$ f(y) = \frac{\alpha}{(y-\tau)^3/2} \exp \! \left(- \delta \alpha \beta - \frac{\delta^2(y-\tau)}{2}\right) \sum_{k = - \infty}^{\infty} (2k + \beta) \phi \! \left(\frac{2k + \alpha \beta}{\sqrt{y - \tau}}\right) $$ where $\phi(x)$ denotes the standard normal density function. The density at the lower boundary can be obtained by substituting $1 - \beta$ for $\beta$ and $-\delta$ for $\delta$ in the above equation. In brms the parameters $\alpha$, $\tau$, and $\beta$ are modeled as auxiliary parameters named *bs* ('boundary separation'), *ndt* ('non-decision time'), and *bias* respectively, whereas the drift rate $\delta$ is modeled via the ordinary model formula that is as $\delta = \mu$. ## Quantile regression Quantile regression is implemented via family **asym_laplace** (asymmetric Laplace distribution) with density $$ f(y) = \frac{p (1 - p)}{\sigma} \exp\left(-\rho_p\left(\frac{y - \mu}{\sigma}\right)\right) $$ where $\rho_p$ is given by $\rho_p(x) = x (p - I_{x < 0})$ and $I_A$ is the indicator function of set $A$. The parameter $\sigma$ is a positive scale parameter and $p$ is the *quantile* parameter taking on values in $(0, 1)$. For this distribution, we have $P(Y < g(\eta)) = p$. Thus, quantile regression can be performed by fixing $p$ to the quantile to interest. ## Probability models The density of the **Beta** family for $y \in (0,1)$ is given by $$ f(y) = \frac{y^{\mu \phi - 1} (1-y)^{(1-\mu) \phi-1}}{B(\mu \phi, (1-\mu) \phi)} $$ where $B$ is the beta function and $\phi$ is a positive precision parameter. A multivariate generalization of the **Beta** family is the **dirichlet** family with density $$ f(y) = \frac{1}{B((\mu_{1}, \ldots, \mu_{K}) \phi)} \prod_{k=1}^K y_{k}^{\mu_{k} \phi - 1}. $$ The **dirichlet** family is implemented with the multivariate logit link function so that $$ \mu_{j} = \frac{\exp(\eta_{j})}{\sum_{k = 1}^{K} \exp(\eta_{k})} $$ For reasons of identifiability, $\eta_{\rm ref}$ is set to $0$, where ${\rm ref}$ is one of the response categories chosen as reference. An alternative to the **dirichlet** family is the **logistic_normal** family with density $$ f(y) = \frac{1}{\prod_{k=1}^K y_k} \times \text{multivariate_normal}(\tilde{y} \, | \, \mu, \sigma, \Omega) $$ where $\tilde{y}$ is the multivariate logit transformed response $$ \tilde{y} = (\log(y_1 / y_{\rm ref}), \ldots, \log(y_{\rm ref-1} / y_{\rm ref}), \log(y_{\rm ref+1} / y_{\rm ref}), \ldots, \log(y_K / y_{\rm ref})) $$ of dimension $K-1$ (excluding the reference category), which is modeled as multivariate normally distributed with latent mean and standard deviation vectors $\mu$ and $\sigma$, as well as correlation matrix $\Omega$. ## Circular models The density of the **von_mises** family for $y \in (-\pi,\pi)$ is given by $$ f(y) = \frac{\exp(\kappa \cos(y - \mu))}{2\pi I_0(\kappa)} $$ where $I_0$ is the modified Bessel function of order 0 and $\kappa$ is a positive precision parameter. ## Ordinal and categorical models For ordinal and categorical models, $y$ is one of the categories $1, ..., K$. The intercepts of ordinal models are called thresholds and are denoted as $\tau_k$, with $k \in \{1, ..., K-1\}$, whereas $\eta$ does not contain a fixed effects intercept. Note that the applied link functions $h$ are technically distribution functions $\mathbb{R} \rightarrow [0,1]$. The density of the **cumulative** family (implementing the most basic ordinal model) is given by $$ f(y) = g(\tau_{y + 1} - \eta) - g(\tau_{y} - \eta) $$ The densities of the **sratio** (stopping ratio) and **cratio** (continuation ratio) families are given by $$ f(y) = g(\tau_{y + 1} - \eta) \prod_{k = 1}^{y} (1 - g(\tau_{k} - \eta)) $$ and $$ f(y) = (1 - g(\eta - \tau_{y + 1})) \prod_{k = 1}^{y} g(\eta - \tau_{k}) $$ respectively. Note that both families are equivalent for symmetric link functions such as logit or probit. The density of the **acat** (adjacent category) family is given by $$ f(y) = \frac{\prod_{k=1}^{y} g(\eta - \tau_{k}) \prod_{k=y+1}^K(1-g(\eta - \tau_{k}))}{\sum_{k=0}^K\prod_{j=1}^k g(\eta-\tau_{j}) \prod_{j=k+1}^K(1-g(\eta - \tau_{j}))} $$ For the logit link, this can be simplified to $$ f(y) = \frac{\exp \left(\sum_{k=1}^{y} (\eta - \tau_{k}) \right)} {\sum_{k=0}^K \exp\left(\sum_{j=1}^k (\eta - \tau_{j}) \right)} $$ The linear predictor $\eta$ can be generalized to also depend on the category $k$ for a subset of predictors. This leads to category specific effects (for details on how to specify them see `help(brm)`). Note that **cumulative** and **sratio** models use $\tau - \eta$, whereas **cratio** and **acat** use $\eta - \tau$. This is done to ensure that larger values of $\eta$ increase the probability of *higher* response categories. The **categorical** family is currently only implemented with the multivariate logit link function and has density $$ f(y) = \mu_{y} = \frac{\exp(\eta_{y})}{\sum_{k = 1}^{K} \exp(\eta_{k})} $$ Note that $\eta$ does also depend on the category $k$. For reasons of identifiability, $\eta_{1}$ is set to $0$. A generalization of the **categorical** family to more than one trial is the **multinomial** family with density $$ f(y) = {N \choose y_{1}, y_{2}, \ldots, y_{K}} \prod_{k=1}^K \mu_{k}^{y_{k}} $$ where, for each category, $\mu_{k}$ is estimated via the multivariate logit link function shown above. ## Zero-inflated and hurdle models **Zero-inflated** and **hurdle** families extend existing families by adding special processes for responses that are zero. The density of a **zero-inflated** family is given by $$ f_z(y) = z + (1 - z) f(0) \quad \text{if } y = 0 \\ f_z(y) = (1 - z) f(y) \quad \text{if } y > 0 $$ where $z$ denotes the zero-inflation probability. Currently implemented families are **zero_inflated_poisson**, **zero_inflated_binomial**, **zero_inflated_negbinomial**, and **zero_inflated_beta**. The density of a **hurdle** family is given by $$ f_z(y) = z \quad \text{if } y = 0 \\ f_z(y) = (1 - z) f(y) / (1 - f(0)) \quad \text{if } y > 0 $$ Currently implemented families are **hurdle_poisson**, **hurdle_negbinomial**, **hurdle_gamma**, and **hurdle_lognormal**. The density of a **zero-one-inflated** family is given by $$ f_{\alpha, \gamma}(y) = \alpha (1 - \gamma) \quad \text{if } y = 0 \\ f_{\alpha, \gamma}(y) = \alpha \gamma \quad \text{if } y = 1 \\ f_{\alpha, \gamma}(y) = (1 - \alpha) f(y) \quad \text{if } y \notin \{0, 1\} $$ where $\alpha$ is the zero-one-inflation probability (i.e. the probability that zero or one occurs) and $\gamma$ is the conditional one-inflation probability (i.e. the probability that one occurs rather than zero). Currently implemented families are **zero_one_inflated_beta**. brms/inst/doc/brms_monotonic.Rmd0000644000176200001440000002057315053072461016445 0ustar liggesusers--- title: "Estimating Monotonic Effects with brms" author: "Paul Bürkner" date: "`r Sys.Date()`" output: rmarkdown::html_vignette: toc: yes vignette: > %\VignetteIndexEntry{Estimating Monotonic Effects with brms} %\VignetteEngine{knitr::rmarkdown} \usepackage[utf8]{inputenc} params: EVAL: !r identical(Sys.getenv("NOT_CRAN"), "true") --- ```{r, SETTINGS-knitr, include=FALSE} stopifnot(require(knitr)) options(width = 90) knit_hooks$set(pngquant = knitr::hook_pngquant) opts_chunk$set( comment = NA, message = FALSE, warning = FALSE, eval = if (isTRUE(exists("params"))) params$EVAL else FALSE, dev = "ragg_png", dpi = 72, fig.retina = 1.5, fig.asp = 0.8, fig.width = 5, out.width = "60%", fig.align = "center", pngquant = "--speed=1 --quality=50" ) library(brms) ggplot2::theme_set(theme_default()) ``` ## Introduction This vignette is about monotonic effects, a special way of handling discrete predictors that are on an ordinal or higher scale (Bürkner & Charpentier, in review). A predictor, which we want to model as monotonic (i.e., having a monotonically increasing or decreasing relationship with the response), must either be integer valued or an ordered factor. As opposed to a continuous predictor, predictor categories (or integers) are not assumed to be equidistant with respect to their effect on the response variable. Instead, the distance between adjacent predictor categories (or integers) is estimated from the data and may vary across categories. This is realized by parameterizing as follows: One parameter, $b$, takes care of the direction and size of the effect similar to an ordinary regression parameter. If the monotonic effect is used in a linear model, $b$ can be interpreted as the expected average difference between two adjacent categories of the ordinal predictor. An additional parameter vector, $\zeta$, estimates the normalized distances between consecutive predictor categories which thus defines the shape of the monotonic effect. For a single monotonic predictor, $x$, the linear predictor term of observation $n$ looks as follows: $$\eta_n = b D \sum_{i = 1}^{x_n} \zeta_i$$ The parameter $b$ can take on any real value, while $\zeta$ is a simplex, which means that it satisfies $\zeta_i \in [0,1]$ and $\sum_{i = 1}^D \zeta_i = 1$ with $D$ being the number of elements of $\zeta$. Equivalently, $D$ is the number of categories (or highest integer in the data) minus 1, since we start counting categories from zero to simplify the notation. ## A Simple Monotonic Model A main application of monotonic effects are ordinal predictors that can be modeled this way without falsely treating them either as continuous or as unordered categorical predictors. In Psychology, for instance, this kind of data is omnipresent in the form of Likert scale items, which are often treated as being continuous for convenience without ever testing this assumption. As an example, suppose we are interested in the relationship of yearly income (in $) and life satisfaction measured on an arbitrary scale from 0 to 100. Usually, people are not asked for the exact income. Instead, they are asked to rank themselves in one of certain classes, say: 'below 20k', 'between 20k and 40k', 'between 40k and 100k' and 'above 100k'. We use some simulated data for illustration purposes. ```{r} income_options <- c("below_20", "20_to_40", "40_to_100", "greater_100") income <- factor(sample(income_options, 100, TRUE), levels = income_options, ordered = TRUE) mean_ls <- c(30, 60, 70, 75) ls <- mean_ls[income] + rnorm(100, sd = 7) dat <- data.frame(income, ls) ``` We now proceed with analyzing the data modeling `income` as a monotonic effect. ```{r, results='hide'} fit1 <- brm(ls ~ mo(income), data = dat) ``` The summary methods yield ```{r} summary(fit1) plot(fit1, variable = "simo", regex = TRUE) plot(conditional_effects(fit1)) ``` The distributions of the simplex parameter of `income`, as shown in the `plot` method, demonstrate that the largest difference (about 70% of the difference between minimum and maximum category) is between the first two categories. Now, let's compare of monotonic model with two common alternative models. (a) Assume `income` to be continuous: ```{r, results='hide'} dat$income_num <- as.numeric(dat$income) fit2 <- brm(ls ~ income_num, data = dat) ``` ```{r} summary(fit2) ``` or (b) Assume `income` to be an unordered factor: ```{r, results='hide'} contrasts(dat$income) <- contr.treatment(4) fit3 <- brm(ls ~ income, data = dat) ``` ```{r} summary(fit3) ``` We can easily compare the fit of the three models using leave-one-out cross-validation. ```{r} loo(fit1, fit2, fit3) ``` The monotonic model fits better than the continuous model, which is not surprising given that the relationship between `income` and `ls` is non-linear. The monotonic and the unordered factor model have almost identical fit in this example, but this may not be the case for other data sets. ## Setting Prior Distributions In the previous monotonic model, we have implicitly assumed that all differences between adjacent categories were a-priori the same, or formulated correctly, had the same prior distribution. In the following, we want to show how to change this assumption. The canonical prior distribution of a simplex parameter is the Dirichlet distribution, a multivariate generalization of the beta distribution. It is non-zero for all valid simplexes (i.e., $\zeta_i \in [0,1]$ and $\sum_{i = 1}^D \zeta_i = 1$) and zero otherwise. The Dirichlet prior has a single parameter $\alpha$ of the same length as $\zeta$. The higher $\alpha_i$ the higher the a-priori probability of higher values of $\zeta_i$. Suppose that, before looking at the data, we expected that the same amount of additional money matters more for people who generally have less money. This translates into a higher a-priori values of $\zeta_1$ (difference between 'below_20' and '20_to_40') and hence into higher values of $\alpha_1$. We choose $\alpha_1 = 2$ and $\alpha_2 = \alpha_3 = 1$, the latter being the default value of $\alpha$. To fit the model we write: ```{r, results='hide'} prior4 <- prior(dirichlet(c(2, 1, 1)), class = "simo", coef = "moincome1") fit4 <- brm(ls ~ mo(income), data = dat, prior = prior4, sample_prior = TRUE) ``` The `1` at the end of `"moincome1"` may appear strange when first working with monotonic effects. However, it is necessary as one monotonic term may be associated with multiple simplex parameters, if interactions of multiple monotonic variables are included in the model. ```{r} summary(fit4) ``` We have used `sample_prior = TRUE` to also obtain draws from the prior distribution of `simo_moincome1` so that we can visualized it. ```{r} plot(fit4, variable = "prior_simo", regex = TRUE, N = 3) ``` As is visible in the plots, `simo_moincome1[1]` was a-priori on average twice as high as `simo_moincome1[2]` and `simo_moincome1[3]` as a result of setting $\alpha_1$ to 2. ## Modeling interactions of monotonic variables Suppose, we have additionally asked participants for their age. ```{r} dat$age <- rnorm(100, mean = 40, sd = 10) ``` We are not only interested in the main effect of age but also in the interaction of income and age. Interactions with monotonic variables can be specified in the usual way using the `*` operator: ```{r, results='hide'} fit5 <- brm(ls ~ mo(income)*age, data = dat) ``` ```{r} summary(fit5) conditional_effects(fit5, "income:age") ``` ## Modelling Monotonic Group-Level Effects Suppose that the 100 people in our sample data were drawn from 10 different cities; 10 people per city. Thus, we add an identifier for `city` to the data and add some city-related variation to `ls`. ```{r} dat$city <- rep(1:10, each = 10) var_city <- rnorm(10, sd = 10) dat$ls <- dat$ls + var_city[dat$city] ``` With the following code, we fit a multilevel model assuming the intercept and the effect of `income` to vary by city: ```{r, results='hide'} fit6 <- brm(ls ~ mo(income)*age + (mo(income) | city), data = dat) ``` ```{r} summary(fit6) ``` reveals that the effect of `income` varies only little across cities. For the present data, this is not overly surprising given that, in the data simulations, we assumed `income` to have the same effect across cities. ## References Bürkner P. C. & Charpentier, E. (in review). [Monotonic Effects: A Principled Approach for Including Ordinal Predictors in Regression Models](https://osf.io/preprints/psyarxiv/9qkhj/). *PsyArXiv preprint*. brms/inst/doc/brms_multivariate.Rmd0000644000176200001440000002025315053072461017141 0ustar liggesusers--- title: "Estimating Multivariate Models with brms" author: "Paul Bürkner" date: "`r Sys.Date()`" output: rmarkdown::html_vignette: toc: yes vignette: > %\VignetteIndexEntry{Estimating Multivariate Models with brms} %\VignetteEngine{knitr::rmarkdown} \usepackage[utf8]{inputenc} params: EVAL: !r identical(Sys.getenv("NOT_CRAN"), "true") --- ```{r, SETTINGS-knitr, include=FALSE} stopifnot(require(knitr)) options(width = 90) knit_hooks$set(pngquant = knitr::hook_pngquant) opts_chunk$set( comment = NA, message = FALSE, warning = FALSE, eval = if (isTRUE(exists("params"))) params$EVAL else FALSE, dev = "ragg_png", dpi = 72, fig.retina = 1.5, fig.asp = 0.8, fig.width = 5, out.width = "60%", fig.align = "center", pngquant = "--speed=1 --quality=50" ) library(brms) ggplot2::theme_set(theme_default()) ``` ## Introduction In the present vignette, we want to discuss how to specify multivariate multilevel models using **brms**. We call a model *multivariate* if it contains multiple response variables, each being predicted by its own set of predictors. Consider an example from biology. Hadfield, Nutall, Osorio, and Owens (2007) analyzed data of the Eurasian blue tit (https://en.wikipedia.org/wiki/Eurasian_blue_tit). They predicted the `tarsus` length as well as the `back` color of chicks. Half of the brood were put into another `fosternest`, while the other half stayed in the fosternest of their own `dam`. This allows to separate genetic from environmental factors. Additionally, we have information about the `hatchdate` and `sex` of the chicks (the latter being known for 94\% of the animals). ```{r data} data("BTdata", package = "MCMCglmm") head(BTdata) ``` ## Basic Multivariate Models We begin with a relatively simple multivariate normal model. ```{r fit1, message=FALSE, warning=FALSE, results='hide'} bform1 <- bf(mvbind(tarsus, back) ~ sex + hatchdate + (1|p|fosternest) + (1|q|dam)) + set_rescor(TRUE) fit1 <- brm(bform1, data = BTdata, chains = 2, cores = 2) ``` As can be seen in the model code, we have used `mvbind` notation to tell **brms** that both `tarsus` and `back` are separate response variables. The term `(1|p|fosternest)` indicates a varying intercept over `fosternest`. By writing `|p|` in between we indicate that all varying effects of `fosternest` should be modeled as correlated. This makes sense since we actually have two model parts, one for `tarsus` and one for `back`. The indicator `p` is arbitrary and can be replaced by other symbols that comes into your mind (for details about the multilevel syntax of **brms**, see `help("brmsformula")` and `vignette("brms_multilevel")`). Similarly, the term `(1|q|dam)` indicates correlated varying effects of the genetic mother of the chicks. Alternatively, we could have also modeled the genetic similarities through pedigrees and corresponding relatedness matrices, but this is not the focus of this vignette (please see `vignette("brms_phylogenetics")`). The model results are readily summarized via ```{r summary1, warning=FALSE} fit1 <- add_criterion(fit1, "loo") summary(fit1) ``` The summary output of multivariate models closely resembles those of univariate models, except that the parameters now have the corresponding response variable as prefix. Across dams, tarsus length and back color seem to be negatively correlated, while across fosternests the opposite is true. This indicates differential effects of genetic and environmental factors on these two characteristics. Further, the small residual correlation `rescor(tarsus, back)` on the bottom of the output indicates that there is little unmodeled dependency between tarsus length and back color. Although not necessary at this point, we have already computed and stored the LOO information criterion of `fit1`, which we will use for model comparisons. Next, let's take a look at some posterior-predictive checks, which give us a first impression of the model fit. ```{r pp_check1, message=FALSE} pp_check(fit1, resp = "tarsus") pp_check(fit1, resp = "back") ``` This looks pretty solid, but we notice a slight unmodeled left skewness in the distribution of `tarsus`. We will come back to this later on. Next, we want to investigate how much variation in the response variables can be explained by our model and we use a Bayesian generalization of the $R^2$ coefficient. ```{r R2_1} bayes_R2(fit1) ``` Clearly, there is much variation in both animal characteristics that we can not explain, but apparently we can explain more of the variation in tarsus length than in back color. ## More Complex Multivariate Models Now, suppose we only want to control for `sex` in `tarsus` but not in `back` and vice versa for `hatchdate`. Not that this is particular reasonable for the present example, but it allows us to illustrate how to specify different formulas for different response variables. We can no longer use `mvbind` syntax and so we have to use a more verbose approach: ```{r fit2, message=FALSE, warning=FALSE, results='hide'} bf_tarsus <- bf(tarsus ~ sex + (1|p|fosternest) + (1|q|dam)) bf_back <- bf(back ~ hatchdate + (1|p|fosternest) + (1|q|dam)) fit2 <- brm(bf_tarsus + bf_back + set_rescor(TRUE), data = BTdata, chains = 2, cores = 2) ``` Note that we have literally *added* the two model parts via the `+` operator, which is in this case equivalent to writing `mvbf(bf_tarsus, bf_back)`. See `help("brmsformula")` and `help("mvbrmsformula")` for more details about this syntax. Again, we summarize the model first. ```{r summary2, warning=FALSE} fit2 <- add_criterion(fit2, "loo") summary(fit2) ``` Let's find out, how model fit changed due to excluding certain effects from the initial model: ```{r loo12} loo(fit1, fit2) ``` Apparently, there is no noteworthy difference in the model fit. Accordingly, we do not really need to model `sex` and `hatchdate` for both response variables, but there is also no harm in including them (so I would probably just include them). To give you a glimpse of the capabilities of **brms**' multivariate syntax, we change our model in various directions at the same time. Remember the slight left skewness of `tarsus`, which we will now model by using the `skew_normal` family instead of the `gaussian` family. Since we do not have a multivariate normal (or student-t) model, anymore, estimating residual correlations is no longer possible. We make this explicit using the `set_rescor` function. Further, we investigate if the relationship of `back` and `hatchdate` is really linear as previously assumed by fitting a non-linear spline of `hatchdate`. On top of it, we model separate residual variances of `tarsus` for male and female chicks. ```{r fit3, message=FALSE, warning=FALSE, results='hide'} bf_tarsus <- bf(tarsus ~ sex + (1|p|fosternest) + (1|q|dam)) + lf(sigma ~ 0 + sex) + skew_normal() bf_back <- bf(back ~ s(hatchdate) + (1|p|fosternest) + (1|q|dam)) + gaussian() fit3 <- brm( bf_tarsus + bf_back + set_rescor(FALSE), data = BTdata, chains = 2, cores = 2, control = list(adapt_delta = 0.95) ) ``` Again, we summarize the model and look at some posterior-predictive checks. ```{r summary3, warning=FALSE} fit3 <- add_criterion(fit3, "loo") summary(fit3) ``` We see that the (log) residual standard deviation of `tarsus` is somewhat larger for chicks whose sex could not be identified as compared to male or female chicks. Further, we see from the negative `alpha` (skewness) parameter of `tarsus` that the residuals are indeed slightly left-skewed. Lastly, running ```{r me3} conditional_effects(fit3, "hatchdate", resp = "back") ``` reveals a non-linear relationship of `hatchdate` on the `back` color, which seems to change in waves over the course of the hatch dates. There are many more modeling options for multivariate models, which are not discussed in this vignette. Examples include autocorrelation structures, Gaussian processes, or explicit non-linear predictors (e.g., see `help("brmsformula")` or `vignette("brms_multilevel")`). In fact, nearly all the flexibility of univariate models is retained in multivariate models. ## References Hadfield JD, Nutall A, Osorio D, Owens IPF (2007). Testing the phenotypic gambit: phenotypic, genetic and environmental correlations of colour. *Journal of Evolutionary Biology*, 20(2), 549-557. brms/inst/doc/brms_phylogenetics.R0000644000176200001440000001353215057753012016773 0ustar liggesusersparams <- list(EVAL = TRUE) ## ----SETTINGS-knitr, include=FALSE------------------------------------------------------ stopifnot(require(knitr)) options(width = 90) knit_hooks$set(pngquant = knitr::hook_pngquant) opts_chunk$set( comment = NA, message = FALSE, warning = FALSE, eval = if (isTRUE(exists("params"))) params$EVAL else FALSE, dev = "ragg_png", dpi = 72, fig.retina = 1.5, fig.asp = 0.8, fig.width = 5, out.width = "60%", fig.align = "center", pngquant = "--speed=1 --quality=50" ) library(brms) ggplot2::theme_set(theme_default()) ## --------------------------------------------------------------------------------------- phylo <- ape::read.nexus("https://paul-buerkner.github.io/data/phylo.nex") data_simple <- read.table( "https://paul-buerkner.github.io/data/data_simple.txt", header = TRUE ) head(data_simple) ## --------------------------------------------------------------------------------------- A <- ape::vcv.phylo(phylo) ## ----results='hide'--------------------------------------------------------------------- model_simple <- brm( phen ~ cofactor + (1|gr(phylo, cov = A)), data = data_simple, family = gaussian(), data2 = list(A = A), prior = c( prior(normal(0, 10), "b"), prior(normal(0, 50), "Intercept"), prior(student_t(3, 0, 20), "sd"), prior(student_t(3, 0, 20), "sigma") ) ) ## --------------------------------------------------------------------------------------- summary(model_simple) plot(model_simple, N = 2, ask = FALSE) plot(conditional_effects(model_simple), points = TRUE) ## --------------------------------------------------------------------------------------- hyp <- "sd_phylo__Intercept^2 / (sd_phylo__Intercept^2 + sigma^2) = 0" (hyp <- hypothesis(model_simple, hyp, class = NULL)) plot(hyp) ## --------------------------------------------------------------------------------------- data_repeat <- read.table( "https://paul-buerkner.github.io/data/data_repeat.txt", header = TRUE ) data_repeat$spec_mean_cf <- with(data_repeat, sapply(split(cofactor, phylo), mean)[phylo]) head(data_repeat) ## ----results='hide'--------------------------------------------------------------------- model_repeat1 <- brm( phen ~ spec_mean_cf + (1|gr(phylo, cov = A)) + (1|species), data = data_repeat, family = gaussian(), data2 = list(A = A), prior = c( prior(normal(0,10), "b"), prior(normal(0,50), "Intercept"), prior(student_t(3,0,20), "sd"), prior(student_t(3,0,20), "sigma") ), sample_prior = TRUE, chains = 2, cores = 2, iter = 4000, warmup = 1000 ) ## --------------------------------------------------------------------------------------- summary(model_repeat1) ## --------------------------------------------------------------------------------------- hyp <- paste( "sd_phylo__Intercept^2 /", "(sd_phylo__Intercept^2 + sd_species__Intercept^2 + sigma^2) = 0" ) (hyp <- hypothesis(model_repeat1, hyp, class = NULL)) plot(hyp) ## --------------------------------------------------------------------------------------- data_repeat$within_spec_cf <- data_repeat$cofactor - data_repeat$spec_mean_cf ## ----results='hide'--------------------------------------------------------------------- model_repeat2 <- update( model_repeat1, formula = ~ . + within_spec_cf, newdata = data_repeat, chains = 2, cores = 2, iter = 4000, warmup = 1000 ) ## --------------------------------------------------------------------------------------- summary(model_repeat2) ## --------------------------------------------------------------------------------------- hyp <- paste( "sd_phylo__Intercept^2 /", "(sd_phylo__Intercept^2 + sd_species__Intercept^2 + sigma^2) = 0" ) (hyp <- hypothesis(model_repeat2, hyp, class = NULL)) ## --------------------------------------------------------------------------------------- data_fisher <- read.table( "https://paul-buerkner.github.io/data/data_effect.txt", header = TRUE ) data_fisher$obs <- 1:nrow(data_fisher) head(data_fisher) ## ----results='hide'--------------------------------------------------------------------- model_fisher <- brm( Zr | se(sqrt(1 / (N - 3))) ~ 1 + (1|gr(phylo, cov = A)) + (1|obs), data = data_fisher, family = gaussian(), data2 = list(A = A), prior = c( prior(normal(0, 10), "Intercept"), prior(student_t(3, 0, 10), "sd") ), control = list(adapt_delta = 0.95), chains = 2, cores = 2, iter = 4000, warmup = 1000 ) ## --------------------------------------------------------------------------------------- summary(model_fisher) plot(model_fisher) ## --------------------------------------------------------------------------------------- data_pois <- read.table( "https://paul-buerkner.github.io/data/data_pois.txt", header = TRUE ) data_pois$obs <- 1:nrow(data_pois) head(data_pois) ## ----results='hide'--------------------------------------------------------------------- model_pois <- brm( phen_pois ~ cofactor + (1|gr(phylo, cov = A)) + (1|obs), data = data_pois, family = poisson("log"), data2 = list(A = A), chains = 2, cores = 2, iter = 4000, control = list(adapt_delta = 0.95) ) ## --------------------------------------------------------------------------------------- summary(model_pois) plot(conditional_effects(model_pois), points = TRUE) ## ----results='hide'--------------------------------------------------------------------- model_normal <- brm( phen_pois ~ cofactor + (1|gr(phylo, cov = A)), data = data_pois, family = gaussian(), data2 = list(A = A), chains = 2, cores = 2, iter = 4000, control = list(adapt_delta = 0.95) ) ## --------------------------------------------------------------------------------------- summary(model_normal) ## --------------------------------------------------------------------------------------- pp_check(model_pois) pp_check(model_normal) ## --------------------------------------------------------------------------------------- loo(model_pois, model_normal) brms/inst/doc/brms_multilevel.ltx0000644000176200001440000016555114213413565016716 0ustar liggesusers\documentclass[article, nojss]{jss} %\VignetteIndexEntry{Multilevel Models with brms} %\VignetteEngine{R.rsp::tex} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %% declarations for jss.cls %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %% almost as usual \author{Paul-Christian B\"urkner} \title{Advanced Bayesian Multilevel Modeling with the \proglang{R} Package \pkg{brms}} %% for pretty printing and a nice hypersummary also set: \Plainauthor{Paul-Christian B\"urkner} %% comma-separated \Plaintitle{Advanced Bayesian Multilevel Modeling with the R Package brms} %% without formatting \Shorttitle{Advanced Bayesian Multilevel Modeling with \pkg{brms}} %% a short title (if necessary) %% an abstract and keywords \Abstract{ The \pkg{brms} package allows R users to easily specify a wide range of Bayesian single-level and multilevel models, which are fitted with the probabilistic programming language \proglang{Stan} behind the scenes. Several response distributions are supported, of which all parameters (e.g., location, scale, and shape) can be predicted at the same time thus allowing for distributional regression. Non-linear relationships may be specified using non-linear predictor terms or semi-parametric approaches such as splines or Gaussian processes. Multivariate models, in which each response variable can be predicted using the above mentioned options, can be fitted as well. To make all of these modeling options possible in a multilevel framework, \pkg{brms} provides an intuitive and powerful formula syntax, which extends the well known formula syntax of \pkg{lme4}. The purpose of the present paper is to introduce this syntax in detail and to demonstrate its usefulness with four examples, each showing other relevant aspects of the syntax. If you use \pkg{brms}, please cite this article as published in the R Journal \citep{brms2}. } \Keywords{Bayesian inference, multilevel models, distributional regression, MCMC, \proglang{Stan}, \proglang{R}} \Plainkeywords{Bayesian inference, multilevel models, distributional regression, MCMC, Stan, R} %% without formatting %% at least one keyword must be supplied %% publication information %% NOTE: Typically, this can be left commented and will be filled out by the technical editor %% \Volume{50} %% \Issue{9} %% \Month{June} %% \Year{2012} %% \Submitdate{2012-06-04} %% \Acceptdate{2012-06-04} %% The address of (at least) one author should be given %% in the following format: \Address{ Paul-Christian B\"urkner\\ E-mail: \email{paul.buerkner@gmail.com}\\ URL: \url{https://paul-buerkner.github.io} } %% It is also possible to add a telephone and fax number %% before the e-mail in the following format: %% Telephone: +43/512/507-7103 %% Fax: +43/512/507-2851 %% for those who use Sweave please include the following line (with % symbols): %% need no \usepackage{Sweave.sty} %% end of declarations %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \begin{document} %% include your article here, just as usual %% Note that you should use the \pkg{}, \proglang{} and \code{} commands. \section{Introduction} Multilevel models (MLMs) offer great flexibility for researchers across sciences \citep{brown2015, demidenko2013, gelmanMLM2006, pinheiro2006}. They allow modeling of data measured on different levels at the same time -- for instance data of students nested within classes and schools -- thus taking complex dependency structures into account. It is not surprising that many packages for R have been developed to fit MLMs. Usually, however, the functionality of these implementations is limited insofar as it is only possible to predict the mean of the response distribution. Other parameters of the response distribution, such as the residual standard deviation in linear models, are assumed constant across observations, which may be violated in many applications. Accordingly, it is desirable to allow for prediction of \emph{all} response parameters at the same time. Models doing exactly that are often referred to as \emph{distributional models} or more verbosely \emph{models for location, scale and shape} \citep{rigby2005}. Another limitation of basic MLMs is that they only allow for linear predictor terms. While linear predictor terms already offer good flexibility, they are of limited use when relationships are inherently non-linear. Such non-linearity can be handled in at least two ways: (1) by fully specifying a non-linear predictor term with corresponding parameters each of which can be predicted using MLMs \citep{lindstrom1990}, or (2) estimating the form of the non-linear relationship on the fly using splines \citep{wood2004} or Gaussian processes \citep{rasmussen2006}. The former are often simply called \emph{non-linear models}, while models applying splines are referred to as \emph{generalized additive models} (GAMs; \citeauthor{hastie1990}, \citeyear{hastie1990}). Combining all of these modeling options into one framework is a complex task, both conceptually and with regard to model fitting. Maximum likelihood methods, which are typically applied in classical 'frequentist' statistics, can reach their limits at some point and fully Bayesian methods become the go-to solutions to fit such complex models \citep{gelman2014}. In addition to being more flexible, the Bayesian framework comes with other advantages, for instance, the ability to derive probability statements for every quantity of interest or explicitly incorporating prior knowledge about parameters into the model. The former is particularly relevant in non-linear models, for which classical approaches struggle more often than not in propagating all the uncertainty in the parameter estimates to non-linear functions such as out-of-sample predictions. Possibly the most powerful program for performing full Bayesian inference available to date is Stan \citep{stanM2017, carpenter2017}. It implements Hamiltonian Monte Carlo \citep{duane1987, neal2011, betancourt2014} and its extension, the No-U-Turn (NUTS) Sampler \citep{hoffman2014}. These algorithms converge much more quickly than other Markov-Chain Monte-Carlo (MCMC) algorithms especially for high-dimensional models \citep{hoffman2014, betancourt2014, betancourt2017}. An excellent non-mathematical introduction to Hamiltonian Monte Carlo can be found in \citet{betancourt2017}. Stan comes with its own programming language, allowing for great modeling flexibility \cite{stanM2017, carpenter2017}). Many researchers may still be hesitent to use Stan directly, as every model has to be written, debugged and possibly also optimized. This may be a time-consuming and error-prone process even for researchers familiar with Bayesian inference. The \pkg{brms} package \citep{brms1}, presented in this paper, aims to remove these hurdles for a wide range of regression models by allowing the user to benefit from the merits of Stan by using extended \pkg{lme4}-like \citep{bates2015} formula syntax, with which many R users are familiar with. It offers much more than writing efficient and human-readable Stan code: \pkg{brms} comes with many post-processing and visualization functions, for instance to perform posterior predictive checks, leave-one-out cross-validation, visualization of estimated effects, and prediction of new data. The overarching aim is to have one general framework for regression modeling, which offers everything required to successfully apply regression models to complex data. To date, it already replaces and extends the functionality of dozens of other R packages, each of which is restricted to specific regression models\footnote{Unfortunately, due to the implementation via Stan, it is not easily possible for users to define their own response distributions and run them via \pkg{brms}. If you feel that a response distribution is missing in \pkg{brms}, please open an issue on GitHub (\url{https://github.com/paul-buerkner/brms}).}. The purpose of the present article is to provide an introduction of the advanced multilevel formula syntax implemented in \pkg{brms}, which allows to fit a wide and growing range of non-linear distributional multilevel models. A general overview of the package is already given in \citet{brms1}. Accordingly, the present article focuses on more recent developments. We begin by explaining the underlying structure of distributional models. Next, the formula syntax of \pkg{lme4} and its extensions implemented in \pkg{brms} are explained. Four examples that demonstrate the use of the new syntax are discussed in detail. Afterwards, the functionality of \pkg{brms} is compared with that of \pkg{rstanarm} \citep{rstanarm2017} and \pkg{MCMCglmm} \citep{hadfield2010}. We end by describing future plans for extending the package. \section{Model description} \label{model} The core of models implemented in \pkg{brms} is the prediction of the response $y$ through predicting all parameters $\theta_p$ of the response distribution $D$, which is also called the model \code{family} in many R packages. We write $$y_i \sim D(\theta_{1i}, \theta_{2i}, ...)$$ to stress the dependency on the $i\textsuperscript{th}$ observation. Every parameter $\theta_p$ may be regressed on its own predictor term $\eta_p$ transformed by the inverse link function $f_p$ that is $\theta_{pi} = f_p(\eta_{pi})$\footnote{A parameter can also be assumed constant across observations so that a linear predictor is not required.}. Such models are typically refered to as \emph{distributional models}\footnote{The models described in \citet{brms1} are a sub-class of the here described models.}. Details about the parameterization of each \code{family} are given in \code{vignette("brms\_families")}. Suppressing the index $p$ for simplicity, a predictor term $\eta$ can generally be written as $$ \eta = \mathbf{X} \beta + \mathbf{Z} u + \sum_{k = 1}^K s_k(x_k) $$ In this equation, $\beta$ and $u$ are the coefficients at population-level and group-level respectively and $\mathbf{X}, \mathbf{Z}$ are the corresponding design matrices. The terms $s_k(x_k)$ symbolize optional smooth functions of unspecified form based on covariates $x_k$ fitted via splines (see \citet{wood2011} for the underlying implementation in the \pkg{mgcv} package) or Gaussian processes \citep{williams1996}. The response $y$ as well as $\mathbf{X}$, $\mathbf{Z}$, and $x_k$ make up the data, whereas $\beta$, $u$, and the smooth functions $s_k$ are the model parameters being estimated. The coefficients $\beta$ and $u$ may be more commonly known as fixed and random effects, but I avoid theses terms following the recommendations of \citet{gelmanMLM2006}. Details about prior distributions of $\beta$ and $u$ can be found in \citet{brms1} and under \code{help("set\_prior")}. As an alternative to the strictly additive formulation described above, predictor terms may also have any form specifiable in Stan. We call it a \emph{non-linear} predictor and write $$\eta = f(c_1, c_2, ..., \phi_1, \phi_2, ...)$$ The structure of the function $f$ is given by the user, $c_r$ are known or observed covariates, and $\phi_s$ are non-linear parameters each having its own linear predictor term $\eta_{\phi_s}$ of the form specified above. In fact, we should think of non-linear parameters as placeholders for linear predictor terms rather than as parameters themselves. A frequentist implementation of such models, which inspired the non-linear syntax in \pkg{brms}, can be found in the \pkg{nlme} package \citep{nlme2016}. \section{Extended multilevel formula syntax} \label{formula_syntax} The formula syntax applied in \pkg{brms} builds upon the syntax of the R package \pkg{lme4} \citep{bates2015}. First, we will briefly explain the \pkg{lme4} syntax used to specify multilevel models and then introduce certain extensions that allow to specify much more complicated models in \pkg{brms}. An \pkg{lme4} formula has the general form \begin{Sinput} response ~ pterms + (gterms | group) \end{Sinput} The \code{pterms} part contains the population-level effects that are assumed to be the same across obervations. The \code{gterms} part contains so called group-level effects that are assumed to vary accross grouping variables specified in \code{group}. Multiple grouping factors each with multiple group-level effects are possible. Usually, \code{group} contains only a single variable name pointing to a factor, but you may also use \code{g1:g2} or \code{g1/g2}, if both \code{g1} and \code{g2} are suitable grouping factors. The \code{:} operator creates a new grouping factor that consists of the combined levels of \code{g1} and \code{g2} (you could think of this as pasting the levels of both factors together). The \code{/} operator indicates nested grouping structures and expands one grouping factor into two or more when using multiple \code{/} within one term. If, for instance, you write \code{(1 | g1/g2)}, it will be expanded to \code{(1 | g1) + (1 | g1:g2)}. Instead of \code{|} you may use \code{||} in grouping terms to prevent group-level correlations from being modeled. This may be useful in particular when modeling so many group-level effects that convergence of the fitting algorithms becomes an issue due to model complexity. One limitation of the \code{||} operator in \pkg{lme4} is that it only splits up terms so that columns of the design matrix originating from the same term are still modeled as correlated (e.g., when coding a categorical predictor; see the \code{mixed} function of the \pkg{afex} package by \citet{afex2015} for a way to avoid this behavior). While intuitive and visually appealing, the classic \pkg{lme4} syntax is not flexible enough to allow for specifying the more complex models supported by \pkg{brms}. In non-linear or distributional models, for instance, multiple parameters are predicted, each having their own population and group-level effects. Hence, multiple formulas are necessary to specify such models\footnote{Actually, it is possible to specify multiple model parts within one formula using interactions terms for instance as implemented in \pkg{MCMCglmm} \citep{hadfield2010}. However, this syntax is limited in flexibility and requires a rather deep understanding of the way R parses formulas, thus often being confusing to users.}. Then, however, specifying group-level effects of the same grouping factor to be correlated \emph{across} formulas becomes complicated. The solution implemented in \pkg{brms} (and currently unique to it) is to expand the \code{|} operator into \code{||}, where \code{} can be any value. Group-level terms with the same \code{ID} will then be modeled as correlated if they share same grouping factor(s)\footnote{It might even be further extended to \code{|fun()|}, where \code{fun} defines the type of correlation structure, defaulting to unstructured that is estimating the full correlation matrix. The \code{fun} argument is not yet supported by \pkg{brms} but could be supported in the future if other correlation structures, such as compound symmetry or Toeplitz, turn out to have reasonable practical applications and effective implementations in Stan.}. For instance, if the terms \code{(x1|ID|g1)} and \code{(x2|ID|g1)} appear somewhere in the same or different formulas passed to \pkg{brms}, they will be modeled as correlated. Further extensions of the classical \pkg{lme4} syntax refer to the \code{group} part. It is rather limited in its flexibility since only variable names combined by \code{:} or \code{/} are supported. We propose two extensions of this syntax: Firstly, \code{group} can generally be split up in its terms so that, say, \code{(1 | g1 + g2)} is expanded to \code{(1 | g1) + (1 | g2)}. This is fully consistent with the way \code{/} is handled so it provides a natural generalization to the existing syntax. Secondly, there are some special grouping structures that cannot be expressed by simply combining grouping variables. For instance, multi-membership models cannot be expressed this way. To overcome this limitation, we propose wrapping terms in \code{group} within special functions that allow specifying alternative grouping structures: \code{(gterms | fun(group))}. In \pkg{brms}, there are currently two such functions implemented, namely \code{gr} for the default behavior and \code{mm} for multi-membership terms. To be compatible with the original syntax and to keep formulas short, \code{gr} is automatically added internally if none of these functions is specified. While some non-linear relationships, such as quadratic relationships, can be expressed within the basic R formula syntax, other more complicated ones cannot. For this reason, it is possible in \pkg{brms} to fully specify non-linear predictor terms similar to how it is done in \pkg{nlme}, but fully compatible with the extended multilevel syntax described above. Suppose, for instance, we want to model the non-linear growth curve $$ y = b_1 (1 - \exp(-(x / b_2)^{b_3}) $$ between $y$ and $x$ with parameters $b_1$, $b_2$, and $b_3$ (see Example 3 in this paper for an implementation of this model with real data). Furthermore, we want all three parameters to vary by a grouping variable $g$ and model those group-level effects as correlated. Additionally $b_1$ should be predicted by a covariate $z$. We can express this in \pkg{brms} using multiple formulas, one for the non-linear model itself and one per non-linear parameter: \begin{Sinput} y ~ b1 * (1 - exp(-(x / b2) ^ b3) b1 ~ z + (1|ID|g) b2 ~ (1|ID|g) b3 ~ (1|ID|g) \end{Sinput} The first formula will not be evaluated using standard R formula parsing, but instead taken literally. In contrast, the formulas for the non-linear parameters will be evaluated in the usual way and are compatible with all terms supported by \pkg{brms}. Note that we have used the above described ID-syntax to model group-level effects as correlated across formulas. There are other syntax extensions implemented in \pkg{brms} that do not directly target grouping terms. Firstly, there are terms formally included in the \code{pterms} part that are handled separately. The most prominent examples are smooth terms specified through the \code{s} and \code{t2} functions of the \pkg{mgcv} package \citep{wood2011}. Other examples are category specific effects \code{cs}, monotonic effects \code{mo}, noise-free effects \code{me}, or Gaussian process terms \code{gp}. The former is explained in \citet{brms1}, while the latter three are documented in \code{help(brmsformula)}. Internally, these terms are extracted from \code{pterms} and not included in the construction of the population-level design matrix. Secondly, making use of the fact that \code{|} is unused on the left-hand side of $\sim$ in formula, additional information on the response variable may be specified via \begin{Sinput} response | aterms ~ \end{Sinput} The \code{aterms} part may contain multiple terms of the form \code{fun()} separated by \code{+} each providing special information on the response variable. This allows among others to weight observations, provide known standard errors for meta-analysis, or model censored or truncated data. As it is not the main topic of the present paper, we refer to \code{help("brmsformula")} and \code{help("addition-terms")} for more details. To set up the model formulas and combine them into one object, \pkg{brms} defines the \code{brmsformula} (or short \code{bf}) function. Its output can then be passed to the \code{parse\_bf} function, which splits up the formulas in separate parts and prepares them for the generation of design matrices and related data. Other packages may re-use these functions in their own routines making it easier to offer support for the above described multilevel syntax. \section{Examples} The idea of \pkg{brms} is to provide one unified framework for multilevel regression models in R. As such, the above described formula syntax in all of its variations can be applied in combination with all response distributions supported by \pkg{brms} (currently about 35 response distributions are supported; see \code{help("brmsfamily")} and \code{vignette("brms\_families")} for an overview). In this section, we will discuss four examples in detail, each focusing on certain aspects of the syntax. They are chosen to provide a broad overview of the modeling options. The first is about the number of fish caught be different groups of people. It does not actually contain any multilevel structure, but helps in understanding how to set up formulas for different model parts. The second example is about housing rents in Munich. We model the data using splines and a distributional regression approach. The third example is about cumulative insurance loss payments across several years, which is fitted using a rather complex non-linear multilevel model. Finally, the fourth example is about the performance of school children, who change school during the year, thus requiring a multi-membership model. Despite not being covered in the four examples, there are a few more modeling options that we want to briefly describe. First, \pkg{brms} allows fitting so called phylogenetic models. These models are relevant in evolutionary biology when data of many species are analyzed at the same time. Species are not independent as they come from the same phylogenetic tree, implying that different levels of the same grouping-factor (i.e., species) are likely correlated. There is a whole vignette dedicated to this topic, which can be found via \code{vignette("brms\_phylogenetics")}. Second, there is a canonical way to handle ordinal predictors, without falsely assuming they are either categorical or continuous. We call them monotonic effects and discuss them in \code{vignette("brms\_monotonic")}. Last but not least, it is possible to account for measurement error in both response and predictor variables. This is often ignored in applied regression modeling \citep{westfall2016}, although measurement error is very common in all scientific fields making use of observational data. There is no vignette yet covering this topic, but one will be added in the future. In the meantime, \code{help("brmsformula")} is the best place to start learning about such models as well as about other details of the \pkg{brms} formula syntax. \subsection{Example 1: Catching fish} An important application of the distributional regression framework of \pkg{brms} are so called zero-inflated and hurdle models. These models are helpful whenever there are more zeros in the response variable than one would naturally expect. Here, we consider an example dealing with the number of fish caught by various groups of people. On the UCLA website (\url{https://stats.idre.ucla.edu/stata/dae/zero-inflated-poisson-regression}), the data are described as follows: ``The state wildlife biologists want to model how many fish are being caught by fishermen at a state park. Visitors are asked how long they stayed, how many people were in the group, were there children in the group and how many fish were caught. Some visitors do not fish, but there is no data on whether a person fished or not. Some visitors who did fish did not catch any fish so there are excess zeros in the data because of the people that did not fish.'' \begin{Sinput} zinb <- read.csv("http://stats.idre.ucla.edu/stat/data/fish.csv") zinb$camper <- factor(zinb$camper, labels = c("no", "yes")) head(zinb) \end{Sinput} \begin{Sinput} nofish livebait camper persons child xb zg count 1 1 0 no 1 0 -0.8963146 3.0504048 0 2 0 1 yes 1 0 -0.5583450 1.7461489 0 3 0 1 no 1 0 -0.4017310 0.2799389 0 4 0 1 yes 2 1 -0.9562981 -0.6015257 0 5 0 1 no 1 0 0.4368910 0.5277091 1 6 0 1 yes 4 2 1.3944855 -0.7075348 0 \end{Sinput} As predictors we choose the number of people per group, the number of children, as well as whether or not the group consists of campers. Many groups may not catch any fish just because they do not try and so we fit a zero-inflated Poisson model. For now, we assume a constant zero-inflation probability across observations. \begin{Sinput} fit_zinb1 <- brm(count ~ persons + child + camper, data = zinb, family = zero_inflated_poisson("log")) \end{Sinput} The model is readily summarized via \begin{Sinput} summary(fit_zinb1) \end{Sinput} \begin{Sinput} Family: zero_inflated_poisson (log) Formula: count ~ persons + child + camper Data: zinb (Number of observations: 250) Samples: 4 chains, each with iter = 2000; warmup = 1000; thin = 1; total post-warmup samples = 4000 WAIC: Not computed Population-Level Effects: Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat Intercept -1.01 0.17 -1.34 -0.67 2171 1 persons 0.87 0.04 0.79 0.96 2188 1 child -1.36 0.09 -1.55 -1.18 1790 1 camper 0.80 0.09 0.62 0.98 2950 1 Family Specific Parameters: Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat zi 0.41 0.04 0.32 0.49 2409 1 Samples were drawn using sampling(NUTS). For each parameter, Eff.Sample is a crude measure of effective sample size, and Rhat is the potential scale reduction factor on split chains (at convergence, Rhat = 1). \end{Sinput} A graphical summary is available through \begin{Sinput} conditional_effects(fit_zinb1) \end{Sinput} \begin{figure}[ht] \centering \includegraphics[width=0.99\textwidth,keepaspectratio]{me_zinb1.pdf} \caption{Conditional effects plots of the \code{fit\_zinb1} model.} \label{me_zinb1} \end{figure} (see Figure \ref{me_zinb1}). In fact, the \code{conditional\_effects} method turned out to be so powerful in visualizing effects of predictors that I am using it almost as frequently as \code{summary}. According to the parameter estimates, larger groups catch more fish, campers catch more fish than non-campers, and groups with more children catch less fish. The zero-inflation probability \code{zi} is pretty large with a mean of 41\%. Please note that the probability of catching no fish is actually higher than 41\%, but parts of this probability are already modeled by the Poisson distribution itself (hence the name zero-\emph{inflation}). If you want to treat all zeros as originating from a separate process, you can use hurdle models instead (not shown here). Now, we try to additionally predict the zero-inflation probability by the number of children. The underlying reasoning is that we expect groups with more children to not even try catching fish, since children often lack the patience required for fishing. From a purely statistical perspective, zero-inflated (and hurdle) distributions are a mixture of two processes and predicting both parts of the model is natural and often very reasonable to make full use of the data. \begin{Sinput} fit_zinb2 <- brm(bf(count ~ persons + child + camper, zi ~ child), data = zinb, family = zero_inflated_poisson()) \end{Sinput} To transform the linear predictor of \code{zi} into a probability, \pkg{brms} applies the logit-link, which takes values within $[0, 1]$ and returns values on the real line. Thus, it allows the transition between probabilities and linear predictors. \begin{Sinput} summary(fit_zinb2) \end{Sinput} \begin{Sinput} Family: zero_inflated_poisson (log) Formula: count ~ persons + child + camper zi ~ child Data: zinb (Number of observations: 250) Samples: 4 chains, each with iter = 2000; warmup = 1000; thin = 1; total post-warmup samples = 4000 WAIC: Not computed Population-Level Effects: Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat Intercept -1.07 0.18 -1.43 -0.73 2322 1 persons 0.89 0.05 0.80 0.98 2481 1 child -1.17 0.10 -1.37 -1.00 2615 1 camper 0.78 0.10 0.60 0.96 3270 1 zi_Intercept -0.95 0.27 -1.52 -0.48 2341 1 zi_child 1.21 0.28 0.69 1.79 2492 1 Samples were drawn using sampling(NUTS). For each parameter, Eff.Sample is a crude measure of effective sample size, and Rhat is the potential scale reduction factor on split chains (at convergence, Rhat = 1). \end{Sinput} According to the model, trying to fish with children not only decreases the overall number fish caught (as implied by the Poisson part of the model) but also drastically increases your chance of catching no fish at all (as implied by the zero-inflation part), possibly because groups with more children spend less time or no time at all fishing. Comparing model fit via leave-one-out cross validation as implemented in the \pkg{loo} package \citep{loo2016, vehtari2016}. \begin{Sinput} LOO(fit_zinb1, fit_zinb2) \end{Sinput} \begin{Sinput} LOOIC SE fit_zinb1 1639.52 363.30 fit_zinb2 1621.35 362.39 fit_zinb1 - fit_zinb2 18.16 15.71 \end{Sinput} reveals that the second model using the number of children to predict both model parts has better fit. However, when considering the standard error of the \code{LOOIC} difference, improvement in model fit is apparently modest and not substantial. More examples of distributional model can be found in \code{vignette("brms\_distreg")}. \subsection{Example 2: Housing rents} In their book about regression modeling, \citet{fahrmeir2013} use an example about the housing rents in Munich from 1999. The data contains information about roughly 3000 apartments including among others the absolute rent (\code{rent}), rent per square meter (\code{rentsqm}), size of the apartment (\code{area}), construction year (\code{yearc}), and the district in Munich (\code{district}), where the apartment is located. The data can be found in the \pkg{gamlss.data} package \citep{gamlss.data}: \begin{Sinput} data("rent99", package = "gamlss.data") head(rent99) \end{Sinput} \begin{Sinput} rent rentsqm area yearc location bath kitchen cheating district 1 109.9487 4.228797 26 1918 2 0 0 0 916 2 243.2820 8.688646 28 1918 2 0 0 1 813 3 261.6410 8.721369 30 1918 1 0 0 1 611 4 106.4103 3.547009 30 1918 2 0 0 0 2025 5 133.3846 4.446154 30 1918 2 0 0 1 561 6 339.0256 11.300851 30 1918 2 0 0 1 541 \end{Sinput} Here, we aim at predicting the rent per square meter with the size of the apartment as well as the construction year, while taking the district of Munich into account. As the effect of both predictors on the rent is of unknown non-linear form, we model these variables using a bivariate tensor spline \citep{wood2013}. The district is accounted for via a varying intercept. \begin{Sinput} fit_rent1 <- brm(rentsqm ~ t2(area, yearc) + (1|district), data = rent99, chains = 2, cores = 2) \end{Sinput} We fit the model using just two chains (instead of the default of four chains) on two processor cores to reduce the model fitting time for the purpose of the present paper. In general, using the default option of four chains (or more) is recommended. \begin{Sinput} summary(fit_rent1) \end{Sinput} \begin{Sinput} Family: gaussian(identity) Formula: rentsqm ~ t2(area, yearc) + (1 | district) Data: rent99 (Number of observations: 3082) Samples: 2 chains, each with iter = 2000; warmup = 1000; thin = 1; total post-warmup samples = 2000 ICs: LOO = NA; WAIC = NA; R2 = NA Smooth Terms: Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat sds(t2areayearc_1) 4.93 2.32 1.61 10.77 1546 1.00 sds(t2areayearc_2) 5.78 2.87 1.58 13.15 1175 1.00 sds(t2areayearc_3) 8.09 3.19 3.66 16.22 1418 1.00 Group-Level Effects: ~district (Number of levels: 336) Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat sd(Intercept) 0.60 0.06 0.48 0.73 494 1.01 Population-Level Effects: Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat Intercept 7.80 0.11 7.59 8.02 2000 1.00 t2areayearc_1 -1.00 0.09 -1.15 -0.83 2000 1.00 t2areayearc_2 0.75 0.17 0.43 1.09 2000 1.00 t2areayearc_3 -0.07 0.16 -0.40 0.24 1579 1.00 Family Specific Parameters: Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat sigma 1.95 0.03 1.90 2.01 2000 1.00 Samples were drawn using sampling(NUTS). For each parameter, Eff.Sample is a crude measure of effective sample size, and Rhat is the potential scale reduction factor on split chains (at convergence, Rhat = 1). \end{Sinput} For models including splines, the output of \code{summary} is not tremendously helpful, but we get at least some information. Firstly, the credible intervals of the standard deviations of the coefficients forming the splines (under \code{'Smooth Terms'}) are sufficiently far away from zero to indicate non-linearity in the (combined) effect of \code{area} and \code{yearc}. Secondly, even after controlling for these predictors, districts still vary with respect to rent per square meter by a sizable amount as visible under \code{'Group-Level Effects'} in the output. To further understand the effect of the predictor, we apply graphical methods: \begin{Sinput} conditional_effects(fit_rent1, surface = TRUE) \end{Sinput} In Figure \ref{me_rent1}, the conditional effects of both predictors are displayed, while the respective other predictor is fixed at its mean. In Figure \ref{me_rent2}, the combined effect is shown, clearly demonstrating an interaction between the variables. In particular, housing rents appear to be highest for small and relatively new apartments. \begin{figure}[ht] \centering \includegraphics[width=0.99\textwidth,keepaspectratio]{me_rent1.pdf} \caption{Conditional effects plots of the \code{fit\_rent1} model for single predictors.} \label{me_rent1} \end{figure} \begin{figure}[ht] \centering \includegraphics[width=0.7\textwidth,keepaspectratio]{me_rent2.pdf} \caption{Surface plot of the \code{fit\_rent1} model for the combined effect of \code{area} and \code{yearc}.} \label{me_rent2} \end{figure} In the above example, we only considered the mean of the response distribution to vary by \code{area} and \code{yearc}, but this my not necessarily reasonable assumption, as the variation of the response might vary with these variables as well. Accordingly, we fit splines and effects of district for both the location and the scale parameter, which is called \code{sigma} in Gaussian models. \begin{Sinput} bform <- bf(rentsqm ~ t2(area, yearc) + (1|ID1|district), sigma ~ t2(area, yearc) + (1|ID1|district)) fit_rent2 <- brm(bform, data = rent99, chains = 2, cores = 2) \end{Sinput} If not otherwise specified, \code{sigma} is predicted on the log-scale to ensure it is positive no matter how the predictor term looks like. Instead of \code{(1|district)} as in the previous model, we now use \code{(1|ID1|district)} in both formulas. This results in modeling the varying intercepts of both model parts as correlated (see the description of the ID-syntax above). The group-level part of the \code{summary} output looks as follows: \begin{Sinput} Group-Level Effects: ~district (Number of levels: 336) Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat sd(Intercept) 0.60 0.06 0.49 0.73 744 1.00 sd(sigma_Intercept) 0.11 0.02 0.06 0.15 751 1.00 cor(Intercept,sigma_Intercept) 0.72 0.17 0.35 0.98 648 1.00 \end{Sinput} As visible from the positive correlation of the intercepts, districts with overall higher rent per square meter have higher variation at the same time. Lastly, we want to turn our attention to the splines. While \code{conditional\_effects} is used to visualize effects of predictors on the expected response, \code{conditional\_smooths} is used to show just the spline parts of the model: \begin{Sinput} conditional_smooths(fit_rent2) \end{Sinput} The plot on the left-hand side of Figure \ref{me_rent3} resembles the one in Figure \ref{me_rent2}, but the scale is different since only the spline is plotted. The right-hand side of \ref{me_rent3} shows the spline for \code{sigma}. Since we apply the log-link on \code{sigma} by default the spline is on the log-scale as well. As visible in the plot, the variation in the rent per square meter is highest for relatively small and old apartments, while the variation is smallest for medium to large apartments build around the 1960s. \begin{figure}[ht] \centering \includegraphics[width=0.99\textwidth,keepaspectratio]{me_rent3.pdf} \caption{Plots showing the smooth terms of the \code{fit\_rent2} model.} \label{me_rent3} \end{figure} \subsection{Example 3: Insurance loss payments} On his blog, Markus Gesmann predicts the growth of cumulative insurance loss payments over time, originated from different origin years (see \url{http://www.magesblog.com/2015/11/loss-developments-via-growth-curves-and.html}). We will use a slightly simplified version of his model for demonstration purposes here. It looks as follows: $$cum_{AY, dev} \sim N(\mu_{AY, dev}, \sigma)$$ $$\mu_{AY, dev} = ult_{AY} \left(1 - \exp\left(- \left( \frac{dev}{\theta} \right)^\omega \right) \right)$$ The cumulative insurance payments $cum$ will grow over time, and we model this dependency using the variable $dev$. Further, $ult_{AY}$ is the (to be estimated) ultimate loss of accident each year. It constitutes a non-linear parameter in our framework along with the parameters $\theta$ and $\omega$, which are responsible for the growth of the cumulative loss and are for now assumed to be the same across years. We load the data \begin{Sinput} url <- paste0("https://raw.githubusercontent.com/mages/", "diesunddas/master/Data/ClarkTriangle.csv") loss <- read.csv(url) head(loss) \end{Sinput} \begin{Sinput} AY dev cum 1 1991 6 357.848 2 1991 18 1124.788 3 1991 30 1735.330 4 1991 42 2182.708 5 1991 54 2745.596 6 1991 66 3319.994 \end{Sinput} and translate the proposed model into a non-linear \pkg{brms} model. \begin{Sinput} nlform <- bf(cum ~ ult * (1 - exp(-(dev / theta)^omega)), ult ~ 1 + (1|AY), omega ~ 1, theta ~ 1, nl = TRUE) nlprior <- c(prior(normal(5000, 1000), nlpar = "ult"), prior(normal(1, 2), nlpar = "omega"), prior(normal(45, 10), nlpar = "theta")) fit_loss1 <- brm(formula = nlform, data = loss, family = gaussian(), prior = nlprior, control = list(adapt_delta = 0.9)) \end{Sinput} In the above functions calls, quite a few things are going on. The formulas are wrapped in \code{bf} to combine them into one object. The first formula specifies the non-linear model. We set argument \code{nl = TRUE} so that \pkg{brms} takes this formula literally and instead of using standard R formula parsing. We specify one additional formula per non-linear parameter (a) to clarify what variables are covariates and what are parameters and (b) to specify the predictor term for the parameters. We estimate a group-level effect of accident year (variable \code{AY}) for the ultimate loss \code{ult}. This also shows nicely how a non-linear parameter is actually a placeholder for a linear predictor, which in the case of \code{ult}, contains only a varying intercept for year. Both \code{omega} and \code{theta} are assumed to be constant across observations so we just fit a population-level intercept. Priors on population-level effects are required and, for the present model, are actually mandatory to ensure identifiability. Otherwise, we may observe that different Markov chains converge to different parameter regions as multiple posterior distribution are equally plausible. Setting prior distributions is a difficult task especially in non-linear models. It requires some experience and knowledge both about the model that is being fitted and about the data at hand. Additionally, there is more to keep in mind to optimize the sampler's performance: Firstly, using non- or weakly informative priors in non-linear models often leads to problems even if the model is generally identified. For instance, if a zero-centered and reasonably wide prior such as \code{normal(0, 10000)} it set on \code{ult}, there is little information about \code{theta} and \code{omega} for samples of \code{ult} being close to zero, which may lead to convergence problems. Secondly, Stan works best when parameters are roughly on the same order of magnitude \citep{stan2017}. In the present example, \code{ult} is of three orders larger than \code{omega}. Still, the sampler seems to work quite well, but this may not be true for other models. One solution is to rescale parameters before model fitting. For instance, for the present example, one could have downscaled \code{ult} by replacing it with \code{ult * 1000} and correspondingly the \code{normal(5000, 1000)} prior with \code{normal(5, 1)}. In the \code{control} argument we increase \code{adapt\_delta} to get rid of a few divergent transitions (cf. \citeauthor{stan2017}, \citeyear{stan2017}; \citeauthor{brms1}, \citeyear{brms1}). Again the model is summarized via \begin{Sinput} summary(fit_loss1) \end{Sinput} \begin{Sinput} Family: gaussian (identity) Formula: cum ~ ult * (1 - exp(-(dev / theta)^omega)) ult ~ 1 + (1 | AY) omega ~ 1 theta ~ 1 Data: loss (Number of observations: 55) Samples: 4 chains, each with iter = 2000; warmup = 1000; thin = 1; total post-warmup samples = 4000 WAIC: Not computed Group-Level Effects: ~AY (Number of levels: 10) Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat sd(ult_Intercept) 745.74 231.31 421.05 1306.04 916 1 Population-Level Effects: Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat ult_Intercept 5273.70 292.34 4707.11 5852.28 798 1 omega_Intercept 1.34 0.05 1.24 1.43 2167 1 theta_Intercept 46.07 2.09 42.38 50.57 1896 1 Family Specific Parameters: Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat sigma 139.93 15.52 113.6 175.33 2358 1 Samples were drawn using sampling(NUTS). For each parameter, Eff.Sample is a crude measure of effective sample size, and Rhat is the potential scale reduction factor on split chains (at convergence, Rhat = 1). \end{Sinput} as well as \begin{Sinput} conditional_effects(fit_loss1) \end{Sinput} \begin{figure}[ht] \centering \includegraphics[width=0.7\textwidth,keepaspectratio]{me_loss1.pdf} \caption{Conditional effects plots of the \code{fit\_loss1} model.} \label{me_loss1} \end{figure} (see Figure \ref{me_loss1}). We can also visualize the cumulative insurance loss over time separately for each year. \begin{Sinput} conditions <- data.frame(AY = unique(loss$AY)) rownames(conditions) <- unique(loss$AY) me_year <- conditional_effects(fit_loss1, conditions = conditions, re_formula = NULL, method = "predict") plot(me_year, ncol = 5, points = TRUE) \end{Sinput} \begin{figure}[ht] \centering \includegraphics[width=0.99\textwidth,keepaspectratio]{me_loss1_year.pdf} \caption{Conditional effects plots of the \code{fit\_loss1} model separately for each accident year.} \label{me_loss1_year} \end{figure} (see Figure \ref{me_loss1_year}). It is evident that there is some variation in cumulative loss across accident years, for instance due to natural disasters happening only in certain years. Further, we see that the uncertainty in the predicted cumulative loss is larger for later years with fewer available data points. In the above model, we considered \code{omega} and \code{delta} to be constant across years, which may not necessarily be true. We can easily investigate this by fitting varying intercepts for all three non-linear parameters also estimating group-level correlation using the above introduced \code{ID} syntax. \begin{Sinput} nlform2 <- bf(cum ~ ult * (1 - exp(-(dev / theta)^omega)), ult ~ 1 + (1|ID1|AY), omega ~ 1 + (1|ID1|AY), theta ~ 1 + (1|ID1|AY), nl = TRUE) fit_loss2 <- update(fit_loss1, formula = nlform2, control = list(adapt_delta = 0.90)) \end{Sinput} We could have also specified all predictor terms more conveniently within one formula as \begin{Sinput} ult + omega + theta ~ 1 + (1|ID1|AY) \end{Sinput} because the structure of the predictor terms is identical. To compare model fit, we perform leave-one-out cross-validation. \begin{Sinput} LOO(fit_loss1, fit_loss2) \end{Sinput} \begin{Sinput} LOOIC SE fit_loss1 715.44 19.24 fit_loss2 720.60 19.85 fit_loss1 - fit_loss2 -5.15 5.34 \end{Sinput} Since smaller values indicate better expected out-of-sample predictions and thus better model fit, the simpler model that only has a varying intercept over parameter \code{ult} is preferred. This may not be overly surprising, given that three varying intercepts as well as three group-level correlations are probably overkill for data containing only 55 observations. Nevertheless, it nicely demonstrates how to apply the \code{ID} syntax in practice. More examples of non-linear models can be found in \code{vignette("brms\_nonlinear")}. \subsection{Example 4: Performance of school children} Suppose that we want to predict the performance of students in the final exams at the end of the year. There are many variables to consider, but one important factor will clearly be school membership. Schools might differ in the ratio of teachers and students, the general quality of teaching, in the cognitive ability of the students they draw, or other factors we are not aware of that induce dependency among students of the same school. Thus, it is advised to apply a multilevel modeling techniques including school membership as a group-level term. Of course, we should account for class membership and other levels of the educational hierarchy as well, but for the purpose of the present example, we will focus on schools only. Usually, accounting for school membership is pretty-straight forward by simply adding a varying intercept to the formula: \code{(1 | school)}. However, a non-negligible number of students might change schools during the year. This would result in a situation where one student is a member of multiple schools and so we need a multi-membership model. Setting up such a model not only requires information on the different schools students attend during the year, but also the amount of time spend at each school. The latter can be used to weight the influence each school has on its students, since more time attending a school will likely result in greater influence. For now, let us assume that students change schools maximally once a year and spend equal time at each school. We will later see how to relax these assumptions. Real educational data are usually relatively large and complex so that we simulate our own data for the purpose of this tutorial paper. We simulate 10 schools and 1000 students, with each school having the same expected number of 100 students. We model 10\% of students as changing schools. \begin{Sinput} data_mm <- sim_multi_mem(nschools = 10, nstudents = 1000, change = 0.1) head(data_mm) \end{Sinput} \begin{Sinput} s1 s2 w1 w2 y 1 8 9 0.5 0.5 16.27422 2 10 9 0.5 0.5 18.71387 3 5 3 0.5 0.5 23.65319 4 3 5 0.5 0.5 22.35204 5 5 3 0.5 0.5 16.38019 6 10 6 0.5 0.5 17.63494 \end{Sinput} The code of function \code{sim\_multi\_mem} can be found in the online supplement of the present paper. For reasons of better illustration, students changing schools appear in the first rows of the data. Data of students being only at a single school looks as follows: \begin{Sinput} data_mm[101:106, ] \end{Sinput} \begin{Sinput} s1 s2 w1 w2 y 101 2 2 0.5 0.5 27.247851 102 9 9 0.5 0.5 24.041427 103 4 4 0.5 0.5 12.575001 104 2 2 0.5 0.5 21.203644 105 4 4 0.5 0.5 12.856166 106 4 4 0.5 0.5 9.740174 \end{Sinput} Thus, school variables are identical, but we still have to specify both in order to pass the data appropriately. Incorporating no other predictors into the model for simplicity, a multi-membership model is specified as \begin{Sinput} fit_mm <- brm(y ~ 1 + (1 | mm(s1, s2)), data = data_mm) \end{Sinput} The only new syntax element is that multiple grouping factors (\code{s1} and \code{s2}) are wrapped in \code{mm}. Everything else remains exactly the same. Note that we did not specify the relative weights of schools for each student and thus, by default, equal weights are assumed. \begin{Sinput} summary(fit_mm) \end{Sinput} \begin{Sinput} Family: gaussian (identity) Formula: y ~ 1 + (1 | mm(s1, s2)) Data: data_mm (Number of observations: 1000) Samples: 4 chains, each with iter = 2000; warmup = 1000; thin = 1; total post-warmup samples = 4000 WAIC: Not computed Group-Level Effects: ~mms1s2 (Number of levels: 10) Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat sd(Intercept) 2.76 0.82 1.69 4.74 682 1.01 Population-Level Effects: Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat Intercept 19 0.93 17.06 20.8 610 1 Family Specific Parameters: Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat sigma 3.58 0.08 3.43 3.75 2117 1 Samples were drawn using sampling(NUTS). For each parameter, Eff.Sample is a crude measure of effective sample size, and Rhat is the potential scale reduction factor on split chains (at convergence, Rhat = 1). \end{Sinput} With regard to the assumptions made in the above example, it is unlikely that all children who change schools stay in both schools equally long. To relax this assumption, we have to specify weights. First, we amend the simulated data to contain non-equal weights for students changing schools. For all other students, weighting does of course not matter as they stay in the same school anyway. \begin{Sinput} data_mm[1:100, "w1"] <- runif(100, 0, 1) data_mm[1:100, "w2"] <- 1 - data_mm[1:100, "w1"] head(data_mm) \end{Sinput} \begin{Sinput} s1 s2 w1 w2 y 1 8 9 0.3403258 0.65967423 16.27422 2 10 9 0.1771435 0.82285652 18.71387 3 5 3 0.9059811 0.09401892 23.65319 4 3 5 0.4432007 0.55679930 22.35204 5 5 3 0.8052026 0.19479738 16.38019 6 10 6 0.5610243 0.43897567 17.63494 \end{Sinput} Incorporating these weights into the model is straight forward. \begin{Sinput} fit_mm2 <- brm(y ~ 1 + (1 | mm(s1, s2, weights = cbind(w1, w2))), data = data_mm) \end{Sinput} The summary output is similar to the previous, so we do not show it here. The second assumption that students change schools only once a year, may also easily be relaxed by providing more than two grouping factors, say, \code{mm(s1, s2, s3)}. \section{Comparison between packages} Over the years, many R packages have been developed that implement MLMs, each being more or less general in their supported models. In \cite{brms1}, I compared \pkg{brms} with \pkg{lme4} \citep{bates2015}, \pkg{MCMCglmm} \citep{hadfield2010}, \pkg{rstanarm} \citep{rstanarm2017}, and \pkg{rethinking} \citep{mcelreath2017}. Since then, quite a few new features have been added in particular to \pkg{brms} and \pkg{rstanarm}. Accordingly, in the present paper, I will update these comparisons, but focus on \pkg{brms}, \pkg{rstanarm}, and \pkg{MCMCglmm} as the possibly most important R packages implementing Bayesian MLMs. While \pkg{brms} and \pkg{rstanarm} are both based on the probabilistic programming language \pkg{Stan}, \pkg{MCMCglmm} implements its own custom MCMC algorithm. Modeling options and other important information of these packages are summarized in Table~\ref{comparison} and will be discussed in detail below. Regarding general model classes, all three packages support the most common types such as linear, count data and certain survival models. Currently, \pkg{brms} and \pkg{MCMCglmm} provide more flexibility when modeling categorical and ordinal data. Additionally, they offer support for zero-inflated and hurdle models to account for access zeros in the data (see Example 1 above). For survival / time-to-event models, \pkg{rstanarm} offers great flexibility via the \code{stan\_jm} function, which allows for complex association structures between time-to-event data and one or more models of longitudinal covariates (for details see \url{https://cran.r-project.org/web/packages/rstanarm/vignettes/jm.html}). Model classes currently specific to \pkg{brms} are robust linear models using Student's t-distribution (family \code{student}) as well as response times models via the exponentially modified Gaussian (family \code{exgaussian}) distribution or the Wiener diffusion model (family \code{wiener}). The latter allows to simultaneously model dichotomous decisions and their corresponding response times (for a detailed example see \url{http://singmann.org/wiener-model-analysis-with-brms-part-i/}). All three packages offer many additional modeling options, with \pkg{brms} currently having the greatest flexibility (see Table~\ref{comparison} for a summary). Moreover, the packages differ in the general framework, in which they are implemented: \pkg{brms} and \pkg{MCMCglmm} each come with a single model fitting function (\code{brm} and \code{MCMCglmm} respectively), through which all of their models can be specified. Further, their framework allows to seamlessly combine most modeling options with each other in the same model. In contrast, the approach of \pkg{rstanarm} is to emulate existing functions of other packages. This has the advantage of an easier transition between classical and Bayesian models, since the syntax used to specify models stays the same. However, it comes with the main disadvantage that many modeling options cannot be used in combination within the same model. Information criteria are available in all three packages. The advantages of WAIC and LOO implemented in \pkg{brms} and \pkg{rstanarm}, are their less restrictive assumptions and that their standard errors can be easily estimated to get a better sense of the uncertainty in the criteria. Comparing the prior options of the packages, \pkg{brms} offers a little more flexibility than \pkg{MCMCglmm} and \pkg{rstanarm}, as virtually any prior distribution can be applied on population-level effects as well as on the standard deviations of group-level effects. In addition, I believe that the way priors are specified in \pkg{brms} is more intuitive as it is directly evident what prior is actually applied. In \pkg{brms}, Bayes factors are available both via Savage-Dickey ratios \citep{wagenmakers2010} and bridge-sampling \citep{bridgesampling2017}, while \pkg{rstanarm} allows for the latter option. For a detailed comparison with respect to sampling efficiency, see \cite{brms1}. \begin{table}[hbtp] \centering \begin{tabular}{llll} & \parbox{2cm}{\pkg{brms}} & \parbox{2cm}{\pkg{rstanarm}} & \parbox{2cm}{\pkg{MCMCglmm}} \\ \hline \\ [-1.5ex] \parbox{6cm}{\textbf{Model classes}} & & & \\ [1ex] Linear models & yes & yes & yes \\ Robust linear models & yes & no & no \\ Count data models & yes & yes & yes \\ Survival models & yes & yes$^1$ & yes \\ Response times models & yes & no & no \\ Beta models & yes & yes & no \\ Categorical models & yes & yes$^2$ & yes \\ Multinomial models & no & no & yes \\ Ordinal models & various & cumulative$^2$ & cumulative \\ Zero-inflated and hurdle models & yes & no & yes \\ \hline \\ [-1.5ex] \parbox{5cm}{\textbf{Modeling options}} & & & \\ [1ex] Variable link functions & various & various & no \\ Multilevel structures & yes & yes & yes \\ Multi-membership & yes & no & yes \\ Multivariate responses & yes & yes$^3$ & yes \\ Non-linear predictors & yes & limited$^4$ & no \\ Distributional regression & yes & no & no \\ Finite mixtures & yes & no & no \\ Splines (additive models) & yes & yes & yes \\ Gaussian Processes & yes & no & no \\ Temporal autocorrelation & yes & yes$^{2, 5}$ & no \\ Spatial autocorrelation & yes & yes$^{2, 5}$ & no \\ Monotonic effects & yes & no & no \\ Category specific effects & yes & no & no \\ Measurement error & yes & no & no \\ Weights & yes & yes & no \\ Offset & yes & yes & using priors \\ Censored data & yes & yes$^1$ & yes \\ Truncated data & yes & no & no \\ Customized covariances & yes & no & yes \\ Missing value imputation & no & no & no \\ \hline \\ [-1.5ex] \textbf{Bayesian specifics} & & & \\ [1ex] Population-level priors & flexible & flexible & normal \\ Group-level priors & normal & normal & normal \\ Covariance priors & flexible & restricted$^6$ & restricted$^7$ \\ Bayes factors & yes & yes$^8$ & no \\ Parallelization & yes & yes & no \\ \hline \\ [-1.5ex] \textbf{Other} & & & \\ [1ex] Estimator & HMC, NUTS & HMC, NUTS & MH, Gibbs$^9$ \\ Information criterion & WAIC, LOO & WAIC, LOO & DIC \\ C++ compiler required & yes & no & no \\ \hline \end{tabular} \caption{ Comparison of the capabilities of the \pkg{brms}, \pkg{rstanarm} and \pkg{MCMCglmm} packages. Notes: (1) Advanced functionality available via \code{stan\_jm}. (2) No group-level terms and related functionality allowed. (3) Cannot be combined with other modeling options such as splines. (4) Functionality limited to linear Gaussian models and certein pre-specified non-linear functions. (5) Functionality available only on GitHub branches (\url{https://github.com/stan-dev/rstanarm}). (6) For details see \cite{hadfield2010}. (7) For details see \url{https://github.com/stan-dev/rstanarm/wiki/Prior-distributions}. (8) Available via the \pkg{bridgesampling} package \citep{bridgesampling2017}. (9) Estimator consists of a combination of both algorithms. } \label{comparison} \end{table} \section{Conclusion} The present paper is meant to introduce R users and developers to the extended \pkg{lme4} formula syntax applied in \pkg{brms}. Only a subset of modeling options were discussed in detail, which ensured the paper was not too broad. For some of the more basic models that \pkg{brms} can fit, see \citet{brms1}. Many more examples can be found in the growing number of vignettes accompanying the package (see \code{vignette(package = "brms")} for an overview). To date, \pkg{brms} is already one of the most flexible R packages when it comes to regression modeling. However, for the future, there are quite a few more features that I am planning to implement (see \url{https://github.com/paul-buerkner/brms/issues} for the current list of issues). In addition to smaller, incremental updates, I have two specific features in mind: (1) latent variables estimated via confirmatory factor analysis and (2) missing value imputation. I receive ideas and suggestions from users almost every day -- for which I am always grateful -- and so the list of features that will be implemented in the proceeding versions of \pkg{brms} will continue to grow. \section*{Acknowledgments} First of all, I would like to thank the Stan Development Team for creating the probabilistic programming language Stan, which is an incredibly powerful and flexible tool for performing full Bayesian inference. Without it, \pkg{brms} could not fit a single model. Furthermore, I want to thank Heinz Holling, Donald Williams and Ruben Arslan for valuable comments on earlier versions of the paper. I also would like to thank the many users who reported bugs or had ideas for new features, thus helping to continuously improve \pkg{brms}. \bibliography{citations_multilevel} \end{document} brms/inst/doc/brms_threading.Rmd0000644000176200001440000005632115053072461016405 0ustar liggesusers--- title: "Running brms models with within-chain parallelization" author: "Sebastian Weber & Paul Bürkner" date: "`r Sys.Date()`" output: rmarkdown::html_vignette: toc: yes vignette: > %\VignetteIndexEntry{Running brms models with within-chain parallelization} %\VignetteEngine{knitr::rmarkdown} \usepackage[utf8]{inputenc} params: EVAL: !r identical(Sys.getenv("NOT_CRAN"), "true") --- ```{r, SETTINGS-knitr, include=FALSE} stopifnot(require(knitr)) options(width = 90) knit_hooks$set(pngquant = knitr::hook_pngquant) opts_chunk$set( comment = NA, message = FALSE, warning = FALSE, eval = if (isTRUE(exists("params"))) params$EVAL else FALSE, dev = "ragg_png", dpi = 72, fig.retina = 1.5, fig.asp = 0.8, fig.width = 5, out.width = "60%", fig.align = "center", pngquant = "--speed=1 --quality=50" ) library(ggplot2) library(brms) theme_set(theme_default()) ``` ```{r, fake-data-sim, include=FALSE, eval=TRUE} set.seed(54647) # number of observations N <- 1E4 # number of group levels G <- round(N / 10) # number of predictors P <- 3 # regression coefficients beta <- rnorm(P) # sampled covariates, group means and fake data fake <- matrix(rnorm(N * P), ncol = P) dimnames(fake) <- list(NULL, paste0("x", 1:P)) # fixed effect part and sampled group membership fake <- transform( as.data.frame(fake), theta = fake %*% beta, g = sample.int(G, N, replace=TRUE) ) # add random intercept by group fake <- merge(fake, data.frame(g = 1:G, eta = rnorm(G)), by = "g") # linear predictor fake <- transform(fake, mu = theta + eta) # sample Poisson data fake <- transform(fake, y = rpois(N, exp(mu))) # shuffle order of data rows to ensure even distribution of computational effort fake <- fake[sample.int(N, N),] # drop not needed row names rownames(fake) <- NULL ``` ```{r, model-poisson, include=FALSE} model_poisson <- brm( y ~ 1 + x1 + x2 + (1 | g), data = fake, family = poisson(), iter = 500, # short sampling to speedup example chains = 2, prior = prior(normal(0,1), class = b) + prior(constant(1), class = sd, group = g), backend = "cmdstanr", threads = threading(4), save_pars = save_pars(all = TRUE) ) ``` ```{r, benchmark, include=FALSE} # Benchmarks given model with cross-product of tuning parameters CPU # cores, grainsize and iterations. Models are run with either static # or non-static scheduler and initial values are set by default to 0 on the # unconstrained scale. Function returns a data-frame with the # cross-product of the tuning parameters and as result column the # respective runtime. benchmark_threading <- function(model, cores = 1, grainsize = 1, iter = 100, static = FALSE) { winfo <- extract_warmup_info(model) sims <- rstan::extract(model$fit) init <- list(extract_draw(sims, 1)) scaling_model <- update( model, refresh = 0, threads = threading(1, grainsize = grainsize[1], static = static), chains = 1, iter = 2, backend = "cmdstanr" ) run_benchmark <- function(cores, size, iter) { bench_fit <- update( scaling_model, warmup=0, iter = iter, chains = 1, seed = 1234, init = init, refresh = 0, save_warmup=TRUE, threads = threading(cores, grainsize = size, static = static), inv_metric=winfo$inv_metric[[1]], step_size=winfo$step_size[[1]], adapt_engaged=FALSE ) lf <- sum(subset(nuts_params(bench_fit, inc_warmup=TRUE), Parameter=="n_leapfrog__")$Value) elapsed <- sum(colSums(rstan::get_elapsed_time(bench_fit$fit))) c(num_leapfrog=lf, runtime=elapsed) } cases <- expand.grid(cores = cores, grainsize = grainsize, iter = iter) res <- with(cases, mapply(run_benchmark, cores, grainsize, iter)) cbind(cases, as.data.frame(t(res))) } benchmark_reference <- function(model, iter=100, init=0) { winfo <- extract_warmup_info(model) sims <- rstan::extract(model$fit) init <- list(extract_draw(sims, 1)) ref_model <- update( model, refresh = 0, threads = NULL, chains = 1, iter = 2, backend = "cmdstanr" ) run_benchmark_ref <- function(iter_bench) { bench_fit <- update( ref_model, warmup=0, iter = iter_bench, chains = 1, seed = 1234, init = init, refresh = 0, inv_metric=winfo$inv_metric[[1]], step_size=winfo$step_size[[1]], adapt_engaged=FALSE ) lf <- sum(subset(nuts_params(bench_fit, inc_warmup=TRUE), Parameter=="n_leapfrog__")$Value) elapsed <- sum(colSums(rstan::get_elapsed_time(bench_fit$fit))) c(num_leapfrog=lf, runtime=elapsed) } ref <- sapply(iter, run_benchmark_ref) ref <- cbind(as.data.frame(t(ref)), iter=iter) ref } extract_warmup_info <- function(bfit) { adapt <- lapply(rstan::get_adaptation_info(bfit$fit), strsplit, split="\\n") step_size <- lapply(adapt, function(a) as.numeric(strsplit(a[[1]][[1]], " = ")[[1]][2])) inv_metric <- lapply(adapt, function(a) as.numeric(strsplit(sub("^# ", "", a[[1]][[3]]), ", ")[[1]])) list(step_size=step_size, inv_metric=inv_metric) } extract_draw <- function(sims, draw) { lapply(sims, brms:::slice, dim = 1, i = draw, drop = TRUE) } ``` ## Introduction Full Bayesian inference is a computationally very demanding task and often we wish to run our models faster in shorter walltime. With modern computers we nowadays have multiple processors available on a given machine such that the use of running the inference in parallel will shorten the overall walltime. While between-chain parallelization is straightforward by merely launching multiple chains at the same time, the use of within-chain parallelization is more complicated in various ways. This vignette aims to introduce the user to within-chain parallelization with **brms**, since its efficient use depends on various aspects specific to the users model. ## Quick summary Assuming you have a **brms** model which you wish to evaluate faster by using more cores per chain, for example: ```{r, eval=FALSE} fit_serial <- brm( count ~ zAge + zBase * Trt + (1|patient), data = epilepsy, family = poisson(), chains = 4, cores = 4, backend = "cmdstanr" ) ``` Then you can simply add threading support to an existing model with the `update` mechanism as follows, provided your stan version is at least 2.26 (whether using `rstan` or `cmdstan`): ```{r, eval=FALSE} fit_parallel <- update( fit_serial, chains = 2, cores = 2, backend = "cmdstanr", threads = threading(2) ) ``` The example above assumes that 4 cores are available which are best used without within-chain parallelization by running 4 chains in parallel. When using within chain parallelization it is still advisable to use just as many threads *in total* as you have CPU cores. It's thus sensible in this case to reduce the number of chains running in parallel to just 2, but allow each chain to use 2 threads. Obviously this will reduce the number of iterations in the posterior here as we assumed a fixed amount of 4 cores. - Only apply within-chain parallelization to large problems which take more than a few minutes at least to calculate. The `epilepsy` example above is actually too small to gain in speed (just a few seconds per chain on this machine). - Within-chain parallelization is less efficient than between-chain parallelization. So only use within-chain parallelism if more CPUs can be used to run the entire analysis. - Due to details of the model and data-set, speedups with more cores can be very limited. Not every model amends to within-chain parallelization and an empirical evaluation is in some cases advisable. - Enabling threading *usually* slows down any model to some extent and this slowdown must be offset by sufficient cores per chain in order to really gain in execution speed. - Doubling the execution speed with few cores is a lot easier than obtaining larger speedups with even more cores. - Models with computationally expensive likelihoods are easier to parallelize than less expensive likelihoods. For example, the Poisson distribution involves expensive $\log\Gamma$ functions whereas the normal likelihood is very cheap to calculate in comparison. - Models with many parameters (e.g., multilevel models) carry a large overhead when running in parallel. - With a larger overhead of the model, the likelihood must be sufficiently expensive such that the relative computational cost of likelihood to parallelization overhead is favorable. - Avoid using hyper-threading, that is, only use as many threads as you have physical cores available. - Ensure that the data is randomly sorted such that consecutive subsets of the data are roughly of the same computational effort. ## Within-chain parallelization The within-chain parallelization implemented in **brms** is based on the `reduce_sum` facility in Stan. The basic principle that `reduce_sum` uses is to split a large summation into arbitrary smaller partial sums. Due to the commutativity and associativity of the sum operation these smaller partial sums can be evaluated in any order and in parallel from one another. **brms** leverages `reduce_sum` to evaluate the log-likelihood of the model in parallel as for example $$ \begin{aligned} l(y|\theta) &= \sum_{i=1}^N l_i(y_i| \theta) \\ &= \sum_{i=1}^{S_1} l_i(y_i| \theta) + \sum_{i=S_1+1}^N l_i(y_i| \theta). \end{aligned} $$ As a consequence, the within-chain parallelization requires mutually independent log-likelihood terms which restricts its applicability to some degree. Furthermore, the within-chain parallelization is only applicable to the evaluation of the data likelihood while all other parts of the model, for example priors, will remain running serially. Thus, only a partial fraction of the entire Stan model will run in parallel which limits the potential speedup one may obtain. The theoretical speedup for a partially in parallel running program is described by [Amdahl‘s law](https://en.wikipedia.org/wiki/Amdahl%27s_law). For example, with 90% of the computational load running in parallel one can essentially double the execution speed with 2 cores while 8 cores may only speedup the program by at most 5x. How large the computational cost of the log-likelihood is in relation to the entire model is very dependent on the model of the user. In practice, the speedups are even smaller than the theoretical speedups. This is caused by the additional overhead implied by forming multiple smaller sums than just one large one. For example, for each partial sum formed the entire parameter vector $\theta$ has to be copied in memory for Stan to be able to calculate the gradient of the log-likelihood. Hence, with more partial sums, more copying is necessary as opposed to evaluating just one large sum. Whether the additional copying is indeed relevant depends on the computational cost of the log-likelihood of each term and the number of parameters. For a model with a computationally cheap normal log-likelihood, this effect is more important than for a model with a Poisson log-likelihood, and for multilevel models with many parameters more copying is needed than for simpler regression models. It may therefore be necessary to form sufficiently large partial sums to warrant an efficient parallel execution. The size of the partial sums is referred to as the `grainsize`, which is set to a reasonable default value. However, for some models this tuning parameter requires some attention from the user for optimal performance. Finally, it is important to note that by default the exact size and order of the partial sums is not stable as it is adjusted to the load of the system. As a result, exact numerical reproducibility is not guaranteed by default. In order to warrant the same size and order of the partial sums, the `static` option must be used and set to `TRUE`, which uses a deterministic scheduler for the parallel work. ## Example model As a toy demonstration, we use here a multilevel Poisson model. The model is a varying intercept model with $`r N`$ data observation which are grouped into $`r G`$ groups. Each data item has $`r P`$ continuous covariates. The simulation code for the fake data can be found in the appendix and it's first $10$ rows are: ```{r} kable(head(fake, 10), digits = 3) ``` The **brms** model fitting this data is: ```{r, eval=FALSE} <> ``` Here we have fixed the standard deviation of the between-group variation for the intercept to the true value of $1$ as used in the simulation. This is to avoid unfavorable geometry of the problem allowing us to concentrate on computational aspects alone. The Poisson likelihood is a relatively expensive likelihood due to the use of $\log\Gamma$ function as opposed to, for example, a normal likelihood which does is by far less expensive operations. Moreover, this example is chosen in order to demonstrate parallelization overhead implied by a large number of parameters. ## Managing parallelization overhead As discussed above, the key mechanism to run Stan programs with parallelization is to split the large sum over independent log likelihood terms into arbitrary smaller *partial sums*. Creating more *partial sums* allows to increase simultaneous parallel computations in a granular way, but at the same time additional overhead is introduced through the requirement to copy the entire parameter vector for each *partial sum* formed along with further overhead due to splitting up a single large task into multiple smaller ones. By default, **brms** will choose a sensible `grainsize` which defines how large a given *partial sum* will roughly be. The actual chunk size is automatically tuned whenever the default non-static scheduler is used, which is the recommended choice to start with. As noted before, only the static scheduler is giving fully deterministic results since the chunk size and order of partial sums will be the same during sampling. While we expect that the default `grainsize` in **brms** is reasonably good for many models, it can improve performance if one tunes the `grainsize` specifically to a given model and data-set. We suggest to increase successively the number of chunks a given data set is split into with the static scheduler and run this on a single core. This way one can control the number of *partial sum* accurately and monitor the execution time as it increases. These experiments are run with only a single chain and very short iteration numbers as we are not interested in the statistical results, but rather aim to be able to explore the tuning parameter space of the chunk size as quickly as possible. The number of iterations needed to get reliable runtime estimates for a given chunk size will depend on many details and the easiest way to determine this is to run this benchmark with multiple number of iterations. Whenever their results match approximately, then the iteration numbers are sufficient. In order to decrease the variation between runs, we also fix the random seed, initial value and the tuning parameters of the sampler (step size and mass matrix). Below is an example R code demonstrating such a benchmark. The utility function `benchmark_threading` is shown and explained in the appendix. ```{r, chunking-scale, message=FALSE, warning=FALSE, results='hide'} chunking_bench <- transform( data.frame(chunks = 4^(0:3)), grainsize = ceiling(N / chunks) ) iter_test <- c(10, 20, 40) # very short test runs scaling_chunking <- benchmark_threading( model_poisson, cores = 1, grainsize = chunking_bench$grainsize, # test various grainsizes iter = iter_test, static = TRUE # with static partitioner ) # run as reference the model *without* reduce_sum ref <- benchmark_reference(model_poisson, iter_test) # for additional data munging please refer to the appendix ``` ```{r, munge-chunking-scaling, include=FALSE} scaling_chunking <- merge(scaling_chunking, chunking_bench, by = "grainsize") single_chunk <- transform( subset(scaling_chunking, chunks == 1), num_leapfrog_single = num_leapfrog, num_leapfrog = NULL, runtime_single = runtime, runtime = NULL, grainsize = NULL, chunks=NULL ) scaling_chunking <- transform( merge(scaling_chunking, single_chunk), slowdown = runtime/runtime_single, iter = factor(iter), runtime_single = NULL ) ref <- transform(ref, iter=factor(iter)) ``` Graphically summarizing the results shows that with more than 8 chunks the overhead is about 10% and increasing further with more chunks. For models without many parameters, no such overhead should be observed. Furthermore, one can see that 25 and 50 iterations give similar results implying that 25 iterations suffice for stable runtime estimates for these (and the following) benchmarks. The overhead of up to 20% in this example with 16 chunks may seem large due to the scaling of the plot. One must not forget that when we start to use more CPU cores, the overhead is easily offset, but it limits the maximal speedup we can get. For example, some 2 units of computation become 2.4 units due to the overhead such that on 2 cores we don't quite double the execution speed, but rather get a 1.6x increase in speed instead of a 2x speedup. Considering in addition the time per leapfrog step of the NUTS sampler shows on an absolute scale similar information as before. The upside of this representation is that we can visualize the slowdown in relation to the program *without* `reduce_sum`. As we can see, the additional overhead due to merely enabling `reduce_sum` is substantial in this example. This is attributed in the specific example to the large number of random effects. ```{r} ggplot(scaling_chunking) + aes(chunks, slowdown, colour = iter, shape = iter) + geom_line() + geom_point() + scale_x_log10(breaks = scaling_chunking$chunks) + scale_y_log10(breaks=seq(0.8, 2.5, by=0.1)) + ggtitle("Slowdown with increasing number of chunks") ggplot(scaling_chunking) + aes(chunks, 1E3 * runtime/num_leapfrog, colour = iter, shape=iter) + geom_line() + geom_point() + scale_x_log10(breaks = scaling_chunking$chunks) + scale_y_log10(breaks=seq(0.1, 2.0, by=0.1)) + geom_hline(data=ref, aes(yintercept=1E3 * runtime/num_leapfrog, colour=iter), linetype=I(2)) + ggtitle("Time per leapfrog step vs number of chunks", "Dashed line is reference model without reduce_sum") + ylab("Time per leapfrog step [ms]") ``` ## Parallelization speedup In practice, we are often interested in so-called "hard-scaling" properties of the parallelization system. That is, for a fixed problem size we would like to know how much faster we can execute the Stan program with increasing number of threads. As nowadays CPUs usually run with so-called hyper-threading, it is also of interest if this technique is beneficial for Stan programs as well (spoiler alert: it's not useful). As we have seen before, the `grainsize` can have an impact on the performance and is as such a tuning parameter. Below we demonstrate some exemplary R code which runs a benchmark with varying number of CPU cores and varying number of `grainsize`s. ```{r, speedup-scale, message=FALSE, warning=FALSE, results='hide'} num_cpu <- parallel::detectCores(logical = FALSE) num_cpu_logical <- parallel::detectCores(logical = TRUE) grainsize_default <- ceiling(N / (2 * num_cpu)) cores <- c(2^seq(0, floor(log2(num_cpu_logical))), num_cpu, num_cpu_logical) cores <- sort(unique(cores)) grainsize <- c(grainsize_default, grainsize_default/2, grainsize_default/4) grainsize <- round(grainsize) iter_scaling <- 20 scaling_cores <- benchmark_threading( model_poisson, cores = cores, grainsize = grainsize, iter = iter_scaling, static = FALSE ) single_core <- transform( subset(scaling_cores, cores == 1), runtime_single = runtime, num_leapfrog=NULL, runtime=NULL, cores = NULL ) scaling_cores <- transform( merge(scaling_cores, single_core), speedup = runtime_single/runtime, grainsize = factor(grainsize) ) ``` It is important to consider the absolute runtime and the relative speedup vs. running on a single core. The relative speedup can be misleading if the single core runtime is very slow in which case speed gains on more CPUs may look overly good. Considering instead the absolute runtime avoids this problem. After all, we are interested in the shortest walltime we can get rather than any relative speedups. ```{r} ggplot(scaling_cores) + aes(cores, runtime, shape = grainsize, color = grainsize) + geom_vline(xintercept = num_cpu, linetype = 3) + geom_line() + geom_point() + scale_x_log10(breaks = scaling_cores$cores) + scale_y_log10(breaks=seq(0.1, 1.4, by=0.1)) + theme(legend.position = c(0.85, 0.8)) + geom_hline(data=subset(ref, iter==iter_scaling), aes(yintercept=runtime), linetype=I(2)) + ggtitle("Runtime with varying number of cores", "Dashed line is reference model without reduce_sum") ggplot(scaling_cores) + aes(cores, speedup, shape = grainsize, color = grainsize) + geom_abline(slope = 1, intercept = 0, linetype = 2) + geom_vline(xintercept = num_cpu, linetype = 3) + geom_line() + geom_point() + scale_x_log10(breaks=scaling_cores$cores) + scale_y_log10(breaks=scaling_cores$cores) + theme(aspect.ratio = 1) + coord_fixed(xlim = c(1, num_cpu_logical), ylim = c(1, num_cpu_logical)) + ggtitle("Relative speedup vs 1 core") ``` The vertical dotted line marks the physical number of CPU cores on the machine this was run. The horizontal dashed line in the plot with absolute runtime marks the respective runtime of the model *without* `reduce_sum` and the dashed unity line in the plot with the relative speedup marks the theoretical maximal speedup. We can see that there is no further reduction in execution time when increasing the thread count to be greater than the number of physical CPUs. Hence, the use of hyper-threading is not helpful when aiming to maximize the speed of a Stan program. Moreover, the use of threading outperforms the single core runtime only when using more than 4 cores in this example. For this example, the shown `grainsize`s matter on some machines but not on others, so your results may look quite different from what is shown here. The overall speedups may not seem impressive in this case, which is attributed in this case to the large number of parameters relative to the number of observations. However, we can still outperform the single core runtime when using many cores. Though the most important advantage of threading is that with an increasing data set size, the user has the option to use a brute-force approach to balance the increase in walltime needed. ```{r} kable(scaling_cores, digits = 2) ``` For a given Stan model one should usually choose the number of chains and the number of threads per chain to be equal to the number of (physical) cores one wishes to use. Only if different chains of the model have relatively different execution times (which they should not have, but it occurs sometimes in practice), then one may consider the use of hyper-threading. Doing so will share the resources evenly across all chains and whenever the fastest chain finishes, the freed resources can be given to the still running chains. ## Appendix ### Fake data simulation ```{r, eval=FALSE} <> ``` ### Poisson example model ```{r, eval=FALSE} <> ``` ### Threading benchmark function ```{r, eval=FALSE} <> ``` ### Munging of slowdown with chunking data ```{r, eval=FALSE} <> ``` brms/inst/doc/brms_nonlinear.Rmd0000644000176200001440000003034515053072461016423 0ustar liggesusers--- title: "Estimating Non-Linear Models with brms" author: "Paul Bürkner" date: "`r Sys.Date()`" output: rmarkdown::html_vignette: toc: yes vignette: > %\VignetteIndexEntry{Estimating Non-Linear Models with brms} %\VignetteEngine{knitr::rmarkdown} \usepackage[utf8]{inputenc} params: EVAL: !r identical(Sys.getenv("NOT_CRAN"), "true") --- ```{r, SETTINGS-knitr, include=FALSE} stopifnot(require(knitr)) options(width = 90) knit_hooks$set(pngquant = knitr::hook_pngquant) opts_chunk$set( comment = NA, message = FALSE, warning = FALSE, eval = if (isTRUE(exists("params"))) params$EVAL else FALSE, dev = "ragg_png", dpi = 72, fig.retina = 1.5, fig.asp = 0.8, fig.width = 5, out.width = "60%", fig.align = "center", pngquant = "--speed=1 --quality=50" ) library(brms) ggplot2::theme_set(theme_default()) ``` ## Introduction This vignette provides an introduction on how to fit non-linear multilevel models with **brms**. Non-linear models are incredibly flexible and powerful, but require much more care with respect to model specification and priors than typical generalized linear models. Ignoring group-level effects for the moment, the predictor term $\eta_n$ of a generalized linear model for observation $n$ can be written as follows: $$\eta_n = \sum_{i = 1}^K b_i x_{ni}$$ where $b_i$ is the regression coefficient of predictor $i$ and $x_{ni}$ is the data of predictor $i$ for observation $n$. This also comprises interaction terms and various other data transformations. However, the structure of $\eta_n$ is always linear in the sense that the regression coefficients $b_i$ are multiplied by some predictor values and then summed up. This implies that the hypothetical predictor term $$\eta_n = b_1 \exp(b_2 x_n)$$ would *not* be a *linear* predictor anymore and we could not fit it using classical techniques of generalized linear models. We thus need a more general model class, which we will call *non-linear* models. Note that the term 'non-linear' does not say anything about the assumed distribution of the response variable. In particular it does not mean 'not normally distributed' as we can apply non-linear predictor terms to all kinds of response distributions (for more details on response distributions available in **brms** see `vignette("brms_families")`). ## A Simple Non-Linear Model We begin with a simple example using simulated data. ```{r} b <- c(2, 0.75) x <- rnorm(100) y <- rnorm(100, mean = b[1] * exp(b[2] * x)) dat1 <- data.frame(x, y) ``` As stated above, we cannot use a generalized linear model to estimate $b$ so we go ahead an specify a non-linear model. ```{r, results='hide'} prior1 <- prior(normal(1, 2), nlpar = "b1") + prior(normal(0, 2), nlpar = "b2") fit1 <- brm(bf(y ~ b1 * exp(b2 * x), b1 + b2 ~ 1, nl = TRUE), data = dat1, prior = prior1) ``` When looking at the above code, the first thing that becomes obvious is that we changed the `formula` syntax to display the non-linear formula including predictors (i.e., `x`) and parameters (i.e., `b1` and `b2`) wrapped in a call to `bf`. This stands in contrast to classical **R** formulas, where only predictors are given and parameters are implicit. The argument `b1 + b2 ~ 1` serves two purposes. First, it provides information, which variables in `formula` are parameters, and second, it specifies the linear predictor terms for each parameter. In fact, we should think of non-linear parameters as placeholders for linear predictor terms rather than as parameters themselves (see also the following examples). In the present case, we have no further variables to predict `b1` and `b2` and thus we just fit intercepts that represent our estimates of $b_1$ and $b_2$ in the model equation above. The formula `b1 + b2 ~ 1` is a short form of `b1 ~ 1, b2 ~ 1` that can be used if multiple non-linear parameters share the same formula. Setting `nl = TRUE` tells **brms** that the formula should be treated as non-linear. In contrast to generalized linear models, priors on population-level parameters (i.e., 'fixed effects') are often mandatory to identify a non-linear model. Thus, **brms** requires the user to explicitly specify these priors. In the present example, we used a `normal(1, 2)` prior on (the population-level intercept of) `b1`, while we used a `normal(0, 2)` prior on (the population-level intercept of) `b2`. Setting priors is a non-trivial task in all kinds of models, especially in non-linear models, so you should always invest some time to think of appropriate priors. Quite often, you may be forced to change your priors after fitting a non-linear model for the first time, when you observe different MCMC chains converging to different posterior regions. This is a clear sign of an identification problem and one solution is to set stronger (i.e., more narrow) priors. To obtain summaries of the fitted model, we apply ```{r} summary(fit1) plot(fit1) plot(conditional_effects(fit1), points = TRUE) ``` The `summary` method reveals that we were able to recover the true parameter values pretty nicely. According to the `plot` method, our MCMC chains have converged well and to the same posterior. The `conditional_effects` method visualizes the model-implied (non-linear) regression line. We might be also interested in comparing our non-linear model to a classical linear model. ```{r, results='hide'} fit2 <- brm(y ~ x, data = dat1) ``` ```{r} summary(fit2) ``` To investigate and compare model fit, we can apply graphical posterior predictive checks, which make use of the **bayesplot** package on the backend. ```{r} pp_check(fit1) pp_check(fit2) ``` We can also easily compare model fit using leave-one-out cross-validation. ```{r} loo(fit1, fit2) ``` Since smaller `LOOIC` values indicate better model fit, it is immediately evident that the non-linear model fits the data better, which is of course not too surprising since we simulated the data from exactly that model. ## A Real-World Non-Linear model On his blog, Markus Gesmann predicts the growth of cumulative insurance loss payments over time, originated from different origin years (see https://www.magesblog.com/post/2015-11-03-loss-developments-via-growth-curves-and/). We will use a slightly simplified version of his model for demonstration purposes here. It looks as follows: $$cum_{AY, dev} \sim N(\mu_{AY, dev}, \sigma)$$ $$\mu_{AY, dev} = ult_{AY} \left(1 - \exp\left(- \left( \frac{dev}{\theta} \right)^\omega \right) \right)$$ The cumulative insurance payments $cum$ will grow over time, and we model this dependency using the variable $dev$. Further, $ult_{AY}$ is the (to be estimated) ultimate loss of accident each year. It constitutes a non-linear parameter in our framework along with the parameters $\theta$ and $\omega$, which are responsible for the growth of the cumulative loss and are assumed to be the same across years. The data is already shipped with brms. ```{r} data(loss) head(loss) ``` and translate the proposed model into a non-linear **brms** model. ```{r, results='hide'} fit_loss <- brm( bf(cum ~ ult * (1 - exp(-(dev/theta)^omega)), ult ~ 1 + (1|AY), omega ~ 1, theta ~ 1, nl = TRUE), data = loss, family = gaussian(), prior = c( prior(normal(5000, 1000), nlpar = "ult"), prior(normal(1, 2), nlpar = "omega"), prior(normal(45, 10), nlpar = "theta") ), control = list(adapt_delta = 0.9) ) ``` We estimate a group-level effect of accident year (variable `AY`) for the ultimate loss `ult`. This also shows nicely how a non-linear parameter is actually a placeholder for a linear predictor, which in case of `ult`, contains only an varying intercept over year. Again, priors on population-level effects are required and, for the present model, are actually mandatory to ensure identifiability. We summarize the model using well known methods. ```{r} summary(fit_loss) plot(fit_loss, N = 3, ask = FALSE) conditional_effects(fit_loss) ``` Next, we show marginal effects separately for each year. ```{r} conditions <- data.frame(AY = unique(loss$AY)) rownames(conditions) <- unique(loss$AY) me_loss <- conditional_effects( fit_loss, conditions = conditions, re_formula = NULL, method = "predict" ) plot(me_loss, ncol = 5, points = TRUE) ``` It is evident that there is some variation in cumulative loss across accident years, for instance due to natural disasters happening only in certain years. Further, we see that the uncertainty in the predicted cumulative loss is larger for later years with fewer available data points. For a more detailed discussion of this data set, see Section 4.5 in Gesmann & Morris (2020). ## Advanced Item-Response Models As a third example, we want to show how to model more advanced item-response models using the non-linear model framework of **brms**. For simplicity, suppose we have a single forced choice item with three alternatives of which only one is correct. Our response variable is whether a person answers the item correctly (1) or not (0). Person are assumed to vary in their ability to answer the item correctly. However, every person has a 33% chance of getting the item right just by guessing. We thus simulate some data to reflect this situation. ```{r} inv_logit <- function(x) 1 / (1 + exp(-x)) ability <- rnorm(300) p <- 0.33 + 0.67 * inv_logit(ability) answer <- ifelse(runif(300, 0, 1) < p, 1, 0) dat_ir <- data.frame(ability, answer) ``` The most basic item-response model is equivalent to a simple logistic regression model. ```{r, results='hide'} fit_ir1 <- brm(answer ~ ability, data = dat_ir, family = bernoulli()) ``` However, this model completely ignores the guessing probability and will thus likely come to biased estimates and predictions. ```{r} summary(fit_ir1) plot(conditional_effects(fit_ir1), points = TRUE) ``` A more sophisticated approach incorporating the guessing probability looks as follows: ```{r, results='hide'} fit_ir2 <- brm( bf(answer ~ 0.33 + 0.67 * inv_logit(eta), eta ~ ability, nl = TRUE), data = dat_ir, family = bernoulli("identity"), prior = prior(normal(0, 5), nlpar = "eta") ) ``` It is very important to set the link function of the `bernoulli` family to `identity` or else we will apply two link functions. This is because our non-linear predictor term already contains the desired link function (`0.33 + 0.67 * inv_logit`), but the `bernoulli` family applies the default `logit` link on top of it. This will of course lead to strange and uninterpretable results. Thus, please make sure that you set the link function to `identity`, whenever your non-linear predictor term already contains the desired link function. ```{r} summary(fit_ir2) plot(conditional_effects(fit_ir2), points = TRUE) ``` Comparing model fit via leave-one-out cross-validation ```{r} loo(fit_ir1, fit_ir2) ``` shows that both model fit the data equally well, but remember that predictions of the first model might still be misleading as they may well be below the guessing probability for low ability values. Now, suppose that we don't know the guessing probability and want to estimate it from the data. This can easily be done changing the previous model just a bit. ```{r, results='hide'} fit_ir3 <- brm( bf(answer ~ guess + (1 - guess) * inv_logit(eta), eta ~ 0 + ability, guess ~ 1, nl = TRUE), data = dat_ir, family = bernoulli("identity"), prior = c( prior(normal(0, 5), nlpar = "eta"), prior(beta(1, 1), nlpar = "guess", lb = 0, ub = 1) ) ) ``` Here, we model the guessing probability as a non-linear parameter making sure that it cannot exceed the interval $[0, 1]$. We did not estimate an intercept for `eta`, as this will lead to a bias in the estimated guessing parameter (try it out; this is an excellent example of how careful one has to be in non-linear models). ```{r} summary(fit_ir3) plot(fit_ir3) plot(conditional_effects(fit_ir3), points = TRUE) ``` The results show that we are able to recover the simulated model parameters with this non-linear model. Of course, real item-response data have multiple items so that accounting for item and person variability (e.g., using a multilevel model with varying intercepts) becomes necessary as we have multiple observations per item and person. Luckily, this can all be done within the non-linear framework of **brms** and I hope that this vignette serves as a good starting point. ## References Gesmann M. & Morris J. (2020). Hierarchical Compartmental Reserving Models. *CAS Research Papers*. brms/README.md0000644000176200001440000003643615053072461012513 0ustar liggesusers brms Logo[Stan Logo](https://mc-stan.org/) # brms [![R-CMD-check](https://github.com/paul-buerkner/brms/workflows/R-CMD-check/badge.svg)](https://github.com/paul-buerkner/brms/actions) [![Coverage Status](https://codecov.io/github/paul-buerkner/brms/coverage.svg?branch=master)](https://app.codecov.io/github/paul-buerkner/brms?branch=master) [![CRAN Version](https://www.r-pkg.org/badges/version/brms)](https://cran.r-project.org/package=brms) [![Downloads](https://cranlogs.r-pkg.org/badges/brms?color=brightgreen)](https://CRAN.R-project.org/package=brms) ## Overview The **brms** package provides an interface to fit Bayesian generalized (non-)linear multivariate multilevel models using Stan, which is a C++ package for performing full Bayesian inference (see ). The formula syntax is very similar to that of the package lme4 to provide a familiar and simple interface for performing regression analyses. A wide range of response distributions are supported, allowing users to fit – among others – linear, robust linear, count data, survival, response times, ordinal, zero-inflated, and even self-defined mixture models all in a multilevel context. Further modeling options include non-linear and smooth terms, auto-correlation structures, censored data, missing value imputation, and quite a few more. In addition, all parameters of the response distribution can be predicted in order to perform distributional regression. Multivariate models (i.e., models with multiple response variables) can be fit, as well. Prior specifications are flexible and explicitly encourage users to apply prior distributions that actually reflect their beliefs. Model fit can easily be assessed and compared with posterior predictive checks, cross-validation, and Bayes factors. ## Resources - [Introduction to brms](https://doi.org/10.18637/jss.v080.i01) (Journal of Statistical Software) - [Advanced multilevel modeling with brms](https://journal.r-project.org/archive/2018/RJ-2018-017/index.html) (The R Journal) - [Website](https://paulbuerkner.com/brms/) (Website of brms with documentation and vignettes) - [Blog posts](http://paulbuerkner.com/software/brms-blogposts.html) (List of blog posts about brms) - [Ask a question](https://discourse.mc-stan.org/) (Stan Forums on Discourse) - [Open an issue](https://github.com/paul-buerkner/brms/issues) (GitHub issues for bug reports and feature requests) ## How to use brms ``` r library(brms) ``` As a simple example, we use poisson regression to model the seizure counts in epileptic patients to investigate whether the treatment (represented by variable `Trt`) can reduce the seizure counts and whether the effect of the treatment varies with the (standardized) baseline number of seizures a person had before treatment (variable `zBase`). As we have multiple observations per person, a group-level intercept is incorporated to account for the resulting dependency in the data. ``` r fit1 <- brm(count ~ zAge + zBase * Trt + (1|patient), data = epilepsy, family = poisson()) ``` The results (i.e., posterior draws) can be investigated using ``` r summary(fit1) #> Family: poisson #> Links: mu = log #> Formula: count ~ zAge + zBase * Trt + (1 | patient) #> Data: epilepsy (Number of observations: 236) #> Draws: 4 chains, each with iter = 2000; warmup = 1000; thin = 1; #> total post-warmup draws = 4000 #> #> Multilevel Hyperparameters: #> ~patient (Number of levels: 59) #> Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS #> sd(Intercept) 0.59 0.07 0.46 0.74 1.01 566 1356 #> #> Regression Coefficients: #> Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS #> Intercept 1.78 0.12 1.55 2.01 1.00 771 1595 #> zAge 0.09 0.09 -0.08 0.27 1.00 590 1302 #> zBase 0.71 0.12 0.47 0.96 1.00 848 1258 #> Trt1 -0.27 0.16 -0.60 0.05 1.01 749 1172 #> zBase:Trt1 0.05 0.17 -0.30 0.38 1.00 833 1335 #> #> Draws were sampled using sampling(NUTS). For each parameter, Bulk_ESS #> and Tail_ESS are effective sample size measures, and Rhat is the potential #> scale reduction factor on split chains (at convergence, Rhat = 1). ``` On the top of the output, some general information on the model is given, such as family, formula, number of iterations and chains. Next, group-level effects are displayed separately for each grouping factor in terms of standard deviations and (in case of more than one group-level effect per grouping factor; not displayed here) correlations between group-level effects. On the bottom of the output, population-level effects (i.e. regression coefficients) are displayed. If incorporated, autocorrelation effects and family specific parameters (e.g., the residual standard deviation ‘sigma’ in normal models) are also given. In general, every parameter is summarized using the mean (‘Estimate’) and the standard deviation (‘Est.Error’) of the posterior distribution as well as two-sided 95% credible intervals (‘l-95% CI’ and ‘u-95% CI’) based on quantiles. We see that the coefficient of `Trt` is negative with a zero overlapping 95%-CI. This indicates that, on average, the treatment may reduce seizure counts by some amount but the evidence based on the data and applied model is not very strong and still insufficient by standard decision rules. Further, we find little evidence that the treatment effect varies with the baseline number of seizures. The last three values (‘ESS_bulk’, ‘ESS_tail’, and ‘Rhat’) provide information on how well the algorithm could estimate the posterior distribution of this parameter. If ‘Rhat’ is considerably greater than 1, the algorithm has not yet converged and it is necessary to run more iterations and / or set stronger priors. To visually investigate the chains as well as the posterior distributions, we can use the `plot` method. If we just want to see results of the regression coefficients of `Trt` and `zBase`, we go for ``` r plot(fit1, variable = c("b_Trt1", "b_zBase")) ``` A more detailed investigation can be performed by running `launch_shinystan(fit1)`. To better understand the relationship of the predictors with the response, I recommend the `conditional_effects` method: ``` r plot(conditional_effects(fit1, effects = "zBase:Trt")) ``` This method uses some prediction functionality behind the scenes, which can also be called directly. Suppose that we want to predict responses (i.e. seizure counts) of a person in the treatment group (`Trt = 1`) and in the control group (`Trt = 0`) with average age and average number of previous seizures. Than we can use ``` r newdata <- data.frame(Trt = c(0, 1), zAge = 0, zBase = 0) predict(fit1, newdata = newdata, re_formula = NA) #> Estimate Est.Error Q2.5 Q97.5 #> [1,] 5.91200 2.494857 2 11 #> [2,] 4.57325 2.166058 1 9 ``` We need to set `re_formula = NA` in order not to condition of the group-level effects. While the `predict` method returns predictions of the responses, the `fitted` method returns predictions of the regression line. ``` r fitted(fit1, newdata = newdata, re_formula = NA) #> Estimate Est.Error Q2.5 Q97.5 #> [1,] 5.945276 0.7075160 4.696257 7.450011 #> [2,] 4.540081 0.5343471 3.579757 5.665132 ``` Both methods return the same estimate (up to random error), while the latter has smaller variance, because the uncertainty in the regression line is smaller than the uncertainty in each response. If we want to predict values of the original data, we can just leave the `newdata` argument empty. Suppose, we want to investigate whether there is overdispersion in the model, that is residual variation not accounted for by the response distribution. For this purpose, we include a second group-level intercept that captures possible overdispersion. ``` r fit2 <- brm(count ~ zAge + zBase * Trt + (1|patient) + (1|obs), data = epilepsy, family = poisson()) ``` We can then go ahead and compare both models via approximate leave-one-out (LOO) cross-validation. ``` r loo(fit1, fit2) #> Output of model 'fit1': #> #> Computed from 4000 by 236 log-likelihood matrix. #> #> Estimate SE #> elpd_loo -671.7 36.6 #> p_loo 94.3 14.2 #> looic 1343.4 73.2 #> ------ #> MCSE of elpd_loo is NA. #> MCSE and ESS estimates assume MCMC draws (r_eff in [0.4, 2.0]). #> #> Pareto k diagnostic values: #> Count Pct. Min. ESS #> (-Inf, 0.7] (good) 228 96.6% 157 #> (0.7, 1] (bad) 7 3.0% #> (1, Inf) (very bad) 1 0.4% #> See help('pareto-k-diagnostic') for details. #> #> Output of model 'fit2': #> #> Computed from 4000 by 236 log-likelihood matrix. #> #> Estimate SE #> elpd_loo -596.8 14.0 #> p_loo 109.7 7.2 #> looic 1193.6 28.1 #> ------ #> MCSE of elpd_loo is NA. #> MCSE and ESS estimates assume MCMC draws (r_eff in [0.4, 1.7]). #> #> Pareto k diagnostic values: #> Count Pct. Min. ESS #> (-Inf, 0.7] (good) 172 72.9% 83 #> (0.7, 1] (bad) 56 23.7% #> (1, Inf) (very bad) 8 3.4% #> See help('pareto-k-diagnostic') for details. #> #> Model comparisons: #> elpd_diff se_diff #> fit2 0.0 0.0 #> fit1 -74.9 27.2 ``` The `loo` output when comparing models is a little verbose. We first see the individual LOO summaries of the two models and then the comparison between them. Since higher `elpd` (i.e., expected log posterior density) values indicate better fit, we see that the model accounting for overdispersion (i.e., `fit2`) fits substantially better. However, we also see in the individual LOO outputs that there are several problematic observations for which the approximations may have not have been very accurate. To deal with this appropriately, we need to fall back to other methods such as `reloo` or `kfold` but this requires the model to be refit several times which takes too long for the purpose of a quick example. The post-processing methods we have shown above are just the tip of the iceberg. For a full list of methods to apply on fitted model objects, type `methods(class = "brmsfit")`. ## Citing brms and related software Developing and maintaining open source software is an important yet often underappreciated contribution to scientific progress. Thus, whenever you are using open source software (or software in general), please make sure to cite it appropriately so that developers get credit for their work. When using brms, please cite one or more of the following publications: - Bürkner P. C. (2017). brms: An R Package for Bayesian Multilevel Models using Stan. *Journal of Statistical Software*. 80(1), 1-28. doi.org/10.18637/jss.v080.i01 - Bürkner P. C. (2018). Advanced Bayesian Multilevel Modeling with the R Package brms. *The R Journal*. 10(1), 395-411. doi.org/10.32614/RJ-2018-017 - Bürkner P. C. (2021). Bayesian Item Response Modeling in R with brms and Stan. *Journal of Statistical Software*, 100(5), 1-54. doi.org/10.18637/jss.v100.i05 As brms is a high-level interface to Stan, please additionally cite Stan (see also ): - Stan Development Team. YEAR. Stan Modeling Language Users Guide and Reference Manual, VERSION. - Carpenter B., Gelman A., Hoffman M. D., Lee D., Goodrich B., Betancourt M., Brubaker M., Guo J., Li P., and Riddell A. (2017). Stan: A probabilistic programming language. *Journal of Statistical Software*. 76(1). doi.org/10.18637/jss.v076.i01 Further, brms relies on several other R packages and, of course, on R itself. To find out how to cite R and its packages, use the `citation` function. There are some features of brms which specifically rely on certain packages. The **rstan** package together with **Rcpp** makes Stan conveniently accessible in R. Visualizations and posterior-predictive checks are based on **bayesplot** and **ggplot2**. Approximate leave-one-out cross-validation using `loo` and related methods is done via the **loo** package. Marginal likelihood based methods such as `bayes_factor` are realized by means of the **bridgesampling** package. Splines specified via the `s` and `t2` functions rely on **mgcv**. If you use some of these features, please also consider citing the related packages. ## FAQ ### How do I install brms? To install the latest release version from CRAN use ``` r install.packages("brms") ``` The current developmental version can be downloaded from GitHub via ``` r if (!requireNamespace("remotes")) { install.packages("remotes") } remotes::install_github("paul-buerkner/brms") ``` Because brms is based on Stan, a C++ compiler is required. The program Rtools (available on ) comes with a C++ compiler for Windows. On Mac, you should install Xcode. For further instructions on how to get the compilers running, see the prerequisites section on . ### I am new to brms. Where can I start? Detailed instructions and case studies are given in the package’s extensive vignettes. See `vignette(package = "brms")` for an overview. For documentation on formula syntax, families, and prior distributions see `help("brm")`. ### Where do I ask questions, propose a new feature, or report a bug? Questions can be asked on the [Stan forums](https://discourse.mc-stan.org/) on Discourse. To propose a new feature or report a bug, please open an issue on [GitHub](https://github.com/paul-buerkner/brms). ### How can I extract the generated Stan code? If you have already fitted a model, apply the `stancode` method on the fitted model object. If you just want to generate the Stan code without any model fitting, use the `stancode` method on your model formula. ### Can I avoid compiling models? When you fit your model for the first time with brms, there is currently no way to avoid compilation. However, if you have already fitted your model and want to run it again, for instance with more draws, you can do this without recompilation by using the `update` method. For more details see `help("update.brmsfit")`. ### What is the difference between brms and rstanarm? The rstanarm package is similar to brms in that it also allows to fit regression models using Stan for the backend estimation. Contrary to brms, rstanarm comes with precompiled code to save the compilation time (and the need for a C++ compiler) when fitting a model. However, as brms generates its Stan code on the fly, it offers much more flexibility in model specification than rstanarm. Also, multilevel models are currently fitted a bit more efficiently in brms. For detailed comparisons of brms with other common R packages implementing multilevel models, see `vignette("brms_multilevel")` and `vignette("brms_overview")`. brms/build/0000755000176200001440000000000015057753140012323 5ustar liggesusersbrms/build/vignette.rds0000644000176200001440000000110615057753140014660 0ustar liggesusersTo0Nl!`lC ?!< &$(TB!/4nx?W8il;aEh׋;i_#=D@gW?TpA(ϊGJAHIk38#Ȃ*Ă`qF ,B90P$ ͩ\N'2ښSs/A, *VTB3%g\-["*G(zs!)~x OS,p *.k̗1K)I^9.M,Dگ]m'OwO*w9S'*Gg P($:>&@m0-վCmg_x񬫒rUPq5~-ȦdԪ&: ) nɁ: *`n+*f[Reut6 >ۏFv}5^r:MxXӮq|;Xa_O={=;/uoDm6C ,m'^qWqc=۶G ŲX83S]Dbrms/build/partial.rdb0000644000176200001440000000007515057750766014465 0ustar liggesusersb```b`aed`b1 H020piּb C" 7brms/man/0000755000176200001440000000000015057500075011774 5ustar liggesusersbrms/man/gr.Rd0000644000176200001440000000511615053072461012675 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/formula-re.R \name{gr} \alias{gr} \title{Set up basic grouping terms in \pkg{brms}} \usage{ gr( ..., by = NULL, cor = TRUE, id = NA, pw = NULL, cov = NULL, dist = "gaussian" ) } \arguments{ \item{...}{One or more terms containing grouping factors.} \item{by}{An optional factor variable, specifying sub-populations of the groups. For each level of the \code{by} variable, a separate variance-covariance matrix will be fitted. Levels of the grouping factor must be nested in levels of the \code{by} variable.} \item{cor}{Logical. If \code{TRUE} (the default), group-level terms will be modelled as correlated.} \item{id}{Optional character string. All group-level terms across the model with the same \code{id} will be modeled as correlated (if \code{cor} is \code{TRUE}). See \code{\link{brmsformula}} for more details.} \item{pw}{Optional numeric variable specifying prior weights. They weight the contribution of each group to the log-prior of the group-level coefficients. Should have one distinct value for each level of the grouping variable.} \item{cov}{An optional matrix which is proportional to the within-group covariance matrix of the group-level effects. All levels of the grouping factor should appear as rownames of the corresponding matrix. This argument can be used, among others, to model pedigrees and phylogenetic effects. See \code{vignette("brms_phylogenetics")} for more details. By default, levels of the same grouping factor are modeled as independent of each other.} \item{dist}{Name of the distribution of the group-level effects. Currently \code{"gaussian"} is the only option.} } \description{ Function used to set up a basic grouping term in \pkg{brms}. The function does not evaluate its arguments -- it exists purely to help set up a model with grouping terms. \code{gr} is called implicitly inside the package and there is usually no need to call it directly. } \examples{ \dontrun{ # model using basic lme4-style formula fit1 <- brm(count ~ Trt + (1|patient), data = epilepsy) summary(fit1) # equivalent model using 'gr' which is called anyway internally fit2 <- brm(count ~ Trt + (1|gr(patient)), data = epilepsy) summary(fit2) # include Trt as a by variable fit3 <- brm(count ~ Trt + (1|gr(patient, by = Trt)), data = epilepsy) summary(fit3) # include a group-level weight variable epilepsy[['patient_samp_wgt']] <- c(1, rep(c(0.9, 1.1), each = 29)) fit4 <- brm(count ~ Trt + (1|gr(patient, pw = patient_samp_wgt)), data = epilepsy) summary(fit4) } } \seealso{ \code{\link{brmsformula}} } brms/man/nsamples.brmsfit.Rd0000644000176200001440000000134514160105076015551 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/brmsfit-methods.R \name{nsamples.brmsfit} \alias{nsamples.brmsfit} \alias{nsamples} \title{(Deprecated) Number of Posterior Samples} \usage{ \method{nsamples}{brmsfit}(object, subset = NULL, incl_warmup = FALSE, ...) } \arguments{ \item{object}{An object of class \code{brmsfit}.} \item{subset}{An optional integer vector defining a subset of samples to be considered.} \item{incl_warmup}{A flag indicating whether to also count warmup / burn-in samples.} \item{...}{Currently ignored.} } \description{ Extract the number of posterior samples (draws) stored in a fitted Bayesian model. Method \code{nsamples} is deprecated. Please use \code{ndraws} instead. } brms/man/cor_cosy.Rd0000644000176200001440000000231014213413565014077 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/autocor.R \name{cor_cosy} \alias{cor_cosy} \alias{cor_cosy-class} \title{(Deprecated) Compound Symmetry (COSY) Correlation Structure} \usage{ cor_cosy(formula = ~1) } \arguments{ \item{formula}{A one sided formula of the form \code{~ t}, or \code{~ t | g}, specifying a time covariate \code{t} and, optionally, a grouping factor \code{g}. A covariate for this correlation structure must be integer valued. When a grouping factor is present in \code{formula}, the correlation structure is assumed to apply only to observations within the same grouping level; observations with different grouping levels are assumed to be uncorrelated. Defaults to \code{~ 1}, which corresponds to using the order of the observations in the data as a covariate, and no groups.} } \value{ An object of class \code{cor_cosy}, representing a compound symmetry correlation structure. } \description{ This function is deprecated. Please see \code{\link{cosy}} for the new syntax. This functions is a constructor for the \code{cor_cosy} class, representing a compound symmetry structure corresponding to uniform correlation. } \examples{ cor_cosy(~ visit | patient) } brms/man/emmeans-brms-helpers.Rd0000644000176200001440000000605215033662634016320 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/emmeans.R \name{emmeans-brms-helpers} \alias{emmeans-brms-helpers} \alias{recover_data.brmsfit} \alias{emm_basis.brmsfit} \title{Support Functions for \pkg{emmeans}} \usage{ recover_data.brmsfit( object, data, resp = NULL, dpar = NULL, nlpar = NULL, re_formula = NA, epred = FALSE, ... ) emm_basis.brmsfit( object, trms, xlev, grid, vcov., resp = NULL, dpar = NULL, nlpar = NULL, re_formula = NA, epred = FALSE, ... ) } \arguments{ \item{object}{An object of class \code{brmsfit}.} \item{data, trms, xlev, grid, vcov.}{Arguments required by \pkg{emmeans}.} \item{resp}{Optional names of response variables. If specified, predictions are performed only for the specified response variables.} \item{dpar}{Optional name of a predicted distributional parameter. If specified, expected predictions of this parameters are returned.} \item{nlpar}{Optional name of a predicted non-linear parameter. If specified, expected predictions of this parameters are returned.} \item{re_formula}{Optional formula containing group-level effects to be considered in the prediction. If \code{NULL}, include all group-level effects; if \code{NA} (default), include no group-level effects.} \item{epred}{Logical. If \code{TRUE} compute predictions of the posterior predictive distribution's mean (see \code{\link{posterior_epred.brmsfit}}) while ignoring arguments \code{dpar} and \code{nlpar}. Defaults to \code{FALSE}. If you have specified a response transformation within the formula, you need to set \code{epred} to \code{TRUE} for \pkg{emmeans} to detect this transformation.} \item{...}{Additional arguments passed to \pkg{emmeans}.} } \description{ Functions required for compatibility of \pkg{brms} with \pkg{emmeans}. Users are not required to call these functions themselves. Instead, they will be called automatically by the \code{emmeans} function of the \pkg{emmeans} package. } \details{ In order to ensure compatibility of most \pkg{brms} models with \pkg{emmeans}, predictions are not generated 'manually' via a design matrix and coefficient vector, but rather via \code{\link{posterior_linpred.brmsfit}}. This appears to generally work well, but note that it produces an `.@linfct` slot that contains the computed predictions as columns instead of the coefficients. } \examples{ \dontrun{ fit1 <- brm(time | cens(censored) ~ age * sex + disease + (1|patient), data = kidney, family = lognormal()) summary(fit1) # summarize via 'emmeans' library(emmeans) rg <- ref_grid(fit1) em <- emmeans(rg, "disease") summary(em, point.est = mean) # obtain estimates for the posterior predictive distribution's mean epred <- emmeans(fit1, "disease", epred = TRUE) summary(epred, point.est = mean) # model with transformed response variable fit2 <- brm(log(mpg) ~ factor(cyl), data = mtcars) summary(fit2) # results will be on the log scale by default emmeans(fit2, ~ cyl) # log transform is detected and can be adjusted automatically emmeans(fit2, ~ cyl, epred = TRUE, type = "response") } } brms/man/Shifted_Lognormal.Rd0000644000176200001440000000262614275436221015673 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/distributions.R \name{Shifted_Lognormal} \alias{Shifted_Lognormal} \alias{dshifted_lnorm} \alias{pshifted_lnorm} \alias{qshifted_lnorm} \alias{rshifted_lnorm} \title{The Shifted Log Normal Distribution} \usage{ dshifted_lnorm(x, meanlog = 0, sdlog = 1, shift = 0, log = FALSE) pshifted_lnorm( q, meanlog = 0, sdlog = 1, shift = 0, lower.tail = TRUE, log.p = FALSE ) qshifted_lnorm( p, meanlog = 0, sdlog = 1, shift = 0, lower.tail = TRUE, log.p = FALSE ) rshifted_lnorm(n, meanlog = 0, sdlog = 1, shift = 0) } \arguments{ \item{x, q}{Vector of quantiles.} \item{meanlog}{Vector of means.} \item{sdlog}{Vector of standard deviations.} \item{shift}{Vector of shifts.} \item{log}{Logical; If \code{TRUE}, values are returned on the log scale.} \item{lower.tail}{Logical; If \code{TRUE} (default), return P(X <= x). Else, return P(X > x) .} \item{log.p}{Logical; If \code{TRUE}, values are returned on the log scale.} \item{p}{Vector of probabilities.} \item{n}{Number of draws to sample from the distribution.} } \description{ Density, distribution function, quantile function and random generation for the shifted log normal distribution with mean \code{meanlog}, standard deviation \code{sdlog}, and shift parameter \code{shift}. } \details{ See \code{vignette("brms_families")} for details on the parameterization. } brms/man/ZeroInflated.Rd0000644000176200001440000000410014275473342014653 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/distributions.R \name{ZeroInflated} \alias{ZeroInflated} \alias{dzero_inflated_poisson} \alias{pzero_inflated_poisson} \alias{dzero_inflated_negbinomial} \alias{pzero_inflated_negbinomial} \alias{dzero_inflated_binomial} \alias{pzero_inflated_binomial} \alias{dzero_inflated_beta_binomial} \alias{pzero_inflated_beta_binomial} \alias{dzero_inflated_beta} \alias{pzero_inflated_beta} \title{Zero-Inflated Distributions} \usage{ dzero_inflated_poisson(x, lambda, zi, log = FALSE) pzero_inflated_poisson(q, lambda, zi, lower.tail = TRUE, log.p = FALSE) dzero_inflated_negbinomial(x, mu, shape, zi, log = FALSE) pzero_inflated_negbinomial(q, mu, shape, zi, lower.tail = TRUE, log.p = FALSE) dzero_inflated_binomial(x, size, prob, zi, log = FALSE) pzero_inflated_binomial(q, size, prob, zi, lower.tail = TRUE, log.p = FALSE) dzero_inflated_beta_binomial(x, size, mu, phi, zi, log = FALSE) pzero_inflated_beta_binomial( q, size, mu, phi, zi, lower.tail = TRUE, log.p = FALSE ) dzero_inflated_beta(x, shape1, shape2, zi, log = FALSE) pzero_inflated_beta(q, shape1, shape2, zi, lower.tail = TRUE, log.p = FALSE) } \arguments{ \item{x}{Vector of quantiles.} \item{zi}{zero-inflation probability} \item{log}{Logical; If \code{TRUE}, values are returned on the log scale.} \item{q}{Vector of quantiles.} \item{lower.tail}{Logical; If \code{TRUE} (default), return P(X <= x). Else, return P(X > x) .} \item{log.p}{Logical; If \code{TRUE}, values are returned on the log scale.} \item{mu, lambda}{location parameter} \item{shape, shape1, shape2}{shape parameter} \item{size}{number of trials} \item{prob}{probability of success on each trial} \item{phi}{precision parameter} } \description{ Density and distribution functions for zero-inflated distributions. } \details{ The density of a zero-inflated distribution can be specified as follows. If \eqn{x = 0} set \eqn{f(x) = \theta + (1 - \theta) * g(0)}. Else set \eqn{f(x) = (1 - \theta) * g(x)}, where \eqn{g(x)} is the density of the non-zero-inflated part. } brms/man/update.brmsfit_multiple.Rd0000644000176200001440000000300415057537626017136 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/update.R \name{update.brmsfit_multiple} \alias{update.brmsfit_multiple} \title{Update \pkg{brms} models based on multiple data sets} \usage{ \method{update}{brmsfit_multiple}(object, formula., newdata = NULL, data2 = NULL, ...) } \arguments{ \item{object}{An object of class \code{brmsfit_multiple}.} \item{formula.}{Changes to the formula; for details see \code{\link{update.formula}} and \code{\link{brmsformula}}.} \item{newdata}{List of \code{data.frames} to update the model with new data. Currently required even if the original data should be used.} \item{data2}{A \emph{list} of named lists each of which will be used to fit a separate model. Each of the named lists contains objects representing data which cannot be passed via argument \code{data} (see \code{\link{brm}} for examples). The length of the outer list should match the length of the list passed to the \code{data} argument. Currently required even if the original data should be used.} \item{...}{Other arguments passed to \code{\link{update.brmsfit}} and \code{\link{brm_multiple}}.} } \description{ This method allows to update an existing \code{brmsfit_multiple} object. } \examples{ \dontrun{ library(mice) imp <- mice(nhanes2) # initially fit the model fit_imp1 <- brm_multiple(bmi ~ age + hyp + chl, data = imp, chains = 1) summary(fit_imp1) # update the model using fewer predictors fit_imp2 <- update(fit_imp1, formula. = . ~ hyp + chl, newdata = imp) summary(fit_imp2) } } brms/man/brmsformula-helpers.Rd0000644000176200001440000001114114213413565016252 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/brmsformula.R \name{brmsformula-helpers} \alias{brmsformula-helpers} \alias{bf-helpers} \alias{nlf} \alias{lf} \alias{set_nl} \alias{set_rescor} \alias{acformula} \alias{set_mecor} \title{Linear and Non-linear formulas in \pkg{brms}} \usage{ nlf(formula, ..., flist = NULL, dpar = NULL, resp = NULL, loop = NULL) lf( ..., flist = NULL, dpar = NULL, resp = NULL, center = NULL, cmc = NULL, sparse = NULL, decomp = NULL ) acformula(autocor, resp = NULL) set_nl(nl = TRUE, dpar = NULL, resp = NULL) set_rescor(rescor = TRUE) set_mecor(mecor = TRUE) } \arguments{ \item{formula}{Non-linear formula for a distributional parameter. The name of the distributional parameter can either be specified on the left-hand side of \code{formula} or via argument \code{dpar}.} \item{...}{Additional \code{formula} objects to specify predictors of non-linear and distributional parameters. Formulas can either be named directly or contain names on their left-hand side. Alternatively, it is possible to fix parameters to certain values by passing numbers or character strings in which case arguments have to be named to provide the parameter names. See 'Details' for more information.} \item{flist}{Optional list of formulas, which are treated in the same way as formulas passed via the \code{...} argument.} \item{dpar}{Optional character string specifying the distributional parameter to which the formulas passed via \code{...} and \code{flist} belong.} \item{resp}{Optional character string specifying the response variable to which the formulas passed via \code{...} and \code{flist} belong. Only relevant in multivariate models.} \item{loop}{Logical; Only used in non-linear models. Indicates if the computation of the non-linear formula should be done inside (\code{TRUE}) or outside (\code{FALSE}) a loop over observations. Defaults to \code{TRUE}.} \item{center}{Logical; Indicates if the population-level design matrix should be centered, which usually increases sampling efficiency. See the 'Details' section for more information. Defaults to \code{TRUE} for distributional parameters and to \code{FALSE} for non-linear parameters.} \item{cmc}{Logical; Indicates whether automatic cell-mean coding should be enabled when removing the intercept by adding \code{0} to the right-hand of model formulas. Defaults to \code{TRUE} to mirror the behavior of standard \R formula parsing.} \item{sparse}{Logical; indicates whether the population-level design matrices should be treated as sparse (defaults to \code{FALSE}). For design matrices with many zeros, this can considerably reduce required memory. Sampling speed is currently not improved or even slightly decreased.} \item{decomp}{Optional name of the decomposition used for the population-level design matrix. Defaults to \code{NULL} that is no decomposition. Other options currently available are \code{"QR"} for the QR decomposition that helps in fitting models with highly correlated predictors.} \item{autocor}{A one sided formula containing autocorrelation terms. All none autocorrelation terms in \code{autocor} will be silently ignored.} \item{nl}{Logical; Indicates whether \code{formula} should be treated as specifying a non-linear model. By default, \code{formula} is treated as an ordinary linear model formula.} \item{rescor}{Logical; Indicates if residual correlation between the response variables should be modeled. Currently this is only possible in multivariate \code{gaussian} and \code{student} models. Only relevant in multivariate models.} \item{mecor}{Logical; Indicates if correlations between latent variables defined by \code{\link{me}} terms should be modeled. Defaults to \code{TRUE}.} } \value{ For \code{lf} and \code{nlf} a \code{list} that can be passed to \code{\link[brms:brmsformula]{brmsformula}} or added to an existing \code{brmsformula} or \code{mvbrmsformula} object. For \code{set_nl} and \code{set_rescor} a logical value that can be added to an existing \code{brmsformula} or \code{mvbrmsformula} object. } \description{ Helper functions to specify linear and non-linear formulas for use with \code{\link[brms:brmsformula]{brmsformula}}. } \examples{ # add more formulas to the model bf(y ~ 1) + nlf(sigma ~ a * exp(b * x)) + lf(a ~ x, b ~ z + (1|g)) + gaussian() # specify 'nl' later on bf(y ~ a * inv_logit(x * b)) + lf(a + b ~ z) + set_nl(TRUE) # specify a multivariate model bf(y1 ~ x + (1|g)) + bf(y2 ~ z) + set_rescor(TRUE) # add autocorrelation terms bf(y ~ x) + acformula(~ arma(p = 1, q = 1) + car(W)) } \seealso{ \code{\link{brmsformula}}, \code{\link{mvbrmsformula}} } brms/man/bayes_R2.brmsfit.Rd0000644000176200001440000000441015057747653015414 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/bayes_R2.R \name{bayes_R2.brmsfit} \alias{bayes_R2.brmsfit} \alias{bayes_R2} \title{Compute a Bayesian version of R-squared for regression models} \usage{ \method{bayes_R2}{brmsfit}( object, resp = NULL, summary = TRUE, robust = FALSE, probs = c(0.025, 0.975), ... ) } \arguments{ \item{object}{An object of class \code{brmsfit}.} \item{resp}{Optional names of response variables. If specified, predictions are performed only for the specified response variables.} \item{summary}{Should summary statistics be returned instead of the raw values? Default is \code{TRUE}.} \item{robust}{If \code{FALSE} (the default) the mean is used as the measure of central tendency and the standard deviation as the measure of variability. If \code{TRUE}, the median and the median absolute deviation (MAD) are applied instead. Only used if \code{summary} is \code{TRUE}.} \item{probs}{The percentiles to be computed by the \code{quantile} function. Only used if \code{summary} is \code{TRUE}.} \item{...}{Further arguments passed to \code{\link[brms:posterior_epred.brmsfit]{posterior_epred}}, which is used in the computation of the R-squared values.} } \value{ If \code{summary = TRUE}, an M x C matrix is returned (M = number of response variables and c = \code{length(probs) + 2}) containing summary statistics of the Bayesian R-squared values. If \code{summary = FALSE}, the posterior draws of the Bayesian R-squared values are returned in an S x M matrix (S is the number of draws). } \description{ Compute a Bayesian version of R-squared for regression models } \details{ For an introduction to the approach, see Gelman et al. (2019) and \url{https://github.com/jgabry/bayes_R2/}. } \examples{ \dontrun{ fit <- brm(mpg ~ wt + cyl, data = mtcars) summary(fit) bayes_R2(fit) # compute R2 with new data nd <- data.frame(mpg = c(10, 20, 30), wt = c(4, 3, 2), cyl = c(8, 6, 4)) bayes_R2(fit, newdata = nd) } } \references{ Andrew Gelman, Ben Goodrich, Jonah Gabry & Aki Vehtari. (2019). R-squared for Bayesian regression models, \emph{The American Statistician}, 73(3):307-309. \code{10.1080/00031305.2018.1549100} (Preprint available at \url{https://acris.aalto.fi/ws/portalfiles/portal/34206843/bayes_R2_v3.pdf}) } brms/man/pp_check.brmsfit.Rd0000644000176200001440000000661415053072461015512 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/pp_check.R \name{pp_check.brmsfit} \alias{pp_check.brmsfit} \alias{pp_check} \title{Posterior Predictive Checks for \code{brmsfit} Objects} \usage{ \method{pp_check}{brmsfit}( object, type, ndraws = NULL, prefix = c("ppc", "ppd"), group = NULL, x = NULL, newdata = NULL, resp = NULL, draw_ids = NULL, nsamples = NULL, subset = NULL, ... ) } \arguments{ \item{object}{An object of class \code{brmsfit}.} \item{type}{Type of the ppc plot as given by a character string. See \code{\link[bayesplot:PPC-overview]{PPC}} for an overview of currently supported types. You may also use an invalid type (e.g. \code{type = "xyz"}) to get a list of supported types in the resulting error message.} \item{ndraws}{Positive integer indicating how many posterior draws should be used. If \code{NULL} all draws are used. If not specified, the number of posterior draws is chosen automatically. Ignored if \code{draw_ids} is not \code{NULL}.} \item{prefix}{The prefix of the \pkg{bayesplot} function to be applied. Either `"ppc"` (posterior predictive check; the default) or `"ppd"` (posterior predictive distribution), the latter being the same as the former except that the observed data is not shown for `"ppd"`.} \item{group}{Optional name of a factor variable in the model by which to stratify the ppc plot. This argument is required for ppc \code{*_grouped} types and ignored otherwise.} \item{x}{Optional name of a variable in the model. Only used for ppc types having an \code{x} argument and ignored otherwise.} \item{newdata}{An optional data.frame for which to evaluate predictions. If \code{NULL} (default), the original data of the model is used. \code{NA} values within factors (excluding grouping variables) are interpreted as if all dummy variables of this factor are zero. This allows, for instance, to make predictions of the grand mean when using sum coding. \code{NA} values within grouping variables are treated as a new level.} \item{resp}{Optional names of response variables. If specified, predictions are performed only for the specified response variables.} \item{draw_ids}{An integer vector specifying the posterior draws to be used. If \code{NULL} (the default), all draws are used.} \item{nsamples}{Deprecated alias of \code{ndraws}.} \item{subset}{Deprecated alias of \code{draw_ids}.} \item{...}{Further arguments passed to \code{\link{predict.brmsfit}} as well as to the PPC function specified in \code{type}.} } \value{ A ggplot object that can be further customized using the \pkg{ggplot2} package. } \description{ Perform posterior predictive checks with the help of the \pkg{bayesplot} package. } \details{ For a detailed explanation of each of the ppc functions, see the \code{\link[bayesplot:PPC-overview]{PPC}} documentation of the \pkg{\link[bayesplot:bayesplot-package]{bayesplot}} package. } \examples{ \dontrun{ fit <- brm(count ~ zAge + zBase * Trt + (1|patient) + (1|obs), data = epilepsy, family = poisson()) pp_check(fit) # shows dens_overlay plot by default pp_check(fit, type = "error_hist", ndraws = 11) pp_check(fit, type = "scatter_avg", ndraws = 100) pp_check(fit, type = "stat_2d") pp_check(fit, type = "rootogram") pp_check(fit, type = "loo_pit") ## get an overview of all valid types pp_check(fit, type = "xyz") ## get a plot without the observed data pp_check(fit, prefix = "ppd") } } brms/man/me.Rd0000644000176200001440000000313014213413565012661 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/formula-sp.R \name{me} \alias{me} \title{Predictors with Measurement Error in \pkg{brms} Models} \usage{ me(x, sdx, gr = NULL) } \arguments{ \item{x}{The variable measured with error.} \item{sdx}{Known measurement error of \code{x} treated as standard deviation.} \item{gr}{Optional grouping factor to specify which values of \code{x} correspond to the same value of the latent variable. If \code{NULL} (the default) each observation will have its own value of the latent variable.} } \description{ (Soft deprecated) Specify predictors with measurement error. The function does not evaluate its arguments -- it exists purely to help set up a model. } \details{ For detailed documentation see \code{help(brmsformula)}. \code{me} terms are soft deprecated in favor of the more general and consistent \code{\link{mi}} terms. By default, latent noise-free variables are assumed to be correlated. To change that, add \code{set_mecor(FALSE)} to your model formula object (see examples). } \examples{ \dontrun{ # sample some data N <- 100 dat <- data.frame( y = rnorm(N), x1 = rnorm(N), x2 = rnorm(N), sdx = abs(rnorm(N, 1)) ) # fit a simple error-in-variables model fit1 <- brm(y ~ me(x1, sdx) + me(x2, sdx), data = dat, save_pars = save_pars(latent = TRUE)) summary(fit1) # turn off modeling of correlations bform <- bf(y ~ me(x1, sdx) + me(x2, sdx)) + set_mecor(FALSE) fit2 <- brm(bform, data = dat, save_pars = save_pars(latent = TRUE)) summary(fit2) } } \seealso{ \code{\link{brmsformula}}, \code{\link{brmsformula-helpers}} } brms/man/cor_ar.Rd0000644000176200001440000000376014213413565013536 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/autocor.R \name{cor_ar} \alias{cor_ar} \title{(Deprecated) AR(p) correlation structure} \usage{ cor_ar(formula = ~1, p = 1, cov = FALSE) } \arguments{ \item{formula}{A one sided formula of the form \code{~ t}, or \code{~ t | g}, specifying a time covariate \code{t} and, optionally, a grouping factor \code{g}. A covariate for this correlation structure must be integer valued. When a grouping factor is present in \code{formula}, the correlation structure is assumed to apply only to observations within the same grouping level; observations with different grouping levels are assumed to be uncorrelated. Defaults to \code{~ 1}, which corresponds to using the order of the observations in the data as a covariate, and no groups.} \item{p}{A non-negative integer specifying the autoregressive (AR) order of the ARMA structure. Default is 1.} \item{cov}{A flag indicating whether ARMA effects should be estimated by means of residual covariance matrices. This is currently only possible for stationary ARMA effects of order 1. If the model family does not have natural residuals, latent residuals are added automatically. If \code{FALSE} (the default) a regression formulation is used that is considerably faster and allows for ARMA effects of order higher than 1 but is only available for \code{gaussian} models and some of its generalizations.} } \value{ An object of class \code{cor_arma} containing solely autoregression terms. } \description{ This function is deprecated. Please see \code{\link{ar}} for the new syntax. This function is a constructor for the \code{cor_arma} class, allowing for autoregression terms only. } \details{ AR refers to autoregressive effects of residuals, which is what is typically understood as autoregressive effects. However, one may also model autoregressive effects of the response variable, which is called ARR in \pkg{brms}. } \examples{ cor_ar(~visit|patient, p = 2) } \seealso{ \code{\link{cor_arma}} } brms/man/MultiStudentT.Rd0000644000176200001440000000226015053072461015047 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/distributions.R \name{MultiStudentT} \alias{MultiStudentT} \alias{dmulti_student_t} \alias{rmulti_student_t} \title{The Multivariate Student-t Distribution} \usage{ dmulti_student_t(x, df, mu, Sigma, log = FALSE, check = FALSE) rmulti_student_t(n, df, mu, Sigma, check = FALSE) } \arguments{ \item{x}{Vector or matrix of quantiles. If \code{x} is a matrix, each row is taken to be a quantile.} \item{df}{Vector of degrees of freedom.} \item{mu}{Location vector with length equal to the number of dimensions.} \item{Sigma}{Covariance matrix.} \item{log}{Logical; If \code{TRUE}, values are returned on the log scale.} \item{check}{Logical; Indicates whether several input checks should be performed. Defaults to \code{FALSE} to improve efficiency.} \item{n}{Number of draws to sample from the distribution.} } \description{ Density function and random generation for the multivariate Student-t distribution with location vector \code{mu}, covariance matrix \code{Sigma}, and degrees of freedom \code{df}. } \details{ See the Stan user's manual \url{https://mc-stan.org/docs/} for details on the parameterization } brms/man/launch_shinystan.brmsfit.Rd0000644000176200001440000000213314575527613017314 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/launch_shinystan.R \name{launch_shinystan.brmsfit} \alias{launch_shinystan.brmsfit} \alias{launch_shinystan} \title{Interface to \pkg{shinystan}} \usage{ launch_shinystan.brmsfit(object, rstudio = getOption("shinystan.rstudio"), ...) } \arguments{ \item{object}{A fitted model object typically of class \code{brmsfit}.} \item{rstudio}{Only relevant for RStudio users. The default (\code{rstudio=FALSE}) is to launch the app in the default web browser rather than RStudio's pop-up Viewer. Users can change the default to \code{TRUE} by setting the global option \cr \code{options(shinystan.rstudio = TRUE)}.} \item{...}{Optional arguments to pass to \code{\link[shiny:runApp]{runApp}}} } \value{ An S4 shinystan object } \description{ Provide an interface to \pkg{shinystan} for models fitted with \pkg{brms} } \examples{ \dontrun{ fit <- brm(rating ~ treat + period + carry + (1|subject), data = inhaler, family = "gaussian") launch_shinystan(fit) } } \seealso{ \code{\link[shinystan:launch_shinystan]{launch_shinystan}} } brms/man/brmsfit-class.Rd0000644000176200001440000000544715053072461015045 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/brmsfit-class.R \docType{class} \name{brmsfit-class} \alias{brmsfit-class} \alias{brmsfit} \title{Class \code{brmsfit} of models fitted with the \pkg{brms} package} \description{ Models fitted with the \code{\link[brms:brms-package]{brms}} package are represented as a \code{brmsfit} object, which contains the posterior draws (samples), model formula, Stan code, relevant data, and other information. } \details{ See \code{methods(class = "brmsfit")} for an overview of available methods. } \section{Slots}{ \describe{ \item{\code{formula}}{A \code{\link{brmsformula}} object.} \item{\code{data}}{A \code{data.frame} containing all variables used in the model.} \item{\code{data2}}{A \code{list} of data objects which cannot be passed via \code{data}.} \item{\code{prior}}{A \code{\link{brmsprior}} object containing information on the priors used in the model.} \item{\code{stanvars}}{A \code{\link{stanvars}} object.} \item{\code{model}}{The model code in \pkg{Stan} language.} \item{\code{exclude}}{The names of the parameters for which draws are not saved.} \item{\code{algorithm}}{The name of the algorithm used to fit the model.} \item{\code{backend}}{The name of the backend used to fit the model.} \item{\code{threads}}{An object of class `brmsthreads` created by \code{\link{threading}}.} \item{\code{opencl}}{An object of class `brmsopencl` created by \code{\link{opencl}}.} \item{\code{stan_args}}{Named list of additional control arguments that were passed to the Stan backend directly.} \item{\code{fit}}{An object of class \code{\link[rstan:stanfit-class]{stanfit}} among others containing the posterior draws.} \item{\code{basis}}{An object that contains a small subset of the Stan data created at fitting time, which is needed to process new data correctly.} \item{\code{criteria}}{An empty \code{list} for adding model fit criteria after estimation of the model.} \item{\code{file}}{Optional name of a file in which the model object was stored in or loaded from.} \item{\code{version}}{The versions of \pkg{brms} and \pkg{rstan} with which the model was fitted.} \item{\code{family}}{(Deprecated) A \code{\link{brmsfamily}} object.} \item{\code{autocor}}{(Deprecated) An \code{\link{cor_brms}} object containing the autocorrelation structure if specified.} \item{\code{ranef}}{(Deprecated) A \code{data.frame} containing the group-level structure.} \item{\code{cov_ranef}}{(Deprecated) A \code{list} of customized group-level covariance matrices.} \item{\code{stan_funs}}{(Deprecated) A character string of length one or \code{NULL}.} \item{\code{data.name}}{(Deprecated) The name of \code{data} as specified by the user.} }} \seealso{ \code{\link{brms}}, \code{\link{brm}}, \code{\link{brmsformula}}, \code{\link{brmsfamily}} } brms/man/loss.Rd0000644000176200001440000000302614213413565013244 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/datasets.R \docType{data} \name{loss} \alias{loss} \title{Cumulative Insurance Loss Payments} \format{ A data frame of 55 observations containing information on the following 4 variables. \describe{ \item{AY}{Origin year of the insurance (1991 to 2000)} \item{dev}{Deviation from the origin year in months} \item{cum}{Cumulative loss payments} \item{premium}{Achieved premiums for the given origin year} } } \source{ Gesmann M. & Morris J. (2020). Hierarchical Compartmental Reserving Models. \emph{CAS Research Papers}. } \usage{ loss } \description{ This dataset, discussed in Gesmann & Morris (2020), contains cumulative insurance loss payments over the course of ten years. } \examples{ \dontrun{ # non-linear model to predict cumulative loss payments fit_loss <- brm( bf(cum ~ ult * (1 - exp(-(dev/theta)^omega)), ult ~ 1 + (1|AY), omega ~ 1, theta ~ 1, nl = TRUE), data = loss, family = gaussian(), prior = c( prior(normal(5000, 1000), nlpar = "ult"), prior(normal(1, 2), nlpar = "omega"), prior(normal(45, 10), nlpar = "theta") ), control = list(adapt_delta = 0.9) ) # basic summaries summary(fit_loss) conditional_effects(fit_loss) # plot predictions per origin year conditions <- data.frame(AY = unique(loss$AY)) rownames(conditions) <- unique(loss$AY) me_loss <- conditional_effects( fit_loss, conditions = conditions, re_formula = NULL, method = "predict" ) plot(me_loss, ncol = 5, points = TRUE) } } \keyword{datasets} brms/man/validate_prior.Rd0000644000176200001440000000701014571050211015255 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/priors.R \name{validate_prior} \alias{validate_prior} \title{Validate Prior for \pkg{brms} Models} \usage{ validate_prior( prior, formula, data, family = gaussian(), sample_prior = "no", data2 = NULL, knots = NULL, drop_unused_levels = TRUE, ... ) } \arguments{ \item{prior}{One or more \code{brmsprior} objects created by \code{\link{set_prior}} or related functions and combined using the \code{c} method or the \code{+} operator. See also \code{\link[brms:default_prior.default]{default_prior}} for more help.} \item{formula}{An object of class \code{\link[stats:formula]{formula}}, \code{\link{brmsformula}}, or \code{\link{mvbrmsformula}} (or one that can be coerced to that classes): A symbolic description of the model to be fitted. The details of model specification are explained in \code{\link{brmsformula}}.} \item{data}{An object of class \code{data.frame} (or one that can be coerced to that class) containing data of all variables used in the model.} \item{family}{A description of the response distribution and link function to be used in the model. This can be a family function, a call to a family function or a character string naming the family. Every family function has a \code{link} argument allowing to specify the link function to be applied on the response variable. If not specified, default links are used. For details of supported families see \code{\link{brmsfamily}}. By default, a linear \code{gaussian} model is applied. In multivariate models, \code{family} might also be a list of families.} \item{sample_prior}{Indicate if draws from priors should be drawn additionally to the posterior draws. Options are \code{"no"} (the default), \code{"yes"}, and \code{"only"}. Among others, these draws can be used to calculate Bayes factors for point hypotheses via \code{\link{hypothesis}}. Please note that improper priors are not sampled, including the default improper priors used by \code{brm}. See \code{\link{set_prior}} on how to set (proper) priors. Please also note that prior draws for the overall intercept are not obtained by default for technical reasons. See \code{\link{brmsformula}} how to obtain prior draws for the intercept. If \code{sample_prior} is set to \code{"only"}, draws are drawn solely from the priors ignoring the likelihood, which allows among others to generate draws from the prior predictive distribution. In this case, all parameters must have proper priors.} \item{data2}{A named \code{list} of objects containing data, which cannot be passed via argument \code{data}. Required for some objects used in autocorrelation structures to specify dependency structures as well as for within-group covariance matrices.} \item{knots}{Optional list containing user specified knot values to be used for basis construction of smoothing terms. See \code{\link[mgcv:gamm]{gamm}} for more details.} \item{drop_unused_levels}{Should unused factors levels in the data be dropped? Defaults to \code{TRUE}.} \item{...}{Other arguments for internal usage only.} } \value{ An object of class \code{brmsprior}. } \description{ Validate priors supplied by the user. Return a complete set of priors for the given model, including default priors. } \examples{ prior1 <- prior(normal(0,10), class = b) + prior(cauchy(0,2), class = sd) validate_prior(prior1, count ~ zAge + zBase * Trt + (1|patient), data = epilepsy, family = poisson()) } \seealso{ \code{\link[brms:default_prior.default]{default_prior}}, \code{\link{set_prior}}. } brms/man/control_params.Rd0000644000176200001440000000135214213413565015307 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/diagnostics.R \name{control_params} \alias{control_params} \alias{control_params.brmsfit} \title{Extract Control Parameters of the NUTS Sampler} \usage{ control_params(x, ...) \method{control_params}{brmsfit}(x, pars = NULL, ...) } \arguments{ \item{x}{An \R object} \item{...}{Currently ignored.} \item{pars}{Optional names of the control parameters to be returned. If \code{NULL} (the default) all control parameters are returned. See \code{\link[rstan:stan]{stan}} for more details.} } \value{ A named \code{list} with control parameter values. } \description{ Extract control parameters of the NUTS sampler such as \code{adapt_delta} or \code{max_treedepth}. } brms/man/stancode.default.Rd0000644000176200001440000001550114571051304015504 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/stancode.R \name{stancode.default} \alias{stancode.default} \title{Stan Code for \pkg{brms} Models} \usage{ \method{stancode}{default}( object, data, family = gaussian(), prior = NULL, autocor = NULL, data2 = NULL, cov_ranef = NULL, sparse = NULL, sample_prior = "no", stanvars = NULL, stan_funs = NULL, knots = NULL, drop_unused_levels = TRUE, threads = getOption("brms.threads", NULL), normalize = getOption("brms.normalize", TRUE), save_model = NULL, ... ) } \arguments{ \item{object}{An object of class \code{\link[stats:formula]{formula}}, \code{\link{brmsformula}}, or \code{\link{mvbrmsformula}} (or one that can be coerced to that classes): A symbolic description of the model to be fitted. The details of model specification are explained in \code{\link{brmsformula}}.} \item{data}{An object of class \code{data.frame} (or one that can be coerced to that class) containing data of all variables used in the model.} \item{family}{A description of the response distribution and link function to be used in the model. This can be a family function, a call to a family function or a character string naming the family. Every family function has a \code{link} argument allowing to specify the link function to be applied on the response variable. If not specified, default links are used. For details of supported families see \code{\link{brmsfamily}}. By default, a linear \code{gaussian} model is applied. In multivariate models, \code{family} might also be a list of families.} \item{prior}{One or more \code{brmsprior} objects created by \code{\link{set_prior}} or related functions and combined using the \code{c} method or the \code{+} operator. See also \code{\link[brms:default_prior.default]{default_prior}} for more help.} \item{autocor}{(Deprecated) An optional \code{\link{cor_brms}} object describing the correlation structure within the response variable (i.e., the 'autocorrelation'). See the documentation of \code{\link{cor_brms}} for a description of the available correlation structures. Defaults to \code{NULL}, corresponding to no correlations. In multivariate models, \code{autocor} might also be a list of autocorrelation structures. It is now recommend to specify autocorrelation terms directly within \code{formula}. See \code{\link{brmsformula}} for more details.} \item{data2}{A named \code{list} of objects containing data, which cannot be passed via argument \code{data}. Required for some objects used in autocorrelation structures to specify dependency structures as well as for within-group covariance matrices.} \item{cov_ranef}{(Deprecated) A list of matrices that are proportional to the (within) covariance structure of the group-level effects. The names of the matrices should correspond to columns in \code{data} that are used as grouping factors. All levels of the grouping factor should appear as rownames of the corresponding matrix. This argument can be used, among others to model pedigrees and phylogenetic effects. It is now recommended to specify those matrices in the formula interface using the \code{\link{gr}} and related functions. See \code{vignette("brms_phylogenetics")} for more details.} \item{sparse}{(Deprecated) Logical; indicates whether the population-level design matrices should be treated as sparse (defaults to \code{FALSE}). For design matrices with many zeros, this can considerably reduce required memory. Sampling speed is currently not improved or even slightly decreased. It is now recommended to use the \code{sparse} argument of \code{\link{brmsformula}} and related functions.} \item{sample_prior}{Indicate if draws from priors should be drawn additionally to the posterior draws. Options are \code{"no"} (the default), \code{"yes"}, and \code{"only"}. Among others, these draws can be used to calculate Bayes factors for point hypotheses via \code{\link{hypothesis}}. Please note that improper priors are not sampled, including the default improper priors used by \code{brm}. See \code{\link{set_prior}} on how to set (proper) priors. Please also note that prior draws for the overall intercept are not obtained by default for technical reasons. See \code{\link{brmsformula}} how to obtain prior draws for the intercept. If \code{sample_prior} is set to \code{"only"}, draws are drawn solely from the priors ignoring the likelihood, which allows among others to generate draws from the prior predictive distribution. In this case, all parameters must have proper priors.} \item{stanvars}{An optional \code{stanvars} object generated by function \code{\link{stanvar}} to define additional variables for use in \pkg{Stan}'s program blocks.} \item{stan_funs}{(Deprecated) An optional character string containing self-defined \pkg{Stan} functions, which will be included in the functions block of the generated \pkg{Stan} code. It is now recommended to use the \code{stanvars} argument for this purpose instead.} \item{knots}{Optional list containing user specified knot values to be used for basis construction of smoothing terms. See \code{\link[mgcv:gamm]{gamm}} for more details.} \item{drop_unused_levels}{Should unused factors levels in the data be dropped? Defaults to \code{TRUE}.} \item{threads}{Number of threads to use in within-chain parallelization. For more control over the threading process, \code{threads} may also be a \code{brmsthreads} object created by \code{\link{threading}}. Within-chain parallelization is experimental! We recommend its use only if you are experienced with Stan's \code{reduce_sum} function and have a slow running model that cannot be sped up by any other means. Can be set globally for the current \R session via the \code{"brms.threads"} option (see \code{\link{options}}).} \item{normalize}{Logical. Indicates whether normalization constants should be included in the Stan code (defaults to \code{TRUE}). Setting it to \code{FALSE} requires Stan version >= 2.25 to work. If \code{FALSE}, sampling efficiency may be increased but some post processing functions such as \code{\link{bridge_sampler}} will not be available. Can be controlled globally for the current \R session via the `brms.normalize` option.} \item{save_model}{Either \code{NULL} or a character string. In the latter case, the model's Stan code is saved via \code{\link{cat}} in a text file named after the string supplied in \code{save_model}.} \item{...}{Other arguments for internal usage only.} } \value{ A character string containing the fully commented \pkg{Stan} code to fit a \pkg{brms} model. It is of class \code{c("character", "brmsmodel")} to facilitate pretty printing. } \description{ Generate Stan code for \pkg{brms} models } \examples{ stancode(rating ~ treat + period + carry + (1|subject), data = inhaler, family = "cumulative") stancode(count ~ zAge + zBase * Trt + (1|patient), data = epilepsy, family = "poisson") } brms/man/standata.default.Rd0000644000176200001440000001265114571051305015507 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/standata.R \name{standata.default} \alias{standata.default} \title{Data for \pkg{brms} Models} \usage{ \method{standata}{default}( object, data, family = gaussian(), prior = NULL, autocor = NULL, data2 = NULL, cov_ranef = NULL, sample_prior = "no", stanvars = NULL, threads = getOption("brms.threads", NULL), knots = NULL, drop_unused_levels = TRUE, ... ) } \arguments{ \item{object}{An object of class \code{\link[stats:formula]{formula}}, \code{\link{brmsformula}}, or \code{\link{mvbrmsformula}} (or one that can be coerced to that classes): A symbolic description of the model to be fitted. The details of model specification are explained in \code{\link{brmsformula}}.} \item{data}{An object of class \code{data.frame} (or one that can be coerced to that class) containing data of all variables used in the model.} \item{family}{A description of the response distribution and link function to be used in the model. This can be a family function, a call to a family function or a character string naming the family. Every family function has a \code{link} argument allowing to specify the link function to be applied on the response variable. If not specified, default links are used. For details of supported families see \code{\link{brmsfamily}}. By default, a linear \code{gaussian} model is applied. In multivariate models, \code{family} might also be a list of families.} \item{prior}{One or more \code{brmsprior} objects created by \code{\link{set_prior}} or related functions and combined using the \code{c} method or the \code{+} operator. See also \code{\link[brms:default_prior.default]{default_prior}} for more help.} \item{autocor}{(Deprecated) An optional \code{\link{cor_brms}} object describing the correlation structure within the response variable (i.e., the 'autocorrelation'). See the documentation of \code{\link{cor_brms}} for a description of the available correlation structures. Defaults to \code{NULL}, corresponding to no correlations. In multivariate models, \code{autocor} might also be a list of autocorrelation structures. It is now recommend to specify autocorrelation terms directly within \code{formula}. See \code{\link{brmsformula}} for more details.} \item{data2}{A named \code{list} of objects containing data, which cannot be passed via argument \code{data}. Required for some objects used in autocorrelation structures to specify dependency structures as well as for within-group covariance matrices.} \item{cov_ranef}{(Deprecated) A list of matrices that are proportional to the (within) covariance structure of the group-level effects. The names of the matrices should correspond to columns in \code{data} that are used as grouping factors. All levels of the grouping factor should appear as rownames of the corresponding matrix. This argument can be used, among others to model pedigrees and phylogenetic effects. It is now recommended to specify those matrices in the formula interface using the \code{\link{gr}} and related functions. See \code{vignette("brms_phylogenetics")} for more details.} \item{sample_prior}{Indicate if draws from priors should be drawn additionally to the posterior draws. Options are \code{"no"} (the default), \code{"yes"}, and \code{"only"}. Among others, these draws can be used to calculate Bayes factors for point hypotheses via \code{\link{hypothesis}}. Please note that improper priors are not sampled, including the default improper priors used by \code{brm}. See \code{\link{set_prior}} on how to set (proper) priors. Please also note that prior draws for the overall intercept are not obtained by default for technical reasons. See \code{\link{brmsformula}} how to obtain prior draws for the intercept. If \code{sample_prior} is set to \code{"only"}, draws are drawn solely from the priors ignoring the likelihood, which allows among others to generate draws from the prior predictive distribution. In this case, all parameters must have proper priors.} \item{stanvars}{An optional \code{stanvars} object generated by function \code{\link{stanvar}} to define additional variables for use in \pkg{Stan}'s program blocks.} \item{threads}{Number of threads to use in within-chain parallelization. For more control over the threading process, \code{threads} may also be a \code{brmsthreads} object created by \code{\link{threading}}. Within-chain parallelization is experimental! We recommend its use only if you are experienced with Stan's \code{reduce_sum} function and have a slow running model that cannot be sped up by any other means. Can be set globally for the current \R session via the \code{"brms.threads"} option (see \code{\link{options}}).} \item{knots}{Optional list containing user specified knot values to be used for basis construction of smoothing terms. See \code{\link[mgcv:gamm]{gamm}} for more details.} \item{drop_unused_levels}{Should unused factors levels in the data be dropped? Defaults to \code{TRUE}.} \item{...}{Other arguments for internal use.} } \value{ A named list of objects containing the required data to fit a \pkg{brms} model with \pkg{Stan}. } \description{ Generate data for \pkg{brms} models to be passed to \pkg{Stan}. } \examples{ sdata1 <- standata(rating ~ treat + period + carry + (1|subject), data = inhaler, family = "cumulative") str(sdata1) sdata2 <- standata(count ~ zAge + zBase * Trt + (1|patient), data = epilepsy, family = "poisson") str(sdata2) } brms/man/compare_ic.Rd0000644000176200001440000000303314213413565014363 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/loo.R \name{compare_ic} \alias{compare_ic} \title{Compare Information Criteria of Different Models} \usage{ compare_ic(..., x = NULL, ic = c("loo", "waic", "kfold")) } \arguments{ \item{...}{At least two objects returned by \code{\link{waic}} or \code{\link{loo}}. Alternatively, \code{brmsfit} objects with information criteria precomputed via \code{\link{add_ic}} may be passed, as well.} \item{x}{A \code{list} containing the same types of objects as can be passed via \code{...}.} \item{ic}{The name of the information criterion to be extracted from \code{brmsfit} objects. Ignored if information criterion objects are only passed directly.} } \value{ An object of class \code{iclist}. } \description{ Compare information criteria of different models fitted with \code{\link{waic}} or \code{\link{loo}}. Deprecated and will be removed in the future. Please use \code{\link{loo_compare}} instead. } \details{ See \code{\link{loo_compare}} for the recommended way of comparing models with the \pkg{loo} package. } \examples{ \dontrun{ # model with population-level effects only fit1 <- brm(rating ~ treat + period + carry, data = inhaler) waic1 <- waic(fit1) # model with an additional varying intercept for subjects fit2 <- brm(rating ~ treat + period + carry + (1|subject), data = inhaler) waic2 <- waic(fit2) # compare both models compare_ic(waic1, waic2) } } \seealso{ \code{\link{loo}}, \code{\link{loo_compare}} \code{\link{add_criterion}} } brms/man/GenExtremeValue.Rd0000644000176200001440000000254114403575116015327 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/distributions.R \name{GenExtremeValue} \alias{GenExtremeValue} \alias{dgen_extreme_value} \alias{pgen_extreme_value} \alias{qgen_extreme_value} \alias{rgen_extreme_value} \title{The Generalized Extreme Value Distribution} \usage{ dgen_extreme_value(x, mu = 0, sigma = 1, xi = 0, log = FALSE) pgen_extreme_value( q, mu = 0, sigma = 1, xi = 0, lower.tail = TRUE, log.p = FALSE ) qgen_extreme_value( p, mu = 0, sigma = 1, xi = 0, lower.tail = TRUE, log.p = FALSE ) rgen_extreme_value(n, mu = 0, sigma = 1, xi = 0) } \arguments{ \item{x, q}{Vector of quantiles.} \item{mu}{Vector of locations.} \item{sigma}{Vector of scales.} \item{xi}{Vector of shapes.} \item{log}{Logical; If \code{TRUE}, values are returned on the log scale.} \item{lower.tail}{Logical; If \code{TRUE} (default), return P(X <= x). Else, return P(X > x) .} \item{log.p}{Logical; If \code{TRUE}, values are returned on the log scale.} \item{p}{Vector of probabilities.} \item{n}{Number of draws to sample from the distribution.} } \description{ Density, distribution function, and random generation for the generalized extreme value distribution with location \code{mu}, scale \code{sigma} and shape \code{xi}. } \details{ See \code{vignette("brms_families")} for details on the parameterization. } brms/man/data_predictor.Rd0000644000176200001440000000077514213413565015260 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/data-predictor.R \name{data_predictor} \alias{data_predictor} \title{Prepare Predictor Data} \usage{ data_predictor(x, ...) } \arguments{ \item{x}{An \R object.} \item{...}{Further arguments passed to or from other methods.} } \value{ A named list of data related to predictor variables. } \description{ Prepare data related to predictor variables in \pkg{brms}. Only exported for use in package development. } \keyword{internal} brms/man/cor_ma.Rd0000644000176200001440000000337314213413565013531 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/autocor.R \name{cor_ma} \alias{cor_ma} \title{(Deprecated) MA(q) correlation structure} \usage{ cor_ma(formula = ~1, q = 1, cov = FALSE) } \arguments{ \item{formula}{A one sided formula of the form \code{~ t}, or \code{~ t | g}, specifying a time covariate \code{t} and, optionally, a grouping factor \code{g}. A covariate for this correlation structure must be integer valued. When a grouping factor is present in \code{formula}, the correlation structure is assumed to apply only to observations within the same grouping level; observations with different grouping levels are assumed to be uncorrelated. Defaults to \code{~ 1}, which corresponds to using the order of the observations in the data as a covariate, and no groups.} \item{q}{A non-negative integer specifying the moving average (MA) order of the ARMA structure. Default is 1.} \item{cov}{A flag indicating whether ARMA effects should be estimated by means of residual covariance matrices. This is currently only possible for stationary ARMA effects of order 1. If the model family does not have natural residuals, latent residuals are added automatically. If \code{FALSE} (the default) a regression formulation is used that is considerably faster and allows for ARMA effects of order higher than 1 but is only available for \code{gaussian} models and some of its generalizations.} } \value{ An object of class \code{cor_arma} containing solely moving average terms. } \description{ This function is deprecated. Please see \code{\link{ma}} for the new syntax. This function is a constructor for the \code{cor_arma} class, allowing for moving average terms only. } \examples{ cor_ma(~visit|patient, q = 2) } \seealso{ \code{\link{cor_arma}} } brms/man/brmsterms.Rd0000644000176200001440000000404314213413565014302 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/brmsterms.R \name{brmsterms} \alias{brmsterms} \alias{parse_bf} \alias{brmsterms.default} \alias{brmsterms.brmsformula} \alias{brmsterms.mvbrmsformula} \title{Parse Formulas of \pkg{brms} Models} \usage{ brmsterms(formula, ...) \method{brmsterms}{default}(formula, ...) \method{brmsterms}{brmsformula}(formula, check_response = TRUE, resp_rhs_all = TRUE, ...) \method{brmsterms}{mvbrmsformula}(formula, ...) } \arguments{ \item{formula}{An object of class \code{\link[stats:formula]{formula}}, \code{\link{brmsformula}}, or \code{\link{mvbrmsformula}} (or one that can be coerced to that classes): A symbolic description of the model to be fitted. The details of model specification are explained in \code{\link{brmsformula}}.} \item{...}{Further arguments passed to or from other methods.} \item{check_response}{Logical; Indicates whether the left-hand side of \code{formula} (i.e. response variables and addition arguments) should be parsed. If \code{FALSE}, \code{formula} may also be one-sided.} \item{resp_rhs_all}{Logical; Indicates whether to also include response variables on the right-hand side of formula \code{.$allvars}, where \code{.} represents the output of \code{brmsterms}.} } \value{ An object of class \code{brmsterms} or \code{mvbrmsterms} (for multivariate models), which is a \code{list} containing all required information initially stored in \code{formula} in an easier to use format, basically a list of formulas (not an abstract syntax tree). } \description{ Parse formulas objects for use in \pkg{brms}. } \details{ This is the main formula parsing function of \pkg{brms}. It should usually not be called directly, but is exported to allow package developers making use of the formula syntax implemented in \pkg{brms}. As long as no other packages depend on this functions, it may be changed without deprecation warnings, when new features make this necessary. } \seealso{ \code{\link{brm}}, \code{\link{brmsformula}}, \code{\link{mvbrmsformula}} } brms/man/coef.brmsfit.Rd0000644000176200001440000000344614213413565014653 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/brmsfit-methods.R \name{coef.brmsfit} \alias{coef.brmsfit} \title{Extract Model Coefficients} \usage{ \method{coef}{brmsfit}(object, summary = TRUE, robust = FALSE, probs = c(0.025, 0.975), ...) } \arguments{ \item{object}{An object of class \code{brmsfit}.} \item{summary}{Should summary statistics be returned instead of the raw values? Default is \code{TRUE}.} \item{robust}{If \code{FALSE} (the default) the mean is used as the measure of central tendency and the standard deviation as the measure of variability. If \code{TRUE}, the median and the median absolute deviation (MAD) are applied instead. Only used if \code{summary} is \code{TRUE}.} \item{probs}{The percentiles to be computed by the \code{quantile} function. Only used if \code{summary} is \code{TRUE}.} \item{...}{Further arguments passed to \code{\link{fixef.brmsfit}} and \code{\link{ranef.brmsfit}}.} } \value{ A list of 3D arrays (one per grouping factor). If \code{summary} is \code{TRUE}, the 1st dimension contains the factor levels, the 2nd dimension contains the summary statistics (see \code{\link{posterior_summary}}), and the 3rd dimension contains the group-level effects. If \code{summary} is \code{FALSE}, the 1st dimension contains the posterior draws, the 2nd dimension contains the factor levels, and the 3rd dimension contains the group-level effects. } \description{ Extract model coefficients, which are the sum of population-level effects and corresponding group-level effects } \examples{ \dontrun{ fit <- brm(count ~ zAge + zBase * Trt + (1+Trt|visit), data = epilepsy, family = gaussian(), chains = 2) ## extract population and group-level coefficients separately fixef(fit) ranef(fit) ## extract combined coefficients coef(fit) } } brms/man/R2D2.Rd0000644000176200001440000000627715053072461012747 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/priors.R \name{R2D2} \alias{R2D2} \title{R2D2 Priors in \pkg{brms}} \usage{ R2D2(mean_R2 = 0.5, prec_R2 = 2, cons_D2 = 0.5, autoscale = TRUE, main = FALSE) } \arguments{ \item{mean_R2}{Mean of the Beta prior on the coefficient of determination R^2.} \item{prec_R2}{Precision of the Beta prior on the coefficient of determination R^2.} \item{cons_D2}{Concentration vector of the Dirichlet prior on the variance decomposition parameters. Lower values imply more shrinkage.} \item{autoscale}{Logical; indicating whether the R2D2 prior should be scaled using the residual standard deviation \code{sigma} if possible and sensible (defaults to \code{TRUE}). Autoscaling is not applied for distributional parameters or when the model does not contain the parameter \code{sigma}.} \item{main}{Logical (defaults to \code{FALSE}); only relevant if the R2D2 prior spans multiple parameter classes. In this case, only arguments given in the single instance where \code{main} is \code{TRUE} will be used. Arguments given in other instances of the prior will be ignored. See the Examples section below.} } \description{ Function used to set up R2D2(M2) priors in \pkg{brms}. The function does not evaluate its arguments -- it exists purely to help set up the model. } \details{ The prior does not account for scale differences of the terms it is applied on. Accordingly, please make sure that all these terms have a comparable scale to ensure that shrinkage is applied properly. Currently, the following classes support the R2D2(M2) prior: \code{b} (overall regression coefficients), \code{sds} (SDs of smoothing splines), \code{sdgp} (SDs of Gaussian processes), \code{ar} (autoregressive coefficients), \code{ma} (moving average coefficients), \code{sderr} (SD of latent residuals), \code{sdcar} (SD of spatial CAR structures), \code{sd} (SD of varying coefficients). When the prior is only applied to parameter class \code{b}, it is equivalent to the original R2D2 prior (with Gaussian kernel). When the prior is also applied to other parameter classes, it is equivalent to the R2D2M2 prior. Even when the R2D2(M2) prior is applied to multiple parameter classes at once, the concentration vector (argument \code{cons_D2}) has to be provided jointly in the the one instance of the prior where \code{main = TRUE}. The order in which the elements of concentration vector correspond to the classes' coefficients is the same as the order of the classes provided above. } \examples{ set_prior(R2D2(mean_R2 = 0.8, prec_R2 = 10)) # specify the R2D2 prior across multiple parameter classes set_prior(R2D2(mean_R2 = 0.8, prec_R2 = 10, main = TRUE), class = "b") + set_prior(R2D2(), class = "sd") } \references{ Zhang, Y. D., Naughton, B. P., Bondell, H. D., & Reich, B. J. (2020). Bayesian regression using a prior on the model fit: The R2-D2 shrinkage prior. Journal of the American Statistical Association. \url{https://arxiv.org/pdf/1609.00046} Aguilar J. E. & Bürkner P. C. (2022). Intuitive Joint Priors for Bayesian Linear Multilevel Models: The R2D2M2 prior. ArXiv preprint. \url{https://arxiv.org/pdf/2208.07132} } \seealso{ \code{\link{set_prior}} } brms/man/make_conditions.Rd0000644000176200001440000000212614213413565015432 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/conditional_effects.R \name{make_conditions} \alias{make_conditions} \title{Prepare Fully Crossed Conditions} \usage{ make_conditions(x, vars, ...) } \arguments{ \item{x}{An \R object from which to extract the variables that should be part of the conditions.} \item{vars}{Names of the variables that should be part of the conditions.} \item{...}{Arguments passed to \code{\link{rows2labels}}.} } \value{ A \code{data.frame} where each row indicates a condition. } \description{ This is a helper function to prepare fully crossed conditions primarily for use with the \code{conditions} argument of \code{\link{conditional_effects}}. Automatically creates labels for each row in the \code{cond__} column. } \details{ For factor like variables, all levels are used as conditions. For numeric variables, \code{mean + (-1:1) * SD} are used as conditions. } \examples{ df <- data.frame(x = c("a", "b"), y = rnorm(10)) make_conditions(df, vars = c("x", "y")) } \seealso{ \code{\link{conditional_effects}}, \code{\link{rows2labels}} } brms/man/bridge_sampler.brmsfit.Rd0000644000176200001440000000500614361545260016712 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/bridgesampling.R \name{bridge_sampler.brmsfit} \alias{bridge_sampler.brmsfit} \alias{bridge_sampler} \title{Log Marginal Likelihood via Bridge Sampling} \usage{ \method{bridge_sampler}{brmsfit}(samples, recompile = FALSE, ...) } \arguments{ \item{samples}{A \code{brmsfit} object.} \item{recompile}{Logical, indicating whether the Stan model should be recompiled. This may be necessary if you are running bridge sampling on another machine than the one used to fit the model. No recompilation is done by default.} \item{...}{Additional arguments passed to \code{\link[bridgesampling:bridge_sampler]{bridge_sampler.stanfit}}.} } \description{ Computes log marginal likelihood via bridge sampling, which can be used in the computation of bayes factors and posterior model probabilities. The \code{brmsfit} method is just a thin wrapper around the corresponding method for \code{stanfit} objects. } \details{ Computing the marginal likelihood requires samples of all variables defined in Stan's \code{parameters} block to be saved. Otherwise \code{bridge_sampler} cannot be computed. Thus, please set \code{save_pars = save_pars(all = TRUE)} in the call to \code{brm}, if you are planning to apply \code{bridge_sampler} to your models. The computation of marginal likelihoods based on bridge sampling requires a lot more posterior draws than usual. A good conservative rule of thump is perhaps 10-fold more draws (read: the default of 4000 draws may not be enough in many cases). If not enough posterior draws are provided, the bridge sampling algorithm tends to be unstable leading to considerably different results each time it is run. We thus recommend running \code{bridge_sampler} multiple times to check the stability of the results. More details are provided under \code{\link[bridgesampling:bridge_sampler]{bridgesampling::bridge_sampler}}. } \examples{ \dontrun{ # model with the treatment effect fit1 <- brm( count ~ zAge + zBase + Trt, data = epilepsy, family = negbinomial(), prior = prior(normal(0, 1), class = b), save_pars = save_pars(all = TRUE) ) summary(fit1) bridge_sampler(fit1) # model without the treatment effect fit2 <- brm( count ~ zAge + zBase, data = epilepsy, family = negbinomial(), prior = prior(normal(0, 1), class = b), save_pars = save_pars(all = TRUE) ) summary(fit2) bridge_sampler(fit2) } } \seealso{ \code{ \link[brms:bayes_factor.brmsfit]{bayes_factor}, \link[brms:post_prob.brmsfit]{post_prob} } } brms/man/prior_summary.brmsfit.Rd0000644000176200001440000000170714570436567016662 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/priors.R \name{prior_summary.brmsfit} \alias{prior_summary.brmsfit} \alias{prior_summary} \title{Priors of \code{brms} models} \usage{ \method{prior_summary}{brmsfit}(object, all = TRUE, ...) } \arguments{ \item{object}{An object of class \code{brmsfit}.} \item{all}{Logical; Show all parameters in the model which may have priors (\code{TRUE}) or only those with proper priors (\code{FALSE})?} \item{...}{Further arguments passed to or from other methods.} } \value{ An \code{brmsprior} object. } \description{ Extract priors of models fitted with \pkg{brms}. } \examples{ \dontrun{ fit <- brm( count ~ zAge + zBase * Trt + (1|patient) + (1|obs), data = epilepsy, family = poisson(), prior = prior(student_t(5,0,10), class = b) + prior(cauchy(0,2), class = sd) ) prior_summary(fit) prior_summary(fit, all = FALSE) print(prior_summary(fit, all = FALSE), show_df = FALSE) } } brms/man/cor_arma.Rd0000644000176200001440000000405214213413565014047 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/autocor.R \name{cor_arma} \alias{cor_arma} \alias{cor_arma-class} \title{(Deprecated) ARMA(p,q) correlation structure} \usage{ cor_arma(formula = ~1, p = 0, q = 0, r = 0, cov = FALSE) } \arguments{ \item{formula}{A one sided formula of the form \code{~ t}, or \code{~ t | g}, specifying a time covariate \code{t} and, optionally, a grouping factor \code{g}. A covariate for this correlation structure must be integer valued. When a grouping factor is present in \code{formula}, the correlation structure is assumed to apply only to observations within the same grouping level; observations with different grouping levels are assumed to be uncorrelated. Defaults to \code{~ 1}, which corresponds to using the order of the observations in the data as a covariate, and no groups.} \item{p}{A non-negative integer specifying the autoregressive (AR) order of the ARMA structure. Default is 0.} \item{q}{A non-negative integer specifying the moving average (MA) order of the ARMA structure. Default is 0.} \item{r}{No longer supported.} \item{cov}{A flag indicating whether ARMA effects should be estimated by means of residual covariance matrices. This is currently only possible for stationary ARMA effects of order 1. If the model family does not have natural residuals, latent residuals are added automatically. If \code{FALSE} (the default) a regression formulation is used that is considerably faster and allows for ARMA effects of order higher than 1 but is only available for \code{gaussian} models and some of its generalizations.} } \value{ An object of class \code{cor_arma}, representing an autoregression-moving-average correlation structure. } \description{ This function is deprecated. Please see \code{\link{arma}} for the new syntax. This functions is a constructor for the \code{cor_arma} class, representing an autoregression-moving average correlation structure of order (p, q). } \examples{ cor_arma(~ visit | patient, p = 2, q = 2) } \seealso{ \code{\link{cor_ar}}, \code{\link{cor_ma}} } brms/man/loo_R2.brmsfit.Rd0000644000176200001440000000535015057502546015074 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/loo_predict.R \name{loo_R2.brmsfit} \alias{loo_R2.brmsfit} \alias{loo_R2} \title{Compute a LOO-adjusted R-squared for regression models} \usage{ \method{loo_R2}{brmsfit}( object, resp = NULL, summary = TRUE, robust = FALSE, probs = c(0.025, 0.975), seed = NULL, args_epred = list(), args_loglik = list(), ... ) } \arguments{ \item{object}{An object of class \code{brmsfit}.} \item{resp}{Optional names of response variables. If specified, predictions are performed only for the specified response variables.} \item{summary}{Should summary statistics be returned instead of the raw values? Default is \code{TRUE}.} \item{robust}{If \code{FALSE} (the default) the mean is used as the measure of central tendency and the standard deviation as the measure of variability. If \code{TRUE}, the median and the median absolute deviation (MAD) are applied instead. Only used if \code{summary} is \code{TRUE}.} \item{probs}{The percentiles to be computed by the \code{quantile} function. Only used if \code{summary} is \code{TRUE}.} \item{seed}{Optional integer used to initialize the random number generator.} \item{args_epred}{A named list of further arguments passed only to \code{\link[brms:posterior_epred.brmsfit]{posterior_epred}}.} \item{args_loglik}{A named list of further arguments passed only to \code{\link[brms:log_lik.brmsfit]{log_lik}}.} \item{...}{Further arguments passed to both \code{\link[brms:posterior_epred.brmsfit]{posterior_epred}} and \code{\link[brms:log_lik.brmsfit]{log_lik}}.} } \value{ If \code{summary = TRUE}, an M x C matrix is returned (M = number of response variables and c = \code{length(probs) + 2}) containing Bayesian bootstrap based summary statistics of the LOO-adjusted R-squared values. If \code{summary = FALSE}, the Bayesian bootstrap draws of the LOO-adjusted R-squared values are returned in an S x M matrix (S is the number of draws). @details LOO-R2 uses LOO residuals and is defined as \eqn{1-Var_{loo-res} / Var_y}, with \deqn{ Var_y = V_{n=1}^N y_n, and Var_{loo-res} = V_{n=1}^N \hat{e}_{loo,n}, } where \eqn{\hat{e}_{loo,n}=y_n-\hat{y}_{loo,n}}. Bayesian bootstrap is used to draw from the approximated uncertainty distribution as described by Vehtari and Lampinen (2002). } \description{ Compute a LOO-adjusted R-squared for regression models } \examples{ \dontrun{ fit <- brm(mpg ~ wt + cyl, data = mtcars) summary(fit) loo_R2(fit) # compute R2 with new data nd <- data.frame(mpg = c(10, 20, 30), wt = c(4, 3, 2), cyl = c(8, 6, 4)) loo_R2(fit, newdata = nd) } } \references{ Vehtari and Lampinen (2002). Bayesian model assessment and comparison using cross-validation predictive densities. Neural Computation, 14(10):2439-2468. } brms/man/logm1.Rd0000644000176200001440000000066314160105076013303 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/numeric-helpers.R \name{logm1} \alias{logm1} \title{Logarithm with a minus one offset.} \usage{ logm1(x, base = exp(1)) } \arguments{ \item{x}{A numeric or complex vector.} \item{base}{A positive or complex number: the base with respect to which logarithms are computed. Defaults to \emph{e} = \code{exp(1)}.} } \description{ Computes \code{log(x - 1)}. } brms/man/LogisticNormal.Rd0000644000176200001440000000216514527413457015225 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/distributions.R \name{LogisticNormal} \alias{LogisticNormal} \alias{dlogistic_normal} \alias{rlogistic_normal} \title{The (Multivariate) Logistic Normal Distribution} \usage{ dlogistic_normal(x, mu, Sigma, refcat = 1, log = FALSE, check = FALSE) rlogistic_normal(n, mu, Sigma, refcat = 1, check = FALSE) } \arguments{ \item{x}{Vector or matrix of quantiles. If \code{x} is a matrix, each row is taken to be a quantile.} \item{mu}{Mean vector with length equal to the number of dimensions.} \item{Sigma}{Covariance matrix.} \item{refcat}{A single integer indicating the reference category. Defaults to \code{1}.} \item{log}{Logical; If \code{TRUE}, values are returned on the log scale.} \item{check}{Logical; Indicates whether several input checks should be performed. Defaults to \code{FALSE} to improve efficiency.} \item{n}{Number of draws to sample from the distribution.} } \description{ Density function and random generation for the (multivariate) logistic normal distribution with latent mean vector \code{mu} and covariance matrix \code{Sigma}. } brms/man/log_lik.brmsfit.Rd0000644000176200001440000000733015053072461015352 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/log_lik.R \name{log_lik.brmsfit} \alias{log_lik.brmsfit} \alias{log_lik} \alias{logLik.brmsfit} \title{Compute the Pointwise Log-Likelihood} \usage{ \method{log_lik}{brmsfit}( object, newdata = NULL, re_formula = NULL, resp = NULL, ndraws = NULL, draw_ids = NULL, pointwise = FALSE, combine = TRUE, add_point_estimate = FALSE, cores = NULL, ... ) } \arguments{ \item{object}{A fitted model object of class \code{brmsfit}.} \item{newdata}{An optional data.frame for which to evaluate predictions. If \code{NULL} (default), the original data of the model is used. \code{NA} values within factors (excluding grouping variables) are interpreted as if all dummy variables of this factor are zero. This allows, for instance, to make predictions of the grand mean when using sum coding. \code{NA} values within grouping variables are treated as a new level.} \item{re_formula}{formula containing group-level effects to be considered in the prediction. If \code{NULL} (default), include all group-level effects; if \code{NA} or \code{~0}, include no group-level effects.} \item{resp}{Optional names of response variables. If specified, predictions are performed only for the specified response variables.} \item{ndraws}{Positive integer indicating how many posterior draws should be used. If \code{NULL} (the default) all draws are used. Ignored if \code{draw_ids} is not \code{NULL}.} \item{draw_ids}{An integer vector specifying the posterior draws to be used. If \code{NULL} (the default), all draws are used.} \item{pointwise}{A flag indicating whether to compute the full log-likelihood matrix at once (the default), or just return the likelihood function along with all data and draws required to compute the log-likelihood separately for each observation. The latter option is rarely useful when calling \code{log_lik} directly, but rather when computing \code{\link{waic}} or \code{\link{loo}}.} \item{combine}{Only relevant in multivariate models. Indicates if the log-likelihoods of the submodels should be combined per observation (i.e. added together; the default) or if the log-likelihoods should be returned separately.} \item{add_point_estimate}{For internal use only. Ensures compatibility with the \code{\link{loo_subsample}} method.} \item{cores}{Number of cores (defaults to \code{1}). On non-Windows systems, this argument can be set globally via the \code{mc.cores} option.} \item{...}{Further arguments passed to \code{\link{prepare_predictions}} that control several aspects of data validation and prediction.} } \value{ Usually, an S x N matrix containing the pointwise log-likelihood draws, where S is the number of draws and N is the number of observations in the data. For multivariate models and if \code{combine} is \code{FALSE}, an S x N x R array is returned, where R is the number of response variables. If \code{pointwise = TRUE}, the output is a function with a \code{draws} attribute containing all relevant data and posterior draws. } \description{ Compute the Pointwise Log-Likelihood } \details{ \code{NA} values within factors in \code{newdata}, are interpreted as if all dummy variables of this factor are zero. This allows, for instance, to make predictions of the grand mean when using sum coding. In multilevel models, it is possible to allow new levels of grouping factors to be used in the predictions. This can be controlled via argument \code{allow_new_levels}. New levels can be sampled in multiple ways, which can be controlled via argument \code{sample_new_levels}. Both of these arguments are documented in \code{\link{prepare_predictions}} along with several other useful arguments to control specific aspects of the predictions. } brms/man/get_dpar.Rd0000644000176200001440000000337714213413565014062 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/brmsfit-helpers.R \name{get_dpar} \alias{get_dpar} \title{Draws of a Distributional Parameter} \usage{ get_dpar(prep, dpar, i = NULL, inv_link = NULL) } \arguments{ \item{prep}{A 'brmsprep' or 'mvbrmsprep' object created by \code{\link[brms:prepare_predictions.brmsfit]{prepare_predictions}}.} \item{dpar}{Name of the distributional parameter.} \item{i}{The observation numbers for which predictions shall be extracted. If \code{NULL} (the default), all observation will be extracted. Ignored if \code{dpar} is not predicted.} \item{inv_link}{Should the inverse link function be applied? If \code{NULL} (the default), the value is chosen internally. In particular, \code{inv_link} is \code{TRUE} by default for custom families.} } \value{ If the parameter is predicted and \code{i} is \code{NULL} or \code{length(i) > 1}, an \code{S x N} matrix. If the parameter it not predicted or \code{length(i) == 1}, a vector of length \code{S}. Here \code{S} is the number of draws and \code{N} is the number of observations or length of \code{i} if specified. } \description{ Get draws of a distributional parameter from a \code{brmsprep} or \code{mvbrmsprep} object. This function is primarily useful when developing custom families or packages depending on \pkg{brms}. This function lets callers easily handle both the case when the distributional parameter is predicted directly, via a (non-)linear predictor or fixed to a constant. See the vignette \code{vignette("brms_customfamilies")} for an example use case. } \examples{ \dontrun{ posterior_predict_my_dist <- function(i, prep, ...) { mu <- brms::get_dpar(prep, "mu", i = i) mypar <- brms::get_dpar(prep, "mypar", i = i) my_rng(mu, mypar) } } } brms/man/posterior_average.brmsfit.Rd0000644000176200001440000000626415053072461017457 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/model_weights.R \name{posterior_average.brmsfit} \alias{posterior_average.brmsfit} \alias{posterior_average} \title{Posterior draws of parameters averaged across models} \usage{ \method{posterior_average}{brmsfit}( x, ..., variable = NULL, pars = NULL, weights = "stacking", ndraws = NULL, nsamples = NULL, missing = NULL, model_names = NULL, control = list(), seed = NULL ) posterior_average(x, ...) } \arguments{ \item{x}{A \code{brmsfit} object.} \item{...}{More \code{brmsfit} objects or further arguments passed to the underlying post-processing functions. In particular, see \code{\link{prepare_predictions}} for further supported arguments.} \item{variable}{Names of variables (parameters) for which to average across models. Only those variables can be averaged that appear in every model. Defaults to all overlapping variables.} \item{pars}{Deprecated alias of \code{variable}.} \item{weights}{Name of the criterion to compute weights from. Should be one of \code{"loo"}, \code{"waic"}, \code{"kfold"}, \code{"stacking"} (current default), \code{"bma"}, or \code{"pseudobma"}. For the former three options, Akaike weights will be computed based on the information criterion values returned by the respective methods. For \code{"stacking"} and \code{"pseudobma"}, method \code{\link{loo_model_weights}} will be used to obtain weights. For \code{"bma"}, method \code{\link{post_prob}} will be used to compute Bayesian model averaging weights based on log marginal likelihood values (make sure to specify reasonable priors in this case). For some methods, \code{weights} may also be a numeric vector of pre-specified weights.} \item{ndraws}{Total number of posterior draws to use.} \item{nsamples}{Deprecated alias of \code{ndraws}.} \item{missing}{An optional numeric value or a named list of numeric values to use if a model does not contain a variable for which posterior draws should be averaged. Defaults to \code{NULL}, in which case only those variables can be averaged that are present in all of the models.} \item{model_names}{If \code{NULL} (the default) will use model names derived from deparsing the call. Otherwise will use the passed values as model names.} \item{control}{Optional \code{list} of further arguments passed to the function specified in \code{weights}.} \item{seed}{A single numeric value passed to \code{\link{set.seed}} to make results reproducible.} } \value{ A \code{data.frame} of posterior draws. } \description{ Extract posterior draws of parameters averaged across models. Weighting can be done in various ways, for instance using Akaike weights based on information criteria or marginal likelihoods. } \details{ Weights are computed with the \code{\link{model_weights}} method. } \examples{ \dontrun{ # model with 'treat' as predictor fit1 <- brm(rating ~ treat + period + carry, data = inhaler) summary(fit1) # model without 'treat' as predictor fit2 <- brm(rating ~ period + carry, data = inhaler) summary(fit2) # compute model-averaged posteriors of overlapping parameters posterior_average(fit1, fit2, weights = "waic") } } \seealso{ \code{\link{model_weights}}, \code{\link{pp_average}} } brms/man/SkewNormal.Rd0000644000176200001440000000337314275436221014355 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/distributions.R \name{SkewNormal} \alias{SkewNormal} \alias{dskew_normal} \alias{pskew_normal} \alias{qskew_normal} \alias{rskew_normal} \title{The Skew-Normal Distribution} \usage{ dskew_normal( x, mu = 0, sigma = 1, alpha = 0, xi = NULL, omega = NULL, log = FALSE ) pskew_normal( q, mu = 0, sigma = 1, alpha = 0, xi = NULL, omega = NULL, lower.tail = TRUE, log.p = FALSE ) qskew_normal( p, mu = 0, sigma = 1, alpha = 0, xi = NULL, omega = NULL, lower.tail = TRUE, log.p = FALSE, tol = 1e-08 ) rskew_normal(n, mu = 0, sigma = 1, alpha = 0, xi = NULL, omega = NULL) } \arguments{ \item{x, q}{Vector of quantiles.} \item{mu}{Vector of mean values.} \item{sigma}{Vector of standard deviation values.} \item{alpha}{Vector of skewness values.} \item{xi}{Optional vector of location values. If \code{NULL} (the default), will be computed internally.} \item{omega}{Optional vector of scale values. If \code{NULL} (the default), will be computed internally.} \item{log}{Logical; If \code{TRUE}, values are returned on the log scale.} \item{lower.tail}{Logical; If \code{TRUE} (default), return P(X <= x). Else, return P(X > x) .} \item{log.p}{Logical; If \code{TRUE}, values are returned on the log scale.} \item{p}{Vector of probabilities.} \item{tol}{Tolerance of the approximation used in the computation of quantiles.} \item{n}{Number of draws to sample from the distribution.} } \description{ Density, distribution function, and random generation for the skew-normal distribution with mean \code{mu}, standard deviation \code{sigma}, and skewness \code{alpha}. } \details{ See \code{vignette("brms_families")} for details on the parameterization. } brms/man/expp1.Rd0000644000176200001440000000042614160105076013316 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/numeric-helpers.R \name{expp1} \alias{expp1} \title{Exponential function plus one.} \usage{ expp1(x) } \arguments{ \item{x}{A numeric or complex vector.} } \description{ Computes \code{exp(x) + 1}. } brms/man/as.brmsprior.Rd0000644000176200001440000000061414527413457014715 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/priors.R \name{as.brmsprior} \alias{as.brmsprior} \title{Transform into a brmsprior object} \usage{ as.brmsprior(x) } \arguments{ \item{x}{An object to be transformed.} } \value{ A \code{brmsprior} object if the transformation was possible. } \description{ Try to transform an object into a \code{brmsprior} object. } brms/man/mcmc_plot.brmsfit.Rd0000644000176200001440000000550414213413565015711 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/plot.R \name{mcmc_plot.brmsfit} \alias{mcmc_plot.brmsfit} \alias{stanplot} \alias{stanplot.brmsfit} \alias{mcmc_plot} \title{MCMC Plots Implemented in \pkg{bayesplot}} \usage{ \method{mcmc_plot}{brmsfit}( object, pars = NA, type = "intervals", variable = NULL, regex = FALSE, fixed = FALSE, ... ) mcmc_plot(object, ...) } \arguments{ \item{object}{An \R object typically of class \code{brmsfit}} \item{pars}{Deprecated alias of \code{variable}. Names of the parameters to plot, as given by a character vector or a regular expression.} \item{type}{The type of the plot. Supported types are (as names) \code{hist}, \code{dens}, \code{hist_by_chain}, \code{dens_overlay}, \code{violin}, \code{intervals}, \code{areas}, \code{acf}, \code{acf_bar},\code{trace}, \code{trace_highlight}, \code{scatter}, \code{rhat}, \code{rhat_hist}, \code{neff}, \code{neff_hist} \code{nuts_acceptance}, \code{nuts_divergence}, \code{nuts_stepsize}, \code{nuts_treedepth}, and \code{nuts_energy}. For an overview on the various plot types see \code{\link[bayesplot:MCMC-overview]{MCMC-overview}}.} \item{variable}{Names of the variables (parameters) to plot, as given by a character vector or a regular expression (if \code{regex = TRUE}). By default, a hopefully not too large selection of variables is plotted.} \item{regex}{Logical; Indicates whether \code{variable} should be treated as regular expressions. Defaults to \code{FALSE}.} \item{fixed}{(Deprecated) Indicates whether parameter names should be matched exactly (\code{TRUE}) or treated as regular expressions (\code{FALSE}). Default is \code{FALSE} and only works with argument \code{pars}.} \item{...}{Additional arguments passed to the plotting functions. See \code{\link[bayesplot:MCMC-overview]{MCMC-overview}} for more details.} } \value{ A \code{\link[ggplot2:ggplot]{ggplot}} object that can be further customized using the \pkg{ggplot2} package. } \description{ Convenient way to call MCMC plotting functions implemented in the \pkg{bayesplot} package. } \details{ Also consider using the \pkg{shinystan} package available via method \code{\link{launch_shinystan}} in \pkg{brms} for flexible and interactive visual analysis. } \examples{ \dontrun{ model <- brm(count ~ zAge + zBase * Trt + (1|patient), data = epilepsy, family = "poisson") # plot posterior intervals mcmc_plot(model) # only show population-level effects in the plots mcmc_plot(model, variable = "^b_", regex = TRUE) # show histograms of the posterior distributions mcmc_plot(model, type = "hist") # plot some diagnostics of the sampler mcmc_plot(model, type = "neff") mcmc_plot(model, type = "rhat") # plot some diagnostics specific to the NUTS sampler mcmc_plot(model, type = "nuts_acceptance") mcmc_plot(model, type = "nuts_divergence") } } brms/man/save_pars.Rd0000644000176200001440000000375614500561321014252 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/exclude_pars.R \name{save_pars} \alias{save_pars} \title{Control Saving of Parameter Draws} \usage{ save_pars(group = TRUE, latent = FALSE, all = FALSE, manual = NULL) } \arguments{ \item{group}{A flag to indicate if group-level coefficients for each level of the grouping factors should be saved (default is \code{TRUE}). Set to \code{FALSE} to save memory. Alternatively, \code{group} may also be a character vector naming the grouping factors for which to save draws of coefficients.} \item{latent}{A flag to indicate if draws of latent variables obtained by using \code{me} and \code{mi} terms should be saved (default is \code{FALSE}). Saving these draws allows to better use methods such as \code{posterior_predict} with the latent variables but leads to very large \R objects even for models of moderate size and complexity. Alternatively, \code{latent} may also be a character vector naming the latent variables for which to save draws.} \item{all}{A flag to indicate if draws of all variables defined in Stan's \code{parameters} block should be saved (default is \code{FALSE}). Saving these draws is required in order to apply the certain methods such as \code{bridge_sampler} and \code{bayes_factor}.} \item{manual}{A character vector naming Stan variable names which should be saved. These names should match the variable names inside the Stan code before renaming. This feature is meant for power users only and will rarely be useful outside of very special cases.} } \value{ A list of class \code{"save_pars"}. } \description{ Control which (draws of) parameters should be saved in a \pkg{brms} model. The output of this function is meant for usage in the \code{save_pars} argument of \code{\link{brm}}. } \examples{ \dontrun{ # don't store group-level coefficients fit <- brm(count ~ zAge + zBase * Trt + (1|patient), data = epilepsy, family = poisson(), save_pars = save_pars(group = FALSE)) variables(fit) } } brms/man/data_response.Rd0000644000176200001440000000076614213413565015123 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/data-response.R \name{data_response} \alias{data_response} \title{Prepare Response Data} \usage{ data_response(x, ...) } \arguments{ \item{x}{An \R object.} \item{...}{Further arguments passed to or from other methods.} } \value{ A named list of data related to response variables. } \description{ Prepare data related to response variables in \pkg{brms}. Only exported for use in package development. } \keyword{internal} brms/man/posterior_table.Rd0000644000176200001440000000154614213413565015466 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/summary.R \name{posterior_table} \alias{posterior_table} \title{Table Creation for Posterior Draws} \usage{ posterior_table(x, levels = NULL) } \arguments{ \item{x}{A matrix of posterior draws where rows indicate draws and columns indicate parameters.} \item{levels}{Optional values of possible posterior values. Defaults to all unique values in \code{x}.} } \value{ A matrix where rows indicate parameters and columns indicate the unique values of posterior draws. } \description{ Create a table for unique values of posterior draws. This is usually only useful when summarizing predictions of ordinal models. } \examples{ \dontrun{ fit <- brm(rating ~ period + carry + treat, data = inhaler, family = cumulative()) pr <- predict(fit, summary = FALSE) posterior_table(pr) } } brms/man/is.cor_brms.Rd0000644000176200001440000000100014160105076014466 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/autocor.R \name{is.cor_brms} \alias{is.cor_brms} \alias{is.cor_arma} \alias{is.cor_cosy} \alias{is.cor_sar} \alias{is.cor_car} \alias{is.cor_fixed} \title{Check if argument is a correlation structure} \usage{ is.cor_brms(x) is.cor_arma(x) is.cor_cosy(x) is.cor_sar(x) is.cor_car(x) is.cor_fixed(x) } \arguments{ \item{x}{An \R object.} } \description{ Check if argument is one of the correlation structures used in \pkg{brms}. } brms/man/model_weights.brmsfit.Rd0000644000176200001440000000374115053072461016566 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/model_weights.R \name{model_weights.brmsfit} \alias{model_weights.brmsfit} \alias{model_weights} \title{Model Weighting Methods} \usage{ \method{model_weights}{brmsfit}(x, ..., weights = "stacking", model_names = NULL) model_weights(x, ...) } \arguments{ \item{x}{A \code{brmsfit} object.} \item{...}{More \code{brmsfit} objects or further arguments passed to the underlying post-processing functions. In particular, see \code{\link{prepare_predictions}} for further supported arguments.} \item{weights}{Name of the criterion to compute weights from. Should be one of \code{"loo"}, \code{"waic"}, \code{"kfold"}, \code{"stacking"} (current default), \code{"bma"}, or \code{"pseudobma"}. For the former three options, Akaike weights will be computed based on the information criterion values returned by the respective methods. For \code{"stacking"} and \code{"pseudobma"}, method \code{\link{loo_model_weights}} will be used to obtain weights. For \code{"bma"}, method \code{\link{post_prob}} will be used to compute Bayesian model averaging weights based on log marginal likelihood values (make sure to specify reasonable priors in this case). For some methods, \code{weights} may also be a numeric vector of pre-specified weights.} \item{model_names}{If \code{NULL} (the default) will use model names derived from deparsing the call. Otherwise will use the passed values as model names.} } \value{ A numeric vector of weights for the models. } \description{ Compute model weights in various ways, for instance, via stacking of posterior predictive distributions, Akaike weights, or marginal likelihoods. } \examples{ \dontrun{ # model with 'treat' as predictor fit1 <- brm(rating ~ treat + period + carry, data = inhaler) summary(fit1) # model without 'treat' as predictor fit2 <- brm(rating ~ period + carry, data = inhaler) summary(fit2) # obtain Akaike weights based on the WAIC model_weights(fit1, fit2, weights = "waic") } } brms/man/is.brmsfit.Rd0000644000176200001440000000046414160105076014343 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/brmsfit-class.R \name{is.brmsfit} \alias{is.brmsfit} \title{Checks if argument is a \code{brmsfit} object} \usage{ is.brmsfit(x) } \arguments{ \item{x}{An \R object} } \description{ Checks if argument is a \code{brmsfit} object } brms/man/do_call.Rd0000644000176200001440000000170714160105076013661 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/misc.R \name{do_call} \alias{do_call} \title{Execute a Function Call} \usage{ do_call(what, args, pkg = NULL, envir = parent.frame()) } \arguments{ \item{what}{Either a function or a non-empty character string naming the function to be called.} \item{args}{A list of arguments to the function call. The names attribute of \code{args} gives the argument names.} \item{pkg}{Optional name of the package in which to search for the function if \code{what} is a character string.} \item{envir}{An environment within which to evaluate the call.} } \value{ The result of the (evaluated) function call. } \description{ Execute a function call similar to \code{\link{do.call}}, but without deparsing function arguments. For large number of arguments (i.e., more than a few thousand) this function currently is somewhat inefficient and should be used with care in this case. } \keyword{internal} brms/man/fitted.brmsfit.Rd0000644000176200001440000001120215053072461015202 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/posterior_epred.R \name{fitted.brmsfit} \alias{fitted.brmsfit} \title{Expected Values of the Posterior Predictive Distribution} \usage{ \method{fitted}{brmsfit}( object, newdata = NULL, re_formula = NULL, scale = c("response", "linear"), resp = NULL, dpar = NULL, nlpar = NULL, ndraws = NULL, draw_ids = NULL, sort = FALSE, summary = TRUE, robust = FALSE, probs = c(0.025, 0.975), ... ) } \arguments{ \item{object}{An object of class \code{brmsfit}.} \item{newdata}{An optional data.frame for which to evaluate predictions. If \code{NULL} (default), the original data of the model is used. \code{NA} values within factors (excluding grouping variables) are interpreted as if all dummy variables of this factor are zero. This allows, for instance, to make predictions of the grand mean when using sum coding. \code{NA} values within grouping variables are treated as a new level.} \item{re_formula}{formula containing group-level effects to be considered in the prediction. If \code{NULL} (default), include all group-level effects; if \code{NA} or \code{~0}, include no group-level effects.} \item{scale}{Either \code{"response"} or \code{"linear"}. If \code{"response"}, results are returned on the scale of the response variable. If \code{"linear"}, results are returned on the scale of the linear predictor term, that is without applying the inverse link function or other transformations.} \item{resp}{Optional names of response variables. If specified, predictions are performed only for the specified response variables.} \item{dpar}{Optional name of a predicted distributional parameter. If specified, expected predictions of this parameters are returned.} \item{nlpar}{Optional name of a predicted non-linear parameter. If specified, expected predictions of this parameters are returned.} \item{ndraws}{Positive integer indicating how many posterior draws should be used. If \code{NULL} (the default) all draws are used. Ignored if \code{draw_ids} is not \code{NULL}.} \item{draw_ids}{An integer vector specifying the posterior draws to be used. If \code{NULL} (the default), all draws are used.} \item{sort}{Logical. Only relevant for time series models. Indicating whether to return predicted values in the original order (\code{FALSE}; default) or in the order of the time series (\code{TRUE}).} \item{summary}{Should summary statistics be returned instead of the raw values? Default is \code{TRUE}..} \item{robust}{If \code{FALSE} (the default) the mean is used as the measure of central tendency and the standard deviation as the measure of variability. If \code{TRUE}, the median and the median absolute deviation (MAD) are applied instead. Only used if \code{summary} is \code{TRUE}.} \item{probs}{The percentiles to be computed by the \code{quantile} function. Only used if \code{summary} is \code{TRUE}.} \item{...}{Further arguments passed to \code{\link{prepare_predictions}} that control several aspects of data validation and prediction.} } \value{ An \code{array} of predicted \emph{mean} response values. If \code{summary = FALSE} the output resembles those of \code{\link{posterior_epred.brmsfit}}. If \code{summary = TRUE} the output depends on the family: For categorical and ordinal families, the output is an N x E x C array, where N is the number of observations, E is the number of summary statistics, and C is the number of categories. For all other families, the output is an N x E matrix. The number of summary statistics E is equal to \code{2 + length(probs)}: The \code{Estimate} column contains point estimates (either mean or median depending on argument \code{robust}), while the \code{Est.Error} column contains uncertainty estimates (either standard deviation or median absolute deviation depending on argument \code{robust}). The remaining columns starting with \code{Q} contain quantile estimates as specified via argument \code{probs}. In multivariate models, an additional dimension is added to the output which indexes along the different response variables. } \description{ This method is an alias of \code{\link{posterior_epred.brmsfit}} with additional arguments for obtaining summaries of the computed draws. } \examples{ \dontrun{ ## fit a model fit <- brm(rating ~ treat + period + carry + (1|subject), data = inhaler) ## compute expected predictions fitted_values <- fitted(fit) head(fitted_values) ## plot expected predictions against actual response dat <- as.data.frame(cbind(Y = standata(fit)$Y, fitted_values)) ggplot(dat) + geom_point(aes(x = Estimate, y = Y)) } } \seealso{ \code{\link{posterior_epred.brmsfit}} } brms/man/horseshoe.Rd0000644000176200001440000001444515053072461014271 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/priors.R \name{horseshoe} \alias{horseshoe} \title{Regularized horseshoe priors in \pkg{brms}} \usage{ horseshoe( df = 1, scale_global = 1, df_global = 1, scale_slab = 2, df_slab = 4, par_ratio = NULL, autoscale = TRUE, main = FALSE ) } \arguments{ \item{df}{Degrees of freedom of student-t prior of the local shrinkage parameters. Defaults to \code{1}.} \item{scale_global}{Scale of the student-t prior of the global shrinkage parameter. Defaults to \code{1}. In linear models, \code{scale_global} will internally be multiplied by the residual standard deviation parameter \code{sigma}.} \item{df_global}{Degrees of freedom of student-t prior of the global shrinkage parameter. Defaults to \code{1}. If \code{df_global} is greater \code{1}, the shape of the prior will no longer resemble a horseshoe and it may be more appropriately called an hierarchical shrinkage prior in this case.} \item{scale_slab}{Scale of the Student-t slab. Defaults to \code{2}. The original unregularized horseshoe prior is obtained by setting \code{scale_slab} to infinite, which we can approximate in practice by setting it to a very large real value.} \item{df_slab}{Degrees of freedom of the student-t slab. Defaults to \code{4}.} \item{par_ratio}{Ratio of the expected number of non-zero coefficients to the expected number of zero coefficients. If specified, \code{scale_global} is ignored and internally computed as \code{par_ratio / sqrt(N)}, where \code{N} is the total number of observations in the data.} \item{autoscale}{Logical; indicating whether the horseshoe prior should be scaled using the residual standard deviation \code{sigma} if possible and sensible (defaults to \code{TRUE}). Autoscaling is not applied for distributional parameters or when the model does not contain the parameter \code{sigma}.} \item{main}{Logical (defaults to \code{FALSE}); only relevant if the horseshoe prior spans multiple parameter classes. In this case, only arguments given in the single instance where \code{main} is \code{TRUE} will be used. Arguments given in other instances of the prior will be ignored. See the Examples section below.} } \value{ A character string obtained by \code{match.call()} with additional arguments. } \description{ Function used to set up regularized horseshoe priors and related hierarchical shrinkage priors in \pkg{brms}. The function does not evaluate its arguments -- it exists purely to help set up the model. } \details{ The horseshoe prior is a special shrinkage prior initially proposed by Carvalho et al. (2009). It is symmetric around zero with fat tails and an infinitely large spike at zero. This makes it ideal for sparse models that have many regression coefficients, although only a minority of them is non-zero. The horseshoe prior can be applied on all population-level effects at once (excluding the intercept) by using \code{set_prior("horseshoe(1)")}. The \code{1} implies that the student-t prior of the local shrinkage parameters has 1 degrees of freedom. This may, however, lead to an increased number of divergent transition in \pkg{Stan}. Accordingly, increasing the degrees of freedom to slightly higher values (e.g., \code{3}) may often be a better option, although the prior no longer resembles a horseshoe in this case. Further, the scale of the global shrinkage parameter plays an important role in amount of shrinkage applied. It defaults to \code{1}, but this may result in too few shrinkage (Piironen & Vehtari, 2016). It is thus possible to change the scale using argument \code{scale_global} of the horseshoe prior, for instance \code{horseshoe(1, scale_global = 0.5)}. In linear models, \code{scale_global} will internally be multiplied by the residual standard deviation parameter \code{sigma}. See Piironen and Vehtari (2016) for recommendations how to properly set the global scale. The degrees of freedom of the global shrinkage prior may also be adjusted via argument \code{df_global}. Piironen and Vehtari (2017) recommend to specifying the ratio of the expected number of non-zero coefficients to the expected number of zero coefficients \code{par_ratio} rather than \code{scale_global} directly. As proposed by Piironen and Vehtari (2017), an additional regularization is applied that only affects non-zero coefficients. The amount of regularization can be controlled via \code{scale_slab} and \code{df_slab}. To make sure that shrinkage can equally affect all coefficients, predictors should be one the same scale. Generally, models with horseshoe priors a more likely than other models to have divergent transitions so that increasing \code{adapt_delta} from \code{0.8} to values closer to \code{1} will often be necessary. See the documentation of \code{\link{brm}} for instructions on how to increase \code{adapt_delta}. The prior does not account for scale differences of the terms it is applied on. Accordingly, please make sure that all these terms have a comparable scale to ensure that shrinkage is applied properly. Currently, the following classes support the horseshoe prior: \code{b} (overall regression coefficients), \code{sds} (SDs of smoothing splines), \code{sdgp} (SDs of Gaussian processes), \code{ar} (autoregressive coefficients), \code{ma} (moving average coefficients), \code{sderr} (SD of latent residuals), \code{sdcar} (SD of spatial CAR structures), \code{sd} (SD of varying coefficients). } \examples{ set_prior(horseshoe(df = 3, par_ratio = 0.1)) # specify the horseshoe prior across multiple parameter classes set_prior(horseshoe(df = 3, par_ratio = 0.1, main = TRUE), class = "b") + set_prior(horseshoe(), class = "sd") } \references{ Carvalho, C. M., Polson, N. G., & Scott, J. G. (2009). Handling sparsity via the horseshoe. Artificial Intelligence and Statistics. \url{http://proceedings.mlr.press/v5/carvalho09a} Piironen J. & Vehtari A. (2017). On the Hyperprior Choice for the Global Shrinkage Parameter in the Horseshoe Prior. Artificial Intelligence and Statistics. \url{https://arxiv.org/pdf/1610.05559v1} Piironen, J., and Vehtari, A. (2017). Sparsity information and regularization in the horseshoe and other shrinkage priors. Electronic Journal of Statistics. \url{https://arxiv.org/abs/1707.01694} } \seealso{ \code{\link{set_prior}} } brms/man/posterior_samples.brmsfit.Rd0000644000176200001440000000462314213413565017507 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/posterior_samples.R \name{posterior_samples.brmsfit} \alias{posterior_samples.brmsfit} \alias{posterior_samples} \title{(Deprecated) Extract Posterior Samples} \usage{ \method{posterior_samples}{brmsfit}( x, pars = NA, fixed = FALSE, add_chain = FALSE, subset = NULL, as.matrix = FALSE, as.array = FALSE, ... ) posterior_samples(x, pars = NA, ...) } \arguments{ \item{x}{An \code{R} object typically of class \code{brmsfit}} \item{pars}{Names of parameters for which posterior samples should be returned, as given by a character vector or regular expressions. By default, all posterior samples of all parameters are extracted.} \item{fixed}{Indicates whether parameter names should be matched exactly (\code{TRUE}) or treated as regular expressions (\code{FALSE}). Default is \code{FALSE}.} \item{add_chain}{A flag indicating if the returned \code{data.frame} should contain two additional columns. The \code{chain} column indicates the chain in which each sample was generated, the \code{iter} column indicates the iteration number within each chain.} \item{subset}{A numeric vector indicating the rows (i.e., posterior samples) to be returned. If \code{NULL} (the default), all posterior samples are returned.} \item{as.matrix}{Should the output be a \code{matrix} instead of a \code{data.frame}? Defaults to \code{FALSE}.} \item{as.array}{Should the output be an \code{array} instead of a \code{data.frame}? Defaults to \code{FALSE}.} \item{...}{Arguments passed to individual methods (if applicable).} } \value{ A data.frame (matrix or array) containing the posterior samples. } \description{ Extract posterior samples of specified parameters. The \code{posterior_samples} method is deprecated. We recommend using the more modern and consistent \code{\link[brms:draws-brms]{as_draws_*}} extractor functions of the \pkg{posterior} package instead. } \examples{ \dontrun{ fit <- brm(rating ~ treat + period + carry + (1|subject), data = inhaler, family = "cumulative") # extract posterior samples of population-level effects samples1 <- posterior_samples(fit, pars = "^b") head(samples1) # extract posterior samples of group-level standard deviations samples2 <- posterior_samples(fit, pars = "^sd_") head(samples2) } } \seealso{ \code{\link[brms:draws-brms]{as_draws}}, \code{\link[brms:as.data.frame.brmsfit]{as.data.frame}} } brms/man/summary.brmsfit.Rd0000644000176200001440000000305514213413565015430 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/summary.R \name{summary.brmsfit} \alias{summary.brmsfit} \title{Create a summary of a fitted model represented by a \code{brmsfit} object} \usage{ \method{summary}{brmsfit}( object, priors = FALSE, prob = 0.95, robust = FALSE, mc_se = FALSE, ... ) } \arguments{ \item{object}{An object of class \code{brmsfit}.} \item{priors}{Logical; Indicating if priors should be included in the summary. Default is \code{FALSE}.} \item{prob}{A value between 0 and 1 indicating the desired probability to be covered by the uncertainty intervals. The default is 0.95.} \item{robust}{If \code{FALSE} (the default) the mean is used as the measure of central tendency and the standard deviation as the measure of variability. If \code{TRUE}, the median and the median absolute deviation (MAD) are applied instead.} \item{mc_se}{Logical; Indicating if the uncertainty in \code{Estimate} caused by the MCMC sampling should be shown in the summary. Defaults to \code{FALSE}.} \item{...}{Other potential arguments} } \description{ Create a summary of a fitted model represented by a \code{brmsfit} object } \details{ The convergence diagnostics \code{Rhat}, \code{Bulk_ESS}, and \code{Tail_ESS} are described in detail in Vehtari et al. (2020). } \references{ Aki Vehtari, Andrew Gelman, Daniel Simpson, Bob Carpenter, and Paul-Christian Bürkner (2020). Rank-normalization, folding, and localization: An improved R-hat for assessing convergence of MCMC. *Bayesian Analysis*. 1–28. dpi:10.1214/20-BA1221 } brms/man/restructure.brmsfit.Rd0000644000176200001440000000200114572632206016313 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/restructure.R \name{restructure.brmsfit} \alias{restructure.brmsfit} \title{Restructure Old \code{brmsfit} Objects} \usage{ \method{restructure}{brmsfit}(x, ...) } \arguments{ \item{x}{An object of class \code{brmsfit}.} \item{...}{Currently ignored.} } \value{ A \code{brmsfit} object compatible with the latest version of \pkg{brms}. } \description{ Restructure old \code{brmsfit} objects to work with the latest \pkg{brms} version. This function is called internally when applying post-processing methods. However, in order to avoid unnecessary run time caused by the restructuring, I recommend explicitly calling \code{restructure} once per model after updating \pkg{brms}. } \details{ If you are restructuring an old spline model (fitted with brms < 2.19.3) to avoid prediction inconsistencies between machines (see GitHub issue #1465), please make sure to \code{restructure} your model on the machine on which it was originally fitted. } brms/man/parnames.Rd0000644000176200001440000000070414160105076014066 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/posterior_samples.R \name{parnames} \alias{parnames} \alias{parnames.brmsfit} \title{Extract Parameter Names} \usage{ parnames(x, ...) } \arguments{ \item{x}{An \R object} \item{...}{Further arguments passed to or from other methods.} } \value{ A character vector containing the parameter names of the model. } \description{ Extract all parameter names of a given model. } brms/man/threading.Rd0000644000176200001440000000514115053072461014230 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/backends.R \name{threading} \alias{threading} \title{Threading in Stan} \usage{ threading(threads = NULL, grainsize = NULL, static = FALSE, force = FALSE) } \arguments{ \item{threads}{Number of threads to use in within-chain parallelization.} \item{grainsize}{Number of observations evaluated together in one chunk on one of the CPUs used for threading. If \code{NULL} (the default), \code{grainsize} is currently chosen as \code{max(100, N / (2 * threads))}, where \code{N} is the number of observations in the data. This default is experimental and may change in the future without prior notice.} \item{static}{Logical. Apply the static (non-adaptive) version of \code{reduce_sum}? Defaults to \code{FALSE}. Setting it to \code{TRUE} is required to achieve exact reproducibility of the model results (if the random seed is set as well).} \item{force}{Logical. Defaults to \code{FALSE}. If \code{TRUE}, this will force the Stan model to compile with threading enabled without altering the Stan code generated by brms. This can be useful if your own custom Stan functions use threading internally.} } \value{ A \code{brmsthreads} object which can be passed to the \code{threads} argument of \code{brm} and related functions. } \description{ Use threads for within-chain parallelization in \pkg{Stan} via the \pkg{brms} interface. Within-chain parallelization is experimental! We recommend its use only if you are experienced with Stan's \code{reduce_sum} function and have a slow running model that cannot be sped up by any other means. } \details{ The adaptive scheduling procedure used by \code{reduce_sum} will prevent the results to be exactly reproducible even if you set the random seed. If you need exact reproducibility, you have to set argument \code{static = TRUE} which may reduce efficiency a bit. To ensure that chunks (whose size is defined by \code{grainsize}) require roughly the same amount of computing time, we recommend storing observations in random order in the data. At least, please avoid sorting observations after the response values. This is because the latter often cause variations in the computing time of the pointwise log-likelihood, which makes up a big part of the parallelized code. } \examples{ \dontrun{ # this model just serves as an illustration # threading may not actually speed things up here fit <- brm(count ~ zAge + zBase * Trt + (1|patient), data = epilepsy, family = negbinomial(), chains = 1, threads = threading(2, grainsize = 100), backend = "cmdstanr") summary(fit) } } brms/man/kfold.brmsfit.Rd0000644000176200001440000002416215057533707015044 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/kfold.R \name{kfold.brmsfit} \alias{kfold.brmsfit} \alias{kfold} \title{K-Fold Cross-Validation} \usage{ \method{kfold}{brmsfit}( x, ..., K = 10, Ksub = NULL, folds = NULL, group = NULL, joint = FALSE, compare = TRUE, resp = NULL, model_names = NULL, save_fits = FALSE, recompile = NULL, future_args = list() ) } \arguments{ \item{x}{A \code{brmsfit} object.} \item{...}{Further arguments passed to \code{\link{brm}} and \code{\link{log_lik}}.} \item{K}{The number of subsets of equal (if possible) size into which the data will be partitioned for performing \eqn{K}-fold cross-validation. The model is refit \code{K} times, each time leaving out one of the \code{K} subsets. If \code{K} is equal to the total number of observations in the data then \eqn{K}-fold cross-validation is equivalent to exact leave-one-out cross-validation.} \item{Ksub}{Optional number of subsets (of those subsets defined by \code{K}) to be evaluated. If \code{NULL} (the default), \eqn{K}-fold cross-validation will be performed on all subsets. If \code{Ksub} is a single integer, \code{Ksub} subsets (out of all \code{K}) subsets will be randomly chosen. If \code{Ksub} consists of multiple integers or a one-dimensional array (created via \code{as.array}) potentially of length one, the corresponding subsets will be used. This argument is primarily useful, if evaluation of all subsets is infeasible for some reason.} \item{folds}{Determines how the subsets are being constructed. Possible values are \code{NULL} (the default), \code{"stratified"}, \code{"grouped"}, or \code{"loo"}. May also be a vector of length equal to the number of observations in the data. Alters the way \code{group} is handled. More information is provided in the 'Details' section.} \item{group}{Optional name of a grouping variable or factor in the model. What exactly is done with this variable depends on argument \code{folds}. More information is provided in the 'Details' section.} \item{joint}{Indicates which observations' log likelihoods shall be considered jointly in the ELPD computation. If \code{"obs"} or \code{FALSE} (the default), each observation is considered separately. This enables comparability of \code{kfold} with \code{loo}. If \code{"fold"} or \code{TRUE}, the joint log likelihoods per fold are used. If \code{"group"}, the joint log likelihoods per group within folds are used (only available if argument \code{group} is specified).} \item{compare}{A flag indicating if the information criteria of the models should be compared to each other via \code{\link{loo_compare}}.} \item{resp}{Optional names of response variables. If specified, predictions are performed only for the specified response variables.} \item{model_names}{If \code{NULL} (the default) will use model names derived from deparsing the call. Otherwise will use the passed values as model names.} \item{save_fits}{If \code{TRUE}, a component \code{fits} is added to the returned object to store the cross-validated \code{brmsfit} objects and the indices of the omitted observations for each fold. Defaults to \code{FALSE}.} \item{recompile}{Logical, indicating whether the Stan model should be recompiled. This may be necessary if you are running \code{reloo} on another machine than the one used to fit the model.} \item{future_args}{A list of further arguments passed to \code{\link[future:future]{future}} for additional control over parallel execution if activated.} } \value{ \code{kfold} returns an object that has a similar structure as the objects returned by the \code{loo} and \code{waic} methods and can be used with the same post-processing functions. } \description{ Perform exact K-fold cross-validation by refitting the model \eqn{K} times each leaving out one-\eqn{K}th of the original data. Folds can be run in parallel using the \pkg{future} package. } \details{ The \code{kfold} function performs exact \eqn{K}-fold cross-validation. First the data are partitioned into \eqn{K} folds (i.e. subsets) of equal (or as close to equal as possible) size by default. Then the model is refit \eqn{K} times, each time leaving out one of the \code{K} subsets. If \eqn{K} is equal to the total number of observations in the data then \eqn{K}-fold cross-validation is equivalent to exact leave-one-out cross-validation (to which \code{loo} is an efficient approximation). The \code{compare_ic} function is also compatible with the objects returned by \code{kfold}. The subsets can be constructed in multiple different ways: \itemize{ \item If both \code{folds} and \code{group} are \code{NULL}, the subsets are randomly chosen so that they have equal (or as close to equal as possible) size. \item If \code{folds} is \code{NULL} but \code{group} is specified, the data is split up into subsets, each time omitting all observations of one of the factor levels, while ignoring argument \code{K}. \item If \code{folds = "stratified"} the subsets are stratified after \code{group} using \code{\link[loo:kfold-helpers]{loo::kfold_split_stratified}}. \item If \code{folds = "grouped"} the subsets are split by \code{group} using \code{\link[loo:kfold-helpers]{loo::kfold_split_grouped}}. \item If \code{folds = "loo"} exact leave-one-out cross-validation will be performed and \code{K} will be ignored. Further, if \code{group} is specified, all observations corresponding to the factor level of the currently predicted single value are omitted. Thus, in this case, the predicted values are only a subset of the omitted ones. \item If \code{folds} is a numeric vector, it must contain one element per observation in the data. Each element of the vector is an integer in \code{1:K} indicating to which of the \code{K} folds the corresponding observation belongs. There are some convenience functions available in the \pkg{loo} package that create integer vectors to use for this purpose (see the Examples section below and also the \link[loo:kfold-helpers]{kfold-helpers} page). } When running \code{kfold} on a \code{brmsfit} created with the \pkg{cmdstanr} backend in a different \R session, several recompilations will be triggered because by default, \pkg{cmdstanr} writes the model executable to a temporary directory. To avoid that, set option \code{"cmdstanr_write_stan_file_dir"} to a nontemporary path of your choice before creating the original \code{brmsfit} (see section 'Examples' below). By default, this method uses \code{sample_new_levels = "gaussian"} to sample parameter values for new grouping-factor levels (see also \code{\link{prepare_predictions}}). This default will fail for models with non-Gaussian group-level effects. In this case, we recommend setting \code{sample_new_levels = "uncertainty"}. } \section{Parallelization with multiple CPU cores}{ \pkg{brms} can make use of multiple CPU cores in parallel to speed up computations in various ways. For efficient use of the available resources it is recommended to only use parallelism to an extend such that the available physical CPUs are not oversubscribed. For example, when you have 8 CPU cores locally available, then you may consider to run 4 chains with 2 threads per chain for best performance if you happen to just run a single model. In case you run a simulation study which requires to run many times a given model, then neither chain nor within-chain parallelization is advisable as the computational resources are already exhausted by the simulation study and any further parallelization beyond the simulation study itself will in fact slow down the overall runtime. Please be aware that for historical reasons the nomenclature of the arguments is possibly confusing. The \code{cores} argument refers to running different chains in parallel and the within-chain parallelization will allocate for each chain as many threads as requested. The requested threads therefore increase the use of overall CPUs in a multiplicative way. For more advanced parallelization (including beyond single model fits), \pkg{brms} also integrates with the \pkg{future} package. Importantly, this enables seamless integration with the \pkg{mirai} parallelization framework through the use of the \pkg{future.mirai} adapter. With \pkg{mirai} local and remote machines can be used in a fully transparent manner to the user. This includes the possibility to use large number of remote machines running in the context of a computer cluster, which are managed with queuing systems. Please refer to the section on distributed computing of \code{\link[mirai:daemons]{mirai::daemons}}. } \examples{ \dontrun{ fit1 <- brm(count ~ zAge + zBase * Trt + (1|patient) + (1|obs), data = epilepsy, family = poisson()) # throws warning about some pareto k estimates being too high (loo1 <- loo(fit1)) # perform 10-fold cross validation (kfold1 <- kfold(fit1, chains = 1)) # use joint likelihoods per fold for ELPD evaluation kfold(fit1, chains = 1, joint = "fold") # use the future package for parallelization of models # that is to fit models belonging to different folds in parallel library(future) plan(multisession, workers = 4) kfold(fit1, chains = 1) plan(sequential) ## to avoid recompilations when running kfold() on a 'cmdstanr'-backend fit ## in a fresh R session, set option 'cmdstanr_write_stan_file_dir' before ## creating the initial 'brmsfit' ## CAUTION: the following code creates some files in the current working ## directory: two 'model_.stan' files, one 'model_(.exe)' ## executable, and one 'fit_cmdstanr_.rds' file set.seed(7) fname <- paste0("fit_cmdstanr_", sample.int(.Machine$integer.max, 1)) options(cmdstanr_write_stan_file_dir = getwd()) fit_cmdstanr <- brm(rate ~ conc + state, data = Puromycin, backend = "cmdstanr", file = fname) # now restart the R session and run the following (after attaching 'brms') set.seed(7) fname <- paste0("fit_cmdstanr_", sample.int(.Machine$integer.max, 1)) fit_cmdstanr <- brm(rate ~ conc + state, data = Puromycin, backend = "cmdstanr", file = fname) kfold_cmdstanr <- kfold(fit_cmdstanr, K = 2) } } \seealso{ \code{\link{loo}}, \code{\link{reloo}} } brms/man/brmsfit_needs_refit.Rd0000644000176200001440000000303414570455232016303 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/brmsfit-helpers.R \name{brmsfit_needs_refit} \alias{brmsfit_needs_refit} \title{Check if cached fit can be used.} \usage{ brmsfit_needs_refit( fit, sdata = NULL, scode = NULL, data = NULL, algorithm = NULL, silent = FALSE, verbose = FALSE ) } \arguments{ \item{fit}{Old \code{brmsfit} object (e.g., loaded from file).} \item{sdata}{New Stan data (result of a call to \code{\link[brms:standata.default]{standata}}). Pass \code{NULL} to avoid this data check.} \item{scode}{New Stan code (result of a call to \code{\link[brms:stancode.default]{stancode}}). Pass \code{NULL} to avoid this code check.} \item{data}{New data to check consistency of factor level names. Pass \code{NULL} to avoid this data check.} \item{algorithm}{New algorithm. Pass \code{NULL} to avoid algorithm check.} \item{silent}{Logical. If \code{TRUE}, no messages will be given.} \item{verbose}{Logical. If \code{TRUE} detailed report of the differences is printed to the console.} } \value{ A boolean indicating whether a refit is needed. } \description{ Checks whether a given cached fit can be used without refitting when \code{file_refit = "on_change"} is used. This function is internal and exposed only to facilitate debugging problems with cached fits. The function may change or be removed in future versions and scripts should not use it. } \details{ Use with \code{verbose = TRUE} to get additional info on how the stored fit differs from the given data and code. } \keyword{internal} brms/man/brmsformula.Rd0000644000176200001440000010364415057506046014630 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/brmsformula.R \name{brmsformula} \alias{brmsformula} \alias{bf} \title{Set up a model formula for use in \pkg{brms}} \usage{ brmsformula( formula, ..., flist = NULL, family = NULL, autocor = NULL, nl = NULL, loop = NULL, center = NULL, cmc = NULL, sparse = NULL, decomp = NULL, unused = NULL ) } \arguments{ \item{formula}{An object of class \code{formula} (or one that can be coerced to that class): a symbolic description of the model to be fitted. The details of model specification are given in 'Details'.} \item{...}{Additional \code{formula} objects to specify predictors of non-linear and distributional parameters. Formulas can either be named directly or contain names on their left-hand side. Alternatively, it is possible to fix parameters to certain values by passing numbers or character strings in which case arguments have to be named to provide the parameter names. See 'Details' for more information.} \item{flist}{Optional list of formulas, which are treated in the same way as formulas passed via the \code{...} argument.} \item{family}{Same argument as in \code{\link{brm}}. If \code{family} is specified in \code{brmsformula}, it will overwrite the value specified in other functions.} \item{autocor}{An optional \code{formula} which contains autocorrelation terms as described in \code{\link{autocor-terms}} or alternatively a \code{\link{cor_brms}} object (deprecated). If \code{autocor} is specified in \code{brmsformula}, it will overwrite the value specified in other functions.} \item{nl}{Logical; Indicates whether \code{formula} should be treated as specifying a non-linear model. By default, \code{formula} is treated as an ordinary linear model formula.} \item{loop}{Logical; Only used in non-linear models. Indicates if the computation of the non-linear formula should be done inside (\code{TRUE}) or outside (\code{FALSE}) a loop over observations. Defaults to \code{TRUE}.} \item{center}{Logical; Indicates if the population-level design matrix should be centered, which usually increases sampling efficiency. See the 'Details' section for more information. Defaults to \code{TRUE} for distributional parameters and to \code{FALSE} for non-linear parameters.} \item{cmc}{Logical; Indicates whether automatic cell-mean coding should be enabled when removing the intercept by adding \code{0} to the right-hand of model formulas. Defaults to \code{TRUE} to mirror the behavior of standard \R formula parsing.} \item{sparse}{Logical; indicates whether the population-level design matrices should be treated as sparse (defaults to \code{FALSE}). For design matrices with many zeros, this can considerably reduce required memory. Sampling speed is currently not improved or even slightly decreased.} \item{decomp}{Optional name of the decomposition used for the population-level design matrix. Defaults to \code{NULL} that is no decomposition. Other options currently available are \code{"QR"} for the QR decomposition that helps in fitting models with highly correlated predictors.} \item{unused}{An optional \code{formula} which contains variables that are unused in the model but should still be stored in the model's data frame. This can be useful, for example, if those variables are required for post-processing the model.} } \value{ An object of class \code{brmsformula}, which is essentially a \code{list} containing all model formulas as well as some additional information. } \description{ Set up a model formula for use in the \pkg{brms} package allowing to define (potentially non-linear) additive multilevel models for all parameters of the assumed response distribution. } \details{ \bold{General formula structure} The \code{formula} argument accepts formulas of the following syntax: \code{response | aterms ~ pterms + (gterms | group)} The \code{pterms} part contains effects that are assumed to be the same across observations. We call them 'population-level' or 'overall' effects, or (adopting frequentist vocabulary) 'fixed' effects. The optional \code{gterms} part may contain effects that are assumed to vary across grouping variables specified in \code{group}. We call them 'group-level' or 'varying' effects, or (adopting frequentist vocabulary) 'random' effects, although the latter name is misleading in a Bayesian context. For more details type \code{vignette("brms_overview")} and \code{vignette("brms_multilevel")}. \bold{Group-level terms} Multiple grouping factors each with multiple group-level effects are possible. (Of course we can also run models without any group-level effects.) Instead of \code{|} you may use \code{||} in grouping terms to prevent correlations from being modeled. Equivalently, the \code{cor} argument of the \code{\link{gr}} function can be used for this purpose, for example, \code{(1 + x || g)} is equivalent to \code{(1 + x | gr(g, cor = FALSE))}. It is also possible to model different group-level terms of the same grouping factor as correlated (even across different formulas, e.g., in non-linear models) by using \code{||} instead of \code{|}. All group-level terms sharing the same ID will be modeled as correlated. If, for instance, one specifies the terms \code{(1+x|i|g)} and \code{(1+z|i|g)} somewhere in the formulas passed to \code{brmsformula}, correlations between the corresponding group-level effects will be estimated. In the above example, \code{i} is not a variable in the data but just a symbol to indicate correlations between multiple group-level terms. Equivalently, the \code{id} argument of the \code{\link{gr}} function can be used as well, for example, \code{(1 + x | gr(g, id = "i"))}. If levels of the grouping factor belong to different sub-populations, it may be reasonable to assume a different covariance matrix for each of the sub-populations. For instance, the variation within the treatment group and within the control group in a randomized control trial might differ. Suppose that \code{y} is the outcome, and \code{x} is the factor indicating the treatment and control group. Then, we could estimate different hyper-parameters of the varying effects (in this case a varying intercept) for treatment and control group via \code{y ~ x + (1 | gr(subject, by = x))}. You can specify multi-membership terms using the \code{\link{mm}} function. For instance, a multi-membership term with two members could be \code{(1 | mm(g1, g2))}, where \code{g1} and \code{g2} specify the first and second member, respectively. Moreover, if a covariate \code{x} varies across the levels of the grouping-factors \code{g1} and \code{g2}, we can save the respective covariate values in the variables \code{x1} and \code{x2} and then model the varying effect as \code{(1 + mmc(x1, x2) | mm(g1, g2))}. \bold{Special predictor terms} Flexible non-linear smooth terms can modeled using the \code{\link{s}} and \code{\link{t2}} functions in the \code{pterms} part of the model formula. This allows to fit generalized additive mixed models (GAMMs) with \pkg{brms}. The implementation is similar to that used in the \pkg{gamm4} package. For more details on this model class see \code{\link[mgcv:gam]{gam}} and \code{\link[mgcv:gamm]{gamm}}. Gaussian process terms can be fitted using the \code{\link{gp}} function in the \code{pterms} part of the model formula. Similar to smooth terms, Gaussian processes can be used to model complex non-linear relationships, for instance temporal or spatial autocorrelation. However, they are computationally demanding and are thus not recommended for very large datasets or approximations need to be used. The \code{pterms} and \code{gterms} parts may contain four non-standard effect types namely monotonic, measurement error, missing value, and category specific effects, which can be specified using terms of the form \code{mo(predictor)}, \code{me(predictor, sd_predictor)}, \code{mi(predictor)}, and \code{cs()}, respectively. Category specific effects can only be estimated in ordinal models and are explained in more detail in the package's main vignette (type \code{vignette("brms_overview")}). The other three effect types are explained in the following. A monotonic predictor must either be integer valued or an ordered factor, which is the first difference to an ordinary continuous predictor. More importantly, predictor categories (or integers) are not assumed to be equidistant with respect to their effect on the response variable. Instead, the distance between adjacent predictor categories (or integers) is estimated from the data and may vary across categories. This is realized by parameterizing as follows: One parameter takes care of the direction and size of the effect similar to an ordinary regression parameter, while an additional parameter vector estimates the normalized distances between consecutive predictor categories. A main application of monotonic effects are ordinal predictors that can this way be modeled without (falsely) treating them as continuous or as unordered categorical predictors. For more details and examples see \code{vignette("brms_monotonic")}. Quite often, predictors are measured and as such naturally contain measurement error. Although most researchers are well aware of this problem, measurement error in predictors is ignored in most regression analyses, possibly because only few packages allow for modeling it. Notably, measurement error can be handled in structural equation models, but many more general regression models (such as those featured by \pkg{brms}) cannot be transferred to the SEM framework. In \pkg{brms}, effects of noise-free predictors can be modeled using the \code{me} (for 'measurement error') function. If, say, \code{y} is the response variable and \code{x} is a measured predictor with known measurement error \code{sdx}, we can simply include it on the right-hand side of the model formula via \code{y ~ me(x, sdx)}. This can easily be extended to more general formulas. If \code{x2} is another measured predictor with corresponding error \code{sdx2} and \code{z} is a predictor without error (e.g., an experimental setting), we can model all main effects and interactions of the three predictors in the well known manner: \code{y ~ me(x, sdx) * me(x2, sdx2) * z}. The \code{me} function is soft deprecated in favor of the more flexible and consistent \code{mi} function (see below). When a variable contains missing values, the corresponding rows will be excluded from the data by default (row-wise exclusion). However, quite often we want to keep these rows and instead estimate the missing values. There are two approaches for this: (a) Impute missing values before the model fitting for instance via multiple imputation (see \code{\link{brm_multiple}} for a way to handle multiple imputed datasets). (b) Impute missing values on the fly during model fitting. The latter approach is explained in the following. Using a variable with missing values as predictors requires two things, First, we need to specify that the predictor contains missings that should to be imputed. If, say, \code{y} is the primary response, \code{x} is a predictor with missings and \code{z} is a predictor without missings, we go for \code{y ~ mi(x) + z}. Second, we need to model \code{x} as an additional response with corresponding predictors and the addition term \code{mi()}. In our example, we could write \code{x | mi() ~ z}. Measurement error may be included via the \code{sdy} argument, say, \code{x | mi(sdy = se) ~ z}. See \code{\link{mi}} for examples with real data. \bold{Autocorrelation terms} Autocorrelation terms can be directly specified inside the \code{pterms} part as well. Details can be found in \code{\link{autocor-terms}}. \bold{Additional response information} Another special of the \pkg{brms} formula syntax is the optional \code{aterms} part, which may contain multiple terms of the form \code{fun()} separated by \code{+} each providing special information on the response variable. \code{fun} can be replaced with either \code{se}, \code{weights}, \code{subset}, \code{cens}, \code{trunc}, \code{trials}, \code{cat}, \code{dec}, \code{rate}, \code{vreal}, or \code{vint}. Their meanings are explained below (see also \code{\link{addition-terms}}). For families \code{gaussian}, \code{student} and \code{skew_normal}, it is possible to specify standard errors of the observations, thus allowing to perform meta-analysis. Suppose that the variable \code{yi} contains the effect sizes from the studies and \code{sei} the corresponding standard errors. Then, fixed and random effects meta-analyses can be conducted using the formulas \code{yi | se(sei) ~ 1} and \code{yi | se(sei) ~ 1 + (1|study)}, respectively, where \code{study} is a variable uniquely identifying every study. If desired, meta-regression can be performed via \code{yi | se(sei) ~ 1 + mod1 + mod2 + (1|study)} or \cr \code{yi | se(sei) ~ 1 + mod1 + mod2 + (1 + mod1 + mod2|study)}, where \code{mod1} and \code{mod2} represent moderator variables. By default, the standard errors replace the parameter \code{sigma}. To model \code{sigma} in addition to the known standard errors, set argument \code{sigma} in function \code{se} to \code{TRUE}, for instance, \code{yi | se(sei, sigma = TRUE) ~ 1}. For all families, weighted regression may be performed using \code{weights} in the \code{aterms} part. Internally, this is implemented by multiplying the log-posterior values of each observation by their corresponding weights. Suppose that variable \code{wei} contains the weights and that \code{yi} is the response variable. Then, formula \code{yi | weights(wei) ~ predictors} implements a weighted regression. For multivariate models, \code{subset} may be used in the \code{aterms} part, to use different subsets of the data in different univariate models. For instance, if \code{sub} is a logical variable and \code{y} is the response of one of the univariate models, we may write \code{y | subset(sub) ~ predictors} so that \code{y} is predicted only for those observations for which \code{sub} evaluates to \code{TRUE}. For log-linear models such as Poisson models, \code{rate} may be used in the \code{aterms} part to specify the denominator of a response that is expressed as a rate. The numerator is given by the actual response variable and has a distribution according to the family as usual. In Poisson models, using \code{rate(denom)} is equivalent to adding \code{offset(log(denom))} to the linear predictor of the main parameter. For negative-binomial models, this equivalence no longer holds and \code{rate(denom)} remains the statistically correct approach. With the exception of categorical and ordinal families, left, right, and interval censoring can be modeled through \code{y | cens(censored) ~ predictors}. The censoring variable (named \code{censored} in this example) should contain the values \code{'left'}, \code{'none'}, \code{'right'}, and \code{'interval'} (or equivalently \code{-1}, \code{0}, \code{1}, and \code{2}) to indicate that the corresponding observation is left censored, not censored, right censored, or interval censored. For interval censored data, a second variable (let's call it \code{y2}) has to be passed to \code{cens}. In this case, the formula has the structure \code{y | cens(censored, y2) ~ predictors}. While the lower bounds are given in \code{y}, the upper bounds are given in \code{y2} for interval censored data. Intervals are assumed to be open on the left and closed on the right: \code{(y, y2]}. With the exception of categorical and ordinal families, the response distribution can be truncated using the \code{trunc} function in the addition part. If the response variable is truncated between, say, 0 and 100, we can specify this via \code{yi | trunc(lb = 0, ub = 100) ~ predictors}. Instead of numbers, variables in the data set can also be passed allowing for varying truncation points across observations. Defining only one of the two arguments in \code{trunc} leads to one-sided truncation. For all continuous families, missing values in the responses can be imputed within Stan by using the addition term \code{mi}. This is mostly useful in combination with \code{mi} predictor terms as explained above under 'Special predictor terms'. For families \code{binomial} and \code{zero_inflated_binomial}, addition should contain a variable indicating the number of trials underlying each observation. In \code{lme4} syntax, we may write for instance \code{cbind(success, n - success)}, which is equivalent to \code{success | trials(n)} in \pkg{brms} syntax. If the number of trials is constant across all observations, say \code{10}, we may also write \code{success | trials(10)}. \bold{Please note that the \code{cbind()} syntax will not work in \pkg{brms} in the expected way because this syntax is reserved for other purposes.} For all ordinal families, \code{aterms} may contain a term \code{thres(number)} to specify the number thresholds (e.g, \code{thres(6)}), which should be equal to the total number of response categories - 1. If not given, the number of thresholds is calculated from the data. If different threshold vectors should be used for different subsets of the data, the \code{gr} argument can be used to provide the grouping variable (e.g, \code{thres(6, gr = item)}, if \code{item} is the grouping variable). In this case, the number of thresholds can also be a variable in the data with different values per group. A deprecated quasi alias of \code{thres()} is \code{cat()} with which the total number of response categories (i.e., number of thresholds + 1) can be specified. In Wiener diffusion models (family \code{wiener}) the addition term \code{dec} is mandatory to specify the (vector of) binary decisions corresponding to the reaction times. Non-zero values will be treated as a response on the upper boundary of the diffusion process and zeros will be treated as a response on the lower boundary. Alternatively, the variable passed to \code{dec} might also be a character vector consisting of \code{'lower'} and \code{'upper'}. All families support the \code{index} addition term to uniquely identify each observation of the corresponding response variable. Currently, \code{index} is primarily useful in combination with the \code{subset} addition and \code{\link{mi}} terms. For custom families, it is possible to pass an arbitrary number of real and integer vectors via the addition terms \code{vreal} and \code{vint}, respectively. An example is provided in \code{vignette('brms_customfamilies')}. To pass multiple vectors of the same data type, provide them separated by commas inside a single \code{vreal} or \code{vint} statement. Multiple addition terms of different types may be specified at the same time using the \code{+} operator. For example, the formula \code{formula = yi | se(sei) + cens(censored) ~ 1} implies a censored meta-analytic model. The addition argument \code{disp} (short for dispersion) has been removed in version 2.0. You may instead use the distributional regression approach by specifying \code{sigma ~ 1 + offset(log(xdisp))} or \code{shape ~ 1 + offset(log(xdisp))}, where \code{xdisp} is the variable being previously passed to \code{disp}. \bold{Parameterization of the population-level intercept} By default, the population-level intercept (if incorporated) is estimated separately and not as part of population-level parameter vector \code{b} As a result, priors on the intercept also have to be specified separately. Furthermore, to increase sampling efficiency, the population-level design matrix \code{X} is centered around its column means \code{X_means} if the intercept is incorporated. This leads to a temporary bias in the intercept equal to \code{}, where \code{<,>} is the scalar product. The bias is corrected after fitting the model, but be aware that you are effectively defining a prior on the intercept of the centered design matrix not on the real intercept. You can turn off this special handling of the intercept by setting argument \code{center} to \code{FALSE}. For more details on setting priors on population-level intercepts, see \code{\link{set_prior}}. This behavior can be avoided by using the reserved (and internally generated) variable \code{Intercept}. Instead of \code{y ~ x}, you may write \code{y ~ 0 + Intercept + x}. This way, priors can be defined on the real intercept, directly. In addition, the intercept is just treated as an ordinary population-level effect and thus priors defined on \code{b} will also apply to it. Note that this parameterization may be less efficient than the default parameterization discussed above. \bold{Formula syntax for non-linear models} In \pkg{brms}, it is possible to specify non-linear models of arbitrary complexity. The non-linear model can just be specified within the \code{formula} argument. Suppose, that we want to predict the response \code{y} through the predictor \code{x}, where \code{x} is linked to \code{y} through \code{y = alpha - beta * lambda^x}, with parameters \code{alpha}, \code{beta}, and \code{lambda}. This is certainly a non-linear model being defined via \code{formula = y ~ alpha - beta * lambda^x} (addition arguments can be added in the same way as for ordinary formulas). To tell \pkg{brms} that this is a non-linear model, we set argument \code{nl} to \code{TRUE}. Now we have to specify a model for each of the non-linear parameters. Let's say we just want to estimate those three parameters with no further covariates or random effects. Then we can pass \code{alpha + beta + lambda ~ 1} or equivalently (and more flexible) \code{alpha ~ 1, beta ~ 1, lambda ~ 1} to the \code{...} argument. This can, of course, be extended. If we have another predictor \code{z} and observations nested within the grouping factor \code{g}, we may write for instance \code{alpha ~ 1, beta ~ 1 + z + (1|g), lambda ~ 1}. The formula syntax described above applies here as well. In this example, we are using \code{z} and \code{g} only for the prediction of \code{beta}, but we might also use them for the other non-linear parameters (provided that the resulting model is still scientifically reasonable). By default, non-linear covariates are treated as real vectors in Stan. However, if the data of the covariates is of type `integer` in \R (which can be enforced by the `as.integer` function), the Stan type will be changed to an integer array. That way, covariates can also be used for indexing purposes in Stan. Non-linear models may not be uniquely identified and / or show bad convergence. For this reason it is mandatory to specify priors on the non-linear parameters. For instructions on how to do that, see \code{\link{set_prior}}. For some examples of non-linear models, see \code{vignette("brms_nonlinear")}. \bold{Formula syntax for predicting distributional parameters} It is also possible to predict parameters of the response distribution such as the residual standard deviation \code{sigma} in gaussian models or the hurdle probability \code{hu} in hurdle models. The syntax closely resembles that of a non-linear parameter, for instance \code{sigma ~ x + s(z) + (1+x|g)}. For some examples of distributional models, see \code{vignette("brms_distreg")}. Parameter \code{mu} exists for every family and can be used as an alternative to specifying terms in \code{formula}. If both \code{mu} and \code{formula} are given, the right-hand side of \code{formula} is ignored. Accordingly, specifying terms on the right-hand side of both \code{formula} and \code{mu} at the same time is deprecated. In future versions, \code{formula} might be updated by \code{mu}. The following are distributional parameters of specific families (all other parameters are treated as non-linear parameters): \code{sigma} (residual standard deviation or scale of the \code{gaussian}, \code{student}, \code{skew_normal}, \code{lognormal} \code{exgaussian}, and \code{asym_laplace} families); \code{shape} (shape parameter of the \code{Gamma}, \code{weibull}, \code{negbinomial}, and related zero-inflated / hurdle families); \code{nu} (degrees of freedom parameter of the \code{student} and \code{frechet} families); \code{phi} (precision parameter of the \code{beta}, \code{zero_inflated_beta}, and \code{xbeta} families); \code{kappa} (precision parameter of the \code{von_mises} family); \code{beta} (mean parameter of the exponential component of the \code{exgaussian} family); \code{quantile} (quantile parameter of the \code{asym_laplace} family); \code{zi} (zero-inflation probability); \code{hu} (hurdle probability); \code{zoi} (zero-one-inflation probability); \code{coi} (conditional one-inflation probability); \code{disc} (discrimination) for ordinal models; \code{bs}, \code{ndt}, and \code{bias} (boundary separation, non-decision time, and initial bias of the \code{wiener} diffusion model). By default, distributional parameters are modeled on the log scale if they can be positive only or on the logit scale if the can only be within the unit interval. Alternatively, one may fix distributional parameters to certain values. However, this is mainly useful when models become too complicated and otherwise have convergence issues. We thus suggest to be generally careful when making use of this option. The \code{quantile} parameter of the \code{asym_laplace} distribution is a good example where it is useful. By fixing \code{quantile}, one can perform quantile regression for the specified quantile. For instance, \code{quantile = 0.25} allows predicting the 25\%-quantile. Furthermore, the \code{bias} parameter in drift-diffusion models, is assumed to be \code{0.5} (i.e. no bias) in many applications. To achieve this, simply write \code{bias = 0.5}. Other possible applications are the Cauchy distribution as a special case of the Student-t distribution with \code{nu = 1}, or the geometric distribution as a special case of the negative binomial distribution with \code{shape = 1}. Furthermore, the parameter \code{disc} ('discrimination') in ordinal models is fixed to \code{1} by default and not estimated, but may be modeled as any other distributional parameter if desired (see examples). For reasons of identification, \code{'disc'} can only be positive, which is achieved by applying the log-link. In categorical models, distributional parameters do not have fixed names. Instead, they are named after the response categories (excluding the first one, which serves as the reference category), with the prefix \code{'mu'}. If, for instance, categories are named \code{cat1}, \code{cat2}, and \code{cat3}, the distributional parameters will be named \code{mucat2} and \code{mucat3}. Some distributional parameters currently supported by \code{brmsformula} have to be positive (a negative standard deviation or precision parameter does not make any sense) or are bounded between 0 and 1 (for zero-inflated / hurdle probabilities, quantiles, or the initial bias parameter of drift-diffusion models). However, linear predictors can be positive or negative, and thus the log link (for positive parameters) or logit link (for probability parameters) are used by default to ensure that distributional parameters are within their valid intervals. This implies that, by default, effects for such distributional parameters are estimated on the log / logit scale and one has to apply the inverse link function to get to the effects on the original scale. Alternatively, it is possible to use the identity link to predict parameters on their original scale, directly. However, this is much more likely to lead to problems in the model fitting, if the parameter actually has a restricted range. See also \code{\link{brmsfamily}} for an overview of valid link functions. \bold{Formula syntax for mixture models} The specification of mixture models closely resembles that of non-mixture models. If not specified otherwise (see below), all mean parameters of the mixture components are predicted using the right-hand side of \code{formula}. All types of predictor terms allowed in non-mixture models are allowed in mixture models as well. Distributional parameters of mixture distributions have the same name as those of the corresponding ordinary distributions, but with a number at the end to indicate the mixture component. For instance, if you use family \code{mixture(gaussian, gaussian)}, the distributional parameters are \code{sigma1} and \code{sigma2}. Distributional parameters of the same class can be fixed to the same value. For the above example, we could write \code{sigma2 = "sigma1"} to make sure that both components have the same residual standard deviation, which is in turn estimated from the data. In addition, there are two types of special distributional parameters. The first are named \code{mu}, that allow for modeling different predictors for the mean parameters of different mixture components. For instance, if you want to predict the mean of the first component using predictor \code{x} and the mean of the second component using predictor \code{z}, you can write \code{mu1 ~ x} as well as \code{mu2 ~ z}. The second are named \code{theta}, which constitute the mixing proportions. If the mixing proportions are fixed to certain values, they are internally normalized to form a probability vector. If one seeks to predict the mixing proportions, all but one of the them has to be predicted, while the remaining one is used as the reference category to identify the model. The so-called 'softmax' transformation is applied on the linear predictor terms to form a probability vector. For more information on mixture models, see the documentation of \code{\link{mixture}}. \bold{Formula syntax for multivariate models} Multivariate models may be specified using \code{mvbind} notation or with help of the \code{\link{mvbf}} function. Suppose that \code{y1} and \code{y2} are response variables and \code{x} is a predictor. Then \code{mvbind(y1, y2) ~ x} specifies a multivariate model. The effects of all terms specified at the RHS of the formula are assumed to vary across response variables. For instance, two parameters will be estimated for \code{x}, one for the effect on \code{y1} and another for the effect on \code{y2}. This is also true for group-level effects. When writing, for instance, \code{mvbind(y1, y2) ~ x + (1+x|g)}, group-level effects will be estimated separately for each response. To model these effects as correlated across responses, use the ID syntax (see above). For the present example, this would look as follows: \code{mvbind(y1, y2) ~ x + (1+x|2|g)}. Of course, you could also use any value other than \code{2} as ID. It is also possible to specify different formulas for different responses. If, for instance, \code{y1} should be predicted by \code{x} and \code{y2} should be predicted by \code{z}, we could write \code{mvbf(y1 ~ x, y2 ~ z)}. Alternatively, multiple \code{brmsformula} objects can be added to specify a joint multivariate model (see 'Examples'). } \examples{ # multilevel model with smoothing terms brmsformula(y ~ x1*x2 + s(z) + (1+x1|1) + (1|g2)) # additionally predict 'sigma' brmsformula(y ~ x1*x2 + s(z) + (1+x1|1) + (1|g2), sigma ~ x1 + (1|g2)) # use the shorter alias 'bf' (formula1 <- brmsformula(y ~ x + (x|g))) (formula2 <- bf(y ~ x + (x|g))) # will be TRUE identical(formula1, formula2) # incorporate censoring bf(y | cens(censor_variable) ~ predictors) # define a simple non-linear model bf(y ~ a1 - a2^x, a1 + a2 ~ 1, nl = TRUE) # predict a1 and a2 differently bf(y ~ a1 - a2^x, a1 ~ 1, a2 ~ x + (x|g), nl = TRUE) # correlated group-level effects across parameters bf(y ~ a1 - a2^x, a1 ~ 1 + (1 |2| g), a2 ~ x + (x |2| g), nl = TRUE) # alternative but equivalent way to specify the above model bf(y ~ a1 - a2^x, a1 ~ 1 + (1 | gr(g, id = 2)), a2 ~ x + (x | gr(g, id = 2)), nl = TRUE) # define a multivariate model bf(mvbind(y1, y2) ~ x * z + (1|g)) # define a zero-inflated model # also predicting the zero-inflation part bf(y ~ x * z + (1+x|ID1|g), zi ~ x + (1|ID1|g)) # specify a predictor as monotonic bf(y ~ mo(x) + more_predictors) # for ordinal models only # specify a predictor as category specific bf(y ~ cs(x) + more_predictors) # add a category specific group-level intercept bf(y ~ cs(x) + (cs(1)|g)) # specify parameter 'disc' bf(y ~ person + item, disc ~ item) # specify variables containing measurement error bf(y ~ me(x, sdx)) # specify predictors on all parameters of the wiener diffusion model # the main formula models the drift rate 'delta' bf(rt | dec(decision) ~ x, bs ~ x, ndt ~ x, bias ~ x) # fix the bias parameter to 0.5 bf(rt | dec(decision) ~ x, bias = 0.5) # specify different predictors for different mixture components mix <- mixture(gaussian, gaussian) bf(y ~ 1, mu1 ~ x, mu2 ~ z, family = mix) # fix both residual standard deviations to the same value bf(y ~ x, sigma2 = "sigma1", family = mix) # use the '+' operator to specify models bf(y ~ 1) + nlf(sigma ~ a * exp(b * x), a ~ x) + lf(b ~ z + (1|g), dpar = "sigma") + gaussian() # specify a multivariate model using the '+' operator bf(y1 ~ x + (1|g)) + gaussian() + cor_ar(~1|g) + bf(y2 ~ z) + poisson() # specify correlated residuals of a gaussian and a poisson model form1 <- bf(y1 ~ 1 + x + (1|c|obs), sigma = 1) + gaussian() form2 <- bf(y2 ~ 1 + x + (1|c|obs)) + poisson() # model missing values in predictors bf(bmi ~ age * mi(chl)) + bf(chl | mi() ~ age) + set_rescor(FALSE) # model sigma as a function of the mean bf(y ~ eta, nl = TRUE) + lf(eta ~ 1 + x) + nlf(sigma ~ tau * sqrt(eta)) + lf(tau ~ 1) } \seealso{ \code{\link{mvbrmsformula}}, \code{\link{brmsformula-helpers}} } brms/man/is.brmsfit_multiple.Rd0000644000176200001440000000054114160105076016252 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/brmsfit-class.R \name{is.brmsfit_multiple} \alias{is.brmsfit_multiple} \title{Checks if argument is a \code{brmsfit_multiple} object} \usage{ is.brmsfit_multiple(x) } \arguments{ \item{x}{An \R object} } \description{ Checks if argument is a \code{brmsfit_multiple} object } brms/man/combine_models.Rd0000644000176200001440000000173014213413565015243 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/brm_multiple.R \name{combine_models} \alias{combine_models} \title{Combine Models fitted with \pkg{brms}} \usage{ combine_models(..., mlist = NULL, check_data = TRUE) } \arguments{ \item{...}{One or more \code{brmsfit} objects.} \item{mlist}{Optional list of one or more \code{brmsfit} objects.} \item{check_data}{Logical; indicates if the data should be checked for being the same across models (defaults to \code{TRUE}). Setting it to \code{FALSE} may be useful for instance when combining models fitted on multiple imputed data sets.} } \value{ A \code{brmsfit} object. } \description{ Combine multiple \code{brmsfit} objects, which fitted the same model. This is usefully for instance when having manually run models in parallel. } \details{ This function just takes the first model and replaces its \code{stanfit} object (slot \code{fit}) by the combined \code{stanfit} objects of all models. } brms/man/waic.brmsfit.Rd0000644000176200001440000000555214213413565014662 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/loo.R \name{waic.brmsfit} \alias{waic.brmsfit} \alias{waic} \alias{WAIC} \alias{WAIC.brmsfit} \title{Widely Applicable Information Criterion (WAIC)} \usage{ \method{waic}{brmsfit}( x, ..., compare = TRUE, resp = NULL, pointwise = FALSE, model_names = NULL ) } \arguments{ \item{x}{A \code{brmsfit} object.} \item{...}{More \code{brmsfit} objects or further arguments passed to the underlying post-processing functions. In particular, see \code{\link{prepare_predictions}} for further supported arguments.} \item{compare}{A flag indicating if the information criteria of the models should be compared to each other via \code{\link{loo_compare}}.} \item{resp}{Optional names of response variables. If specified, predictions are performed only for the specified response variables.} \item{pointwise}{A flag indicating whether to compute the full log-likelihood matrix at once or separately for each observation. The latter approach is usually considerably slower but requires much less working memory. Accordingly, if one runs into memory issues, \code{pointwise = TRUE} is the way to go.} \item{model_names}{If \code{NULL} (the default) will use model names derived from deparsing the call. Otherwise will use the passed values as model names.} } \value{ If just one object is provided, an object of class \code{loo}. If multiple objects are provided, an object of class \code{loolist}. } \description{ Compute the widely applicable information criterion (WAIC) based on the posterior likelihood using the \pkg{loo} package. For more details see \code{\link[loo:waic]{waic}}. } \details{ See \code{\link{loo_compare}} for details on model comparisons. For \code{brmsfit} objects, \code{WAIC} is an alias of \code{waic}. Use method \code{\link[brms:add_criterion]{add_criterion}} to store information criteria in the fitted model object for later usage. } \examples{ \dontrun{ # model with population-level effects only fit1 <- brm(rating ~ treat + period + carry, data = inhaler) (waic1 <- waic(fit1)) # model with an additional varying intercept for subjects fit2 <- brm(rating ~ treat + period + carry + (1|subject), data = inhaler) (waic2 <- waic(fit2)) # compare both models loo_compare(waic1, waic2) } } \references{ Vehtari, A., Gelman, A., & Gabry J. (2016). Practical Bayesian model evaluation using leave-one-out cross-validation and WAIC. In Statistics and Computing, doi:10.1007/s11222-016-9696-4. arXiv preprint arXiv:1507.04544. Gelman, A., Hwang, J., & Vehtari, A. (2014). Understanding predictive information criteria for Bayesian models. Statistics and Computing, 24, 997-1016. Watanabe, S. (2010). Asymptotic equivalence of Bayes cross validation and widely applicable information criterion in singular learning theory. The Journal of Machine Learning Research, 11, 3571-3594. } brms/man/theme_black.Rd0000644000176200001440000000231414213413565014521 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/ggplot-themes.R \name{theme_black} \alias{theme_black} \title{(Deprecated) Black Theme for \pkg{ggplot2} Graphics} \usage{ theme_black(base_size = 12, base_family = "") } \arguments{ \item{base_size}{base font size} \item{base_family}{base font family} } \value{ A \code{theme} object used in \pkg{ggplot2} graphics. } \description{ A black theme for ggplot graphics inspired by a blog post of Jon Lefcheck (\url{https://jonlefcheck.net/2013/03/11/black-theme-for-ggplot2-2/}). } \details{ When using \code{theme_black} in plots powered by the \pkg{bayesplot} package such as \code{pp_check} or \code{stanplot}, I recommend using the \code{"viridisC"} color scheme (see examples). } \examples{ \dontrun{ # change default ggplot theme ggplot2::theme_set(theme_black()) # change default bayesplot color scheme bayesplot::color_scheme_set("viridisC") # fit a simple model fit <- brm(count ~ zAge + zBase * Trt + (1|patient), data = epilepsy, family = poisson(), chains = 2) summary(fit) # create various plots plot(marginal_effects(fit), ask = FALSE) pp_check(fit) mcmc_plot(fit, type = "hex", variable = c("b_Intercept", "b_Trt1")) } } brms/man/update.brmsfit.Rd0000644000176200001440000000606214264526224015221 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/update.R \name{update.brmsfit} \alias{update.brmsfit} \title{Update \pkg{brms} models} \usage{ \method{update}{brmsfit}(object, formula., newdata = NULL, recompile = NULL, ...) } \arguments{ \item{object}{An object of class \code{brmsfit}.} \item{formula.}{Changes to the formula; for details see \code{\link{update.formula}} and \code{\link{brmsformula}}.} \item{newdata}{Optional \code{data.frame} to update the model with new data. Data-dependent default priors will not be updated automatically.} \item{recompile}{Logical, indicating whether the Stan model should be recompiled. If \code{NULL} (the default), \code{update} tries to figure out internally, if recompilation is necessary. Setting it to \code{FALSE} will cause all Stan code changing arguments to be ignored.} \item{...}{Other arguments passed to \code{\link{brm}}.} } \description{ This method allows to update an existing \code{brmsfit} object. } \details{ When updating a \code{brmsfit} created with the \pkg{cmdstanr} backend in a different \R session, a recompilation will be triggered because by default, \pkg{cmdstanr} writes the model executable to a temporary directory. To avoid that, set option \code{"cmdstanr_write_stan_file_dir"} to a nontemporary path of your choice before creating the original \code{brmsfit} (see section 'Examples' below). } \examples{ \dontrun{ fit1 <- brm(time | cens(censored) ~ age * sex + disease + (1|patient), data = kidney, family = gaussian("log")) summary(fit1) ## remove effects of 'disease' fit2 <- update(fit1, formula. = ~ . - disease) summary(fit2) ## remove the group specific term of 'patient' and ## change the data (just take a subset in this example) fit3 <- update(fit1, formula. = ~ . - (1|patient), newdata = kidney[1:38, ]) summary(fit3) ## use another family and add population-level priors fit4 <- update(fit1, family = weibull(), init = "0", prior = set_prior("normal(0,5)")) summary(fit4) ## to avoid a recompilation when updating a 'cmdstanr'-backend fit in a fresh ## R session, set option 'cmdstanr_write_stan_file_dir' before creating the ## initial 'brmsfit' ## CAUTION: the following code creates some files in the current working ## directory: two 'model_.stan' files, one 'model_(.exe)' ## executable, and one 'fit_cmdstanr_.rds' file set.seed(7) fname <- paste0("fit_cmdstanr_", sample.int(.Machine$integer.max, 1)) options(cmdstanr_write_stan_file_dir = getwd()) fit_cmdstanr <- brm(rate ~ conc + state, data = Puromycin, backend = "cmdstanr", file = fname) # now restart the R session and run the following (after attaching 'brms') set.seed(7) fname <- paste0("fit_cmdstanr_", sample.int(.Machine$integer.max, 1)) fit_cmdstanr <- brm(rate ~ conc + state, data = Puromycin, backend = "cmdstanr", file = fname) upd_cmdstanr <- update(fit_cmdstanr, formula. = rate ~ conc) } } brms/man/posterior_epred.brmsfit.Rd0000644000176200001440000001017015053072461017133 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/posterior_epred.R \name{posterior_epred.brmsfit} \alias{posterior_epred.brmsfit} \alias{pp_expect} \alias{posterior_epred} \title{Draws from the Expected Value of the Posterior Predictive Distribution} \usage{ \method{posterior_epred}{brmsfit}( object, newdata = NULL, re_formula = NULL, re.form = NULL, resp = NULL, dpar = NULL, nlpar = NULL, ndraws = NULL, draw_ids = NULL, sort = FALSE, ... ) } \arguments{ \item{object}{An object of class \code{brmsfit}.} \item{newdata}{An optional data.frame for which to evaluate predictions. If \code{NULL} (default), the original data of the model is used. \code{NA} values within factors (excluding grouping variables) are interpreted as if all dummy variables of this factor are zero. This allows, for instance, to make predictions of the grand mean when using sum coding. \code{NA} values within grouping variables are treated as a new level.} \item{re_formula}{formula containing group-level effects to be considered in the prediction. If \code{NULL} (default), include all group-level effects; if \code{NA} or \code{~0}, include no group-level effects.} \item{re.form}{Alias of \code{re_formula}.} \item{resp}{Optional names of response variables. If specified, predictions are performed only for the specified response variables.} \item{dpar}{Optional name of a predicted distributional parameter. If specified, expected predictions of this parameters are returned.} \item{nlpar}{Optional name of a predicted non-linear parameter. If specified, expected predictions of this parameters are returned.} \item{ndraws}{Positive integer indicating how many posterior draws should be used. If \code{NULL} (the default) all draws are used. Ignored if \code{draw_ids} is not \code{NULL}.} \item{draw_ids}{An integer vector specifying the posterior draws to be used. If \code{NULL} (the default), all draws are used.} \item{sort}{Logical. Only relevant for time series models. Indicating whether to return predicted values in the original order (\code{FALSE}; default) or in the order of the time series (\code{TRUE}).} \item{...}{Further arguments passed to \code{\link{prepare_predictions}} that control several aspects of data validation and prediction.} } \value{ An \code{array} of draws. For categorical and ordinal models, the output is an S x N x C array. Otherwise, the output is an S x N matrix, where S is the number of posterior draws, N is the number of observations, and C is the number of categories. In multivariate models, an additional dimension is added to the output which indexes along the different response variables. } \description{ Compute posterior draws of the expected value of the posterior predictive distribution. Can be performed for the data used to fit the model (posterior predictive checks) or for new data. By definition, these predictions have smaller variance than the posterior predictions performed by the \code{\link{posterior_predict.brmsfit}} method. This is because only the uncertainty in the expected value of the posterior predictive distribution is incorporated in the draws computed by \code{posterior_epred} while the residual error is ignored there. However, the estimated means of both methods averaged across draws should be very similar. } \details{ \code{NA} values within factors in \code{newdata}, are interpreted as if all dummy variables of this factor are zero. This allows, for instance, to make predictions of the grand mean when using sum coding. In multilevel models, it is possible to allow new levels of grouping factors to be used in the predictions. This can be controlled via argument \code{allow_new_levels}. New levels can be sampled in multiple ways, which can be controlled via argument \code{sample_new_levels}. Both of these arguments are documented in \code{\link{prepare_predictions}} along with several other useful arguments to control specific aspects of the predictions. } \examples{ \dontrun{ ## fit a model fit <- brm(rating ~ treat + period + carry + (1|subject), data = inhaler) ## compute expected predictions ppe <- posterior_epred(fit) str(ppe) } } brms/man/Hurdle.Rd0000644000176200001440000000320214275473342013512 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/distributions.R \name{Hurdle} \alias{Hurdle} \alias{dhurdle_poisson} \alias{phurdle_poisson} \alias{dhurdle_negbinomial} \alias{phurdle_negbinomial} \alias{dhurdle_gamma} \alias{phurdle_gamma} \alias{dhurdle_lognormal} \alias{phurdle_lognormal} \title{Hurdle Distributions} \usage{ dhurdle_poisson(x, lambda, hu, log = FALSE) phurdle_poisson(q, lambda, hu, lower.tail = TRUE, log.p = FALSE) dhurdle_negbinomial(x, mu, shape, hu, log = FALSE) phurdle_negbinomial(q, mu, shape, hu, lower.tail = TRUE, log.p = FALSE) dhurdle_gamma(x, shape, scale, hu, log = FALSE) phurdle_gamma(q, shape, scale, hu, lower.tail = TRUE, log.p = FALSE) dhurdle_lognormal(x, mu, sigma, hu, log = FALSE) phurdle_lognormal(q, mu, sigma, hu, lower.tail = TRUE, log.p = FALSE) } \arguments{ \item{x}{Vector of quantiles.} \item{hu}{hurdle probability} \item{log}{Logical; If \code{TRUE}, values are returned on the log scale.} \item{q}{Vector of quantiles.} \item{lower.tail}{Logical; If \code{TRUE} (default), return P(X <= x). Else, return P(X > x) .} \item{log.p}{Logical; If \code{TRUE}, values are returned on the log scale.} \item{mu, lambda}{location parameter} \item{shape}{shape parameter} \item{sigma, scale}{scale parameter} } \description{ Density and distribution functions for hurdle distributions. } \details{ The density of a hurdle distribution can be specified as follows. If \eqn{x = 0} set \eqn{f(x) = \theta}. Else set \eqn{f(x) = (1 - \theta) * g(x) / (1 - G(0))} where \eqn{g(x)} and \eqn{G(x)} are the density and distribution function of the non-hurdle part, respectively. } brms/man/ExGaussian.Rd0000644000176200001440000000243014275436221014333 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/distributions.R \name{ExGaussian} \alias{ExGaussian} \alias{dexgaussian} \alias{pexgaussian} \alias{rexgaussian} \title{The Exponentially Modified Gaussian Distribution} \usage{ dexgaussian(x, mu, sigma, beta, log = FALSE) pexgaussian(q, mu, sigma, beta, lower.tail = TRUE, log.p = FALSE) rexgaussian(n, mu, sigma, beta) } \arguments{ \item{x, q}{Vector of quantiles.} \item{mu}{Vector of means of the combined distribution.} \item{sigma}{Vector of standard deviations of the gaussian component.} \item{beta}{Vector of scales of the exponential component.} \item{log}{Logical; If \code{TRUE}, values are returned on the log scale.} \item{lower.tail}{Logical; If \code{TRUE} (default), return P(X <= x). Else, return P(X > x) .} \item{log.p}{Logical; If \code{TRUE}, values are returned on the log scale.} \item{n}{Number of draws to sample from the distribution.} } \description{ Density, distribution function, and random generation for the exponentially modified Gaussian distribution with mean \code{mu} and standard deviation \code{sigma} of the gaussian component, as well as scale \code{beta} of the exponential component. } \details{ See \code{vignette("brms_families")} for details on the parameterization. } brms/man/ma.Rd0000644000176200001440000000325514361545260012667 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/formula-ac.R \name{ma} \alias{ma} \title{Set up MA(q) correlation structures} \usage{ ma(time = NA, gr = NA, q = 1, cov = FALSE) } \arguments{ \item{time}{An optional time variable specifying the time ordering of the observations. By default, the existing order of the observations in the data is used.} \item{gr}{An optional grouping variable. If specified, the correlation structure is assumed to apply only to observations within the same grouping level.} \item{q}{A non-negative integer specifying the moving average (MA) order of the ARMA structure. Default is \code{1}.} \item{cov}{A flag indicating whether ARMA effects should be estimated by means of residual covariance matrices. This is currently only possible for stationary ARMA effects of order 1. If the model family does not have natural residuals, latent residuals are added automatically. If \code{FALSE} (the default), a regression formulation is used that is considerably faster and allows for ARMA effects of order higher than 1 but is only available for \code{gaussian} models and some of its generalizations.} } \value{ An object of class \code{'arma_term'}, which is a list of arguments to be interpreted by the formula parsing functions of \pkg{brms}. } \description{ Set up a moving average (MA) term of order q in \pkg{brms}. The function does not evaluate its arguments -- it exists purely to help set up a model with MA terms. } \examples{ \dontrun{ data("LakeHuron") LakeHuron <- as.data.frame(LakeHuron) fit <- brm(x ~ ma(p = 2), data = LakeHuron) summary(fit) } } \seealso{ \code{\link{autocor-terms}}, \code{\link{arma}}, \code{\link{ar}} } brms/man/add_rstan_model.Rd0000644000176200001440000000145214213413565015404 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/brmsfit-helpers.R \name{add_rstan_model} \alias{add_rstan_model} \title{Add compiled \pkg{rstan} models to \code{brmsfit} objects} \usage{ add_rstan_model(x, overwrite = FALSE) } \arguments{ \item{x}{A \code{brmsfit} object to be updated.} \item{overwrite}{Logical. If \code{TRUE}, overwrite any existing \code{\link[rstan:stanmodel-class]{stanmodel}}. Defaults to \code{FALSE}.} } \value{ A (possibly updated) \code{brmsfit} object. } \description{ Compile a \code{\link[rstan:stanmodel-class]{stanmodel}} and add it to a \code{brmsfit} object. This enables some advanced functionality of \pkg{rstan}, most notably \code{\link[rstan:log_prob]{log_prob}} and friends, to be used with brms models fitted with other Stan backends. } brms/man/cor_arr.Rd0000644000176200001440000000162514160105076013712 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/autocor.R \name{cor_arr} \alias{cor_arr} \title{(Defunct) ARR correlation structure} \usage{ cor_arr(formula = ~1, r = 1) } \arguments{ \item{formula}{A one sided formula of the form \code{~ t}, or \code{~ t | g}, specifying a time covariate \code{t} and, optionally, a grouping factor \code{g}. A covariate for this correlation structure must be integer valued. When a grouping factor is present in \code{formula}, the correlation structure is assumed to apply only to observations within the same grouping level; observations with different grouping levels are assumed to be uncorrelated. Defaults to \code{~ 1}, which corresponds to using the order of the observations in the data as a covariate, and no groups.} \item{r}{No longer supported.} } \description{ The ARR correlation structure is no longer supported. } \keyword{internal} brms/man/is.brmsterms.Rd0000644000176200001440000000055614160105076014715 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/brmsterms.R \name{is.brmsterms} \alias{is.brmsterms} \title{Checks if argument is a \code{brmsterms} object} \usage{ is.brmsterms(x) } \arguments{ \item{x}{An \R object} } \description{ Checks if argument is a \code{brmsterms} object } \seealso{ \code{\link[brms:brmsterms]{brmsterms}} } brms/man/is.mvbrmsterms.Rd0000644000176200001440000000057014160105076015254 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/brmsterms.R \name{is.mvbrmsterms} \alias{is.mvbrmsterms} \title{Checks if argument is a \code{mvbrmsterms} object} \usage{ is.mvbrmsterms(x) } \arguments{ \item{x}{An \R object} } \description{ Checks if argument is a \code{mvbrmsterms} object } \seealso{ \code{\link[brms:brmsterms]{brmsterms}} } brms/man/standata.Rd0000644000176200001440000000254614572632206014074 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/standata.R \name{standata} \alias{standata} \alias{make_standata} \title{Stan data for Bayesian models} \usage{ standata(object, ...) make_standata(formula, ...) } \arguments{ \item{object}{A formula object whose class will determine which method will be used. A symbolic description of the model to be fitted.} \item{...}{Further arguments passed to the specific method.} \item{formula}{Synonym of \code{object} for use in \code{make_standata}.} } \value{ A named list of objects containing the required data to fit a Bayesian model with \pkg{Stan}. } \description{ \code{standata} is a generic function that can be used to generate data for Bayesian models to be passed to Stan. Its original use is within the \pkg{brms} package, but new methods for use with objects from other packages can be registered to the same generic. } \details{ See \code{\link{standata.default}} for the default method applied for \pkg{brms} models. You can view the available methods by typing \code{methods(standata)}. The \code{make_standata} function is an alias of \code{standata}. } \examples{ sdata1 <- standata(rating ~ treat + period + carry + (1|subject), data = inhaler, family = "cumulative") str(sdata1) } \seealso{ \code{\link{standata.default}}, \code{\link{standata.brmsfit}} } brms/man/inhaler.Rd0000644000176200001440000000317214213413565013710 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/datasets.R \docType{data} \name{inhaler} \alias{inhaler} \title{Clarity of inhaler instructions} \format{ A data frame of 572 observations containing information on the following 5 variables. \describe{ \item{subject}{The subject number} \item{rating}{The rating of the inhaler instructions on a scale ranging from 1 to 4} \item{treat}{A contrast to indicate which of the two inhaler devices was used} \item{period}{A contrast to indicate the time of administration} \item{carry}{A contrast to indicate possible carry over effects} } } \source{ Ezzet, F., & Whitehead, J. (1991). A random effects model for ordinal responses from a crossover trial. \emph{Statistics in Medicine}, 10(6), 901-907. } \usage{ inhaler } \description{ Ezzet and Whitehead (1991) analyze data from a two-treatment, two-period crossover trial to compare 2 inhalation devices for delivering the drug salbutamol in 286 asthma patients. Patients were asked to rate the clarity of leaflet instructions accompanying each device, using a 4-point ordinal scale. } \examples{ \dontrun{ ## ordinal regression with family "sratio" fit1 <- brm(rating ~ treat + period + carry, data = inhaler, family = sratio(), prior = set_prior("normal(0,5)")) summary(fit1) plot(fit1) ## ordinal regression with family "cumulative" ## and random intercept over subjects fit2 <- brm(rating ~ treat + period + carry + (1|subject), data = inhaler, family = cumulative(), prior = set_prior("normal(0,5)")) summary(fit2) plot(fit2) } } \keyword{datasets} brms/man/kfold_predict.Rd0000644000176200001440000000342414572541241015100 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/kfold.R \name{kfold_predict} \alias{kfold_predict} \title{Predictions from K-Fold Cross-Validation} \usage{ kfold_predict(x, method = "posterior_predict", resp = NULL, ...) } \arguments{ \item{x}{Object of class \code{'kfold'} computed by \code{\link{kfold}}. For \code{kfold_predict} to work, the fitted model objects need to have been stored via argument \code{save_fits} of \code{\link{kfold}}.} \item{method}{Method used to obtain predictions. Can be set to \code{"posterior_predict"} (the default), \code{"posterior_epred"}, or \code{"posterior_linpred"}. For more details, see the respective function documentations.} \item{resp}{Optional names of response variables. If specified, predictions are performed only for the specified response variables.} \item{...}{Further arguments passed to \code{\link{prepare_predictions}} that control several aspects of data validation and prediction.} } \value{ A \code{list} with two slots named \code{'y'} and \code{'yrep'}. Slot \code{y} contains the vector of observed responses. Slot \code{yrep} contains the matrix of predicted responses, with rows being posterior draws and columns being observations. } \description{ Compute and evaluate predictions after performing K-fold cross-validation via \code{\link{kfold}}. } \examples{ \dontrun{ fit <- brm(count ~ zBase * Trt + (1|patient), data = epilepsy, family = poisson()) # perform k-fold cross validation (kf <- kfold(fit, save_fits = TRUE, chains = 1)) # define a loss function rmse <- function(y, yrep) { yrep_mean <- colMeans(yrep) sqrt(mean((yrep_mean - y)^2)) } # predict responses and evaluate the loss kfp <- kfold_predict(kf) rmse(y = kfp$y, yrep = kfp$yrep) } } \seealso{ \code{\link{kfold}} } brms/man/Dirichlet.Rd0000644000176200001440000000146214275436221014177 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/distributions.R \name{Dirichlet} \alias{Dirichlet} \alias{ddirichlet} \alias{rdirichlet} \title{The Dirichlet Distribution} \usage{ ddirichlet(x, alpha, log = FALSE) rdirichlet(n, alpha) } \arguments{ \item{x}{Matrix of quantiles. Each row corresponds to one probability vector.} \item{alpha}{Matrix of positive shape parameters. Each row corresponds to one probability vector.} \item{log}{Logical; If \code{TRUE}, values are returned on the log scale.} \item{n}{Number of draws to sample from the distribution.} } \description{ Density function and random number generation for the dirichlet distribution with shape parameter vector \code{alpha}. } \details{ See \code{vignette("brms_families")} for details on the parameterization. } brms/man/mixture.Rd0000644000176200001440000000673214570412174013771 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/families.R \name{mixture} \alias{mixture} \title{Finite Mixture Families in \pkg{brms}} \usage{ mixture(..., flist = NULL, nmix = 1, order = NULL) } \arguments{ \item{...}{One or more objects providing a description of the response distributions to be combined in the mixture model. These can be family functions, calls to family functions or character strings naming the families. For details of supported families see \code{\link{brmsfamily}}.} \item{flist}{Optional list of objects, which are treated in the same way as objects passed via the \code{...} argument.} \item{nmix}{Optional numeric vector specifying the number of times each family is repeated. If specified, it must have the same length as the number of families passed via \code{...} and \code{flist}.} \item{order}{Ordering constraint to identify mixture components. If \code{'mu'} or \code{TRUE}, population-level intercepts of the mean parameters are ordered in non-ordinal models and fixed to the same value in ordinal models (see details). If \code{'none'} or \code{FALSE}, no ordering constraint is applied. If \code{NULL} (the default), \code{order} is set to \code{'mu'} if all families are the same and \code{'none'} otherwise. Other ordering constraints may be implemented in the future.} } \value{ An object of class \code{mixfamily}. } \description{ Set up a finite mixture family for use in \pkg{brms}. } \details{ Most families supported by \pkg{brms} can be used to form mixtures. The response variable has to be valid for all components of the mixture family. Currently, the number of mixture components has to be specified by the user. It is not yet possible to estimate the number of mixture components from the data. Ordering intercepts in mixtures of ordinal families is not possible as each family has itself a set of vector of intercepts (i.e. ordinal thresholds). Instead, \pkg{brms} will fix the vector of intercepts across components in ordinal mixtures, if desired, so that users can try to identify the mixture model via selective inclusion of predictors. For most mixture models, you may want to specify priors on the population-level intercepts via \code{\link{set_prior}} to improve convergence. In addition, it is sometimes necessary to set \code{init = 0} in the call to \code{\link{brm}} to allow chains to initialize properly. For more details on the specification of mixture models, see \code{\link{brmsformula}}. } \examples{ \dontrun{ ## simulate some data set.seed(1234) dat <- data.frame( y = c(rnorm(200), rnorm(100, 6)), x = rnorm(300), z = sample(0:1, 300, TRUE) ) ## fit a simple normal mixture model mix <- mixture(gaussian, gaussian) prior <- c( prior(normal(0, 7), Intercept, dpar = mu1), prior(normal(5, 7), Intercept, dpar = mu2) ) fit1 <- brm(bf(y ~ x + z), dat, family = mix, prior = prior, chains = 2) summary(fit1) pp_check(fit1) ## use different predictors for the components fit2 <- brm(bf(y ~ 1, mu1 ~ x, mu2 ~ z), dat, family = mix, prior = prior, chains = 2) summary(fit2) ## fix the mixing proportions fit3 <- brm(bf(y ~ x + z, theta1 = 1, theta2 = 2), dat, family = mix, prior = prior, init = 0, chains = 2) summary(fit3) pp_check(fit3) ## predict the mixing proportions fit4 <- brm(bf(y ~ x + z, theta2 ~ x), dat, family = mix, prior = prior, init = 0, chains = 2) summary(fit4) pp_check(fit4) ## compare model fit loo(fit1, fit2, fit3, fit4) } } brms/man/residuals.brmsfit.Rd0000644000176200001440000000744415053072461015733 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/predictive_error.R \name{residuals.brmsfit} \alias{residuals.brmsfit} \title{Posterior Draws of Residuals/Predictive Errors} \usage{ \method{residuals}{brmsfit}( object, newdata = NULL, re_formula = NULL, method = "posterior_predict", type = c("ordinary", "pearson"), resp = NULL, ndraws = NULL, draw_ids = NULL, sort = FALSE, summary = TRUE, robust = FALSE, probs = c(0.025, 0.975), ... ) } \arguments{ \item{object}{An object of class \code{brmsfit}.} \item{newdata}{An optional data.frame for which to evaluate predictions. If \code{NULL} (default), the original data of the model is used. \code{NA} values within factors (excluding grouping variables) are interpreted as if all dummy variables of this factor are zero. This allows, for instance, to make predictions of the grand mean when using sum coding. \code{NA} values within grouping variables are treated as a new level.} \item{re_formula}{formula containing group-level effects to be considered in the prediction. If \code{NULL} (default), include all group-level effects; if \code{NA} or \code{~0}, include no group-level effects.} \item{method}{Method used to obtain predictions. Can be set to \code{"posterior_predict"} (the default), \code{"posterior_epred"}, or \code{"posterior_linpred"}. For more details, see the respective function documentations.} \item{type}{The type of the residuals, either \code{"ordinary"} or \code{"pearson"}. More information is provided under 'Details'.} \item{resp}{Optional names of response variables. If specified, predictions are performed only for the specified response variables.} \item{ndraws}{Positive integer indicating how many posterior draws should be used. If \code{NULL} (the default) all draws are used. Ignored if \code{draw_ids} is not \code{NULL}.} \item{draw_ids}{An integer vector specifying the posterior draws to be used. If \code{NULL} (the default), all draws are used.} \item{sort}{Logical. Only relevant for time series models. Indicating whether to return predicted values in the original order (\code{FALSE}; default) or in the order of the time series (\code{TRUE}).} \item{summary}{Should summary statistics be returned instead of the raw values? Default is \code{TRUE}..} \item{robust}{If \code{FALSE} (the default) the mean is used as the measure of central tendency and the standard deviation as the measure of variability. If \code{TRUE}, the median and the median absolute deviation (MAD) are applied instead. Only used if \code{summary} is \code{TRUE}.} \item{probs}{The percentiles to be computed by the \code{quantile} function. Only used if \code{summary} is \code{TRUE}.} \item{...}{Further arguments passed to \code{\link{prepare_predictions}} that control several aspects of data validation and prediction.} } \value{ An \code{array} of predictive error/residual draws. If \code{summary = FALSE} the output resembles those of \code{\link{predictive_error.brmsfit}}. If \code{summary = TRUE} the output is an N x E matrix, where N is the number of observations and E denotes the summary statistics computed from the draws. } \description{ This method is an alias of \code{\link{predictive_error.brmsfit}} with additional arguments for obtaining summaries of the computed draws. } \details{ Residuals of type \code{'ordinary'} are of the form \eqn{R = Y - Yrep}, where \eqn{Y} is the observed and \eqn{Yrep} is the predicted response. Residuals of type \code{pearson} are of the form \eqn{R = (Y - Yrep) / SD(Yrep)}, where \eqn{SD(Yrep)} is an estimate of the standard deviation of \eqn{Yrep}. } \examples{ \dontrun{ ## fit a model fit <- brm(rating ~ treat + period + carry + (1|subject), data = inhaler, cores = 2) ## extract residuals/predictive errors res <- residuals(fit) head(res) } } brms/man/prior_draws.brmsfit.Rd0000644000176200001440000000354514213413565016272 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/prior_draws.R \name{prior_draws.brmsfit} \alias{prior_draws.brmsfit} \alias{prior_samples} \alias{prior_draws} \title{Extract Prior Draws} \usage{ \method{prior_draws}{brmsfit}(x, variable = NULL, pars = NULL, ...) prior_draws(x, ...) prior_samples(x, ...) } \arguments{ \item{x}{An \code{R} object typically of class \code{brmsfit}.} \item{variable}{A character vector providing the variables to extract. By default, all variables are extracted.} \item{pars}{Deprecated alias of \code{variable}. For reasons of backwards compatibility, \code{pars} is interpreted as a vector of regular expressions by default unless \code{fixed = TRUE} is specified.} \item{...}{Arguments passed to individual methods (if applicable).} } \value{ A \code{data.frame} containing the prior draws. } \description{ Extract prior draws of specified parameters } \details{ To make use of this function, the model must contain draws of prior distributions. This can be ensured by setting \code{sample_prior = TRUE} in function \code{brm}. Priors of certain parameters cannot be saved for technical reasons. For instance, this is the case for the population-level intercept, which is only computed after fitting the model by default. If you want to treat the intercept as part of all the other regression coefficients, so that sampling from its prior becomes possible, use \code{... ~ 0 + Intercept + ...} in the formulas. } \examples{ \dontrun{ fit <- brm(rating ~ treat + period + carry + (1|subject), data = inhaler, family = "cumulative", prior = set_prior("normal(0,2)", class = "b"), sample_prior = TRUE) # extract all prior draws draws1 <- prior_draws(fit) head(draws1) # extract prior draws for the coefficient of 'treat' draws2 <- prior_draws(fit, "b_treat") head(draws2) } } brms/man/sar.Rd0000644000176200001440000000350214213413565013050 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/formula-ac.R \name{sar} \alias{sar} \title{Spatial simultaneous autoregressive (SAR) structures} \usage{ sar(M, type = "lag") } \arguments{ \item{M}{An object specifying the spatial weighting matrix. Can be either the spatial weight matrix itself or an object of class \code{listw} or \code{nb}, from which the spatial weighting matrix can be computed.} \item{type}{Type of the SAR structure. Either \code{"lag"} (for SAR of the response values) or \code{"error"} (for SAR of the residuals). More information is provided in the 'Details' section.} } \value{ An object of class \code{'sar_term'}, which is a list of arguments to be interpreted by the formula parsing functions of \pkg{brms}. } \description{ Set up an spatial simultaneous autoregressive (SAR) term in \pkg{brms}. The function does not evaluate its arguments -- it exists purely to help set up a model with SAR terms. } \details{ The \code{lagsar} structure implements SAR of the response values: \deqn{y = \rho W y + \eta + e} The \code{errorsar} structure implements SAR of the residuals: \deqn{y = \eta + u, u = \rho W u + e} In the above equations, \eqn{\eta} is the predictor term and \eqn{e} are independent normally or t-distributed residuals. Currently, only families \code{gaussian} and \code{student} support SAR structures. } \examples{ \dontrun{ data(oldcol, package = "spdep") fit1 <- brm(CRIME ~ INC + HOVAL + sar(COL.nb, type = "lag"), data = COL.OLD, data2 = list(COL.nb = COL.nb), chains = 2, cores = 2) summary(fit1) plot(fit1) fit2 <- brm(CRIME ~ INC + HOVAL + sar(COL.nb, type = "error"), data = COL.OLD, data2 = list(COL.nb = COL.nb), chains = 2, cores = 2) summary(fit2) plot(fit2) } } \seealso{ \code{\link{autocor-terms}} } brms/man/recompile_model.Rd0000644000176200001440000000153114136566260015427 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/backends.R \name{recompile_model} \alias{recompile_model} \title{Recompile Stan models in \code{brmsfit} objects} \usage{ recompile_model(x, recompile = NULL) } \arguments{ \item{x}{An object of class \code{brmsfit}.} \item{recompile}{Logical, indicating whether the Stan model should be recompiled. If \code{NULL} (the default), \code{recompile_model} tries to figure out internally, if recompilation is necessary. Setting it to \code{FALSE} will cause \code{recompile_model} to always return the \code{brmsfit} object unchanged.} } \value{ A (possibly updated) \code{brmsfit} object. } \description{ Recompile the Stan model inside a \code{brmsfit} object, if necessary. This does not change the model, it simply recreates the executable so that sampling is possible again. } brms/man/Frechet.Rd0000644000176200001440000000235414275436221013651 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/distributions.R \name{Frechet} \alias{Frechet} \alias{dfrechet} \alias{pfrechet} \alias{qfrechet} \alias{rfrechet} \title{The Frechet Distribution} \usage{ dfrechet(x, loc = 0, scale = 1, shape = 1, log = FALSE) pfrechet(q, loc = 0, scale = 1, shape = 1, lower.tail = TRUE, log.p = FALSE) qfrechet(p, loc = 0, scale = 1, shape = 1, lower.tail = TRUE, log.p = FALSE) rfrechet(n, loc = 0, scale = 1, shape = 1) } \arguments{ \item{x, q}{Vector of quantiles.} \item{loc}{Vector of locations.} \item{scale}{Vector of scales.} \item{shape}{Vector of shapes.} \item{log}{Logical; If \code{TRUE}, values are returned on the log scale.} \item{lower.tail}{Logical; If \code{TRUE} (default), return P(X <= x). Else, return P(X > x) .} \item{log.p}{Logical; If \code{TRUE}, values are returned on the log scale.} \item{p}{Vector of probabilities.} \item{n}{Number of draws to sample from the distribution.} } \description{ Density, distribution function, quantile function and random generation for the Frechet distribution with location \code{loc}, scale \code{scale}, and shape \code{shape}. } \details{ See \code{vignette("brms_families")} for details on the parameterization. } brms/man/mmc.Rd0000644000176200001440000000202414213413565013035 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/formula-re.R \name{mmc} \alias{mmc} \title{Multi-Membership Covariates} \usage{ mmc(...) } \arguments{ \item{...}{One or more terms containing covariates corresponding to the grouping levels specified in \code{\link{mm}}.} } \value{ A matrix with covariates as columns. } \description{ Specify covariates that vary over different levels of multi-membership grouping factors thus requiring special treatment. This function is almost solely useful, when called in combination with \code{\link{mm}}. Outside of multi-membership terms it will behave very much like \code{\link{cbind}}. } \examples{ \dontrun{ # simulate some data dat <- data.frame( y = rnorm(100), x1 = rnorm(100), x2 = rnorm(100), g1 = sample(1:10, 100, TRUE), g2 = sample(1:10, 100, TRUE) ) # multi-membership model with level specific covariate values dat$xc <- (dat$x1 + dat$x2) / 2 fit <- brm(y ~ xc + (1 + mmc(x1, x2) | mm(g1, g2)), data = dat) summary(fit) } } \seealso{ \code{\link{mm}} } brms/man/inv_logit_scaled.Rd0000644000176200001440000000077313565500270015576 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/numeric-helpers.R \name{inv_logit_scaled} \alias{inv_logit_scaled} \title{Scaled inverse logit-link} \usage{ inv_logit_scaled(x, lb = 0, ub = 1) } \arguments{ \item{x}{A numeric or complex vector.} \item{lb}{Lower bound defaulting to \code{0}.} \item{ub}{Upper bound defaulting to \code{1}.} } \value{ A numeric or complex vector between \code{lb} and \code{ub}. } \description{ Computes \code{inv_logit(x) * (ub - lb) + lb} } brms/man/rows2labels.Rd0000644000176200001440000000154614213413565014530 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/conditional_effects.R \name{rows2labels} \alias{rows2labels} \title{Convert Rows to Labels} \usage{ rows2labels(x, digits = 2, sep = " & ", incl_vars = TRUE, ...) } \arguments{ \item{x}{A \code{data.frame} for which to extract labels.} \item{digits}{Minimal number of decimal places shown in the labels of numeric variables.} \item{sep}{A single character string defining the separator between variables used in the labels.} \item{incl_vars}{Indicates if variable names should be part of the labels. Defaults to \code{TRUE}.} \item{...}{Currently unused.} } \value{ A character vector of the same length as the number of rows of \code{x}. } \description{ Convert information in rows to labels for each row. } \seealso{ \code{\link{make_conditions}}, \code{\link{conditional_effects}} } brms/man/predictive_error.brmsfit.Rd0000644000176200001440000000531515053072461017302 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/predictive_error.R \name{predictive_error.brmsfit} \alias{predictive_error.brmsfit} \alias{predictive_error} \title{Posterior Draws of Predictive Errors} \usage{ \method{predictive_error}{brmsfit}( object, newdata = NULL, re_formula = NULL, re.form = NULL, method = "posterior_predict", resp = NULL, ndraws = NULL, draw_ids = NULL, sort = FALSE, ... ) } \arguments{ \item{object}{An object of class \code{brmsfit}.} \item{newdata}{An optional data.frame for which to evaluate predictions. If \code{NULL} (default), the original data of the model is used. \code{NA} values within factors (excluding grouping variables) are interpreted as if all dummy variables of this factor are zero. This allows, for instance, to make predictions of the grand mean when using sum coding. \code{NA} values within grouping variables are treated as a new level.} \item{re_formula}{formula containing group-level effects to be considered in the prediction. If \code{NULL} (default), include all group-level effects; if \code{NA} or \code{~0}, include no group-level effects.} \item{re.form}{Alias of \code{re_formula}.} \item{method}{Method used to obtain predictions. Can be set to \code{"posterior_predict"} (the default), \code{"posterior_epred"}, or \code{"posterior_linpred"}. For more details, see the respective function documentations.} \item{resp}{Optional names of response variables. If specified, predictions are performed only for the specified response variables.} \item{ndraws}{Positive integer indicating how many posterior draws should be used. If \code{NULL} (the default) all draws are used. Ignored if \code{draw_ids} is not \code{NULL}.} \item{draw_ids}{An integer vector specifying the posterior draws to be used. If \code{NULL} (the default), all draws are used.} \item{sort}{Logical. Only relevant for time series models. Indicating whether to return predicted values in the original order (\code{FALSE}; default) or in the order of the time series (\code{TRUE}).} \item{...}{Further arguments passed to \code{\link{prepare_predictions}} that control several aspects of data validation and prediction.} } \value{ An S x N \code{array} of predictive error draws, where S is the number of posterior draws and N is the number of observations. } \description{ Compute posterior draws of predictive errors, that is, observed minus predicted responses. Can be performed for the data used to fit the model (posterior predictive checks) or for new data. } \examples{ \dontrun{ ## fit a model fit <- brm(rating ~ treat + period + carry + (1|subject), data = inhaler, cores = 2) ## extract predictive errors pe <- predictive_error(fit) str(pe) } } brms/man/add_criterion.Rd0000644000176200001440000000505714555314073015103 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/loo.R \name{add_criterion} \alias{add_criterion} \alias{add_criterion.brmsfit} \title{Add model fit criteria to model objects} \usage{ add_criterion(x, ...) \method{add_criterion}{brmsfit}( x, criterion, model_name = NULL, overwrite = FALSE, file = NULL, force_save = FALSE, ... ) } \arguments{ \item{x}{An \R object typically of class \code{brmsfit}.} \item{...}{Further arguments passed to the underlying functions computing the model fit criteria. If you are recomputing an already stored criterion with other \code{...} arguments, make sure to set \code{overwrite = TRUE}.} \item{criterion}{Names of model fit criteria to compute. Currently supported are \code{"loo"}, \code{"waic"}, \code{"kfold"}, \code{"loo_subsample"}, \code{"bayes_R2"} (Bayesian R-squared), \code{"loo_R2"} (LOO-adjusted R-squared), and \code{"marglik"} (log marginal likelihood).} \item{model_name}{Optional name of the model. If \code{NULL} (the default) the name is taken from the call to \code{x}.} \item{overwrite}{Logical; Indicates if already stored fit indices should be overwritten. Defaults to \code{FALSE}. Setting it to \code{TRUE} is useful for example when changing additional arguments of an already stored criterion.} \item{file}{Either \code{NULL} or a character string. In the latter case, the fitted model object including the newly added criterion values is saved via \code{\link{saveRDS}} in a file named after the string supplied in \code{file}. The \code{.rds} extension is added automatically. If \code{x} was already stored in a file before, the file name will be reused automatically (with a message) unless overwritten by \code{file}. In any case, \code{file} only applies if new criteria were actually added via \code{add_criterion} or if \code{force_save} was set to \code{TRUE}.} \item{force_save}{Logical; only relevant if \code{file} is specified and ignored otherwise. If \code{TRUE}, the fitted model object will be saved regardless of whether new criteria were added via \code{add_criterion}.} } \value{ An object of the same class as \code{x}, but with model fit criteria added for later usage. } \description{ Add model fit criteria to model objects } \details{ Functions \code{add_loo} and \code{add_waic} are aliases of \code{add_criterion} with fixed values for the \code{criterion} argument. } \examples{ \dontrun{ fit <- brm(count ~ Trt, data = epilepsy) # add both LOO and WAIC at once fit <- add_criterion(fit, c("loo", "waic")) print(fit$criteria$loo) print(fit$criteria$waic) } } brms/man/validate_newdata.Rd0000644000176200001440000000412415053072461015557 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/data-helpers.R \name{validate_newdata} \alias{validate_newdata} \title{Validate New Data} \usage{ validate_newdata( newdata, object, re_formula = NULL, allow_new_levels = FALSE, newdata2 = NULL, resp = NULL, check_response = TRUE, incl_autocor = TRUE, group_vars = NULL, req_vars = NULL, ... ) } \arguments{ \item{newdata}{A \code{data.frame} containing new data to be validated.} \item{object}{A \code{brmsfit} object.} \item{re_formula}{formula containing group-level effects to be considered in the prediction. If \code{NULL} (default), include all group-level effects; if \code{NA} or \code{~0}, include no group-level effects.} \item{allow_new_levels}{A flag indicating if new levels of group-level effects are allowed (defaults to \code{FALSE}). Only relevant if \code{newdata} is provided.} \item{newdata2}{A named \code{list} of objects containing new data, which cannot be passed via argument \code{newdata}. Required for some objects used in autocorrelation structures, or \code{\link{stanvars}}.} \item{resp}{Optional names of response variables. If specified, predictions are performed only for the specified response variables.} \item{check_response}{Logical; Indicates if response variables should be checked as well. Defaults to \code{TRUE}.} \item{incl_autocor}{A flag indicating if correlation structures originally specified via \code{autocor} should be included in the predictions. Defaults to \code{TRUE}.} \item{group_vars}{Optional names of grouping variables to be validated. Defaults to all grouping variables in the model.} \item{req_vars}{Optional names of variables required in \code{newdata}. If \code{NULL} (the default), all variables in the original data are required (unless ignored for some other reason).} \item{...}{Currently ignored.} } \value{ A validated \code{'data.frame'} based on \code{newdata}. } \description{ Validate new data passed to post-processing methods of \pkg{brms}. Unless you are a package developer, you will rarely need to call \code{validate_newdata} directly. } brms/man/mm.Rd0000644000176200001440000000621415053072461012676 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/formula-re.R \name{mm} \alias{mm} \title{Set up multi-membership grouping terms in \pkg{brms}} \usage{ mm( ..., weights = NULL, scale = TRUE, by = NULL, cor = TRUE, id = NA, pw = NULL, cov = NULL, dist = "gaussian" ) } \arguments{ \item{...}{One or more terms containing grouping factors.} \item{weights}{A matrix specifying the membership weights of each member. It should have as many columns as grouping terms specified in \code{...}. If \code{NULL} (the default), equally weights are used.} \item{scale}{Logical; if \code{TRUE} (the default), membership weights are standardized in order to sum to one per row. If negative weights are specified, \code{scale} needs to be set to \code{FALSE}.} \item{by}{An optional factor matrix, specifying sub-populations of the groups. It should have as many columns as grouping terms specified in \code{...}. For each level of the \code{by} variable, a separate variance-covariance matrix will be fitted. Levels of the grouping factor must be nested in levels of the \code{by} variable matrix.} \item{cor}{Logical. If \code{TRUE} (the default), group-level terms will be modelled as correlated.} \item{id}{Optional character string. All group-level terms across the model with the same \code{id} will be modeled as correlated (if \code{cor} is \code{TRUE}). See \code{\link{brmsformula}} for more details.} \item{pw}{Optional numeric matrix specifying prior weights. They weight the contribution of each group to the log-prior of the group-level coefficients. Should have as many columns as grouping terms specified in \code{...} and one distinct value for each group level.} \item{cov}{An optional matrix which is proportional to the within-group covariance matrix of the group-level effects. All levels of the grouping factor should appear as rownames of the corresponding matrix. This argument can be used, among others, to model pedigrees and phylogenetic effects. See \code{vignette("brms_phylogenetics")} for more details. By default, levels of the same grouping factor are modeled as independent of each other.} \item{dist}{Name of the distribution of the group-level effects. Currently \code{"gaussian"} is the only option.} } \description{ Function to set up a multi-membership grouping term in \pkg{brms}. The function does not evaluate its arguments -- it exists purely to help set up a model with grouping terms. } \examples{ \dontrun{ # simulate some data dat <- data.frame( y = rnorm(100), x1 = rnorm(100), x2 = rnorm(100), g1 = sample(1:10, 100, TRUE), g2 = sample(1:10, 100, TRUE) ) # multi-membership model with two members per group and equal weights fit1 <- brm(y ~ x1 + (1|mm(g1, g2)), data = dat) summary(fit1) # weight the first member two times for than the second member dat$w1 <- rep(2, 100) dat$w2 <- rep(1, 100) fit2 <- brm(y ~ x1 + (1|mm(g1, g2, weights = cbind(w1, w2))), data = dat) summary(fit2) # multi-membership model with level specific covariate values dat$xc <- (dat$x1 + dat$x2) / 2 fit3 <- brm(y ~ xc + (1 + mmc(x1, x2) | mm(g1, g2)), data = dat) summary(fit3) } } \seealso{ \code{\link{brmsformula}}, \code{\link{mmc}} } brms/man/kidney.Rd0000644000176200001440000000351414213413565013551 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/datasets.R \docType{data} \name{kidney} \alias{kidney} \title{Infections in kidney patients} \format{ A data frame of 76 observations containing information on the following 7 variables. \describe{ \item{time}{The time to first or second recurrence of the infection, or the time of censoring} \item{recur}{A factor of levels \code{1} or \code{2} indicating if the infection recurred for the first or second time for this patient} \item{censored}{Either \code{0} or \code{1}, where \code{0} indicates no censoring of recurrence time and \code{1} indicates right censoring} \item{patient}{The patient number} \item{age}{The age of the patient} \item{sex}{The sex of the patient} \item{disease}{A factor of levels \code{other, GN, AN}, and \code{PKD} specifying the type of disease} } } \source{ McGilchrist, C. A., & Aisbett, C. W. (1991). Regression with frailty in survival analysis. \emph{Biometrics}, 47(2), 461-466. } \usage{ kidney } \description{ This dataset, originally discussed in McGilchrist and Aisbett (1991), describes the first and second (possibly right censored) recurrence time of infection in kidney patients using portable dialysis equipment. In addition, information on the risk variables age, sex and disease type is provided. } \examples{ \dontrun{ ## performing surivival analysis using the "weibull" family fit1 <- brm(time | cens(censored) ~ age + sex + disease, data = kidney, family = weibull, init = "0") summary(fit1) plot(fit1) ## adding random intercepts over patients fit2 <- brm(time | cens(censored) ~ age + sex + disease + (1|patient), data = kidney, family = weibull(), init = "0", prior = set_prior("cauchy(0,2)", class = "sd")) summary(fit2) plot(fit2) } } \keyword{datasets} brms/man/brms-package.Rd0000644000176200001440000001113115053072461014613 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/brms-package.R \docType{package} \name{brms-package} \alias{brms-package} \alias{brms} \title{Bayesian Regression Models using 'Stan'} \description{ \if{html}{ \figure{stanlogo.png}{options: width="50" alt="https://mc-stan.org/about/logo/"} \emph{Stan Development Team} } The \pkg{brms} package provides an interface to fit Bayesian generalized multivariate (non-)linear multilevel models using \pkg{Stan}, which is a C++ package for obtaining full Bayesian inference (see \url{https://mc-stan.org/}). The formula syntax is an extended version of the syntax applied in the \pkg{lme4} package to provide a familiar and simple interface for performing regression analyses. } \details{ The main function of \pkg{brms} is \code{\link{brm}}, which uses formula syntax to specify a wide range of complex Bayesian models (see \code{\link{brmsformula}} for details). Based on the supplied formulas, data, and additional information, it writes the Stan code on the fly via \code{\link[brms:stancode.default]{stancode}}, prepares the data via \code{\link[brms:standata.default]{standata}} and fits the model using \pkg{\link[rstan:rstan]{Stan}}. Subsequently, a large number of post-processing methods can be applied: To get an overview on the estimated parameters, \code{\link[brms:summary.brmsfit]{summary}} or \code{\link[brms:conditional_effects.brmsfit]{conditional_effects}} are perfectly suited. Detailed visual analyses can be performed by applying the \code{\link{pp_check}} and \code{\link{stanplot}} methods, which both rely on the \pkg{\link[bayesplot:bayesplot-package]{bayesplot}} package. Model comparisons can be done via \code{\link{loo}} and \code{\link{waic}}, which make use of the \pkg{\link[loo:loo-package]{loo}} package as well as via \code{\link{bayes_factor}} which relies on the \pkg{bridgesampling} package. For a full list of methods to apply, type \code{methods(class = "brmsfit")}. Because \pkg{brms} is based on \pkg{Stan}, a C++ compiler is required. The program Rtools (available on \url{https://cran.r-project.org/bin/windows/Rtools/}) comes with a C++ compiler for Windows. On Mac, you should use Xcode. For further instructions on how to get the compilers running, see the prerequisites section at the \href{https://github.com/stan-dev/rstan/wiki/RStan-Getting-Started}{RStan-Getting-Started} page. When comparing other packages fitting multilevel models to \pkg{brms}, keep in mind that the latter needs to compile models before actually fitting them, which will require between 20 and 40 seconds depending on your machine, operating system and overall model complexity. Thus, fitting smaller models may be relatively slow as compilation time makes up the majority of the whole running time. For larger / more complex models however, fitting my take several minutes or even hours, so that the compilation time won't make much of a difference for these models. See \code{vignette("brms_overview")} and \code{vignette("brms_multilevel")} for a general introduction and overview of \pkg{brms}. For a full list of available vignettes, type \code{vignette(package = "brms")}. } \references{ Paul-Christian Buerkner (2017). brms: An R Package for Bayesian Multilevel Models Using Stan. \emph{Journal of Statistical Software}, 80(1), 1-28. \code{doi:10.18637/jss.v080.i01} Paul-Christian Buerkner (2018). Advanced Bayesian Multilevel Modeling with the R Package brms. \emph{The R Journal}. 10(1), 395–411. \code{doi:10.32614/RJ-2018-017} The Stan Development Team. \emph{Stan Modeling Language User's Guide and Reference Manual}. \url{https://mc-stan.org/users/documentation/}. Stan Development Team (2020). RStan: the R interface to Stan. R package version 2.21.2. \url{https://mc-stan.org/} } \seealso{ \code{\link{brm}}, \code{\link{brmsformula}}, \code{\link{brmsfamily}}, \code{\link{brmsfit}} } \author{ \strong{Maintainer}: Paul-Christian Bürkner \email{paul.buerkner@gmail.com} Other contributors: \itemize{ \item Jonah Gabry [contributor] \item Sebastian Weber [contributor] \item Andrew Johnson [contributor] \item Martin Modrak [contributor] \item Hamada S. Badr [contributor] \item Frank Weber [contributor] \item Aki Vehtari [contributor] \item Mattan S. Ben-Shachar [contributor] \item Hayden Rabel [contributor] \item Simon C. Mills [contributor] \item Stephen Wild [contributor] \item Ven Popov [contributor] \item Ioannis Kosmidis [contributor] \item Ben Schneider [contributor] \item Noa Kallioinen [contributor] \item Wellington J. Silva [contributor] \item Luiz Carvalho [contributor] \item Sermet Pekin [contributor] } } brms/man/fixef.brmsfit.Rd0000644000176200001440000000310214213413565015025 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/brmsfit-methods.R \name{fixef.brmsfit} \alias{fixef.brmsfit} \alias{fixef} \title{Extract Population-Level Estimates} \usage{ \method{fixef}{brmsfit}( object, summary = TRUE, robust = FALSE, probs = c(0.025, 0.975), pars = NULL, ... ) } \arguments{ \item{object}{An object of class \code{brmsfit}.} \item{summary}{Should summary statistics be returned instead of the raw values? Default is \code{TRUE}.} \item{robust}{If \code{FALSE} (the default) the mean is used as the measure of central tendency and the standard deviation as the measure of variability. If \code{TRUE}, the median and the median absolute deviation (MAD) are applied instead. Only used if \code{summary} is \code{TRUE}.} \item{probs}{The percentiles to be computed by the \code{quantile} function. Only used if \code{summary} is \code{TRUE}.} \item{pars}{Optional names of coefficients to extract. By default, all coefficients are extracted.} \item{...}{Currently ignored.} } \value{ If \code{summary} is \code{TRUE}, a matrix returned by \code{\link{posterior_summary}} for the population-level effects. If \code{summary} is \code{FALSE}, a matrix with one row per posterior draw and one column per population-level effect. } \description{ Extract the population-level ('fixed') effects from a \code{brmsfit} object. } \examples{ \dontrun{ fit <- brm(time | cens(censored) ~ age + sex + disease, data = kidney, family = "exponential") fixef(fit) # extract only some coefficients fixef(fit, pars = c("age", "sex")) } } brms/man/constant.Rd0000644000176200001440000000263214571050211014107 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/priors.R \name{constant} \alias{constant} \title{Constant priors in \pkg{brms}} \usage{ constant(const, broadcast = TRUE) } \arguments{ \item{const}{Numeric value, vector, matrix of values to which the parameters should be fixed to. Can also be a valid Stan variable in the model.} \item{broadcast}{Should \code{const} be automatically broadcasted to the correct size of the parameter? Defaults to \code{TRUE}. If you supply vectors or matrices in \code{const} or vector/matrix valued Stan variables, you need to set \code{broadcast} to \code{TRUE} (see Examples).} } \value{ A named list with elements \code{const} and \code{broadcast}. } \description{ Function used to set up constant priors in \pkg{brms}. The function does not evaluate its arguments -- it exists purely to help set up the model. } \examples{ stancode(count ~ Base + Age, data = epilepsy, prior = prior(constant(1), class = "b")) # will fail parsing because brms will try to broadcast a vector into a vector stancode(count ~ Base + Age, data = epilepsy, prior = prior(constant(alpha), class = "b"), stanvars = stanvar(c(1, 0), name = "alpha")) stancode(count ~ Base + Age, data = epilepsy, prior = prior(constant(alpha, broadcast = FALSE), class = "b"), stanvars = stanvar(c(1, 0), name = "alpha")) } \seealso{ \code{\link{set_prior}} } brms/man/pp_average.brmsfit.Rd0000644000176200001440000000710315053072461016041 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/model_weights.R \name{pp_average.brmsfit} \alias{pp_average.brmsfit} \alias{pp_average} \title{Posterior predictive draws averaged across models} \usage{ \method{pp_average}{brmsfit}( x, ..., weights = "stacking", method = "posterior_predict", ndraws = NULL, nsamples = NULL, summary = TRUE, probs = c(0.025, 0.975), robust = FALSE, model_names = NULL, control = list(), seed = NULL ) pp_average(x, ...) } \arguments{ \item{x}{A \code{brmsfit} object.} \item{...}{More \code{brmsfit} objects or further arguments passed to the underlying post-processing functions. In particular, see \code{\link{prepare_predictions}} for further supported arguments.} \item{weights}{Name of the criterion to compute weights from. Should be one of \code{"loo"}, \code{"waic"}, \code{"kfold"}, \code{"stacking"} (current default), \code{"bma"}, or \code{"pseudobma"}. For the former three options, Akaike weights will be computed based on the information criterion values returned by the respective methods. For \code{"stacking"} and \code{"pseudobma"}, method \code{\link{loo_model_weights}} will be used to obtain weights. For \code{"bma"}, method \code{\link{post_prob}} will be used to compute Bayesian model averaging weights based on log marginal likelihood values (make sure to specify reasonable priors in this case). For some methods, \code{weights} may also be a numeric vector of pre-specified weights.} \item{method}{Method used to obtain predictions to average over. Should be one of \code{"posterior_predict"} (default), \code{"posterior_epred"}, \code{"posterior_linpred"} or \code{"predictive_error"}.} \item{ndraws}{Total number of posterior draws to use.} \item{nsamples}{Deprecated alias of \code{ndraws}.} \item{summary}{Should summary statistics (i.e. means, sds, and 95\% intervals) be returned instead of the raw values? Default is \code{TRUE}.} \item{probs}{The percentiles to be computed by the \code{quantile} function. Only used if \code{summary} is \code{TRUE}.} \item{robust}{If \code{FALSE} (the default) the mean is used as the measure of central tendency and the standard deviation as the measure of variability. If \code{TRUE}, the median and the median absolute deviation (MAD) are applied instead. Only used if \code{summary} is \code{TRUE}.} \item{model_names}{If \code{NULL} (the default) will use model names derived from deparsing the call. Otherwise will use the passed values as model names.} \item{control}{Optional \code{list} of further arguments passed to the function specified in \code{weights}.} \item{seed}{A single numeric value passed to \code{\link{set.seed}} to make results reproducible.} } \value{ Same as the output of the method specified in argument \code{method}. } \description{ Compute posterior predictive draws averaged across models. Weighting can be done in various ways, for instance using Akaike weights based on information criteria or marginal likelihoods. } \details{ Weights are computed with the \code{\link{model_weights}} method. } \examples{ \dontrun{ # model with 'treat' as predictor fit1 <- brm(rating ~ treat + period + carry, data = inhaler) summary(fit1) # model without 'treat' as predictor fit2 <- brm(rating ~ period + carry, data = inhaler) summary(fit2) # compute model-averaged predicted values (df <- unique(inhaler[, c("treat", "period", "carry")])) pp_average(fit1, fit2, newdata = df) # compute model-averaged fitted values pp_average(fit1, fit2, method = "fitted", newdata = df) } } \seealso{ \code{\link{model_weights}}, \code{\link{posterior_average}} } brms/man/print.brmsprior.Rd0000644000176200001440000000102614213413565015434 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/priors.R \name{print.brmsprior} \alias{print.brmsprior} \title{Print method for \code{brmsprior} objects} \usage{ \method{print}{brmsprior}(x, show_df = NULL, ...) } \arguments{ \item{x}{An object of class \code{brmsprior}.} \item{show_df}{Logical; Print priors as a single \code{data.frame} (\code{TRUE}) or as a sequence of sampling statements (\code{FALSE})?} \item{...}{Currently ignored.} } \description{ Print method for \code{brmsprior} objects } brms/man/loo.brmsfit.Rd0000644000176200001440000001033015053072461014515 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/loo.R \name{loo.brmsfit} \alias{loo.brmsfit} \alias{loo} \alias{LOO} \alias{LOO.brmsfit} \title{Efficient approximate leave-one-out cross-validation (LOO)} \usage{ \method{loo}{brmsfit}( x, ..., compare = TRUE, resp = NULL, pointwise = FALSE, moment_match = FALSE, reloo = FALSE, k_threshold = 0.7, save_psis = FALSE, moment_match_args = list(), reloo_args = list(), model_names = NULL ) } \arguments{ \item{x}{A \code{brmsfit} object.} \item{...}{More \code{brmsfit} objects or further arguments passed to the underlying post-processing functions. In particular, see \code{\link{prepare_predictions}} for further supported arguments.} \item{compare}{A flag indicating if the information criteria of the models should be compared to each other via \code{\link{loo_compare}}.} \item{resp}{Optional names of response variables. If specified, predictions are performed only for the specified response variables.} \item{pointwise}{A flag indicating whether to compute the full log-likelihood matrix at once or separately for each observation. The latter approach is usually considerably slower but requires much less working memory. Accordingly, if one runs into memory issues, \code{pointwise = TRUE} is the way to go.} \item{moment_match}{Logical; Indicate whether \code{\link{loo_moment_match}} should be applied on problematic observations. Defaults to \code{FALSE}. For most models, moment matching will only work if you have set \code{save_pars = save_pars(all = TRUE)} when fitting the model with \code{\link{brm}}. See \code{\link{loo_moment_match.brmsfit}} for more details.} \item{reloo}{Logical; Indicate whether \code{\link{reloo}} should be applied on problematic observations. Defaults to \code{FALSE}.} \item{k_threshold}{The Pareto \eqn{k} threshold for which observations \code{\link{loo_moment_match}} or \code{\link{reloo}} is applied if argument \code{moment_match} or \code{reloo} is \code{TRUE}. Defaults to \code{0.7}. See \code{\link[loo:pareto-k-diagnostic]{pareto_k_ids}} for more details.} \item{save_psis}{Should the \code{"psis"} object created internally be saved in the returned object? For more details see \code{\link[loo:loo]{loo}}.} \item{moment_match_args}{Optional named \code{list} of additional arguments passed to \code{\link{loo_moment_match}}.} \item{reloo_args}{Optional named \code{list} of additional arguments passed to \code{\link{reloo}}. This can be useful, among others, to control how many chains, iterations, etc. to use for the fitted sub-models.} \item{model_names}{If \code{NULL} (the default) will use model names derived from deparsing the call. Otherwise will use the passed values as model names.} } \value{ If just one object is provided, an object of class \code{loo}. If multiple objects are provided, an object of class \code{loolist}. } \description{ Perform approximate leave-one-out cross-validation based on the posterior likelihood using the \pkg{loo} package. For more details see \code{\link[loo:loo]{loo}}. } \details{ See \code{\link{loo_compare}} for details on model comparisons. For \code{brmsfit} objects, \code{LOO} is an alias of \code{loo}. Use method \code{\link{add_criterion}} to store information criteria in the fitted model object for later usage. } \examples{ \dontrun{ # model with population-level effects only fit1 <- brm(rating ~ treat + period + carry, data = inhaler) (loo1 <- loo(fit1)) # model with an additional varying intercept for subjects fit2 <- brm(rating ~ treat + period + carry + (1|subject), data = inhaler) (loo2 <- loo(fit2)) # compare both models loo_compare(loo1, loo2) } } \references{ Vehtari, A., Gelman, A., & Gabry J. (2016). Practical Bayesian model evaluation using leave-one-out cross-validation and WAIC. In Statistics and Computing, doi:10.1007/s11222-016-9696-4. arXiv preprint arXiv:1507.04544. Gelman, A., Hwang, J., & Vehtari, A. (2014). Understanding predictive information criteria for Bayesian models. Statistics and Computing, 24, 997-1016. Watanabe, S. (2010). Asymptotic equivalence of Bayes cross validation and widely applicable information criterion in singular learning theory. The Journal of Machine Learning Research, 11, 3571-3594. } brms/man/ar.Rd0000644000176200001440000000325614361545260012675 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/formula-ac.R \name{ar} \alias{ar} \title{Set up AR(p) correlation structures} \usage{ ar(time = NA, gr = NA, p = 1, cov = FALSE) } \arguments{ \item{time}{An optional time variable specifying the time ordering of the observations. By default, the existing order of the observations in the data is used.} \item{gr}{An optional grouping variable. If specified, the correlation structure is assumed to apply only to observations within the same grouping level.} \item{p}{A non-negative integer specifying the autoregressive (AR) order of the ARMA structure. Default is \code{1}.} \item{cov}{A flag indicating whether ARMA effects should be estimated by means of residual covariance matrices. This is currently only possible for stationary ARMA effects of order 1. If the model family does not have natural residuals, latent residuals are added automatically. If \code{FALSE} (the default), a regression formulation is used that is considerably faster and allows for ARMA effects of order higher than 1 but is only available for \code{gaussian} models and some of its generalizations.} } \value{ An object of class \code{'arma_term'}, which is a list of arguments to be interpreted by the formula parsing functions of \pkg{brms}. } \description{ Set up an autoregressive (AR) term of order p in \pkg{brms}. The function does not evaluate its arguments -- it exists purely to help set up a model with AR terms. } \examples{ \dontrun{ data("LakeHuron") LakeHuron <- as.data.frame(LakeHuron) fit <- brm(x ~ ar(p = 2), data = LakeHuron) summary(fit) } } \seealso{ \code{\link{autocor-terms}}, \code{\link{arma}}, \code{\link{ma}} } brms/man/mvbind.Rd0000644000176200001440000000102713565500267013547 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/brmsformula.R \name{mvbind} \alias{mvbind} \title{Bind response variables in multivariate models} \usage{ mvbind(...) } \arguments{ \item{...}{Same as in \code{\link{cbind}}} } \description{ Can be used to specify a multivariate \pkg{brms} model within a single formula. Outside of \code{\link{brmsformula}}, it just behaves like \code{\link{cbind}}. } \examples{ bf(mvbind(y1, y2) ~ x) } \seealso{ \code{\link{brmsformula}}, \code{\link{mvbrmsformula}} } brms/man/MultiNormal.Rd0000644000176200001440000000207715053072461014533 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/distributions.R \name{MultiNormal} \alias{MultiNormal} \alias{dmulti_normal} \alias{rmulti_normal} \title{The Multivariate Normal Distribution} \usage{ dmulti_normal(x, mu, Sigma, log = FALSE, check = FALSE) rmulti_normal(n, mu, Sigma, check = FALSE) } \arguments{ \item{x}{Vector or matrix of quantiles. If \code{x} is a matrix, each row is taken to be a quantile.} \item{mu}{Mean vector with length equal to the number of dimensions.} \item{Sigma}{Covariance matrix.} \item{log}{Logical; If \code{TRUE}, values are returned on the log scale.} \item{check}{Logical; Indicates whether several input checks should be performed. Defaults to \code{FALSE} to improve efficiency.} \item{n}{Number of draws to sample from the distribution.} } \description{ Density function and random generation for the multivariate normal distribution with mean vector \code{mu} and covariance matrix \code{Sigma}. } \details{ See the Stan user's manual \url{https://mc-stan.org/docs/} for details on the parameterization } brms/man/s.Rd0000644000176200001440000000343014363466275012541 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/formula-sm.R \name{s} \alias{s} \alias{t2} \title{Defining smooths in \pkg{brms} formulas} \usage{ s(...) t2(...) } \arguments{ \item{...}{Arguments passed to \code{\link[mgcv:s]{mgcv::s}} or \code{\link[mgcv:t2]{mgcv::t2}}.} } \description{ Functions used in definition of smooth terms within a model formulas. The function does not evaluate a (spline) smooth - it exists purely to help set up a model using spline based smooths. } \details{ The function defined here are just simple wrappers of the respective functions of the \pkg{mgcv} package. When using them, please cite the appropriate references obtained via \code{citation("mgcv")}. \pkg{brms} uses the "random effects" parameterization of smoothing splines as explained in \code{\link[mgcv:gamm]{mgcv::gamm}}. A nice tutorial on this topic can be found in Pedersen et al. (2019). The answers provided in this \href{https://discourse.mc-stan.org/t/better-priors-non-flat-for-gams-brms/23012/4}{Stan discourse post} may also be helpful. } \examples{ \dontrun{ # simulate some data dat <- mgcv::gamSim(1, n = 200, scale = 2) # fit univariate smooths for all predictors fit1 <- brm(y ~ s(x0) + s(x1) + s(x2) + s(x3), data = dat, chains = 2) summary(fit1) plot(conditional_smooths(fit1), ask = FALSE) # fit a more complicated smooth model fit2 <- brm(y ~ t2(x0, x1) + s(x2, by = x3), data = dat, chains = 2) summary(fit2) plot(conditional_smooths(fit2), ask = FALSE) } } \references{ Pedersen, E. J., Miller, D. L., Simpson, G. L., & Ross, N. (2019). Hierarchical generalized additive models in ecology: an introduction with mgcv. PeerJ. } \seealso{ \code{\link{brmsformula}}, \code{\link[mgcv:s]{mgcv::s}}, \code{\link[mgcv:t2]{mgcv::t2}} } brms/man/theme_default.Rd0000644000176200001440000000076614160105076015076 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/plot.R \name{theme_default} \alias{theme_default} \title{Default \pkg{bayesplot} Theme for \pkg{ggplot2} Graphics} \arguments{ \item{base_size}{base font size} \item{base_family}{base font family} } \value{ A \code{theme} object used in \pkg{ggplot2} graphics. } \description{ This theme is imported from the \pkg{bayesplot} package. See \code{\link[bayesplot:theme_default]{theme_default}} for a complete documentation. } brms/man/addition-terms.Rd0000644000176200001440000001226115053305627015212 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/formula-ad.R \name{addition-terms} \alias{addition-terms} \alias{se} \alias{weights} \alias{trials} \alias{thres} \alias{cat} \alias{dec} \alias{cens} \alias{trunc} \alias{index} \alias{rate} \alias{subset} \alias{vreal} \alias{vint} \alias{resp_se} \alias{resp_weights} \alias{resp_trials} \alias{resp_thres} \alias{resp_cat} \alias{resp_dec} \alias{resp_bhaz} \alias{resp_cens} \alias{resp_trunc} \alias{resp_mi} \alias{resp_index} \alias{resp_rate} \alias{resp_subset} \alias{resp_vreal} \alias{resp_vint} \title{Additional Response Information} \usage{ resp_se(x, sigma = FALSE) resp_weights(x, scale = FALSE) resp_trials(x) resp_thres(x, gr = NA) resp_cat(x) resp_dec(x) resp_bhaz(gr = NA, df = 5, ...) resp_cens(x, y2 = NA) resp_trunc(lb = -Inf, ub = Inf) resp_mi(sdy = NA) resp_index(x) resp_rate(denom) resp_subset(x) resp_vreal(...) resp_vint(...) } \arguments{ \item{x}{A vector; Ideally a single variable defined in the data (see Details). Allowed values depend on the function: \code{resp_se} and \code{resp_weights} require positive numeric values. \code{resp_trials}, \code{resp_thres}, and \code{resp_cat} require positive integers. \code{resp_dec} requires \code{0} and \code{1}, or alternatively \code{'lower'} and \code{'upper'}. \code{resp_subset} requires \code{0} and \code{1}, or alternatively \code{FALSE} and \code{TRUE}. \code{resp_cens} requires \code{'left'}, \code{'none'}, \code{'right'}, and \code{'interval'} (or equivalently \code{-1}, \code{0}, \code{1}, and \code{2}) to indicate left, no, right, or interval censoring. \code{resp_index} does not make any requirements other than the value being unique for each observation.} \item{sigma}{Logical; Indicates whether the residual standard deviation parameter \code{sigma} should be included in addition to the known measurement error. Defaults to \code{FALSE} for backwards compatibility, but setting it to \code{TRUE} is usually the better choice.} \item{scale}{Logical; Indicates whether weights should be scaled so that the average weight equals one. Defaults to \code{FALSE}.} \item{gr}{A vector of grouping indicators.} \item{df}{Degrees of freedom of baseline hazard splines for Cox models.} \item{...}{For \code{resp_vreal}, vectors of real values. For \code{resp_vint}, vectors of integer values. In Stan, these variables will be named \code{vreal1}, \code{vreal2}, ..., and \code{vint1}, \code{vint2}, ..., respectively.} \item{y2}{A vector specifying the upper bounds in interval censoring. Will be ignored for non-interval censored observations. However, it should NOT be \code{NA} even for non-interval censored observations to avoid accidental exclusion of these observations.} \item{lb}{A numeric vector or single numeric value specifying the lower truncation bound.} \item{ub}{A numeric vector or single numeric value specifying the upper truncation bound.} \item{sdy}{Optional known measurement error of the response treated as standard deviation. If specified, handles measurement error and (completely) missing values at the same time using the plausible-values-technique.} \item{denom}{A vector of positive numeric values specifying the denominator values from which the response rates are computed.} } \value{ A list of additional response information to be processed further by \pkg{brms}. } \description{ Provide additional information on the response variable in \pkg{brms} models, such as censoring, truncation, or known measurement error. Detailed documentation on the use of each of these functions can be found in the Details section of \code{\link{brmsformula}} (under "Additional response information"). } \details{ These functions are almost solely useful when called in formulas passed to the \pkg{brms} package. Within formulas, the \code{resp_} prefix may be omitted. More information is given in the 'Details' section of \code{\link{brmsformula}} (under "Additional response information"). It is highly recommended to use a single data variable as input for \code{x} (instead of a more complicated expression) to make sure all post-processing functions work as expected. } \examples{ \dontrun{ ## Random effects meta-analysis nstudies <- 20 true_effects <- rnorm(nstudies, 0.5, 0.2) sei <- runif(nstudies, 0.05, 0.3) outcomes <- rnorm(nstudies, true_effects, sei) data1 <- data.frame(outcomes, sei) fit1 <- brm(outcomes | se(sei, sigma = TRUE) ~ 1, data = data1) summary(fit1) ## Probit regression using the binomial family n <- sample(1:10, 100, TRUE) # number of trials success <- rbinom(100, size = n, prob = 0.4) x <- rnorm(100) data2 <- data.frame(n, success, x) fit2 <- brm(success | trials(n) ~ x, data = data2, family = binomial("probit")) summary(fit2) ## Survival regression modeling the time between the first ## and second recurrence of an infection in kidney patients. fit3 <- brm(time | cens(censored) ~ age * sex + disease + (1|patient), data = kidney, family = lognormal()) summary(fit3) ## Poisson model with truncated counts fit4 <- brm(count | trunc(ub = 104) ~ zBase * Trt, data = epilepsy, family = poisson()) summary(fit4) } } \seealso{ \code{\link{brm}}, \code{\link{brmsformula}} } brms/man/cor_bsts.Rd0000644000176200001440000000157614160105076014106 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/autocor.R \name{cor_bsts} \alias{cor_bsts} \title{(Defunct) Basic Bayesian Structural Time Series} \usage{ cor_bsts(formula = ~1) } \arguments{ \item{formula}{A one sided formula of the form \code{~ t}, or \code{~ t | g}, specifying a time covariate \code{t} and, optionally, a grouping factor \code{g}. A covariate for this correlation structure must be integer valued. When a grouping factor is present in \code{formula}, the correlation structure is assumed to apply only to observations within the same grouping level; observations with different grouping levels are assumed to be uncorrelated. Defaults to \code{~ 1}, which corresponds to using the order of the observations in the data as a covariate, and no groups.} } \description{ The BSTS correlation structure is no longer supported. } \keyword{internal} brms/man/default_prior.default.Rd0000644000176200001440000001001514570436567016557 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/priors.R \name{default_prior.default} \alias{default_prior.default} \title{Default Priors for \pkg{brms} Models} \usage{ \method{default_prior}{default}( object, data, family = gaussian(), autocor = NULL, data2 = NULL, knots = NULL, drop_unused_levels = TRUE, sparse = NULL, ... ) } \arguments{ \item{object}{An object of class \code{\link[stats:formula]{formula}}, \code{\link{brmsformula}}, or \code{\link{mvbrmsformula}} (or one that can be coerced to that classes): A symbolic description of the model to be fitted. The details of model specification are explained in \code{\link{brmsformula}}.} \item{data}{An object of class \code{data.frame} (or one that can be coerced to that class) containing data of all variables used in the model.} \item{family}{A description of the response distribution and link function to be used in the model. This can be a family function, a call to a family function or a character string naming the family. Every family function has a \code{link} argument allowing to specify the link function to be applied on the response variable. If not specified, default links are used. For details of supported families see \code{\link{brmsfamily}}. By default, a linear \code{gaussian} model is applied. In multivariate models, \code{family} might also be a list of families.} \item{autocor}{(Deprecated) An optional \code{\link{cor_brms}} object describing the correlation structure within the response variable (i.e., the 'autocorrelation'). See the documentation of \code{\link{cor_brms}} for a description of the available correlation structures. Defaults to \code{NULL}, corresponding to no correlations. In multivariate models, \code{autocor} might also be a list of autocorrelation structures. It is now recommend to specify autocorrelation terms directly within \code{formula}. See \code{\link{brmsformula}} for more details.} \item{data2}{A named \code{list} of objects containing data, which cannot be passed via argument \code{data}. Required for some objects used in autocorrelation structures to specify dependency structures as well as for within-group covariance matrices.} \item{knots}{Optional list containing user specified knot values to be used for basis construction of smoothing terms. See \code{\link[mgcv:gamm]{gamm}} for more details.} \item{drop_unused_levels}{Should unused factors levels in the data be dropped? Defaults to \code{TRUE}.} \item{sparse}{(Deprecated) Logical; indicates whether the population-level design matrices should be treated as sparse (defaults to \code{FALSE}). For design matrices with many zeros, this can considerably reduce required memory. Sampling speed is currently not improved or even slightly decreased. It is now recommended to use the \code{sparse} argument of \code{\link{brmsformula}} and related functions.} \item{...}{Other arguments for internal usage only.} } \value{ A \code{brmsprior} object. That is, a data.frame with specific columns including \code{prior}, \code{class}, \code{coef}, and \code{group} and several rows, each providing information on a parameter (or parameter class) on which priors can be specified. The prior column is empty except for internal default priors. } \description{ Get information on all parameters (and parameter classes) for which priors may be specified including default priors. } \examples{ # get all parameters and parameters classes to define priors on (prior <- default_prior(count ~ zAge + zBase * Trt + (1|patient) + (1|obs), data = epilepsy, family = poisson())) # define a prior on all population-level effects a once prior$prior[1] <- "normal(0,10)" # define a specific prior on the population-level effect of Trt prior$prior[5] <- "student_t(10, 0, 5)" # verify that the priors indeed found their way into Stan's model code stancode(count ~ zAge + zBase * Trt + (1|patient) + (1|obs), data = epilepsy, family = poisson(), prior = prior) } \seealso{ \code{\link{default_prior}}, \code{\link{set_prior}} } brms/man/BetaBinomial.Rd0000644000176200001440000000245414527413457014626 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/distributions.R \name{BetaBinomial} \alias{BetaBinomial} \alias{dbeta_binomial} \alias{pbeta_binomial} \alias{rbeta_binomial} \title{The Beta-binomial Distribution} \usage{ dbeta_binomial(x, size, mu, phi, log = FALSE) pbeta_binomial(q, size, mu, phi, lower.tail = TRUE, log.p = FALSE) rbeta_binomial(n, size, mu, phi) } \arguments{ \item{x, q}{Vector of quantiles.} \item{size}{Vector of number of trials (zero or more).} \item{mu}{Vector of means.} \item{phi}{Vector of precisions.} \item{log}{Logical; If \code{TRUE}, values are returned on the log scale.} \item{lower.tail}{Logical; If \code{TRUE} (default), return P(X <= x). Else, return P(X > x) .} \item{log.p}{Logical; If \code{TRUE}, values are returned on the log scale.} \item{n}{Number of draws to sample from the distribution.} } \description{ Cumulative density & mass functions, and random number generation for the Beta-binomial distribution using the following re-parameterisation of the \href{https://mc-stan.org/docs/2_29/functions-reference/beta-binomial-distribution.html}{Stan Beta-binomial definition}: \itemize{ \item{\code{mu = alpha * beta}} mean probability of trial success. \item{\code{phi = (1 - mu) * beta}} precision or over-dispersion, component. } } brms/man/Wiener.Rd0000644000176200001440000000371614275473342013532 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/distributions.R \name{Wiener} \alias{Wiener} \alias{dwiener} \alias{rwiener} \title{The Wiener Diffusion Model Distribution} \usage{ dwiener( x, alpha, tau, beta, delta, resp = 1, log = FALSE, backend = getOption("wiener_backend", "Rwiener") ) rwiener( n, alpha, tau, beta, delta, types = c("q", "resp"), backend = getOption("wiener_backend", "Rwiener") ) } \arguments{ \item{x}{Vector of quantiles.} \item{alpha}{Boundary separation parameter.} \item{tau}{Non-decision time parameter.} \item{beta}{Bias parameter.} \item{delta}{Drift rate parameter.} \item{resp}{Response: \code{"upper"} or \code{"lower"}. If no character vector, it is coerced to logical where \code{TRUE} indicates \code{"upper"} and \code{FALSE} indicates \code{"lower"}.} \item{log}{Logical; If \code{TRUE}, values are returned on the log scale.} \item{backend}{Name of the package to use as backend for the computations. Either \code{"Rwiener"} (the default) or \code{"rtdists"}. Can be set globally for the current \R session via the \code{"wiener_backend"} option (see \code{\link{options}}).} \item{n}{Number of draws to sample from the distribution.} \item{types}{Which types of responses to return? By default, return both the response times \code{"q"} and the dichotomous responses \code{"resp"}. If either \code{"q"} or \code{"resp"}, return only one of the two types.} } \description{ Density function and random generation for the Wiener diffusion model distribution with boundary separation \code{alpha}, non-decision time \code{tau}, bias \code{beta} and drift rate \code{delta}. } \details{ These are wrappers around functions of the \pkg{RWiener} or \pkg{rtdists} package (depending on the chosen \code{backend}). See \code{vignette("brms_families")} for details on the parameterization. } \seealso{ \code{\link[RWiener:wienerdist]{wienerdist}}, \code{\link[rtdists:Diffusion]{Diffusion}} } brms/man/posterior_linpred.brmsfit.Rd0000644000176200001440000000641615053072461017501 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/posterior_epred.R \name{posterior_linpred.brmsfit} \alias{posterior_linpred.brmsfit} \alias{posterior_linpred} \title{Posterior Draws of the Linear Predictor} \usage{ \method{posterior_linpred}{brmsfit}( object, transform = FALSE, newdata = NULL, re_formula = NULL, re.form = NULL, resp = NULL, dpar = NULL, nlpar = NULL, incl_thres = NULL, ndraws = NULL, draw_ids = NULL, sort = FALSE, ... ) } \arguments{ \item{object}{An object of class \code{brmsfit}.} \item{transform}{Logical; if \code{FALSE} (the default), draws of the linear predictor are returned. If \code{TRUE}, draws of the transformed linear predictor, that is, after applying the inverse link function are returned.} \item{newdata}{An optional data.frame for which to evaluate predictions. If \code{NULL} (default), the original data of the model is used. \code{NA} values within factors (excluding grouping variables) are interpreted as if all dummy variables of this factor are zero. This allows, for instance, to make predictions of the grand mean when using sum coding. \code{NA} values within grouping variables are treated as a new level.} \item{re_formula}{formula containing group-level effects to be considered in the prediction. If \code{NULL} (default), include all group-level effects; if \code{NA} or \code{~0}, include no group-level effects.} \item{re.form}{Alias of \code{re_formula}.} \item{resp}{Optional names of response variables. If specified, predictions are performed only for the specified response variables.} \item{dpar}{Name of a predicted distributional parameter for which draws are to be returned. By default, draws of the main distributional parameter(s) \code{"mu"} are returned.} \item{nlpar}{Optional name of a predicted non-linear parameter. If specified, expected predictions of this parameters are returned.} \item{incl_thres}{Logical; only relevant for ordinal models when \code{transform} is \code{FALSE}, and ignored otherwise. Shall the thresholds and category-specific effects be included in the linear predictor? For backwards compatibility, the default is to not include them.} \item{ndraws}{Positive integer indicating how many posterior draws should be used. If \code{NULL} (the default) all draws are used. Ignored if \code{draw_ids} is not \code{NULL}.} \item{draw_ids}{An integer vector specifying the posterior draws to be used. If \code{NULL} (the default), all draws are used.} \item{sort}{Logical. Only relevant for time series models. Indicating whether to return predicted values in the original order (\code{FALSE}; default) or in the order of the time series (\code{TRUE}).} \item{...}{Further arguments passed to \code{\link{prepare_predictions}} that control several aspects of data validation and prediction.} } \description{ Compute posterior draws of the linear predictor, that is draws before applying any link functions or other transformations. Can be performed for the data used to fit the model (posterior predictive checks) or for new data. } \examples{ \dontrun{ ## fit a model fit <- brm(rating ~ treat + period + carry + (1|subject), data = inhaler) ## extract linear predictor values pl <- posterior_linpred(fit) str(pl) } } \seealso{ \code{\link{posterior_epred.brmsfit}} } brms/man/stancode.Rd0000644000176200001440000000272014572632206014067 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/stancode.R \name{stancode} \alias{stancode} \alias{make_stancode} \title{Stan Code for Bayesian models} \usage{ stancode(object, ...) make_stancode(formula, ...) } \arguments{ \item{object}{An object whose class will determine which method to apply. Usually, it will be some kind of symbolic description of the model form which Stan code should be generated.} \item{...}{Further arguments passed to the specific method.} \item{formula}{Synonym of \code{object} for use in \code{make_stancode}.} } \value{ Usually, a character string containing the generated Stan code. For pretty printing, we recommend the returned object to be of class \code{c("character", "brmsmodel")}. } \description{ \code{stancode} is a generic function that can be used to generate Stan code for Bayesian models. Its original use is within the \pkg{brms} package, but new methods for use with objects from other packages can be registered to the same generic. } \details{ See \code{\link[brms:stancode.default]{stancode.default}} for the default method applied for \pkg{brms} models. You can view the available methods by typing: \code{methods(stancode)} The \code{make_stancode} function is an alias of \code{stancode}. } \examples{ stancode(rating ~ treat + period + carry + (1|subject), data = inhaler, family = "cumulative") } \seealso{ \code{\link{stancode.default}}, \code{\link{stancode.brmsfit}} } brms/man/read_csv_as_stanfit.Rd0000644000176200001440000000333214576002636016272 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/backends.R \name{read_csv_as_stanfit} \alias{read_csv_as_stanfit} \title{Read CmdStan CSV files as a brms-formatted stanfit object} \usage{ read_csv_as_stanfit( files, variables = NULL, sampler_diagnostics = NULL, model = NULL, exclude = "", algorithm = "sampling" ) } \arguments{ \item{files}{Character vector of CSV files names where draws are stored.} \item{variables}{Character vector of variables to extract from the CSV files.} \item{sampler_diagnostics}{Character vector of sampler diagnostics to extract.} \item{model}{A compiled cmdstanr model object (optional). Provide this argument if you want to allow updating the model without recompilation.} \item{exclude}{Character vector of variables to exclude from the stanfit. Only used when \code{variables} is also specified.} \item{algorithm}{The algorithm with which the model was fitted. See \code{\link{brm}} for details.} } \value{ A stanfit object consistent with the structure of the \code{fit} slot of a brmsfit object. } \description{ \code{read_csv_as_stanfit} is used internally to read CmdStan CSV files into a \code{stanfit} object that is consistent with the structure of the fit slot of a brmsfit object. } \examples{ \dontrun{ # fit a model manually via cmdstanr scode <- stancode(count ~ Trt, data = epilepsy) sdata <- standata(count ~ Trt, data = epilepsy) mod <- cmdstanr::cmdstan_model(cmdstanr::write_stan_file(scode)) stanfit <- mod$sample(data = sdata) # feed the Stan model back into brms fit <- brm(count ~ Trt, data = epilepsy, empty = TRUE, backend = 'cmdstanr') fit$fit <- read_csv_as_stanfit(stanfit$output_files(), model = mod) fit <- rename_pars(fit) summary(fit) } } brms/man/cor_fixed.Rd0000644000176200001440000000151514213413565014227 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/autocor.R \name{cor_fixed} \alias{cor_fixed} \alias{cov_fixed} \title{(Deprecated) Fixed user-defined covariance matrices} \usage{ cor_fixed(V) } \arguments{ \item{V}{Known covariance matrix of the response variable. If a vector is passed, it will be used as diagonal entries (variances) and covariances will be set to zero.} } \value{ An object of class \code{cor_fixed}. } \description{ This function is deprecated. Please see \code{\link{fcor}} for the new syntax. Define a fixed covariance matrix of the response variable for instance to model multivariate effect sizes in meta-analysis. } \examples{ \dontrun{ dat <- data.frame(y = rnorm(3)) V <- cbind(c(0.5, 0.3, 0.2), c(0.3, 1, 0.1), c(0.2, 0.1, 0.2)) fit <- brm(y~1, data = dat, autocor = cor_fixed(V)) } } brms/man/conditional_smooths.brmsfit.Rd0000644000176200001440000001034415053072461020010 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/conditional_smooths.R \name{conditional_smooths.brmsfit} \alias{conditional_smooths.brmsfit} \alias{marginal_smooths} \alias{marginal_smooths.brmsfit} \alias{conditional_smooths} \title{Display Smooth Terms} \usage{ \method{conditional_smooths}{brmsfit}( x, smooths = NULL, int_conditions = NULL, prob = 0.95, spaghetti = FALSE, surface = TRUE, resolution = 100, too_far = 0, ndraws = NULL, draw_ids = NULL, nsamples = NULL, subset = NULL, probs = NULL, ... ) conditional_smooths(x, ...) } \arguments{ \item{x}{An object of class \code{brmsfit}.} \item{smooths}{Optional character vector of smooth terms to display. If \code{NULL} (the default) all smooth terms are shown.} \item{int_conditions}{An optional named \code{list} whose elements are vectors of values of the variables specified in \code{effects}. At these values, predictions are evaluated. The names of \code{int_conditions} have to match the variable names exactly. Additionally, the elements of the vectors may be named themselves, in which case their names appear as labels for the conditions in the plots. Instead of vectors, functions returning vectors may be passed and are applied on the original values of the corresponding variable. If \code{NULL} (the default), predictions are evaluated at the \eqn{mean} and at \eqn{mean +/- sd} for numeric predictors and at all categories for factor-like predictors.} \item{prob}{A value between 0 and 1 indicating the desired probability to be covered by the uncertainty intervals. The default is 0.95.} \item{spaghetti}{Logical. Indicates if predictions should be visualized via spaghetti plots. Only applied for numeric predictors. If \code{TRUE}, it is recommended to set argument \code{ndraws} to a relatively small value (e.g., \code{100}) in order to reduce computation time.} \item{surface}{Logical. Indicates if interactions or two-dimensional smooths should be visualized as a surface. Defaults to \code{TRUE}. The surface type can be controlled via argument \code{stype} of the related plotting method.} \item{resolution}{Number of support points used to generate the plots. Higher resolution leads to smoother plots. Defaults to \code{100}. If \code{surface} is \code{TRUE}, this implies \code{10000} support points for interaction terms, so it might be necessary to reduce \code{resolution} when only few RAM is available.} \item{too_far}{Positive number. For surface plots only: Grid points that are too far away from the actual data points can be excluded from the plot. \code{too_far} determines what is too far. The grid is scaled into the unit square and then grid points more than \code{too_far} from the predictor variables are excluded. By default, all grid points are used. Ignored for non-surface plots.} \item{ndraws}{Positive integer indicating how many posterior draws should be used. If \code{NULL} (the default) all draws are used. Ignored if \code{draw_ids} is not \code{NULL}.} \item{draw_ids}{An integer vector specifying the posterior draws to be used. If \code{NULL} (the default), all draws are used.} \item{nsamples}{Deprecated alias of \code{ndraws}.} \item{subset}{Deprecated alias of \code{draw_ids}.} \item{probs}{(Deprecated) The quantiles to be used in the computation of uncertainty intervals. Please use argument \code{prob} instead.} \item{...}{Currently ignored.} } \value{ For the \code{brmsfit} method, an object of class \code{brms_conditional_effects}. See \code{\link{conditional_effects}} for more details and documentation of the related plotting function. } \description{ Display smooth \code{s} and \code{t2} terms of models fitted with \pkg{brms}. } \details{ Two-dimensional smooth terms will be visualized using either contour or raster plots. } \examples{ \dontrun{ set.seed(0) dat <- mgcv::gamSim(1, n = 200, scale = 2) fit <- brm(y ~ s(x0) + s(x1) + s(x2) + s(x3), data = dat) # show all smooth terms plot(conditional_smooths(fit), rug = TRUE, ask = FALSE) # show only the smooth term s(x2) plot(conditional_smooths(fit, smooths = "s(x2)"), ask = FALSE) # fit and plot a two-dimensional smooth term fit2 <- brm(y ~ t2(x0, x2), data = dat) ms <- conditional_smooths(fit2) plot(ms, stype = "contour") plot(ms, stype = "raster") } } brms/man/cs.Rd0000644000176200001440000000160714224021465012670 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/formula-cs.R \name{cs} \alias{cs} \alias{cse} \title{Category Specific Predictors in \pkg{brms} Models} \usage{ cs(expr) } \arguments{ \item{expr}{Expression containing predictors, for which category specific effects should be estimated. For evaluation, \R formula syntax is applied.} } \description{ Category Specific Predictors in \pkg{brms} Models } \details{ For detailed documentation see \code{help(brmsformula)} as well as \code{vignette("brms_overview")}. This function is almost solely useful when called in formulas passed to the \pkg{brms} package. } \examples{ \dontrun{ fit <- brm(rating ~ period + carry + cs(treat), data = inhaler, family = sratio("cloglog"), prior = set_prior("normal(0,5)"), chains = 2) summary(fit) plot(fit, ask = FALSE) } } \seealso{ \code{\link{brmsformula}} } brms/man/loo_model_weights.brmsfit.Rd0000644000176200001440000000243314213413565017435 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/loo.R \name{loo_model_weights.brmsfit} \alias{loo_model_weights.brmsfit} \alias{loo_model_weights} \title{Model averaging via stacking or pseudo-BMA weighting.} \usage{ \method{loo_model_weights}{brmsfit}(x, ..., model_names = NULL) } \arguments{ \item{x}{A \code{brmsfit} object.} \item{...}{More \code{brmsfit} objects or further arguments passed to the underlying post-processing functions. In particular, see \code{\link{prepare_predictions}} for further supported arguments.} \item{model_names}{If \code{NULL} (the default) will use model names derived from deparsing the call. Otherwise will use the passed values as model names.} } \value{ A named vector of model weights. } \description{ Compute model weights for \code{brmsfit} objects via stacking or pseudo-BMA weighting. For more details, see \code{\link[loo:loo_model_weights]{loo::loo_model_weights}}. } \examples{ \dontrun{ # model with population-level effects only fit1 <- brm(rating ~ treat + period + carry, data = inhaler, family = "gaussian") # model with an additional varying intercept for subjects fit2 <- brm(rating ~ treat + period + carry + (1|subject), data = inhaler, family = "gaussian") loo_model_weights(fit1, fit2) } } brms/man/standata.brmsfit.Rd0000644000176200001440000000336115053072461015531 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/standata.R \name{standata.brmsfit} \alias{standata.brmsfit} \title{Extract data passed to Stan from \code{brmsfit} objects} \usage{ \method{standata}{brmsfit}( object, newdata = NULL, re_formula = NULL, newdata2 = NULL, new_objects = NULL, incl_autocor = TRUE, ... ) } \arguments{ \item{object}{An object of class \code{brmsfit}.} \item{newdata}{An optional data.frame for which to evaluate predictions. If \code{NULL} (default), the original data of the model is used. \code{NA} values within factors (excluding grouping variables) are interpreted as if all dummy variables of this factor are zero. This allows, for instance, to make predictions of the grand mean when using sum coding. \code{NA} values within grouping variables are treated as a new level.} \item{re_formula}{formula containing group-level effects to be considered in the prediction. If \code{NULL} (default), include all group-level effects; if \code{NA} or \code{~0}, include no group-level effects.} \item{newdata2}{A named \code{list} of objects containing new data, which cannot be passed via argument \code{newdata}. Required for some objects used in autocorrelation structures, or \code{\link{stanvars}}.} \item{new_objects}{Deprecated alias of \code{newdata2}.} \item{incl_autocor}{A flag indicating if correlation structures originally specified via \code{autocor} should be included in the predictions. Defaults to \code{TRUE}.} \item{...}{More arguments passed to \code{\link[brms:standata.default]{standata.default}}. and \code{\link{validate_newdata}}.} } \value{ A named list containing the data passed to Stan. } \description{ Extract all data that was used by Stan to fit a \pkg{brms} model. } brms/man/create_priorsense_data.brmsfit.Rd0000644000176200001440000000271615053072461020442 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/priorsense.R \name{create_priorsense_data.brmsfit} \alias{create_priorsense_data.brmsfit} \title{Prior sensitivity: Create priorsense data} \usage{ create_priorsense_data.brmsfit(x, ...) } \arguments{ \item{x}{A \code{brmsfit} object.} \item{...}{Additional arguments passed to \code{\link{log_lik}}, for example \code{newdata}.} } \value{ A \code{priorsense_data} object to be used in conjunction with the \pkg{priorsense} package. } \description{ The \code{create_priorsense_data.brmsfit} method can be used to create the data structure needed by the \pkg{priorsense} package for performing power-scaling sensitivity analysis. This method is called automatically when performing powerscaling via \code{\link[priorsense:powerscale]{powerscale}} or other related functions, so you will rarely need to call it manually yourself. } \examples{ \dontrun{ # fit a model with non-uniform priors fit <- brm(rating ~ treat + period + carry, data = inhaler, family = sratio(), prior = set_prior("normal(0, 0.5)")) summary(fit) # The following code requires the 'priorsense' package to be installed: library(priorsense) # perform power-scaling of the prior powerscale(fit, alpha = 1.5, component = "prior") # perform power-scaling sensitivity checks powerscale_sensitivity(fit) # create power-scaling sensitivity plots (for one variable) powerscale_plot_dens(fit, variable = "b_treat") } } brms/man/AsymLaplace.Rd0000644000176200001440000000266514275436221014471 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/distributions.R \name{AsymLaplace} \alias{AsymLaplace} \alias{dasym_laplace} \alias{pasym_laplace} \alias{qasym_laplace} \alias{rasym_laplace} \title{The Asymmetric Laplace Distribution} \usage{ dasym_laplace(x, mu = 0, sigma = 1, quantile = 0.5, log = FALSE) pasym_laplace( q, mu = 0, sigma = 1, quantile = 0.5, lower.tail = TRUE, log.p = FALSE ) qasym_laplace( p, mu = 0, sigma = 1, quantile = 0.5, lower.tail = TRUE, log.p = FALSE ) rasym_laplace(n, mu = 0, sigma = 1, quantile = 0.5) } \arguments{ \item{x, q}{Vector of quantiles.} \item{mu}{Vector of locations.} \item{sigma}{Vector of scales.} \item{quantile}{Asymmetry parameter corresponding to quantiles in quantile regression (hence the name).} \item{log}{Logical; If \code{TRUE}, values are returned on the log scale.} \item{lower.tail}{Logical; If \code{TRUE} (default), return P(X <= x). Else, return P(X > x) .} \item{log.p}{Logical; If \code{TRUE}, values are returned on the log scale.} \item{p}{Vector of probabilities.} \item{n}{Number of draws to sample from the distribution.} } \description{ Density, distribution function, quantile function and random generation for the asymmetric Laplace distribution with location \code{mu}, scale \code{sigma} and asymmetry parameter \code{quantile}. } \details{ See \code{vignette("brms_families")} for details on the parameterization. } brms/man/vcov.brmsfit.Rd0000644000176200001440000000207414213413565014710 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/brmsfit-methods.R \name{vcov.brmsfit} \alias{vcov.brmsfit} \title{Covariance and Correlation Matrix of Population-Level Effects} \usage{ \method{vcov}{brmsfit}(object, correlation = FALSE, pars = NULL, ...) } \arguments{ \item{object}{An object of class \code{brmsfit}.} \item{correlation}{Logical; if \code{FALSE} (the default), compute the covariance matrix, if \code{TRUE}, compute the correlation matrix.} \item{pars}{Optional names of coefficients to extract. By default, all coefficients are extracted.} \item{...}{Currently ignored.} } \value{ covariance or correlation matrix of population-level parameters } \description{ Get a point estimate of the covariance or correlation matrix of population-level parameters } \details{ Estimates are obtained by calculating the maximum likelihood covariances (correlations) of the posterior draws. } \examples{ \dontrun{ fit <- brm(count ~ zAge + zBase * Trt + (1+Trt|visit), data = epilepsy, family = gaussian(), chains = 2) vcov(fit) } } brms/man/hypothesis.brmsfit.Rd0000644000176200001440000001676015057500075016141 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/hypothesis.R \name{hypothesis.brmsfit} \alias{hypothesis.brmsfit} \alias{hypothesis} \alias{hypothesis.default} \title{Non-Linear Hypothesis Testing} \usage{ \method{hypothesis}{brmsfit}( x, hypothesis, class = "b", group = "", scope = c("standard", "ranef", "coef"), alpha = 0.05, robust = FALSE, seed = NULL, ... ) hypothesis(x, ...) \method{hypothesis}{default}(x, hypothesis, alpha = 0.05, robust = FALSE, ...) } \arguments{ \item{x}{An \code{R} object. If it is no \code{brmsfit} object, it must be coercible to a \code{data.frame}. In the latter case, the variables used in the \code{hypothesis} argument need to correspond to column names of \code{x}, while the rows are treated as representing posterior draws of the variables.} \item{hypothesis}{A character vector specifying one or more non-linear hypothesis concerning parameters of the model.} \item{class}{A string specifying the class of parameters being tested. Default is "b" for population-level effects. Other typical options are "sd" or "cor". If \code{class = NULL}, all parameters can be tested against each other, but have to be specified with their full name (see also \code{\link[brms:draws-index-brms]{variables}})} \item{group}{Name of a grouping factor to evaluate only group-level effects parameters related to this grouping factor.} \item{scope}{Indicates where to look for the variables specified in \code{hypothesis}. If \code{"standard"}, use the full parameter names (subject to the restriction given by \code{class} and \code{group}). If \code{"coef"} or \code{"ranef"}, compute the hypothesis for all levels of the grouping factor given in \code{"group"}, based on the output of \code{\link{coef.brmsfit}} and \code{\link{ranef.brmsfit}}, respectively.} \item{alpha}{The alpha-level of the tests (default is 0.05; see 'Details' for more information).} \item{robust}{If \code{FALSE} (the default) the mean is used as the measure of central tendency and the standard deviation as the measure of variability. If \code{TRUE}, the median and the median absolute deviation (MAD) are applied instead.} \item{seed}{A single numeric value passed to \code{\link{set.seed}} to make results reproducible. This is currently only relevant for point hypotheses that scope over at least two parameters (see Details).} \item{...}{Currently ignored.} } \value{ A \code{\link{brmshypothesis}} object. } \description{ Perform non-linear hypothesis testing for all model parameters. } \details{ Among others, \code{hypothesis} computes an evidence ratio (\code{Evid.Ratio}) for each hypothesis. For a one-sided hypothesis, this is just the posterior probability (\code{Post.Prob}) under the hypothesis against its alternative. That is, when the hypothesis is of the form \code{a > b}, the evidence ratio is the ratio of the posterior probability of \code{a > b} and the posterior probability of \code{a < b}. In this example, values greater than one indicate that the evidence in favor of \code{a > b} is larger than evidence in favor of \code{a < b}. For a two-sided (point) hypothesis, the evidence ratio is a Bayes factor between the hypothesis and its alternative computed via the Savage-Dickey density ratio method. That is the posterior density at the point of interest divided by the prior density at that point. Values greater than one indicate that evidence in favor of the point hypothesis has increased after seeing the data. In order to calculate this Bayes factor, all parameters related to the hypothesis must have proper priors and argument \code{sample_prior} of function \code{brm} must be set to \code{"yes"}. Otherwise \code{Evid.Ratio} (and \code{Post.Prob}) will be \code{NA}. Please note that the Savage-Dickey density ratio as implemented here provides only a very basic test of point hypotheses. It is recommended that you use bridge sampling instead (via \code{\link{bayes_factor}} which relies on the \pkg{bridgesampling} package). When interpreting Bayes factors for point hypotheses, make sure that your priors are reasonable and carefully chosen, as the result will depend heavily on the priors. In particular, avoid using default priors. Additionally, note that point hypotheses that scope over more than one parameter (e.g., when testing equality between two parameters) involve random sampling of the priors over those parameters (to accommodate the the assumption that priors for different parameters are independent of each other). This introduces an element of randomness into such hypothesis tests. Consider repeating the test to assure results are sufficiently stable, and use the argument \code{seed} for reproducibility. Finally, note that, for technical reasons, we cannot sample from priors of certain parameters classes. Most notably, these include overall intercept parameters (prior class \code{"Intercept"}) as well as group-level coefficients. For one-sided hypotheses, the \code{Evid.Ratio} may sometimes be \code{0} or \code{Inf} implying very small or large evidence, respectively, in favor of the tested hypothesis. For one-sided hypotheses pairs, this basically means that all posterior draws are on the same side of the value dividing the two hypotheses. In that sense, instead of \code{0} or \code{Inf,} you may rather read it as \code{Evid.Ratio} smaller \code{1 / S} or greater \code{S}, respectively, where \code{S} denotes the number of posterior draws used in the computations. The argument \code{alpha} specifies the size of the credible interval (i.e., Bayesian confidence interval). For instance, if we tested a two-sided hypothesis and set \code{alpha = 0.05} (5\%) an, the credible interval will contain \code{1 - alpha = 0.95} (95\%) of the posterior values. Hence, \code{alpha * 100}\% of the posterior values will lie outside of the credible interval. Although this allows testing of hypotheses in a similar manner as in the frequentist null-hypothesis testing framework, we strongly argue against using arbitrary cutoffs (e.g., \code{p < .05}) to determine the 'existence' of an effect. } \examples{ \dontrun{ ## define priors prior <- c(set_prior("normal(0,2)", class = "b"), set_prior("student_t(10,0,1)", class = "sigma"), set_prior("student_t(10,0,1)", class = "sd")) ## fit a linear mixed effects models fit <- brm(time ~ age + sex + disease + (1 + age|patient), data = kidney, family = lognormal(), prior = prior, sample_prior = "yes", control = list(adapt_delta = 0.95)) ## perform two-sided hypothesis testing (hyp1 <- hypothesis(fit, "sexfemale = age + diseasePKD")) plot(hyp1) hypothesis(fit, "exp(age) - 3 = 0", alpha = 0.01) ## perform one-sided hypothesis testing hypothesis(fit, "diseasePKD + diseaseGN - 3 < 0") hypothesis(fit, "age < Intercept", class = "sd", group = "patient") ## test the amount of random intercept variance on all variance h <- paste("sd_patient__Intercept^2 / (sd_patient__Intercept^2 +", "sd_patient__age^2 + sigma^2) = 0") (hyp2 <- hypothesis(fit, h, class = NULL)) plot(hyp2) ## test more than one hypothesis at once h <- c("diseaseGN = diseaseAN", "2 * diseaseGN - diseasePKD = 0") (hyp3 <- hypothesis(fit, h)) plot(hyp3, ignore_prior = TRUE) ## compute hypotheses for all levels of a grouping factor hypothesis(fit, "age = 0", scope = "coef", group = "patient") ## use the default method dat <- as.data.frame(fit) str(dat) hypothesis(dat, "b_age > 0") } } \seealso{ \code{\link{brmshypothesis}} } brms/man/mi.Rd0000644000176200001440000000404515053305627012675 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/formula-sp.R \name{mi} \alias{mi} \title{Predictors with Missing Values in \pkg{brms} Models} \usage{ mi(x, idx = NA) } \arguments{ \item{x}{The variable containing missing values.} \item{idx}{An optional variable containing indices of observations in `x` that are to be used in the model. This is mostly relevant in partially subsetted models (via \code{resp_subset}) but may also have other applications that I haven't thought of.} } \description{ Specify predictor term with missing values in \pkg{brms}. The function does not evaluate its arguments -- it exists purely to help set up a model. For documentation on how to specify missing values in response variables, see \code{\link{resp_mi}}. } \details{ For detailed documentation see \code{help(brmsformula)}. } \examples{ \dontrun{ data("nhanes", package = "mice") N <- nrow(nhanes) # simple model with missing data bform1 <- bf(bmi | mi() ~ age * mi(chl)) + bf(chl | mi() ~ age) + set_rescor(FALSE) fit1 <- brm(bform1, data = nhanes) summary(fit1) plot(conditional_effects(fit1, resp = "bmi"), ask = FALSE) loo(fit1, newdata = na.omit(fit1$data)) # simulate some measurement noise nhanes$se <- rexp(N, 2) # measurement noise can be handled within 'mi' terms # with or without the presence of missing values bform2 <- bf(bmi | mi() ~ age * mi(chl)) + bf(chl | mi(se) ~ age) + set_rescor(FALSE) fit2 <- brm(bform2, data = nhanes) summary(fit2) plot(conditional_effects(fit2, resp = "bmi"), ask = FALSE) # 'mi' terms can also be used when some responses are subsetted nhanes$sub <- TRUE nhanes$sub[1:2] <- FALSE nhanes$id <- 1:N nhanes$idx <- sample(3:N, N, TRUE) # this requires the addition term 'index' being specified # in the subsetted part of the model bform3 <- bf(bmi | mi() ~ age * mi(chl, idx)) + bf(chl | mi(se) + subset(sub) + index(id) ~ age) + set_rescor(FALSE) fit3 <- brm(bform3, data = nhanes) summary(fit3) plot(conditional_effects(fit3, resp = "bmi"), ask = FALSE) } } \seealso{ \code{\link{brmsformula}} } brms/man/predict.brmsfit.Rd0000644000176200001440000001146315053072461015366 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/posterior_predict.R \name{predict.brmsfit} \alias{predict.brmsfit} \title{Draws from the Posterior Predictive Distribution} \usage{ \method{predict}{brmsfit}( object, newdata = NULL, re_formula = NULL, transform = NULL, resp = NULL, negative_rt = FALSE, ndraws = NULL, draw_ids = NULL, sort = FALSE, ntrys = 5, cores = NULL, summary = TRUE, robust = FALSE, probs = c(0.025, 0.975), ... ) } \arguments{ \item{object}{An object of class \code{brmsfit}.} \item{newdata}{An optional data.frame for which to evaluate predictions. If \code{NULL} (default), the original data of the model is used. \code{NA} values within factors (excluding grouping variables) are interpreted as if all dummy variables of this factor are zero. This allows, for instance, to make predictions of the grand mean when using sum coding. \code{NA} values within grouping variables are treated as a new level.} \item{re_formula}{formula containing group-level effects to be considered in the prediction. If \code{NULL} (default), include all group-level effects; if \code{NA} or \code{~0}, include no group-level effects.} \item{transform}{(Deprecated) A function or a character string naming a function to be applied on the predicted responses before summary statistics are computed.} \item{resp}{Optional names of response variables. If specified, predictions are performed only for the specified response variables.} \item{negative_rt}{Only relevant for Wiener diffusion models. A flag indicating whether response times of responses on the lower boundary should be returned as negative values. This allows to distinguish responses on the upper and lower boundary. Defaults to \code{FALSE}.} \item{ndraws}{Positive integer indicating how many posterior draws should be used. If \code{NULL} (the default) all draws are used. Ignored if \code{draw_ids} is not \code{NULL}.} \item{draw_ids}{An integer vector specifying the posterior draws to be used. If \code{NULL} (the default), all draws are used.} \item{sort}{Logical. Only relevant for time series models. Indicating whether to return predicted values in the original order (\code{FALSE}; default) or in the order of the time series (\code{TRUE}).} \item{ntrys}{Parameter used in rejection sampling for truncated discrete models only (defaults to \code{5}). See Details for more information.} \item{cores}{Number of cores (defaults to \code{1}). On non-Windows systems, this argument can be set globally via the \code{mc.cores} option.} \item{summary}{Should summary statistics be returned instead of the raw values? Default is \code{TRUE}.} \item{robust}{If \code{FALSE} (the default) the mean is used as the measure of central tendency and the standard deviation as the measure of variability. If \code{TRUE}, the median and the median absolute deviation (MAD) are applied instead. Only used if \code{summary} is \code{TRUE}.} \item{probs}{The percentiles to be computed by the \code{quantile} function. Only used if \code{summary} is \code{TRUE}.} \item{...}{Further arguments passed to \code{\link{prepare_predictions}} that control several aspects of data validation and prediction.} } \value{ An \code{array} of predicted response values. If \code{summary = FALSE} the output resembles those of \code{\link{posterior_predict.brmsfit}}. If \code{summary = TRUE} the output depends on the family: For categorical and ordinal families, the output is an N x C matrix, where N is the number of observations, C is the number of categories, and the values are predicted category probabilities. For all other families, the output is a N x E matrix where E = \code{2 + length(probs)} is the number of summary statistics: The \code{Estimate} column contains point estimates (either mean or median depending on argument \code{robust}), while the \code{Est.Error} column contains uncertainty estimates (either standard deviation or median absolute deviation depending on argument \code{robust}). The remaining columns starting with \code{Q} contain quantile estimates as specified via argument \code{probs}. } \description{ This method is an alias of \code{\link{posterior_predict.brmsfit}} with additional arguments for obtaining summaries of the computed draws. } \examples{ \dontrun{ ## fit a model fit <- brm(time | cens(censored) ~ age + sex + (1 + age || patient), data = kidney, family = "exponential", init = "0") ## predicted responses pp <- predict(fit) head(pp) ## predicted responses excluding the group-level effect of age pp <- predict(fit, re_formula = ~ (1 | patient)) head(pp) ## predicted responses of patient 1 for new data newdata <- data.frame( sex = factor(c("male", "female")), age = c(20, 50), patient = c(1, 1) ) predict(fit, newdata = newdata) } } \seealso{ \code{\link{posterior_predict.brmsfit}} } brms/man/update_adterms.Rd0000644000176200001440000000202213565500267015265 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/brmsformula.R \name{update_adterms} \alias{update_adterms} \title{Update Formula Addition Terms} \usage{ update_adterms(formula, adform, action = c("update", "replace")) } \arguments{ \item{formula}{Two-sided formula to be updated.} \item{adform}{One-sided formula containing addition terms to update \code{formula} with.} \item{action}{Indicates what should happen to the existing addition terms in \code{formula}. If \code{"update"} (the default), old addition terms that have no corresponding term in \code{adform} will be kept. If \code{"replace"}, all old addition terms will be removed.} } \value{ An object of class \code{formula}. } \description{ Update additions terms used in formulas of \pkg{brms}. See \code{\link{addition-terms}} for details. } \examples{ form <- y | trials(size) ~ x update_adterms(form, ~ trials(10)) update_adterms(form, ~ weights(w)) update_adterms(form, ~ weights(w), action = "replace") update_adterms(y ~ x, ~ trials(10)) } brms/man/lasso.Rd0000644000176200001440000000152614424715563013417 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/priors.R \name{lasso} \alias{lasso} \title{(Defunct) Set up a lasso prior in \pkg{brms}} \usage{ lasso(df = 1, scale = 1) } \arguments{ \item{df}{Degrees of freedom of the chi-square prior of the inverse tuning parameter. Defaults to \code{1}.} \item{scale}{Scale of the lasso prior. Defaults to \code{1}.} } \value{ An error indicating that the lasso prior is no longer supported. } \description{ This functionality is no longer supported as of brms version 2.19.2. Please use the \code{\link{horseshoe}} or \code{\link{R2D2}} shrinkage priors instead. } \references{ Park, T., & Casella, G. (2008). The Bayesian Lasso. Journal of the American Statistical Association, 103(482), 681-686. } \seealso{ \code{\link{set_prior}}, \code{\link{horseshoe}}, \code{\link{R2D2}} } brms/man/bayes_factor.brmsfit.Rd0000644000176200001440000000420014213413565016365 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/bridgesampling.R \name{bayes_factor.brmsfit} \alias{bayes_factor.brmsfit} \alias{bayes_factor} \title{Bayes Factors from Marginal Likelihoods} \usage{ \method{bayes_factor}{brmsfit}(x1, x2, log = FALSE, ...) } \arguments{ \item{x1}{A \code{brmsfit} object} \item{x2}{Another \code{brmsfit} object based on the same responses.} \item{log}{Report Bayes factors on the log-scale?} \item{...}{Additional arguments passed to \code{\link[brms:bridge_sampler.brmsfit]{bridge_sampler}}.} } \description{ Compute Bayes factors from marginal likelihoods. } \details{ Computing the marginal likelihood requires samples of all variables defined in Stan's \code{parameters} block to be saved. Otherwise \code{bayes_factor} cannot be computed. Thus, please set \code{save_all_pars = TRUE} in the call to \code{brm}, if you are planning to apply \code{bayes_factor} to your models. The computation of Bayes factors based on bridge sampling requires a lot more posterior samples than usual. A good conservative rule of thumb is perhaps 10-fold more samples (read: the default of 4000 samples may not be enough in many cases). If not enough posterior samples are provided, the bridge sampling algorithm tends to be unstable, leading to considerably different results each time it is run. We thus recommend running \code{bayes_factor} multiple times to check the stability of the results. More details are provided under \code{\link[bridgesampling:bf]{bridgesampling::bayes_factor}}. } \examples{ \dontrun{ # model with the treatment effect fit1 <- brm( count ~ zAge + zBase + Trt, data = epilepsy, family = negbinomial(), prior = prior(normal(0, 1), class = b), save_all_pars = TRUE ) summary(fit1) # model without the treatment effect fit2 <- brm( count ~ zAge + zBase, data = epilepsy, family = negbinomial(), prior = prior(normal(0, 1), class = b), save_all_pars = TRUE ) summary(fit2) # compute the bayes factor bayes_factor(fit1, fit2) } } \seealso{ \code{ \link[brms:bridge_sampler.brmsfit]{bridge_sampler}, \link[brms:post_prob.brmsfit]{post_prob} } } brms/man/psis.brmsfit.Rd0000644000176200001440000000675515053072461014722 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/loo.R \name{psis.brmsfit} \alias{psis.brmsfit} \alias{psis} \title{Pareto smoothed importance sampling (PSIS)} \usage{ \method{psis}{brmsfit}(log_ratios, newdata = NULL, resp = NULL, model_name = NULL, ...) } \arguments{ \item{log_ratios}{A fitted model object of class \code{brmsfit}. Argument is named "log_ratios" to match the argument name of the \code{\link[loo:psis]{loo::psis}} generic function.} \item{newdata}{An optional data.frame for which to evaluate predictions. If \code{NULL} (default), the original data of the model is used. \code{NA} values within factors (excluding grouping variables) are interpreted as if all dummy variables of this factor are zero. This allows, for instance, to make predictions of the grand mean when using sum coding. \code{NA} values within grouping variables are treated as a new level.} \item{resp}{Optional names of response variables. If specified, predictions are performed only for the specified response variables.} \item{model_name}{Currently ignored.} \item{...}{Further arguments passed to \code{\link{log_lik}} and \code{\link[loo:psis]{loo::psis}}.} } \value{ The \code{psis()} methods return an object of class \code{"psis"}, which is a named list with the following components: \describe{ \item{\code{log_weights}}{ Vector or matrix of smoothed (and truncated) but \emph{unnormalized} log weights. To get normalized weights use the \code{\link[loo:weights.importance_sampling]{weights()}} method provided for objects of class \code{"psis"}. } \item{\code{diagnostics}}{ A named list containing two vectors: \itemize{ \item \code{pareto_k}: Estimates of the shape parameter \eqn{k} of the generalized Pareto distribution. See the \link[loo]{pareto-k-diagnostic} page for details. \item \code{n_eff}: PSIS effective sample size estimates. } } } Objects of class \code{"psis"} also have the following \link[=attributes]{attributes}: \describe{ \item{\code{norm_const_log}}{ Vector of precomputed values of \code{colLogSumExps(log_weights)} that are used internally by the \code{weights} method to normalize the log weights. } \item{\code{tail_len}}{ Vector of tail lengths used for fitting the generalized Pareto distribution. } \item{\code{r_eff}}{ If specified, the user's \code{r_eff} argument. } \item{\code{dims}}{ Integer vector of length 2 containing \code{S} (posterior sample size) and \code{N} (number of observations). } \item{\code{method}}{ Method used for importance sampling, here \code{psis}. } } } \description{ Implementation of Pareto smoothed importance sampling (PSIS), a method for stabilizing importance ratios. The version of PSIS implemented here corresponds to the algorithm presented in Vehtari, Simpson, Gelman, Yao, and Gabry (2024). For PSIS diagnostics see the \link[loo]{pareto-k-diagnostic} page. } \examples{ \dontrun{ fit <- brm(rating ~ treat + period + carry, data = inhaler) psis(fit) } } \references{ Vehtari, A., Gelman, A., and Gabry, J. (2017). Practical Bayesian model evaluation using leave-one-out cross-validation and WAIC. \emph{Statistics and Computing}. 27(5), 1413--1432. doi:10.1007/s11222-016-9696-4 (\href{https://link.springer.com/article/10.1007/s11222-016-9696-4}{journal version}, \href{https://arxiv.org/abs/1507.04544}{preprint arXiv:1507.04544}). Vehtari, A., Simpson, D., Gelman, A., Yao, Y., and Gabry, J. (2024). Pareto smoothed importance sampling. \emph{Journal of Machine Learning Research}, 25(72):1-58. \href{https://jmlr.org/papers/v25/19-556.html}{PDF} } brms/man/pairs.brmsfit.Rd0000644000176200001440000000307014213413565015046 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/plot.R \name{pairs.brmsfit} \alias{pairs.brmsfit} \title{Create a matrix of output plots from a \code{brmsfit} object} \usage{ \method{pairs}{brmsfit}(x, pars = NA, variable = NULL, regex = FALSE, fixed = FALSE, ...) } \arguments{ \item{x}{An object of class \code{brmsfit}} \item{pars}{Deprecated alias of \code{variable}. Names of the parameters to plot, as given by a character vector or a regular expression.} \item{variable}{Names of the variables (parameters) to plot, as given by a character vector or a regular expression (if \code{regex = TRUE}). By default, a hopefully not too large selection of variables is plotted.} \item{regex}{Logical; Indicates whether \code{variable} should be treated as regular expressions. Defaults to \code{FALSE}.} \item{fixed}{(Deprecated) Indicates whether parameter names should be matched exactly (\code{TRUE}) or treated as regular expressions (\code{FALSE}). Default is \code{FALSE} and only works with argument \code{pars}.} \item{...}{Further arguments to be passed to \code{\link[bayesplot:MCMC-scatterplots]{mcmc_pairs}}.} } \description{ A \code{\link[graphics:pairs]{pairs}} method that is customized for MCMC output. } \details{ For a detailed description see \code{\link[bayesplot:MCMC-scatterplots]{mcmc_pairs}}. } \examples{ \dontrun{ fit <- brm(count ~ zAge + zBase * Trt + (1|patient) + (1|visit), data = epilepsy, family = "poisson") pairs(fit, variable = variables(fit)[1:3]) pairs(fit, variable = "^sd_", regex = TRUE) } } brms/man/predictive_interval.brmsfit.Rd0000644000176200001440000000161714160105076017773 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/posterior_predict.R \name{predictive_interval.brmsfit} \alias{predictive_interval.brmsfit} \alias{predictive_interval} \title{Predictive Intervals} \usage{ \method{predictive_interval}{brmsfit}(object, prob = 0.9, ...) } \arguments{ \item{object}{An \R object of class \code{brmsfit}.} \item{prob}{A number p (0 < p < 1) indicating the desired probability mass to include in the intervals. Defaults to \code{0.9}.} \item{...}{Further arguments passed to \code{\link{posterior_predict}}.} } \value{ A matrix with 2 columns for the lower and upper bounds of the intervals, respectively, and as many rows as observations being predicted. } \description{ Compute intervals from the posterior predictive distribution. } \examples{ \dontrun{ fit <- brm(count ~ zBase, data = epilepsy, family = poisson()) predictive_interval(fit) } } brms/man/logit_scaled.Rd0000644000176200001440000000070514160105076014712 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/numeric-helpers.R \name{logit_scaled} \alias{logit_scaled} \title{Scaled logit-link} \usage{ logit_scaled(x, lb = 0, ub = 1) } \arguments{ \item{x}{A numeric or complex vector.} \item{lb}{Lower bound defaulting to \code{0}.} \item{ub}{Upper bound defaulting to \code{1}.} } \value{ A numeric or complex vector. } \description{ Computes \code{logit((x - lb) / (ub - lb))} } brms/man/conditional_effects.brmsfit.Rd0000644000176200001440000003162615053072461017741 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/conditional_effects.R \name{conditional_effects.brmsfit} \alias{conditional_effects.brmsfit} \alias{marginal_effects} \alias{marginal_effects.brmsfit} \alias{conditional_effects} \alias{plot.brms_conditional_effects} \title{Display Conditional Effects of Predictors} \usage{ \method{conditional_effects}{brmsfit}( x, effects = NULL, conditions = NULL, int_conditions = NULL, re_formula = NA, prob = 0.95, robust = TRUE, method = "posterior_epred", spaghetti = FALSE, surface = FALSE, categorical = FALSE, ordinal = FALSE, transform = NULL, resolution = 100, select_points = 0, too_far = 0, probs = NULL, ... ) conditional_effects(x, ...) \method{plot}{brms_conditional_effects}( x, ncol = NULL, points = getOption("brms.plot_points", FALSE), rug = getOption("brms.plot_rug", FALSE), mean = TRUE, jitter_width = 0, stype = c("contour", "raster"), line_args = list(), cat_args = list(), errorbar_args = list(), surface_args = list(), spaghetti_args = list(), point_args = list(), rug_args = list(), facet_args = list(), theme = NULL, ask = TRUE, plot = TRUE, ... ) } \arguments{ \item{x}{An object of class \code{brmsfit}.} \item{effects}{An optional character vector naming effects (main effects or interactions) for which to compute conditional plots. Interactions are specified by a \code{:} between variable names. If \code{NULL} (the default), plots are generated for all main effects and two-way interactions estimated in the model. When specifying \code{effects} manually, \emph{all} two-way interactions (including grouping variables) may be plotted even if not originally modeled.} \item{conditions}{An optional \code{data.frame} containing variable values to condition on. Each effect defined in \code{effects} will be plotted separately for each row of \code{conditions}. Values in the \code{cond__} column will be used as titles of the subplots. If \code{cond__} is not given, the row names will be used for this purpose instead. It is recommended to only define a few rows in order to keep the plots clear. See \code{\link{make_conditions}} for an easy way to define conditions. If \code{NULL} (the default), numeric variables will be conditionalized by using their means and factors will get their first level assigned. \code{NA} values within factors are interpreted as if all dummy variables of this factor are zero. This allows, for instance, to make predictions of the grand mean when using sum coding.} \item{int_conditions}{An optional named \code{list} whose elements are vectors of values of the variables specified in \code{effects}. At these values, predictions are evaluated. The names of \code{int_conditions} have to match the variable names exactly. Additionally, the elements of the vectors may be named themselves, in which case their names appear as labels for the conditions in the plots. Instead of vectors, functions returning vectors may be passed and are applied on the original values of the corresponding variable. If \code{NULL} (the default), predictions are evaluated at the \eqn{mean} and at \eqn{mean +/- sd} for numeric predictors and at all categories for factor-like predictors.} \item{re_formula}{A formula containing group-level effects to be considered in the conditional predictions. If \code{NULL}, include all group-level effects; if \code{NA} (default), include no group-level effects.} \item{prob}{A value between 0 and 1 indicating the desired probability to be covered by the uncertainty intervals. The default is 0.95.} \item{robust}{If \code{TRUE} (the default) the median is used as the measure of central tendency. If \code{FALSE} the mean is used instead.} \item{method}{Method used to obtain predictions. Can be set to \code{"posterior_epred"} (the default), \code{"posterior_predict"}, or \code{"posterior_linpred"}. For more details, see the respective function documentations.} \item{spaghetti}{Logical. Indicates if predictions should be visualized via spaghetti plots. Only applied for numeric predictors. If \code{TRUE}, it is recommended to set argument \code{ndraws} to a relatively small value (e.g., \code{100}) in order to reduce computation time.} \item{surface}{Logical. Indicates if interactions or two-dimensional smooths should be visualized as a surface. Defaults to \code{FALSE}. The surface type can be controlled via argument \code{stype} of the related plotting method.} \item{categorical}{Logical. Indicates if effects of categorical or ordinal models should be shown in terms of probabilities of response categories. Defaults to \code{FALSE}.} \item{ordinal}{(Deprecated) Please use argument \code{categorical}. Logical. Indicates if effects in ordinal models should be visualized as a raster with the response categories on the y-axis. Defaults to \code{FALSE}.} \item{transform}{A function or a character string naming a function to be applied on the predicted responses before summary statistics are computed. Only allowed if \code{method = "posterior_predict"}.} \item{resolution}{Number of support points used to generate the plots. Higher resolution leads to smoother plots. Defaults to \code{100}. If \code{surface} is \code{TRUE}, this implies \code{10000} support points for interaction terms, so it might be necessary to reduce \code{resolution} when only few RAM is available.} \item{select_points}{Positive number. Only relevant if \code{points} or \code{rug} are set to \code{TRUE}: Actual data points of numeric variables that are too far away from the values specified in \code{conditions} can be excluded from the plot. Values are scaled into the unit interval and then points more than \code{select_points} from the values in \code{conditions} are excluded. By default, all points are used.} \item{too_far}{Positive number. For surface plots only: Grid points that are too far away from the actual data points can be excluded from the plot. \code{too_far} determines what is too far. The grid is scaled into the unit square and then grid points more than \code{too_far} from the predictor variables are excluded. By default, all grid points are used. Ignored for non-surface plots.} \item{probs}{(Deprecated) The quantiles to be used in the computation of uncertainty intervals. Please use argument \code{prob} instead.} \item{...}{Further arguments such as \code{draw_ids} or \code{ndraws} passed to \code{\link{posterior_predict}} or \code{\link{posterior_epred}}.} \item{ncol}{Number of plots to display per column for each effect. If \code{NULL} (default), \code{ncol} is computed internally based on the number of rows of \code{conditions}.} \item{points}{Logical. Indicates if the original data points should be added via \code{\link[ggplot2:geom_jitter]{geom_jitter}}. Default is \code{FALSE}. Can be controlled globally via the \code{brms.plot_points} option. Note that only those data points will be added that match the specified conditions defined in \code{conditions}. For categorical predictors, the conditions have to match exactly. For numeric predictors, argument \code{select_points} is used to determine, which points do match a condition.} \item{rug}{Logical. Indicates if a rug representation of predictor values should be added via \code{\link[ggplot2:geom_rug]{geom_rug}}. Default is \code{FALSE}. Depends on \code{select_points} in the same way as \code{points} does. Can be controlled globally via the \code{brms.plot_rug} option.} \item{mean}{Logical. Only relevant for spaghetti plots. If \code{TRUE} (the default), display the mean regression line on top of the regression lines for each sample.} \item{jitter_width}{Only used if \code{points = TRUE}: Amount of horizontal jittering of the data points. Mainly useful for ordinal models. Defaults to \code{0} that is no jittering.} \item{stype}{Indicates how surface plots should be displayed. Either \code{"contour"} or \code{"raster"}.} \item{line_args}{Only used in plots of continuous predictors: A named list of arguments passed to \code{\link[ggplot2:geom_smooth]{geom_smooth}}.} \item{cat_args}{Only used in plots of categorical predictors: A named list of arguments passed to \code{\link[ggplot2:geom_point]{geom_point}}.} \item{errorbar_args}{Only used in plots of categorical predictors: A named list of arguments passed to \code{\link[ggplot2:geom_errorbar]{geom_errorbar}}.} \item{surface_args}{Only used in surface plots: A named list of arguments passed to \code{\link[ggplot2:geom_contour]{geom_contour}} or \code{\link[ggplot2:geom_raster]{geom_raster}} (depending on argument \code{stype}).} \item{spaghetti_args}{Only used in spaghetti plots: A named list of arguments passed to \code{\link[ggplot2:geom_smooth]{geom_smooth}}.} \item{point_args}{Only used if \code{points = TRUE}: A named list of arguments passed to \code{\link[ggplot2:geom_jitter]{geom_jitter}}.} \item{rug_args}{Only used if \code{rug = TRUE}: A named list of arguments passed to \code{\link[ggplot2:geom_rug]{geom_rug}}.} \item{facet_args}{Only used if if multiple conditions are provided: A named list of arguments passed to \code{\link[ggplot2:facet_wrap]{facet_wrap}}.} \item{theme}{A \code{\link[ggplot2:theme]{theme}} object modifying the appearance of the plots. For some basic themes see \code{\link[ggplot2:ggtheme]{ggtheme}} and \code{\link[bayesplot:theme_default]{theme_default}}.} \item{ask}{Logical; indicates if the user is prompted before a new page is plotted. Only used if \code{plot} is \code{TRUE}.} \item{plot}{Logical; indicates if plots should be plotted directly in the active graphic device. Defaults to \code{TRUE}.} } \value{ An object of class \code{'brms_conditional_effects'} which is a named list with one data.frame per effect containing all information required to generate conditional effects plots. Among others, these data.frames contain some special variables, namely \code{estimate__} (predicted values of the response), \code{se__} (standard error of the predicted response), \code{lower__} and \code{upper__} (lower and upper bounds of the uncertainty interval of the response), as well as \code{cond__} (used in faceting when \code{conditions} contains multiple rows). The corresponding \code{plot} method returns a named list of \code{\link[ggplot2:ggplot]{ggplot}} objects, which can be further customized using the \pkg{ggplot2} package. } \description{ Display conditional effects of one or more numeric and/or categorical predictors including two-way interaction effects. } \details{ When creating \code{conditional_effects} for a particular predictor (or interaction of two predictors), one has to choose the values of all other predictors to condition on. By default, the mean is used for continuous variables and the reference category is used for factors, but you may change these values via argument \code{conditions}. This also has an implication for the \code{points} argument: In the created plots, only those points will be shown that correspond to the factor levels actually used in the conditioning, in order not to create the false impression of bad model fit, where it is just due to conditioning on certain factor levels. To fully change colors of the created plots, one has to amend both \code{scale_colour} and \code{scale_fill}. See \code{\link[ggplot2:scale_color_grey]{scale_colour_grey}} or \code{\link[ggplot2:scale_color_gradient]{scale_colour_gradient}} for more details. } \examples{ \dontrun{ fit <- brm(count ~ zAge + zBase * Trt + (1 | patient), data = epilepsy, family = poisson()) ## plot all conditional effects plot(conditional_effects(fit), ask = FALSE) ## change colours to grey scale library(ggplot2) ce <- conditional_effects(fit, "zBase:Trt") plot(ce, plot = FALSE)[[1]] + scale_color_grey() + scale_fill_grey() ## only plot the conditional interaction effect of 'zBase:Trt' ## for different values for 'zAge' conditions <- data.frame(zAge = c(-1, 0, 1)) plot(conditional_effects(fit, effects = "zBase:Trt", conditions = conditions)) ## also incorporate group-level effects variance over patients ## also add data points and a rug representation of predictor values plot(conditional_effects(fit, effects = "zBase:Trt", conditions = conditions, re_formula = NULL), points = TRUE, rug = TRUE) ## change handling of two-way interactions int_conditions <- list( zBase = setNames(c(-2, 1, 0), c("b", "c", "a")) ) conditional_effects(fit, effects = "Trt:zBase", int_conditions = int_conditions) conditional_effects(fit, effects = "Trt:zBase", int_conditions = list(zBase = quantile)) ## fit a model to illustrate how to plot 3-way interactions fit3way <- brm(count ~ zAge * zBase * Trt, data = epilepsy) conditions <- make_conditions(fit3way, "zAge") conditional_effects(fit3way, "zBase:Trt", conditions = conditions) ## only include points close to the specified values of zAge ce <- conditional_effects( fit3way, "zBase:Trt", conditions = conditions, select_points = 0.1 ) plot(ce, points = TRUE) } } brms/man/post_prob.brmsfit.Rd0000644000176200001440000000533114213413565015741 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/bridgesampling.R \name{post_prob.brmsfit} \alias{post_prob.brmsfit} \alias{post_prob} \title{Posterior Model Probabilities from Marginal Likelihoods} \usage{ \method{post_prob}{brmsfit}(x, ..., prior_prob = NULL, model_names = NULL) } \arguments{ \item{x}{A \code{brmsfit} object.} \item{...}{More \code{brmsfit} objects or further arguments passed to the underlying post-processing functions. In particular, see \code{\link{prepare_predictions}} for further supported arguments.} \item{prior_prob}{Numeric vector with prior model probabilities. If omitted, a uniform prior is used (i.e., all models are equally likely a priori). The default \code{NULL} corresponds to equal prior model weights.} \item{model_names}{If \code{NULL} (the default) will use model names derived from deparsing the call. Otherwise will use the passed values as model names.} } \description{ Compute posterior model probabilities from marginal likelihoods. The \code{brmsfit} method is just a thin wrapper around the corresponding method for \code{bridge} objects. } \details{ Computing the marginal likelihood requires samples of all variables defined in Stan's \code{parameters} block to be saved. Otherwise \code{post_prob} cannot be computed. Thus, please set \code{save_all_pars = TRUE} in the call to \code{brm}, if you are planning to apply \code{post_prob} to your models. The computation of model probabilities based on bridge sampling requires a lot more posterior samples than usual. A good conservative rule of thump is perhaps 10-fold more samples (read: the default of 4000 samples may not be enough in many cases). If not enough posterior samples are provided, the bridge sampling algorithm tends to be unstable leading to considerably different results each time it is run. We thus recommend running \code{post_prob} multiple times to check the stability of the results. More details are provided under \code{\link[bridgesampling:post_prob]{bridgesampling::post_prob}}. } \examples{ \dontrun{ # model with the treatment effect fit1 <- brm( count ~ zAge + zBase + Trt, data = epilepsy, family = negbinomial(), prior = prior(normal(0, 1), class = b), save_all_pars = TRUE ) summary(fit1) # model without the treatent effect fit2 <- brm( count ~ zAge + zBase, data = epilepsy, family = negbinomial(), prior = prior(normal(0, 1), class = b), save_all_pars = TRUE ) summary(fit2) # compute the posterior model probabilities post_prob(fit1, fit2) # specify prior model probabilities post_prob(fit1, fit2, prior_prob = c(0.8, 0.2)) } } \seealso{ \code{ \link[brms:bridge_sampler.brmsfit]{bridge_sampler}, \link[brms:bayes_factor.brmsfit]{bayes_factor} } } brms/man/figures/0000755000176200001440000000000013255206242013435 5ustar liggesusersbrms/man/figures/stanlogo.png0000644000176200001440000003745413271032273016005 0ustar liggesusersPNG  IHDRwx+sBIT|d pHYs&:4tEXtSoftwarewww.inkscape.org< IDATxw|ՙsf$w+$` ؘbQCB ے'7B6R6uq6e7M ل$ ؒm Л$W43+WY{nyޯ/lIw >̙31 B2J #7¡# #a@H P U] ]tuW~V-nUt+ˊ@l sy#/f TILxC&f~I&`= PX]&b.{gʘɋE 邞0t hrh=OuO\Κ;gnnՓ zt2L¾xYIqAsb?l_3bw끳1s+WAŮmZ􇕻OA_LӀsxH`9pO_Can5 j.͠gڪ' UX;i\}2Ə A|g2xEnE٬Z;),V%sNLbALpCfX3j8w5O+~WϪg}1~X%L]PSyL1|/cʽ atC=؟{9ROLl;-!/aKH> `<` 4u-7%ʽNiܻ ;)x+֑|1c^"Qs.ȇ} hLOSq#cʽ-p+5o P;)7Ŵ0o܋|F dS |1J7(`-Nczʽ,a؈#~ܔgw3VE`ܗyBwS o0{V,sQ?|}1K"{/Y.+q5Jy9NZx "j9UX\oӶwa^2[xmoG!F@ǘ,٤׆2O2X{Lã)A¿6ҲwrdgK?%F#c]JF>;H9rϓJ?#ti;/evyʁ{4Qs%AFb_ .YB*2wc K ^;Kri*oC}1@J;-ߙ 0=Q=S8NRJܳZRGӠ_.[|s~5wS JBja킾 ˘ʎ7՞6rfjߣOASdb1E 8y)PF҄we߁ʑ{-aї1hnY@ʽG1a8wc Jл,Exq@f_VsaLy%p",CþYTFnwc r =U[(H_,N?+LpleK鲑;ɕt\/;}g1&V.NpTi/}2W徘 z+YɒdFɒzd˽ ^ r,C<{hyt$CʶR}&{)R{)-`ʲQ} VĘUnw*{9+EԾW¦mDe_鑲*&j&` J5Kgw Sʦܛ -=;r\Ȕ(&j?s^KY;)M%_¿aʚMޕ )|wSvv 9A;[Y;)?%9r^#ࣾ@,]NߙLy+ro?@;)i1"ДܴLfnrdP%Xs(%5roS5sJE2^n1Ţdʽ+\O 7oV.܂9/E)*%Q~ <5}" 9~wc˽F)&̞*"ܔ.%AQd mĉ_1( $W69I1ٗ۩{AP!Ug[S2r_ȸG,003.;1&rA5 Z[hL}15O89}4 5U|'1GNK}؍)/9-SypZ.a0B"Fq xN\t뮐z˘ÑY{sO;hnLƏ Vӕ|bYﾓc= [܊"&p 4a/71 b؍)5xSLSXHwyܛȋ@U6kЖ&u-y4,er$S''L&o+Hl;#wV7؍g9;U0i S#'!> |*[6rof\<?dϫevA)TiB2k$~*?+/z1ٷqnT 2 =϶vO][V-e쨈j`@6gzF3 9zk|g1X)d"]8&B8ɄY=&(Vy ؍f L z2ȉ'v]qx pe9Xhg7f?ׁ͋la\v(o#y/Vy'r{)w9$`*N2S+'r4/2zYҟ+H35O`F5&sSZjXOG+i2_#b3e­L<"E<]$EO9`-x]Eh]L^o ˜@j'(LKΡSA|BKĻ1sKЇzg;}12ۀ'+:ݡ')LVuG`j=ˋɻ$-T pCNQS]T[?^}'(7&(-3K"_ie&?1G"'55'_{DVA+)\Z]U]yBJ ~ړq rES>lV|*=NHftɚ*7.zX=ZD8Vlk> Cꩂ:8;) NՇ U4p{a۽~\n68Ȕ%Nu]#1\;y͵ԥb*SaG~ȅq{&kuϋLo88d3ɂW}M\Vy߳bYc# z:l8͘Cp!ɥa]!kLOll}(UK86">8]f88"3zOMqpn˽R&IoRHe5h!JR&W=[3߹ɂeF6m;t;rBA$sh 9pTzZÖωHW 6hJKcC}ae%V55ss 3dގw)u̦.%YOd?P-vxΑmph66*7H߬ Z|qȟ&jM4y"i;wBڣ8`&pv1HN͚nF\2Jpe|TQ{<{X87A'eLq.Kn޴ V!e9(3Ag>ksw$g*6Le2|#m#W.5g8$ru9c~;D?WթzUvB$:̍?}ș 5Cs@,!zKqtu;ZE.>v#azblbɳCh=<#?QB + \1>}`;U]oorF&VˠԞ -L˸JTo9vO >ҮɻSW\8G!` \'.慃س}ޠQc;Bڈ.$S#!=g&`TOjuW>fX|a_uLz7:.ΊǎQ#ԖBm)}LxE< zZ>s~c撷"8o8* 83d1Y9z6}0SP"~c_N.ʘqQ`+yc"!5sorדRږ_]~q+UAѱcZ2Jޘ~C'*3 88jB{*zx`.ΑmR2HLX'u{~ V<+EGhn%(/c␩Q@13ݞLF>zn7=η3zsnv\]ld+$!p|r|ƌ) `o7E\½ 4(dBߚ81.wE&o)cB-scae~*m[Dy0ˆcc 6ecʀ1j2Vd]wRuOJݛ\2WrK'Ȉq(({p)aw 2&ϡe{j{ڵo5 q k*:88ҾMQdr,%Ikw?t^n+a vQ ##jqH͛1]a(5M+ { >w s8`R؍v;Miџ*;9m]<FK<-ܘ;YȸG'dҗ]bJcj0(և<~d^ҒyKAĈD8&maSƅ [=/Vw]Edt8P+wpVg :*Xś%_R, eN r/E\Qh?5%V0Q|RÉMQゎ .`x,XVfˎ"i)PF694/\|YivT8W]sA !S P Δ=ӵ<qVgtӣЖ^[nHžw sU*483p^N{8HIKvb'^q / !τ123  A6;W|1sd831]Ɍ(dXsx;*:Xk-EB`&;*T8. &R67ފNBlRxw]Bf)qzgA Agĺx$"R P`j”b^ bۍ-f?/u}_#e{9%dsed 'D!6Ɓ-4X'>;͡WrJ=mSGM.aetM" wWtp~Gm%MQ, Ч|1:y]5U8!VE'ɲ jS3f(mABKK솗25@:*f_TbD`<@Eiq Ͷ /;hnQLAT8Mԧ+9% 9v,§"kX ]7)V\QACΐV%o(:mGҢ E 6r76H)qȔ^vѝ0IDAT .Rgv|G1r+Y0~RLҢuYԊb&{jTbRccbeKX^%0fdaqJne2WgD&Hhu1ĊH)ʃN.IWlrU>ØBLNx9Hhski+1Q cN陂tM,Ua^S(뜲&iu VE!+` zZ=K!Qg2JJu,]ɬt%ӣБV޼:{K$gO7Q 0<ɒK,c=|$OБb\bw5zHUgy]3!P;jbv&$]2g9.x޿٧yr7%Axqe%%촢Ϫ];dL 0:qNu+Niu-Ab ^kSiyv4N0"IqJ]f+M _ ҜzD^3S v42nEct>Bb}P˘0L9J.(d-{wn*\PצnBNBwc|쒁*^nh6Ӣ.aUb6gJQc)/Joc{ bd#&2,,FnØči¿Jճvd2x^GFgeLQ;岢 O.TOeŖ?xL61#j‚8Si Zu..7$2T;v8 A61+E湱oHѐ(Ű[q3Dݦ;*~ R=htܝ"ywci 'D'D] fK(7!$M+_QJ.B7D9cLu.fe&(i)xaz-)TN8g[zWS`|03EcΐE2ms4$Ċ!]lݘz%J.8,إ'U~^y>;C.9Id9]*U\@J=Az[N"`D9C}>ہrsHU 'DJ蘒&?͵ w}KNyc{cU>{97d71$1cgBbuM Wo|mlcYy `rE c鋁*{.cyCƷw}c7L~h7ЃuM> z\"cay*;wHJwmof@%h M_h]7ݘ4> :*CdItŞ+P[ \ϒhNA_AM85Q&jZKk]a+g olߴP_LjGi0onɴ 4e-1&%uTpNg\x Ck+vE?O;LCoN[~2q800"sT"EaCǺ!ȦdAOG從Q< `S)*!prrtH*]RqM?=@9џ]\Ý@0!*Q1:ݛb,2 Y =|u/'&E>Nk]#-}Cw;w!Yzp=MAy8O1S4'Oy8)L߭urG]flnLaFZ>| =-v` 1&T`A@2bM[0Y 7/CAz:cLN$@Sۥ=6S}"bh7/c1~%W+ <+I "z~cX k1/z^ neq+3^(6Tŋ޼3_cCPޓbpDƊ`}|zy0ч17t~-ٖC E_^rn}}1[OhW='3ۚyBo19w_ 4rPGZ=?>Rws֭Դ>z_ OY+D3V8t`}}u:kzc \=`bm_YQ{AgJ_D2vTDq)#i&%[RWǸ )Y ;#YM X<Ê|2"_OB*v +B"ءs{"G3ۂڲHc*l<;̡dls=AۋYK{cJD$$pˌ@Յ\ U؞C[/#0_cSYp pͪuMԾ'KlHS6*̇y_¦T Ɓ2rv4oBЛҶ<|3ɍ}g1;V5S}"1)iл/f߁jW`,WO뙽yRw6rHo ,1$ p.Re߁Vj @;9l;dyǰ.ެ7r@5QȧJy!@yEy\cr(^'pk#k}ʆLJrC?pnVG%dqLYwlzԷZqs@coLYwl[L }حԋm Łs2r̕_\Ø hSi!Sx;Dq_s:mL!ɃaZ)yw ڜ.߁r)˄K}?h=P;ɪ6\ >nstqk^Ϩ?^ÝO!$ﳟ$R@Yyrk?>?Քd K}?S4_ne[@;-FZs~g.4QspIg*;,ͮq@0p* odA@8SΖB>NpwֳY߁e)+#җ]^A६DDNfjyN㝂> !s=XHC\;CFZ)_kgvzmGeB5^S.s@13tu;9M959.p @ܗd` \͡\\Oy>gپ3%)NEt$ֳv@LxE%3L(H{}޼]P[@>od2S-LqoF \Z:@-M):?.7Qn|Vpp#>3=AV*:T%(:[tY@l_g2-GĖy!w[PM30Uq 0))&d[@Q |+w2g"] ^;!H) \( b7י,R}gDR;sdLѻqnK4!""A.dJZ;i":R80w".Kp*S9 Id&91QXƔ0J|,AR@O(,sݻH[.oo#zp>0^2@}o; y{H];Or)d΂|AO@މr@[<~20SLY v(ٴ\;Au[9@c:oȧhSD/{.p"h=ɩn8Aꀩsiw(=яU) /)Kۮ|?0iBBtVW}yNeܱBw{6v5f AuJR'TcKam+QlȻOf98vM|g+~ZNƟ )rt{j1EqWLӺcKymS^Νͪud{7v/?k9rcJIK@xlV$ܻ۬dZq)r}VN{e]pϡe$PN}m+Ӏscf% Xw\)r_DI7KɌk}g2xd@Rc_Qs N#B|lZ7kw|hdwŸ|g1xs_;Y[e2-R&WFo.W^_9ޭvoP63ƔE!o+]av&Y-3crGJG[VʲwkKW)ƔLė/E^!诀c]};Oe_ >! )vil~A|rLxyQY;H!(u=QOۚv4b-Czk2imT+czJ{1\B+9&jjLڮiY;H!rBj:t0wc>^ppZPٴL7.ieY|Y1{4gXwF=DA Ř2+GiyL7{g+fwcʉB$idrYMB=kS.Jd+ޱ{d6 `<Ɣ]|Ra1G'}ifbLy( yl<;Hi~Cˊ!wcJXܳd5 ;1E5z FYHCh?i'[gs 3Z4Y)pwXrR1ǘ +|g.ľÔ"+~Y) H>lLs=O~ A?_Oo})VyC;IY=jLإ*:b\X{̸Z} ]؟)iꕾ+R}f(:Y.}TOF=S&)7&M['>L/^YTB>%9aK$?gNa{Y!~8wc' I;1[|1r/PVm}s-cd^S;9gv+m89{[1[BywO<۫^~y4vq>>̮reoh3q{6s +2邼O@<&o^+zs#m 4z >]]r們w@TUsKo D7~1ʝ{jv8wu nZִˡjWtSw.$qoX

Vf>?+}piܱ++G0YS 4^~әnD r{gC8F05M`U~k'yZ&>00<)Ky#bڴkKup\!S9 Hq;<,VfV14wC8y +Vp{.fzUU ޠ*X|X5j9W/ׯyAEy qK鱽oA )9 3"2p_}x}qOq$sCuO+o}LJNDÖ+w'F CdFg98ɶ)fAy6K|Yk++G 7*=`GPy7/z\lerj5*0MHLf|gˣx^yOͦe 9pQEeˍ#N ԝae4`F,\|Y[jd (0O1.`+dUׯW%z<{5wzΗs6lS]os$7^%LI4!@&&1F(:BHō t3f 3c}f]yJX9Q4Gn@~NERCI;D8'WݴsByK)j0~D%P! d޹EQpm,Fi*RڂX U`$j2G1l?Πɡ"^@p_zNƙa$FF:u5ȏ2IENDB`brms/man/figures/README-plot-1.png0000644000176200001440000030366714571050177016237 0ustar liggesusersPNG  IHDRX=ciCCPkCGColorSpaceGenericRGB8U]hU>+$΃Ԧ5lRфem,lAݝi&3i)>A['!j-P(G 3k~s ,[%,-:t} }-+*&¿ gPG݅ج8"eŲ]A b ;l õWϙ2_E,(ۈ#Zsێ<5)"E6N#ӽEkۃO0}*rUt.iei #]r >cU{t7+ԙg߃xuWB_-%=^ t0uvW9 %/VBW'_tMۓP\>@y0`D i|[` hh)Tj0B#ЪhU# ~yhu fp#1I/I"0! 'Sdd:J5ǖ"sdy#R7wAgdJ7kʕn^:}nWFVst$gj-tԝr_װ_7Z ~V54V }o[G=Nd>-UlaY5V}xg[?k&>srq߀].r_r_qsGjy4k iQܟBZ-<(d=dKO a/zv7]ǰod}sn?TF'|3Nn#I?"mzv~K=گsl<b|_|4>?pߋQrib 2* (Ѧh{28oIyes8';Z9h6g>xRx'b8ՃWOϫ[xn%|^z}%x c8eXIfMM*iXw@IDATxG=|%M(180 K%-f, o Y^ 6ƀk/99Ae<Ҍ&I=}F5n7nݪ:t[CvkK!`!`!_#0t 0 C0 C0F`!`!` dC4 C0 C0w0 C0 CqɆh!`!`q!`!`!00> 0 C0 C0nC0 C0 C` `}<$!`!`!`ݾ!`!`@xH6DC0 C0 C} C0 C0 l!`!`w!`!`#! C0 C0 #0 C0 C0FC!!`!`F;`!`!` dC4 C0 C0w0 C0 CqɆh!`!`q!`!`!00> 0 C0 C0n߁A@CClڴi̇b֮!`E~cGd&P\s5r=?/?_^tI}X~_M.j+d˖->! ;h_C80{q\n1ʩ*^{tvv[)0 k3Y܉],r!q2$?thޭ#F3fȑ#/zˬ]V> 铟d CB`^xLXN~] XXn#tww9眓Jc=VNVUEEijjʪ0asYuV`@.m&RcX! FK0(X~?G>ߎ)SȒ%K\w?ϝD9F^{M>X@ ?7ooq䗿:3{1-@aq/ ' qzr8Kϭ2NNs}ê4d>>0 wp0=t}x"`>Bd ;,c-YfW1;6W!s19rBc!/ FNN zJc Bg?Y+ {C0 C0 CXT~Ch C0 C0 }}`!`!`#!`!`#c0 C0 C7F )0 C0 C0=F=փ!`!`!oBS`!`!`{{C0 C0 C S_}U9Γ~oOQj[{j*9Йʙ!P }1ʶuVa!`0nC`ï˿)/Sî]t Uz&W +7 C0 bC{=q^E`*99u6tɓ/5='@Va!`#A>쳲vԎ塇Kʮ]RePX\NVa!`!` R q_b|ߗ^{-ݺ/K.D&M$K,}sY_ Pn7!`!`@!oWew]w,^Xnv>|~R[[+^x\}RUU.TM0 CXr9a['eqI%bۆ@-W]us9n~ 믿^#2`ǂ’!`!`=H܋S:dP5M@3q_jss~'#LdWWW\\VB岔hܹsݟ_i}27 C0j.6T cO}1}(@J`q6~\ySO2FnC# w}~ꩧɓ]|Γ eCOrIvo!`o,T'FTȜ{<ݡ l1%pQ{WOvb g26l0uwVzzz\94e?>E-rB2؍!Ptv픖ṼҠJeyiZ>D`ݓ}>W]]L([@~Lܿ/giGt}crgzys?Muu444'N9唂"1mCxV9娹F܋{b~g98{whq.6`( H{N^ii\pȶmAW/ŽTC5LX0. 9B6}CCE{O?:9_0O0]:)@-j8 .;΅~lllK/TJJ T[0 CدYY֬ۂ;wo*,Ȇ=ij9`x{Y(&yU̚5K/^OEfȑRUU/Vh!`( KYwѥzpOޥ}%m8wtvɶF}O!s{_@0_!`!KOZuy/$~uJ9/O'?-r~Ot)%19Li{Oʊ#mֆ!` ?ݑ0|yKcSpylwNq߳x vto` ;RSKŇ@>XX#b'c'&۾ `Ľ/h!`!}*ANn!k6H͎b-זꉉn孀{ȫ8G%Ƌ$4i)x_z* ^0+D&`!`@.l%Ii͖Kzv.0l9=h1%ܒ5[IZC+}\SxBV0+ Bgy&Y^­]J4KM]SR!`Ľ L0 C}.i_&I7|DzO{>i.\n.mjmjͥy͒{X$+o| !C\XT՜7Baa!&_{3w0 C ļ=NE>>tA}F"+;H& w}oI2)d\x4﹏I' sa~og;$]Sqfh!0@T"+Pb_|S[VwH/mP*OVN[ Ӓtz1!O2Sk@¾u[޲#! C0yHJH;S9ah-KD97˘9!cݺmu?E^)ח+0__*)+7vʉ#O$Qe B()T bBVICK%UG1!ds5/ g/C1,4/$>9H2IAxKKө@-,-Ջ'QrK<||#4L_S -9w˂24dP),O/,w9/YUnҘ-ê;BIr wʲt\J pr 7?DZN~s*ڹp}9%*ghF*4C_˗mSw A,뵵S\#kaCeƖTsEb3 q7h2y|eN ^xF윢Va==(9r?D'I mWl[WYQF!CSIh:Ky)$9`'ZӦ~YG3r\mo%;yB[+fȅo]rmiuaqeߖ{}\^z֯!P^L&d!P,/ٶG])&O}~9+ -'?Qaɇsٍwjuyĕ}uQ c$J"݊wvMICrvAEEtw'-9|O*J]/}|S,8xL<,1,F!`!{+qυ.W:oyoD61H,] Ą=,V \ƄҠ+H w4U%sSm "k׃@}~9? _^ۜWZ/.\"(GN;@ IF܋9, C0 DV׾w̎JtH9qɛ]]CITP59b|ޓ#m!`!x݃/HS[vxU[es}G}(%'=;7rCM\Yѿ+puF֨Omͩ@ As͝:ԓ$3I1)sgˎЭ >!Q0EwqdR6nW $ib-qu+|ϑReþɷ~ 0BVo!0`R$ݪ8@BQEWWP7$ioАKlɈ6}m]#z8ܧYQVH3sN\|@Oqzj(Cfd\_Ze٦:'~Xl[ 4 ;&lO'BmlWW .j !I{ʓ'YاWmYCW !` T@kPU\GG\ i/iuv+ p<:ՂMO'$Ky fX?d|= Apۻvc*  >F$T+z(#PsAiYO۶ҥDZ9Fgq7:,_td_[t؄ C0; ]w^;r^b-jh_ 2{~ٸ1Fc,,g!0e%H ;4a)dA $}lF=$m,ē92ؖrEyIi~g%KSY-*L;;e1?c`^9}Hc*lQeD' ĕWW>acƌ?kn]')|[[`V[}z~<_pB(sKtrj%ńbz6WC0"CҥKwҟkϖ!$HY,Is][;e@co"r.9Τ|G>׺ pd8\p!+|9פE(Zvi,4Yur?fglob}% ʹFy@a`)C]Pqh(h>+z4&,\p!U}~ &MALuÉG{ C0_,\rL4I,Y"d˖-*O^ 9Bq/ٜ-"YڦvyGjf_s/De[5 1RP6,j=a\Xj.ilyމG?ZV}ñt7ijOxoLܽQX+8ua2Bbv+,|$\46\X(zGU~COSLq,YW#5<^׬>hJLɕ!%QjqqNBԒ>#E0 C]w,^X~.gc /PZ[mFH(ȃ%AG,un.rগO\5%֓l>1ƻ=6b|P̿V/9WCbxg_cǎQF8Ҋ(Xϼ2bUA{% ʪ 8A3&KYipjxk&RAܔ+QeZ>KJ0Q˯\`9Lb:w ˤ+󙽤:}GU` G߾%.XrF;`!P0r˙g~ãv{[N㎨,OۤC>E@xԴ?8p:b@">Làw'=om& &N7 ڒG} E vH38 C0 ^ N |}/Ff̌J}[ )+- [t@h%y☇i푕e ·_isg9 2I-6^e $cN;$ uwȴ)w9BJOy߻";,"wdo6HaTպ <d~K cFp^_UPi њD~~Ya*97T rqr X~>.rx`[rM}{q<&mJsAN$ūC@V^zI-[T 'jJ,1 .t Br}!`%<Ֆx#_ߟ oN;CFaQ̝j=uLY|lpkDvd'T%N [MZc΢K-Czp(,0mPƉg/˞eӖ̞9Mޭ!@Ju(.8`7|躋l2*=TH[# Esk0=It-qѐO{yQ` k,61 '$w%):V,FTj{ƍߠpʰ3q!ƽ h| Zȑ#eڵ__L>Hx?Oݏ+B!d/ _\2"I_Uk1ߓ1[Yu]ԃ;,@&&L+V(Ij 4k;$駟OA@ "eICIЍRw|WM[wȢp*#t%iЯ:ƍ+C] 5[} !1,\)Xo/Xz% ;G;~Ϯ'xBN:$yǪ^~r5dw]lfBT ꫥ*)U=.C ؽϯg'ɓ!mmه oVӬ)~x1 49k:?%KIٯ Nt1ܩ8X%H.Q ꜓+K[q~#59D#CW'ְxOz=$#9ɱs؈_oDž~B"ɋģdᝋ]/:@3]Om6lsX `_4D%Ya|fr|M|'(Ѕo_ACO9GVC9}а_Q] "P2l̝12C`BHi-}Μ9>?m Đ׀p? HW 8vF:쐺$[IZw_* DMMȳA`l}n+"`SEHu>fB } %W,߸MozefCqp$*K# {>m5Y &,Jȑ@]aڟv~@VkdOҥh2Jߒ CuJDBCJQ+X{}g,J\}>wwqY!lYgPHe C01`?~/.y oh̸q|B$3rB-AbIxO]uw%9Wti-:Bޥi݆]m=\$Q]=q'\k֬7OʼydժU2|W]hدB6;!^M8w]|yUF!`38ۋ.Ƚxcc\z饑k;Yrl޼E{_R޸G+; h}M̘6U*뷷BwG>D~O;֑tO֦RZVYls2G`@>=vzUd_+}WD+Uk26Ioc$ S]ܪAIS]}ˣΒqzH-.F.'?rYrܑ%oʖm;2)tsV{ a#@9-܍}3Ĵ}AS0 =_Y&"\Bv1EAaa6"|;ߑnE(4Wriꦛnr%ƍK{C0 =COEl ?>iRжI]{rOXN6l#P1*:ZǖXvFJX_݃lRҎy/$c%%IIjH)dƑG,: fq%x{4W@85un$$A)*T>^VE׷Vjlinn{  aʥ _CXJCb0 C`#0eʔcsO֗|HB&HћzhԹ_f0 jBK4r0w%lL}FY>wddɅB;rb TU ;TyAFR]X 5e%hO3:J:C![\p:8 4@lPG4Sren\.1bJd$mU%#*vE>ӢEƳm||F # Y+y,ThدB6>'[C0||; )B!"r$vճ? +6HSK44zڢ 万1"T O:zU40xe, , lVy| ' %&Hp7^~J:t1؀VpT2͔\dF[cdMg7b5s.8n~;Wov]$%k\v X5N&S-3Dw.V6lZvs 8f}BህXPgB!d͝;5.4Wr}0 C0*5,"HEzR ?5ȲU]#zbcT5U];誁BQGÄM{(׳tP+/RY ˘ 멫ʧ@DI,$uCA=⾷]e?"- 4 $T}zd27jQ8VU K~SK,[֕e"ҫ `PzD¨pᕮ (UUU< k<QR_n_$nϼ#mfMޑ,rܙHiF9p fZ T}mq5i\F(ϳ/-uZ!u :=g+>w EĽG.2yG;< _nME.2*TΞ!`!wB ]HzZNbZۮ ,Oh&iCDL7 at\34diKU GܡI()8q\dIyiIk0b"OwEs9!,x|9?.J0dPxK2}~2@9Ė%"!*C;?I;K+Gp]0{8bqp,+ƺ jyy睺c\Νа_e(C0 C"_IG̓g m$QPעnLf *dr׊,:@Z{MƕVcF{!%v2"O .+>T0Pwё.M#/33$p/#[)G7'-zF=9i ' > ~nuA&cȃ@RP?m:wxP +P ڄ^ 5./gr:R=\7΁>X#~65J H mŎ@S _J۝k'P<]Y!`!H! huI9ttY[]N}7qSa3k2e;zW&>")_8$njϿt! YS$Bı2ccc!yN53(L8| Y@z[oSCSrED=ՍI/'CgO`3,!nk r]zqE }[[MM[#U(f| $X%g>jUUVVJoP9_ C0 TBF<%'"EJp(,w 2O'@B ;7 80c,8SxjD5/2ڹBCcb]?c?{('tG}, d**?*39⮓R(xBO ǎpT1{=c (a'e|WoR#iLc|6nPGrB"FFחurxB`~ >I3dHԹgJZYT$;WXN7j=eO77}|P(v7ǯA)ߚgX0^O<xXcH#ACa=@V>h 9UIn} "U͙!ƾ ܷut8} ?BW *1jD4DaXL8-tM:mjp:-7Ru>~ 4?1t-vϗIq:}ˠp_ORk8/s㜠1?tB5oc@ $2>2qӭaqF',s*sA2`#5 k)orKWxŖ5%G8S45YS%!}*2&IkG1e\#ܭD{-X.C=C.I1~4G#QΑfGJp__Ѝw&qFG,(O:]J-7{`}3+j%72"CczN.^(N.h֔N_1MY0^|fl@ k+]ejΈ _5VdΌ@IDATѡ~'oqGldŽ; fC1#ˇ?||đ-tѧ"zP2m֍ z2lI Atkn&#:BRp'۔&" Uaܵ3GOk@˼?>wqzkDh\ (پK7){qk2}SgqǾ+N&x ,^Ll憀!` G4戨wc ==:h&ƑCnNudɑ7͢.&xa]ĞE@JU+'MfPrO;,H%'󰒸_ 8G?r8=pAyr (KK#eI=,7ڭ\p8N 0'YDq1BzZkeI YҭM =St~"5{~[N۸;k4w+lN7w76{C0 Aj͕>.*axVsa#-׎bo}e;2/'ҨOzY;Q[͐646U. q6;j&vcL"KsP@+}ꬹ~H/PR_'" +o3 9C4yDOT_} zYF!;Ac>cC /Waa36 Cd삩 H"?\)r0e(X܇ɚQS;Z߀t-DfALhLo.'H#ԇÂAM9D-H vy\@Ogׄ??waLwR"$':dd눁OLw4=et1ftԌ )pw7,'ǹCiIw25D#OUǩTǖ[ u(#64 eӮi"2#M4T̈{q?A5n~ZgzS^!` (V٨.?u>D:K$U/{L6> 2S6*x"z $xeC ]+*ILzxuŽFi(^:!Okq5ette <NVg-mktpn4uvɱ%~i*I >~mq)CM2XË~1qfyڵ25FJ. |Ji$1LG)d.=;Nz|EHoii_y7%)omXDP, yvj&iJrop=cprjIKm:\4j1qgiT>.\#`Ľؿ6C01 컐䂁ruCA P!K`Zs 7/.B[}ҟ&Y2GPrl ݓE} |8>GU!sghMY&jxŠ_+pJw&S&.Ǥ\rQe/n!0EYAi9%$k6e'˨xA;vd_K=zP 2Aism4'="̟9Yt{$qcMm}hqO<#|sapNicc_ޗ,k"`Ľx0 AS Q jp5I[ccp%" Zc$wSLc^>MH%H>N~ݪa&)ZVP*w`r9xőFf^Hb+~r{J bFgԓg1%lkevm27F܋ CZ *OD}IIaY$a̤iZ2FYjnDjjneR@ܝ߸`xVgc$2 ?#&I]i$unv>M^`tqbJɱ";REt\eLXsY!?^fnG>ؾ{?a\їCw<ڞ$9S4&̀gJwH%5h.T6Aʡ$$524~rn>0;ȑޗa> [%<V̽IdYZKlrrL]6wFX-dxò!` XARlɰ vr(wqI&וn'my"m[<@W$:X/qaÔ7wK}TԛMtp!A}̿IL˺aT ..z,~Yq[REtQ3yݓ9Q]'FsY!`(yh%$|+d d\c6|DK

'm|%uK|ָ@s]!\n(^qMėB/0'B[CT%`LYχhXV_ Xʨ:ŷ6&ꛤ+<=5jeTST{+1򉁯Q)nJat\V^|q/gn36 CH#U?{Or,Ƅ?F;Pw6.ɞ FrQe]~:_YȸI p3]矛.P>ҭ@51t$6"J uNr%>ڮoVm|.͵ᰥ۵ݹs:w4 ;\qA|Wj>߂#*춈b`S5 CKG 6nQ}dq֤qDj"Iȃ K^q^O8Ά8gTHIRࢁ.4̜?\fq;G'啔#cMQlkąS}[p# F܋aT C(F, ap=ogb_[ܹYXX1O8'?m5umFy&X}J.񢫌?__(JbڦůVX4 w=.-ySK$tA$;<:v8(K\ozvZcǓw2G©8+Lq-%CG C0p^{渉r$q'e}5VUu 6dCU4 >F:|<-fKoʆU!]wu#-,\S'u^Q=fCfG}<Nmƿbs%)g:]$ 7B>$D!. A}q /nEܗ.]*v8k$ ax1 NN%A#)y'wpnV7H_:gKKrK_ˬY,ZHW^yŵ_/gy#Tyʺu;0#GM1Jx7w`}ݑӑDG^/.+ (&>TguD]%O2 6Ң'I'AwthW_v}Q=zH%%a{k^/K{&W2,\"%#`\ E!0$5yTiԛ*IVۘ,"GĽF;,N=TWc9+O.cƌ*밼!`ҡ2$_ywb wTG yjW蚐б >K4yJX;' ]_:iwZa pJ~EX2]{ԪlOmf =Rf? |X )H|ϰVjŇ'3aH0jWE߈nC8,s7hЊvOF믿Uֽ|c3wt+ѝ->ajo ݬ |L-v-LΝ+'|*+͛犱iڴiL:UV^a:܆B7 C0 A'BhuS 0->qE<ٮbu6@9#˒W!GS@HIF{ 畕k,Ae[]|Z{K>f/ 7ke(o}|.:4﹯ $x ;CԷ7ȑLww! [qlҷHEʰkXM-vqd({㞆ܲe䨣 꺺oSQz_̙3}.Ͱ꧍7ʈWݾ C07J絷ZYZ2,r t(%]a>*0b ,H nD-wF>֪ įZ7Q֩MNT!/%yֺFٰ=7%jk\vdJ]oޓK ;WX,YmmQj9 ]k"T/y Щ>A!ͩ1Ma!mW+5}#yUDz,+GX:Fѥ]O.F:(;B>qRV[JݼG=7V^))d]}d {3LNVmRkw~r?_;W]07/_Sp.P GyxFB=Dž$qXKtƅsӫ/Owb2;C7(= arM9n_>$— Qf."={vT2LpjVB:p|E뮌?S>M!` Nj$Y =]0) P vGAJ+D@IܓiD͠]kڱRZu(V :}IytXEi"K὿mWDaqy!1ߩo E5XyZ+pH"s@6K|6wQPSfv'F![y^?BB}̷5ߏ>a~7r'G'aO&VB:0 C c8XFx+5IsY].IXiGYnH >%Wݖِ5 #W3a_^R}sc!KFUc )O${EOBqȔ#*>3ڂ̃okiW+v{OJWvN&.x\Qo2<, ukݝ @cؕ}+qQ.@`=w4pxxѣ,!P]~OƎ+guVX .teÖP9sB地}!`}@LƎ a3h2fc.q| 3eFYᢠ! Yϱ =`3*Osp)TMB$H ;'ힺiٰrcBuB2\^1+˺"qi{͝GY3،Ea==GxFA{$;т"vD1?#~2ے4DF~S]~{$p%,(HyW! y{DSF5Z=I?X6Tr8ŒZWOlک`MQ{Ispqܜ Lgt~-MŔvo&Xt$̝&% K/wP}4hO./{dq!KW\qk~_NE?\ <3%XAؑ c{!`}AEs"5zݖ^8FZWWbFOj\9BzG>@X7Q5(1-Q 5n٤'6hT!OK'Z$žl2yNcrז乬4Qw6B"ѐ:~J@1.v=g'c6Oz;:)3pkl\=\FK+*ՙ!` .lsFaI<92V{mkHp/œ $-!AL{S `B2"BFu5mRtߡV蕯tD t$ЏD"s Hk!nޤH6.f|XH,1.jޝ@ƊOnmQ'3Xgz|Z˜8j~̙2>?}&x 駟.ȑ#*אz ] C0  CV))IպD [SEb?H}$<K.hw8._G]wtu`a22m}옸ͶNG>$SU?w攌EXB-}]II`1PRuzRk.nvTGuo \~xp t Wy5jWzJ8:"b1+)cM܄5;ff?Xq 0p $4]:ȿZ<'?v|Q#G2{ؔ)Srv__r~!` DŽ&G[ަMl3YCřɁ$2{GBRkOcEGᕑ \_؞W\9V'Ϫ 0<[}ѬZxqZY-*@iF+,`iG6yoз"LmVݠ[ЋqfT?!n?Wsuz?ȷu2G@t!-.h=} H?UhЃ,2]36wC0 >h@J5;I5IN_:|kq@o‚ F"3.b+6G㺐2]uiyΊ ozHvves T1hD|m!Ck3>PFRF{4?J<\Z.>K'I<,UBw$ã1U[X>7Cdw澫hn"̄64:7P{ NE̚:YCEf7`g&N,S7+$M&`|H,[#-;YWf;A++oGDvRaH7f; HH?R3 }@}}K$l Lo}pZ/dSSߡ[Q;TT+mnEoZiEc 1N7V=T"6U~ΌɎH>2dK!xfHv(qwmBqP~,}_䭵[- *.~MwH>єaîmz3g<(}H3!AD `5'U5Sa̺5kBE"A9뭾oayKtwSO_>uXi  "(NA`㶝h^'Қ<k}Pɩ?Ќ@}f^  ƎۑbjU'l@^vͬ ڞ^_/'e\^Y˛6qtt>#/=KߪV5- AG+@fxKfRjs^qkӼ(ZIGFo /Xf͚eyi޼y (馛dA>hqq+V,pL jbjfT; |%sΑ_O яɑMX܀1xT@ڂܝnJ4~+7l:95(HwQ ӁBxO)Sn50t R žh6Ȑ ѹ1q,k7_֫}8A" ilyCRw`s(u86K^~cLqڵ nґpjskմ1g:n+rIsE@G8m/ pĝ߁ פ{5zu̢  @^~e'pimcNV&pʚ-RÜ3E,qmx-MH7tc&68зNkDjY, #8ǃw*{s̹Ke}  2n89SP`l2%W_}]AhequkIGQ^ӭ։I`yVb @sNOAnjwrO4 e_e #^Q @]U_uu_UGi!cdjy[CZ+ {k8X~h{Y>RAM q_neԁ\3hdwGÍC!Bc+|oEFtGӌg;~~ d8:q|?x I9"  E`ĉh(7hBrsseٳg̙3?, I|FۻKVCY(lM:2z޺ʘwǨ6[udg.l9+c 6k+jڅVmUPr~cMh{p0JGo:YҞ1I}xV 5FT1u(KOUV(|퍧m r{E$@$Psεґ|ٛ5k&K.5>ZLf2a,YbGG)=ly_u:1 ?}?ߡaUrB{NjVkÀE \mF= ѦiVHͷuXa+ocx;V'S}ƩC ,Q5 _g__:꜑]51εs!'#jj5̾>Apпqǿ]#<{_j7#tFٍ?&h^lM}esY#n?R^MLd`SV@Vњ&6x}knؐmh"k7*=U"VpEeO$@$P<-[X5|TN7JV4;h;bK?uT?) O YFO͒kJ:E!A'vri[HƑpo6>tl)[v9QZ ZI"Nyommߵnqj O嘣{˲keQE^'zLRyժ~M߷c:?G2!jhԅ1Q[Cd-8vQo<%{)`!J/mK kmvFɷm-UyF}W!G#bi@ީx2&(ZHU4C@҇) jDч;mKUS,XA5Ŋe42yɬB!@$@$NtIG+pܹ\veJ˖-/9sD- }VZeF'RC Y ɐۨ/[%+z)D&5jB;&&؊I e̸Ưyk,Q]7 @8,c_ܶk71wX1&&6B-"{oŰBگGYG݄豣U}=g QEV n}HpW!0Y8F.j8 &ٷZ(Pm&Ҥ~mr[oNm΀&ڎ6r*x8}p9p :ÁV- ##  GPC ƍKÆ H#F۽ߩS'ꪫ䮻1xTlvo2e}ެN !58GWt5P9 *_ ǰr ?5L~T2k]clԁ"Uבv]ZY5יBc"a_>x@f̯I4c?$0dFu6wR0O>p\MF6>k6`P"-Z^:4o$#ʎ铑଀mpg;[zv ~+ͩ.̄NYFݡ^O[ sj+mhAԶecк,\]IW%dmm5@ERT$zsVwv@ w~H"ر+߄%m,yď֧c..jC]S^|Ei ys4 ׯ Ν}N^vvƘF=h-ÏsװuVSvy&ҮECY11յݳe7`Mzi70ɲ?qG.зL!5DpTγ iV}Ǹ*9 d֑>:" 6t5S#Z;v׶厓jbGɼD@#(4#p?nrW&* U nN.e6P_*n]1֦ES@:[S2|N{|n_TonI I"$@$` `^y+yg;vjׯ/X! +vEO-Yuf͚m`= 4=kXcFj9skqR{\L ̪##F5Uf͒fA!0.fF([)GuMo$Ny0zvt?4ɪEz@vg5/=CN}\c&ߎz{M4q`@@֥}TcW5bt:a|ש̫@mGۘ̄SPJd(7.:[tT yD;?FϢ8[۾mۑQKFsKEdA$@!0q^QRL14h6n:ٶm <ĽFwLl=gf+(QmFj8פƓ~a׫m zG#͕Ik (oߦhX,֭[j^Cّ3e@ 2؅AGJsj?zXC}Sŧ)2A|QaIRXT@/HVfQۨ9`QyR=6ֻGgS50`RmfD=y+1kb}8gYr4u4_qP}BStߓeNMC@|9z{Sڃszh.[+.Ue $pMn),xބUV?|+|r/p={SO=%];oٷƛV E=ju0#uj:nըԐꨦSAV#O }̪尅N`}Q~0aepG{*r^9lԇ2XS:a7lsܗ tT YӶVP) ƓM~tp|!+7},<ɵ/# M:&I(vMf$<(7[z!rv)WNp*dY\G]e*gIH f;S/}v3fLXŋիe֭&D^-;or1znY#]75,УZsG8>!W}xc|F9Ur0wo^.ukuWqUF/JqOڤƿzM^:қm|5Mqeю=u ң[Gy?_i!aמh5Nh*ӌfZX* =GO CtP Y5JZ:UlE _].8e$P>:Yp}\FXs-<FPo/GP{Z"q^lσzz^s2zM}p韭H @; $@$@%&0tP.2999(Toh@IDATɽk { {a;EsTo\ʸ8zYa#ϱn3jDť[|;$Z5 !OQTY'/`931ҵ95`x^v9Fw$ktR]xS$Ĺیp)4bڻGY.t5Ul VgШVl YivkDp@mfrmWɱG.5{Z޻5Aj2Y5!vMc1~>MQav^ Z/>8iK> ݺ`i!|GCn_1 b& @ӦMz u)2MjMIG=ᎢI ,= ԡF"zݎm.Ѧh}f/f^Iz8i"9*n5v O09U3(:ƿ]fZG Y9}Q=AƩ㐖>BoL4v l-Frpbkc#HU_dtlk [u;¹^&fmĂn#Ǩ}94B=](rDtvG++P?{LY@E$@$@$P PG^C6a&(f 2PCT L+rf$֫K~g;`e95m&_u 9G95&)Σms~[-,] Qw{:;B[6F}oCr [N ̚5?dtj{9χ享~M:-FiiEj`;ոa6JlmHqP .fD"ݑF?2iɪNZCe#UjT"%lP symyGalq ҩyC3W>-meq=ʖ{=<@2J[/%O$@$@Hk5vq:na _|Yjp @:;n PPjF Y;{ǚM.:Fn0Ƕd"ǴrТqJX75.,=K׎:{@쒊L}' (>x7<zj`Ek!Z;#fdXa)pJ]:P>S񟖳#u3U#te W|T#W6Ѐ;~[3vlO{E?s eꀳ55[[*HL |piT :@usupwyi<f9޶Qnx#Q4:uoRרLռE{n٢,z+Hr:9UeB! $@$@@Uz 9ջE5"VP`GW|<wOH2Nyg\3a>_B,LxGk5&ꯪOE=j:E;L%ٺ9{(>\14QC,֩m"4t,>Z7^փrխɲIW8R_UWYukKցmv-]I#'ʄ):և!m H 2D\  rB#6 @oiYyTnz>xnokc?)[>Ҿث>چWVuWVs'HbϞ=[z~uV1c4kLvt+-}  @GJsj8vjv+}kѤ~XFj=8 "f Uڸst(Zg$NH^2ZjVaխtl)yMנ`!Α'+KVcR:)4ڈ)u%ف6+ |bD*ǼK ؽ{%;;;S}į\X%&.7-[aDg @0?-Z+x+4ˎk;^W𦣸:MrМŕuCz-#m۾C>ᗘ߅HWq < " 4ӧսn:ٶm < $@$@$b 6۪Yү3{Cڸ*!5=-ۿWgy뢶6ztFu\jBIP3 FW71k&Vh/%Cڇfxĉ}뫤Wn+GA1ԛ0Itȑ6SXx 0ؑʹpHHRLwĽSʏVC29.jEn(pUc4hNm6lI1''&n-_9Q: _KɑjB:ѫF"jMgݢ/R,~hhr'%Pj]+mY8yr$@$@$HMG5KRʨՌ8F&"MVi:R~|L"X)W,A}3և>3ӴWAK^A$@$@偀mҨF tןP͸2rkא.Zⶒ]ۇdUugI˕L$ w(G$@$Pa Ԉ2pqPtgA qw z[h-hg$'}4C^bvL}5-ӟ2 O@PkXfL#tfu$7Ef/4doH - N5iӼhPEw/1 d<Du3T! s53!u$ paŬ5[+n,Y+H:Q;F^2j! "#P9GoA* 4ͥLmGz]9.Y.Lfc벏A3HH h'͂5RE|1x|X:= `ELz ឞߣ ЪPi*jD Mq]* @ Po"&g= C`ӦM7?l?֭KN#~رcer1ٳ??I.ℳeܸq;ȱQat+N  `{]e2]|iDsaǽ{zjyw;vȨQ.xi'0+%  $PJ_!Ӿ5ខ߾S:W^yEZl)0*Էo_KK/>w-Z=#3f̰n2yd \s{زf  j9kی?`'bzFwʧk5jȔ)SUV[?#O>^zI^^+SvHdP;]t|2)pϤE]IH2'HJ[Ý#^$܏A_~G}JG=ѮUSN?t;St4ܣ   }l tM~ʒ[nŗ2wy̙3',\onm69uebLܹ 4H:vQvŊE稣 :sN3|pj]Xr|Ү];9LHjA: @\13Wj:6178ˌ1"L!.[/_~5ȧN$v ;Qj:kc4>sel"<󌝐ڶm[y뭷s&L38C5jd}߷o.]t51NiSY$eAm @{]2T~s}1BozGlp7sDk~套^]1޼ys7p|i7s`*~Æ >Z_*4SIm @{^2P{ܹn0a8ck6mHhF&vDjҤfhNUK͢El8Jh:l`l]D^ 6LN8["ǽ,q3g;Y5XHH +Nw8Ք֯_?,>V=n62d~snՏ\ yU3gδ"&MrErٲe8tխ[섆sڮzK= d f1_O=]#^Cs1IUV)n]v >sz'\ȸq)v7Z]rrrT<[IGHIYfz߁}#׺M{dr';";PZM6~Q>gbI۷C9D4ԲeKyW'Mz>}Ȕ)SdA0ƤU~$k$z|h>)=OY&eIm @zh)ooAS'(%ʔ)$3yWNv<$*bŦyzS3[gE!  "q{@W=}U{G˹Uvf&u1ex22,tsNјƑs:"6RfM;RoeYxϙC$@H Ý7/$k ("{OݺA{ﻢ̐~s .~wޱ1s5ڵ B?P.HH @\ $@l9?nnc ?p9Sr$\'eC[h!2~x~aRHB(sÝ7߻[wc dСCPk׮_|^-"ٳG`Lœ3^dI< D('B^hV䟻P)Ya9T5=zޠi[#iצ胷=R0߶6~]? 6>]8~?bU_@E*э7jբ?|_Æ e…s,\dp4ً.~P%\v@_||%=CeTJѥyw].hCzq?s ύB'9R 0@ƛpF:V`|ￗڵkKn\S֬Y#tImg %/CӃ bP$ѽ&M"ȃ{ %<]tg}6~~MVX!{7L.]*\*E͛obTcn/M{ >}>L?lߢ=~~<:ό P{o䠎0eLn'xr-4Jl1ֱcG3@['$ &pwׯ_?aT$<&=[K/$?OG}`)S.{,X -teÆ iˍ7(i˖@6CQF޶ml $35GrH /aL$@$@ 7|^g0Y7rL1b¼FHA H9yّscɠA#2/իW֭[}ذavߝw)3f;q[$@$@p:c<3}G&PWjJv3?0LKep4tP.2999I7TE_AWuJ႔ Q֭. B:D.xD^Lg,6)7,!    p7HHHHHB(ɩ6;K$@$@$@$@$@ýXHHHHRI{*i-    &HXeIex۝={^o[YwY 6a\ 7iWrAG9z뭷Z+ r޺#Ϝ9SJ㏗N:ۆ_9bmfׅҥ]~#% rZyq-q?`C0@&L`2$\~8 Ho~*9xGo 9mï\FƎ[BwOvWE֗h9E`ƌwiӦ^h }MPqݻ]u־s̍Wƍg_{x_s>\* VqeJp߶m-4]3W;ӧO=z˥ct-P-Bs)IX;J?.6͵^k=iF_b;op<묳hJ"~+Va ]w?mï\hz w,Xrӹsg{zŊv rvq-q.v.w$I}@YUaĉMgϞA-Z܍?>(!ZUV֯[롇*;w~7xC>S_"o۷/Tq:S6NYH܌˥^FH_]ʅ51i$ܬHƅ6ʅ4M穧:xd\ r޺v&aVfmïh-zq[:UT)]*{IarRÊ5kL.]*{ ;njYƎGyzm"e׮]kw;/GG O5U$z{k.b ~u+K>Ff?3袋BOcm؈4CM)1ȸȿoٰa[o~܊Cv ;Ck(oi[liW.D~K\Tx"cp7  tAF7 Sb (w{ܽ7{=[Լ[֕顇׭['~}R9n#ul|ZtE%߹#2^r!_]EƏVx mDo~H/^q׿eP`*6J#i۶ vVwuu$b}3J]B۷D˅#P5TNfB4;;;,G04qg(we2pW}ү_?1xW_j)~\xƯ9k;9 &Ol)wzCpru{+"3fo(z7iĊAF1"ބ 3#"2EcoDy,i믿n,#旴._ܿv)[ѹ#Pw.suַo W. P>aMzXp ۆ_9m˻x mï_|aj0ҏARLO裏yO> ~hP=Rq_oHESn31$t6*h~/D:&w͛CD&uֵ=4o;&4a'h/)\xFֆ$@ wSO=5L1 kd,&]zeUK6B*sss! QmGD8D(7 ?NdU~+m?־-Kdkצ\wU}7&?\cHē^H>|cqJO}wyGG_j+ ,I\|YX#h2<@<)Y'9B bp,Fݯ.~ `eRx?_=pm ~BIyepOoԨu[ۆ_9o;;vXo^NNuU$mko}e3bLlLBx˾rv0,mVߴ*8L!p)XPhµǠ3y /`EE$L4e{=\6N%)UYE'9 sϺb=ھ_x.6E &j9s{:ۆ_9m'te˖[nE;~+C4[o} ՏǙGcd5kV؈mud2yu#)C͆HHHH2o-w_ssse ,HiwU& @8ӥCQر=WT&6"   H{v(W^zmp=U T0={(,zvVUV-&.&V\YnTu˶^+lHHHH |6is)U鎫|~7o.={&2LD,$   o6'_o5%*aoOD} {/ȴiӤN:>K%F{b8    rNO>#FԩS})- #g$@$@$@$@F`r '| }-ULQ    L!e}ܸqefG3C=IHHHRN`޽rꩧʟ'9Mz1D    G@?|ˣ}̛7/%l8lHHHH ʥ^*=z*L͛7?,O=L0A*U& qO4QG$@$@$@$:yWm?F7!@IDAT?>`Jv('HHHH*"1cȭZl׫U&+W&M+:HHHHH 895ɀY= $ DPd$@$@$@$@$d4ܓ Փ @"pOEA$@$@$@$@I&@=ɀY= $ DPd$@$@$@$@$d4ܓ Փ @"pOEA$@$@$@$@I&@=ɀY= $ DPd$@$@$@$@$d4ܓ Փ @"pOEA$@$@$@$@I&@=ɀY= $ DPd$@$@$@$@$d4ܓ Փ @"pOEA$@$@$@$@I&P5z    h[lsJAAtU6mZ&{`g$@$@$@$@N`2j(iԨ 4H,͚5#FȎ;R~BR*$    4&k.khBN=To/b袋W_Mih7t=jXH2{x9r~Ⴍ7=r۬7JÆ O=xYy",X@}Y0aٳG/^jKTW_}%|r[jժRR%]}֣G9`Q"&CA?(C#;Cy晰Jo>}$+{ȲބXduQ[&v믗_]4i"f[noFF-~7-ܢE% }0!Y "w^+Wz7&VءC[nݺhAz䬳Β>Ȟ{eڴivHH QxLICh.2JvhMýkG4!Na:u$jĘO$@&`ѱ $dJyoS[!ք@ \Uo޻woYf J~jB@UW h??uw5W^ҼyͮXBfϞ-ru\:uDʲu DnIX (_p !.riР˗S{\xnWnIN;4k?c;ؾV17"M~v3fȜ9s5\"ܒ c>sN;FSj>Ν;QP}Y/FumпNs4|;_Ub^ommx }p bAQe˘1cG~+-i„_:&}v'h۷ώc5<@h!QUռX;{On69ݶagK.ŏ8_߷qcz-gwD{wަO$PT ~ګ{9عF]v@]ήzvU\qbߔvsF m}i9s  ?w ]D=UNB5(&af gL E>F4a {vd#Xax'dժU2o/~In7x0+a.]>x]z嗭=#ٿ;%S[] 8V]a :OU-0ք׭|51-Acke˖ m)W_ڵk矷8tٳ׺%(*}7ްw-mڴA ~0@2 `%] mK.MfsAus=2@߾+8Ǔ:F" ~+>G?}F nSXX(L:U 4ǏOgq]'.ZȊ>FqK$P T X_xᅊ}2%0d.uP. q=FR kNتUځѾi&5jDs))DѴa0MdQi~#<&>`W9DBX'&5}v  |Da"X*}s{`,!>n1@ ` s.d7T?  @$P A ؛^{ C9@I `0-:/x{HrÖD=V\0҂IGXHSH0q뮻! # cӦM9EXHbt^ &xCC!c-2eoQ~ĉ}Lt㏱k~``GB݈X7p ?`=nH}PUྊHZp%Ĝ$>| Þ%fX(00Hpׂm:moJ0(H |v&.Qk'|r4βe=X;xFhF`7up!#BDa^cF;|/7| ]I {Ĉm!SNvF?{oYǏ &s1hH}Љ!$ p1DSO=5;խ[."p/ l3.0t12 8nxJ G !Wǘh}M[]xIF;|<1>b"xtul\ tdA^<\^17=eh` '~_})G$@h߸ 4D$=3,zȷ4V?I2\u4 u$@$@$@$@$Ó$@$@$@$@$hu$@$@$@$@$ xxHHHH҃ ԂHHHHbO @zׁZ @L4cI    H4:P     Iܭ/ȨQ .:fy~jٕ߰m/mƔ+V$@%#}xQH ;}ǎW=(3#lؾKgE'e^9xPֈ'ίߒ'?UUU'HJN3c  &*~Q{@aao#MD7eT\Izw}dyHHH_R#    2$2ϦSO`-r!l֋)Ó$@$@$@$J4SIm9} dҫk۲+y$  ~W]4n8*Rl,T6~ UT)4$@$@$@F`ԩҹsgyS #g$@$@$@$@H`ΝrEɁD}e d*f-*S&x\s5}x, 0 @E#qYigE6BS#_yY+$v Ħ zK֯_/g}v^f0 @&0<0@R Liïd.I*Tb ;dܸqR 'p/E( /A `@$&9V_ KGM#4ܓ˗ 30hfݡ^d̘16̙gY1{_*@$@$IhgL];V x!oR9A,?k2}2%p6m4iDڵkֱ[ʌ3YfҵkW\9@_A$@$@)"SttO ٌyc|&Cض{,\-]hYlP;6w-_~kUV% .[oUn 7_v!_|̚5Gy~!  2"84ofVBL 3er}PҦQNJ̩^-!p rJ߾}R_"*_޽{G_ɓ'/5k֔={ʦMd2vXѧr0   x'*~n5#̈kﶍ$ZʕO*~]Ybý<|תW*r67S}xӰW)EY)\-[&~+%  $PRADS:`$&;cMyئ#Gdk/>W s7oNRz4i4lj;qDԢE ͕\ ~upHHʔ}eJ"#yIqima@\W^7xCAOdذa1qԆ;:g}'`h;w &Ο?_fWzZnذAlcgʕRjTH ^8=d3)RNEzu,1I @E6B]>w\V%\}֝)bzIpm {ڝ?F4hp VSNQyT.HO<\{RJd55kԨ7nt ZjV?/JX~FAeA椟/ZڸuiK= d<׀JbDڰDqҝwUlp?cE 2~m9clxhm#RvvvHVV۷o d5ʺx͜9S;?gϖO<.Ƅ̼]?xc֭m۶mސ!C|ɹpHH2`nT5SKAʓ|I%/OؗJ<ժU?s[MXx 0ؑiynIHH S2%IM@HYO *hZ3@GKI/B߆~ܾ}3&(ֺ_MY  H X}?{oWQ }!FDY$(PFořGeqTQ"::@Y*I{'{o'%o{V:UܷO{ԜYRƫNzS6LB1wl*fU>}tYti&f-EfذaR[[{XrCa@ ^%w t;2tګ4?c7X}%6FR8OyD{!P }!PBt@@ bJK=|VY 9#tX S1;6׾ݡ; +ȗ!_QY|0_, $ &s #@D`0Z`B# X^xK/+$߫~ ]Fr!CPߍBz@7ׁtwu$`q/8d…2}2ŋE]dH;.2ټy5EʱŠ\(abt]FG$XKK,eK[;?ec+c?k>Av &3P!nmkH72r;olk>9}r)>-ۇы@ G 3 @dW+L"#G*8y`za\ЇUEX|]f=Թ 4glfu]Kgwh,^wB`Ԡ \eJYcMTOk]9F lo94>P 2 &N={K~R(Z6^\elDE}xfԟO]iT{tQ~Ey>bƕGM(>Ja^-LWUUU9]VVV.)T.G? 7!w| $peyAnUX3cͭmuv֤@dZf)8=$%UO|SFWJʰ+"miÅZeM!2;W2W#y⿁ Fd6s{G #B C |Ȅ@@ (ZEo^ߞC05ϓS.je8#ڡ}RCesqU Y2G %' ;_lEjj~QqOE!,^Kʢy\k}q߁@@ 8,N8>} >sLS_>;-Po#Z|Zq+_JH4c,~!Hee O"-uV{m? /ٛDQO:&0׷j)H&SRmU{Bէ+d8 cO幑60kdUʞ۰CJ*vhyfm-CJ4Zq`CSY:m|++2"֟ō@ a#p˘1c駟Nڵk466yg K(97eY?Ǭxsq:}& __, -tI%J A&Jr𠵸bl%bz8M{2bwtZFydA~>8^d;GM}3eցĭ)&;datק9!*YdIb(^P̸a8G{+"C*%f"+V/t\zgL1t1 dEy4CܩD.0VPLY3p##9ǟ{Y^\ݨ-cL8E5Cc9p\y%sG!NnYmP9M rF\mr|Yٯ5k74!e_2}k&>[B0%(&>k֬1sx-8I2@ ;vHCC] 30䦛nߒ[9Wp4ڠa$['rTC/2zr\c]}ԅpllnq?dG} GS/IYt'HWGɱwqz'Ro\+~o76>:+1E}mybqqi9ރwQ.dҩL%nkŸeϿ, NZFMOXK[bq{V@`^p-ji{80TDYr8x|J$qqOT@@ !p' ~ʨ,+/}ɐsDxaZh.2Æ ZV%% |r274%Q/$X=Hp ޺pG._S*I.;Pާd/|Vo"P^k5Չzz9!?,󩮩(?q˾ŔVb`^QdqԈ=wgG}r|wFY QxƎgwi1jaDJ7I#kdh@kh7:W=RZe(!IΡ7̓OpRyo~F%] |cJ Ń@p)gfWeպ<3E^Xk7#8$ S#Ъ]@CS>zu=糥UK[k0f?n|.?yaݎȟ֘{~_#V`FP@× j@.~=Ah ZH@*u)㵓R#Cf>W)MVh?Iױ^ 0,bTVS|z#Z) 9D={.m:ؠpV[9sVKinO4''O/oۘ&YsskSvnݿ~gsL|PM+Gu._u&ޘ % {эH," "Fz|1נRCM0;G"BR?X}J>eS,rd]E,{„q]Yٟ)ۤԭSf/\glol3_`&6|ܳRYsn}e/[s7&WÜ8DH,0,hg\,ؔ1~)`?>>,]uFE4Hnk@G vhKC> xUmQ/ *c1Ʌ@@ F4$!#C R%q$aa[^ryEo2$ )Yza &USbkic"+5,8t9]cpFX&6õ8cJ Q-c'rCTr&K"@D5mn-E m f[:MGI 1[R٥r=j~iZOԋLR!e$*ׂmU=JR']!e~qźXQ%5#լD9ţ?Db YyXɉUJr$?r[^oBII*Ƴsox7Z.81S\#u+)Fڲ}L5Kƌa擧#ۢa)q"+eL#I>CF9Hgb몣Kܯ5:XxLKoх&\88,l2Aj*lə("\dq5bprv> ZG8O>nLKi?pd#1$AِqGj蕧VESܡ<,~b9I7H2vBz)[7T Kk{Z79O>})+e2?TWğSo9d8>_,=.~~,8F)^oUmy.|~s?ǃ|swVw\G8 =ƺV )qЅG53 ! ~ _nA?-"7#x_eb3X}5{hlם6;WXwo"|ø΃Ǜ'C\s>MU{pChqo:]L 5N}/ 0q̉j/.;Aڗh~&"U}w&iqDZK/V裏ʹ+  ~5. ,zK.{GW52o3 2lF뿶IxV?}iUymn(CSjdPk?¡9eQ}--YYa\7ȞND}˲ǽ$"$(jC|c=j&ee8h=i57Uplۙ'cxCؘKmx|e{ #X}vwBoG_J`#yI'%A_x\tE.Lp"F*T5 AI%|i2G3Bk񴄊2$P4$b9BZ}gHqcddiП/۵W%oGa!&6PMezbk[E/xNJ~; 1ZQHqbC]K s7HF?W'acX^3B:-Kv2v} ޕsAKNLi5Ǖ@"ss͇ E`_PgNrG?%OSL#Go u|@  E >Ж 䋄VSJoy&m:|ry9ͳ)}̱ $|_ZǜHu{[|sߌ6m_SOjJ;E8s M~3_ygv],NT bѯS]Q~1] qHÉ%啲&۬ u4ͣE5tE;'c|US+L[TǑ, bF`= ,{w+^zgmX& 6IgR\8d@@ 0HpXyWKԒ짿Z",H5e MK[=8K+JJQ@H i`g,HWhArPK\b7 c&/wN1u}l$ 4!F98?_O6q JN!g}-7DuU~/8.p=U{XLjBۑNmʶ74`:2NI!W;ڸqqcɜ9sd2w\S=@giZBڻw*7mڴYjY֭C> X8ApOH9TKV|F'SU#A$d$$(ZF>Xgmc߽rҺz*jUf!6֨ŽU0KclNݢs]OV-:ϭޅ4"kQ#pX}&cSS\R>O]w%cǎ6lUUUG*X.Gw;Q_0 Zg)Y a H#~_XYI|7WZQ6~pE{OQg5p=mޱR5M:wTLV'~Uו'WǏ2ȑ/kaohlQ#1[*B;⹏dTH'n.j;hrA1%ف7AHUܴS;,0~^K`k7l3%g;JuULRܻYF =kT*G;ܜ"<[Ucg V֘1?^oe7c]DZ^uZV ʇ>![K.{wn=9"/:ʥu3صkWx( "DD8=C@Iʣ:׈G'#yC^F&Ǎ2bS-$$Y_s_ON?!z WH[)G\| F\ͩ/+1Ưl=4SmZ78e8O;xt͑Ý䠒w+c{r>(/2\亴Z\`7[rͿ.fQ⊹w;w4:LĔ,^`>{ŷXaf6X9YP>\iSAw;f &vln2_\:@@ P8)w"CnBĩ.*d > = D~G2yt8ݨNXX;_3Avͅ B?>F=7z|akLSsl۱蠫 }pql*V(J}->)仙&kO4S2h6xaA~"1] wwlk߾ 7JEکͪ~,,ɫHȏo򎷟a+-kѢA۶X1oׄ\"pD;8qqQ5kA'"[B|gΜqu 9Ȅ"+j{|;ϖcNΕc-5wd TZ+ah YiC9,]N' R M75eţ $!mܲC&G.R0NZ۬!DzOΰFiD<(bXExVS]h0EP+z. GR 5)Cr7V~=sԪRH4&x}Mz!]ڰEWOӑ _uUdٽ{w/^5PHA@@`z'jdт- c>ӓOI"$4vyC#AH"I"MFSFʡH"z̄R- dW#%|Rp\m'W}P&_Q~EʺjR$`jH#0ڵQVno;0?tp/E0I٢vZZdxsEbL}m>,CfrG}.js476W~)jwmN==\uV6\@ СC K/Yf%P /u]gmBGD馛SWѠPp0V(Hx8*1q]5*s9G W9N\p!iUq{ I,eIH q1#R2R:H}!mH/ Ն²izH)F<* 犲#KGER>tlDpIі%jyo3G9VǬ𖢥#ya%'6yGe˶]?{uTŷQQ쬗 LB"##hokdqk)gg\mp]yMtttט#|P.ZHaÆImw/T..@@?@Up!J*=ɘ@x ş$bq Ȭꂬ۴]֭]oە }$aiaʐݙ6uMr@ MHR .,$idg-x:&@@\UkC2";.JO'Z`FT qv|ނ@IDAT(WG5ir/w|sa5@pg=wDYU 7. F`ĝp`ÕXbj!PBt[ꆟSk߄C]@ PYa!Q$ȓx!fy#]rNG ʚɮYa$ɟdǚbcI繨\RXTjLtʙ`" kHy΄5Xnڬf_^!$PG(7qh/_!ST "/y耷ؔ>>{-7rzY.7_c5 =4u b,$qcA7HX{皇K@\enWcD}­&%q~ dߨ01c°F:m̈́@Lq7UF`%{ڢ~T_GM$$q$>)4& $%rp:T1n> ,$ZWeƣj;ҍČIfwxQaOLVtׅ$6-sܨCⷝ!ųW_oªAL'M(c!.4Ů2[g:>`>ϼA>mٵ[ e8̂AF)5l'27# 5hșSʨɓ6deB> (.P@\Yipx% 2c Ҹ e٦RצP?HbIX+IH+,uZeXbX{@SV >zMԹ˱(g_pq!,u}冞_ M1sQ^c%&Fg3q Vs1mOg{cXRYX!%R54APW"uϜ"s#rrx%=7x]D2V= 2⮛o*/La(z^Kf-Q}ZH4|³k#ReJކ~9Vp:} }H,*U>} _{Ǚr폃jU9D7ү]U&Ʊ-^Ęֽ)@?Rt<8gAOP-Qq.-$9]n#`.1(#Zѷf6ٸ=Yet1N?Ptv8_WC$!C_7̝DX@m#;cCp-vŽؿa@@(FZDcK7Xk{]O n8c둦=U墤F~Tox:r~⮄Ďr$>we z D'fwu>Tjb&{/~ lvz0W(LKon9I'$puIG6^U>D~|g䑧VʖNRKIԩ/vA;O_jX%y8']?c Gv7"1L%e2nX)S<CўaLꌮޘb >#9ڗ>&ֶ\\4p'n4.9 xvXn$l1aMp-no}qfG!<򞼈wv_#{4҉Okd ?$*.bƚj,dNXE‡d}9Ԃ X'L'ۭCtѭwf=(^iUwHy{",a'ضuƑVpuiGjlm7Vz d1pq'(S1k rЅVf,Sr߹)Y?S1A{Z=+'avq~&ߐ>h|@ Un|«MQDoې)%i$n%ŦݴR"WxyCGu|9]m3ӤگKk:PNJq*]dmNʱyI0ڀ`ڰKIqJ+:I{q.gr1jzcĠXLʾ*-)|tٸfsԎrfʨ ,2W˔~7G7 H߁ŽSx19v^IqOq\`t8Lg2^օk@ Q@Zc@lȕ#N$Jβ )r7RZlv˿>Z\u2[L1c6C=k76 ,ɷ\ =]@&IuvIoKѐcNJOI.Kڝ砺п! fP:Ns22Mf^CZc8n򱫌1NcI|FDZawݜK>5@FK 8$hD  @@ p"P[&zrh[D WBUB\\1w:KUD%I )/"$>V|P\V_< _u_)3GiFmDϺG=T4/x#tLwIbkN̓g| ħRue%̛2(y2XI\+GsCV|ޖ׺vsu1Zs|l~WQ> ԇFozQC&uj)A/ں!GrhHfwDo;;b/]Vx8jgTᵮncv<ŧ{3NJ6CD34lP9i辐 `:8<ͪV)mQǢ~`l^MĶ p3-||y< >Y*HjAߴޟځ8cD](qnBrFI˄EV@@ @CC,[L&M$'pBDVRb={Ȯ]e9ykuuuR__ǼY.\J+sy ܷbr0QA[5: RwhI$qU>!~}4ma>~Dy|56yWXcKKq":wάJVpB7tq}1<ρaž$_ p1,*C|IVImDIVCWoDfWźYGss'08W^r{/L@@@@ @`}WȊ+׾5^#T ,$ nLi](ks;J`xs@SW+ƀmjm6 ƒKP CE.klhg Jtu5IgyMTO4NF *3]݆p=qǗI1c=ae'1䒮%i#3rx&Բ !qz$g,h y)_9+CBeChqa.f$%`ʵS?ҥ.pɗq'?IQU&L89?g('Gş|Zd괕1+ lL>i9g"1)C0ﳮxPHBA{z]HF džrc5dNM+05\ܵKi!*kFyuqԭ1 }>sR*$Rc#e~HTy2eFZ`<+B.A ya@@ /mmbYUbk{#\@ʇ.'tRN_笳Β/| ȥ^*rJ< ;＜ELygFT'N9TO S1jI Q c0eH 0oIoRs>U2UBᬔ| ''> I v4w A:iD#EMhhjǘ4f(s@ymD4GBg"W/LP+䱱vF?tIR8&@aKoEQرc͜ua*EdPk;M'1)㎓~&Ow,N;M&~=\eT!7|Dtnp/u%liz%sa"ˢ ;BH>Y H%~u֩QwRzyl>n05~9`0f|_&=cRTy#@ßfL:9ǂi0N[#y!|Ĕ^`,4;]LAp-^q/gf"rH02gYӲчo~sVuNF}Zr疾.J*WA+< E q'[S EZu?l$#u=c?J=9o=.JZx3QO7s4V7(l nj7.82EnVω5 U~^)+kn"Ĩ$:-C| ) #F"E'"Dto̙3yA+PbC#Ip5dgKUH׼bVF7A @?LȖ#,4I-/OzڪL]+l(0UGЙ~",#6(GXI?E X_N]"rOVxw缸uR=#a썸xȱk@`Q@ &tc]vIcc1/ɼMoR+ua͛7h5~z],G7)n lP]=nڥE3v)Blu$C3,<\v.LC a7,™.+Bu}I}ǿ4xaENe6Yς e@W·0AʚxF:Fc3a/GιM;RhxI&X܅kp!Jq'gAAOZi^?@C\uUdٽ{w4[k5O8e}{_B ;i˖-~V?H[oU>Ͽ" I- ҰrqD#͉~GIїWl''Ϝ"W]0Vʑ6K sI'wiHG&ku%uLIB&IeN[ț[kHy^? =<'{Հ~;?w%?oV?Cn!o^mp B@ωʍ{TF -"YiȶdɆ@@ 13ljj22 5[Nv! Ͳ =|{ߓs9O~RNJG:}YQ^)G lBf[+cS5&3U gO1Qݜ-wo"?jl/ӉdYsqE,t ݘJܕH/Rb[.`m-Mә&іmLݐ2bւ'pkY~vHP+_^e[+e QK||u3܎q2fxɘ+K>'s*9qǶ[*#E?p6lf*җdz;'zU&*ͯ~+ٳg㰧?yB_+ d}"EPcUVP_duhS͢~JO1σi͢7Yfɣu.@䖋\G,鸌oM0זθ9įۛ xr!ݤp|ķV_/=%>|>Ì@ EЗ)(-~e$N_%mCR{hﳮpŹ ѳf؍# l tu=B!K&=Wu6g nk'堛ʷ/z)| ևk!PodafqHdDڟ: "Hp2g]0d1P-\v/MBػ1 -f{/Fy2.gkH{?̝V{tԋMo7L"Mbכϖc q2_ v-]8=VzO. ławl2"" p5%\\VP4Y$Ce#1doа/i,o^w`y䑖ή ,5^ HxiLȱN"M{|McvO6˚ vc+3/o/>6FidK 6+? ƕ6w>t|]:pL*+`t&Dq$^+`>yG(| 7ȍ7h|!WX!W\qE%@@  Aw/YپosҮ '.D(Vk72pЉ>NaD!K19?eC8$o}˜p_Z~{^GC$,tR zG[ſX 3A +O ѝIUuّzl2M[I*!c+d 9|JW͏N 7P1Dڛf>=˅z/7Xm@HqVʳYQ mq.^hY'E"voq֨?HESsWT~Lސ M=4qomm5wgL>]j9 y_|A 3/.Hp5e]&8%z *BuIkz`eJ -67`)CyM?HkK UFW_&*Le X <2hJTn2 a%a˘ovýfh\=%w5mHχt/xK|j/hu [VG zzYō޽{CPjo{L,H?7oǔ)SdȑrB>\@@ P([v[ˬ/rc˲;UηBvǾipQ]9Cҵ|Î7!1L`pYef>1ֱO5ھ՘C.X7naĹpa[\\/`jQ׋%6N1{U֢ s7V!w>,89؄kAYf%N㔫톗9s"lDEʊ;i$ٰatvv e# @'ThE^ܺS:¶{~Gm)MōPW!c$:xkZƯ80,ټ{_$=<Y)@k43Nuv%\ 3.oQ>G11#;qĨ9(eF9 YB7җ!1LJ )djBI =nDdO$zy&򬃓І Kt$Ѹ?z.Z:etj*-'GE1NV^>0gߟL+.q؄o;BOn6$)2[lgy+>'*M@ sH$pɳ_lz똮'{^.5Z%# Noe p|FcڼD=pk7 &$-אBꀢ-޸gBF.l88,I ,'j VpV$UhƷ-Az5/c=ր`nWh.!c %zTߤߛYǦE=Y &"u]'3f̈@;v˂Б|aE/T.͏_Og|@ )=J@Sp i>h|2A-u2A# ^!(9#" Tkj/Iڽ怺@ݾF.誃;,NfnJ裷'6 d{dw۾N hͻIko4٥@_݀jR=n,_2kR] L7(-:$LI^dg=qS̍@qn̛T k,G;<5Q'Ջ oyt8ri\U7Y}ps+j'u5`~== ]wZz9it =[@_KCKdq; |a7jÜwk2ϮCCXKU&2[~XQF_ '`sNm9s).T.#@@` A"hd=kҴO`s5e>F(NmuI5]bw\]2ϱPU&X6u²? p@hsFf$[[|WxO-Xb>)^pI2C7 tlzilұ"q${pH#y.+ Y_WV;9@xlÅBngՅD?. _~yݻw b&O??|ccwyPpፉᏦUWK뀭d KFccAJFoI(|7x0T*q,&=%/C#&\: { iؔŋVcq8-닶?Qe a~͐5~s()CMоN8O-H {,ed@x>Z=c$Y[oE!6^(?\p7Jn$7Jh:ha4Z5.0b/"wfwAqE }b\ g6VeѢE.2Æ ̦e6@@ @@c*y*->"NaRY*` YtwrQ,+|-qWڞ+ 2sUP/9XX(2qovLM'7(ǩOk㰘󆹳"XhxDy680&,Z̏#\p吣մ>DjR~\%;Y},h޴\?\Y W'%~mB> YqqkqW|Ď ?@n7h֡#aĩFCM,K w#+94t[%k SDbͺϮ{-`Ĉw;oQzL?|G 0ȡU{k|c@]Hʼn@ ì@Q Cbd-$q^phkKG߻ump<#@/Xoؐ8^@cNh72<՘:ͯjA|j͸SR,ܺg!̆reu[YaUlJ||x O7idcɭEcq@lt.^iL(^~6b>RO͘=em=܆A\Ըi٣-=QcCi@(A._1 N/!\ * dq%dV>&"hc|ŵ?srG-,:˖iH`Q'&pXtJNhc:%цNvz97ꛈz"c\AQ&rQhsݯno`ijnEYԉmRu3&n]tQ an,_r'H;V[@\56z֨:z+10; Qxxka8*2UOm'6)>xv6A|iN;mL G p 2w^8sOXA`ͭҠk|qC-2m@< !B7oWm0}ruW8峢̸l۽WòtztqsOׄ45^?Ud$ 鮨ۯӑ~3nn. ԋrY`bfx* 6?`\e9Py8%-qJ*k_X/EuF`iކĜ"=^{|'\ c (+u'(50w |F"J!/3?8fpRm{zcG1 ajChFa5*"тnnzpHHAٸBMrfA0]>ЎDDϑk KlXn'!yyٺ^&<.e"艒3Kd[߭Q B1)qwU'b!k=Ijiz0Ï#r^C;T1a)5c=ɺ8g |Ѝ=k,%H$5jnصDŽ4F>F,¹V &;,ƮWeѲC̛?6|U~j>[/.sMx[fxq@Ba3 :J(𫱵RS]Z̴Z#S`(,0р@@ 8Z ~IyhfG 3ׄ]iñ$$$e"d<䕡1* ʠk1DUz!uADrF#3OK ѝyf.~j]]mwP.{ǛЇ2J>h7:ARUTK̝=83*S|~1b]Ui8r=qAw$?`u%ku.8O<)\J!:W ݼ}11-[v p K| :-2*/ԑ! Bf|ܵoY!JHdAܐ gBT;?vLJiS"zmEuJ0koXƍ.T#ځ<_η kH' j%?}MZ4& ڝ-6Ԣ>d#khEnB &c y qrhwF/|Vm}e_= lΗ3$ޞ# 3mǐ>@@ pT!0yh- ^BI68'-̶$W%e, iȢM$oV'[4eh}ᙧJ߁n9yDI;ԕ w#:8Jsdc+ йiNiki~۳_F\@9.=i}!V@4o,ZܵOG\L׽Ԋvbdž{{CvNi%ߌ^-^Vgߋx,J.> veƢW̍?Z\$ՙ7p[[0:O2<+13 (f@ᆁԧ(9wf% eHZÒ> : -T_ZVU6ƄO~_?m Kц\Mp)pc7duS"h563UŒ1>f<jMC =5#ݐp 9R;Ү67?XGڒnwkU>;rjCb߳l_TL5JX9ƍ\P1@%n,s.bR@G lN#?{ݼ4@oMCu@ r0B4ߜ?i6BlfXm*5Y{[d ֒7qwqӭKlQQC"Y=8"y JV©Y)M$! &Z,YF11^zÎ/;w#MUytiƎN) #Fab erh`m>9m,bFU.|_yѱz=E?D]`tSi7O'`S6} 0&'|&LSsV9tD!2W1ã7J ) #FQaa2{|K]li_fՇ@@ p8_Zq} RE;%HH a1F'-[{2sCԌQcFVi4r'ʦټl|JBh5ğp$9Q'Ybk7UB8`qEcؗLdo3>̓hw䱣lT ƈJ)-2|di QM]I>R6b^[[hURL6i_KHϮZ/O<[ ʅiĤ҅nߌJLYvK='7=Z?e'8S/ [>dOxS{b߈b/ׯ+C kv6{Fy[h孲YĖU4XK,+ҲѐȽzB爡6?utwQf}rqȡYeJ5" Вrہ |F!18fDX$j@i8J$H$f,N8\ϓ@ȱk_sQ]>pɛ &qrGDUu߭9ƏӘ;*ӮQh0FoFѥuɳ+֚.9~bJK~nX6JZɛ9ԝloGt!wq嚏T2mNs@lg-voCc`BDj{KW`qO@=0B6 3 7px2~x+du5??F?W_}"qXa],Xb9N1cw0u$tKCl_;@IDATTCysg(AЀKl}آh62ܴ?_o7ɠ"(;zM:Ǹ}c5FY  A9C*n{q?0@@ !pwҥK{7o˵^+vFY=#HT]n ,H!dL4mg8~ Mk9r$+1Kn*\jx?rN'jYG;Z9 ,E8mRM)kufPPp2CIW5ߜYu'̐vc)DŽ+95T_p\始&s3fs*'H;9ȼ#zW;3N>=`G^e㝦 D ':S }7wke?QE<Fx7ˌ9zK[.-90R`= c"D!Q13"1x|G?QL"j4 xTXXدz{gjwgٙWLwW3~jCTdU^HLܱY T!l!FG}]ܡM1QgF1ьNG0q_&o&JR:$q:/VΏʍܲE|@z͑j-2)椓"ZBmb" D̤lSS:-uFܣ6\HvV#8uet±[NzTYN}8cs q11ԕ"_8Y.y;YA=r$e:5©<2Ga%A>[9m𛊧nbrDl!r% Ђ 4(JJJ͛gfï}ٲeU+VUGL?O=@&ԡM6{zˆI&q"M={HH\rfxU$$!k>0"n0 Ӧ&k9M^ꚪNI;?d`] NCW" ~Î~zQY-l}Q496~8~ԧWW-zC?x))n/|}J _ آ#q};wA@"`"*RbZnUT8~ܑl>P.-iڵzt~ƌ_ZBϕj+Z5k7y R spacg9ĽyeUWWr^"6$Q1S4V:?B꘴"2aGyVuMz=@ E8|ψ=+8SLڌ&o\7vN4927'|zxHըs07&߭vwУt#/7["2!+5@}ZY r,?W1U"JQs/M\ciG6tUp"r5 Y9p*&عcw:B;n81K4f- ̈́IdP9i"׫:r1.S?I.&•_|2[NE*dvdE|yR&6wZ|Jx6uG  CRVmUjN©'GϺ0W`](_w{%VCu*84.+?:")+&f[1taZ3p~_&(Bj4bc,-nD2DA@DtIG @C^x!=#ԥKV>Z\c0@tYP4Pq(VS}'TqH#q4;L !f yjiğ )lj,|mcML̇]/GSwFu2ht0I: w!֏-dpUwgWlcٟ"4jLDqLY/3?h].g#Vqr[җn&5>-t̐1&=(1VBY&5*ϓPfdժub<]F˲aitWA@ ib Eh{LѻwoKtEɓ顇|JB3dƼOGgђJ6qGc6U~tPU"+BI:/L{b s5A^4,CԂG&e<۝Ѷb;_FD{E>cxu " qߘ(s;i~n=ʺ=Sl-9[h|`%\Xx$ۺ BJA@k[o{=jbgH(3Y21%wo co9Ү*a9c#３V>y uUdn/VuEg+zbSta;eR Ŭ M8zW*,׍!"61^=V~5ӌ #G,Sue0mɬ}n F#p6ru(jrp]gҶnC1M$ƃ x䜏Y/܊N1mshћ,e+!r 녅d7oݻwӘ1c<6G|d백cDntҀ&*Y~L]Ms R>ݻ:!% +n'JBh%X"2W*08#ӌbúP7W7H^#*rLQ #F9$FaA]phF| uۨ8Cs_GqǞ8XK>OKhvP!ҸS's-k~& 1˚[-9S;/+f5WM?ΞD0JT.9QA@K B8Ο?l b%t +wyZvt7ҫ5rbc>Hr8ZWS_]GEOD[PWF3 B E9P|@%&jEM3,jb`dt> ۶;n>H 3M~kLs"Ofb12cW))-sɼPjdmnF[/^i# ~@0vx\Wް;J:VM>EvU:li3ʀRٳ6h0lDg]?NEZ9q`:nh?]{]G?8מ/AE |:+";  jBz+9qϞ=4{l5jXf mڴIO%L@}뭷QFv*YĮ&:z Xu|)&g\hhf%T&0g1ZEO !?H 3@˜yާ+{zURQ&z%E?rub XXr}lTXMH\}̬!G3W֢ǬV-T,2EoF́pS>F̙35С.zi֭z8YVYA{nBwc^$_Z0N-_SAܧbBI(vLzZ-etOqpq<tU\H]I!ɬfrmpy믇|_~@PC6 ,bGQ}HY$ůr;sPơ;Y};Y֔[0r#A?l߱>WC;Q4{7d]ɘ"u>+c%#W>{A@ԩS(iGs&| ޭ[TH)[_L@.681EV4ɗiF12 o&9P};T<@M>()}Y85U}o_;0>1Fz]mlLy:ͶL!,eSYgycfsA0U4:Wʴه]rLyib<)F )aH"k_k Y[' Kd2n&󷍑\erښG8@AVM?=rdv AUUMB; OwG`Mf1xp LoZ8AF␗/|J┰Uۯv(cM`<"šNէs;BlF# * F>˖-Ӌjlܸ1>DXp!͝;wȐ!}viΜ9kX[PER  &qL+/zYAM#(?hI)<*<'P y `@w,܁L1am6Fk׮fzg+X]vf lJb,G!F*?c nB6ͤ 㐋T3F-|&ÛD\L eؚ}jUγ'~k%\R-\^p~Q9Kn`Kc 0Bx@]Ʈ>!561N"' PoĽ̙4fS˖β˕d+ojoDՓ?کY5!U#': :~&)fl*POd8 Nmmmڐ:z#׺-!=zrZXA@$#4N9Ŏz'.o:w,]z7̬辷h~=I+FoJދϊ)LRl 1ew"gdG7~DZSp3vm:}P:f`xe%S FǎKd7o&L 3fη4" @"' Kcu3Ւ\R8Ʒ_y;/b/OqYԽ(m!N;e#6S5Q'B-+T%AEMnGoFdT.y:A2':wDdPL45S 5gƌ4|ڲe[0Žd+6 ; @r)l׆zD&Jʤ7FDnc]C'DmtϦQ^]:X%=fLW:Pxy @%1b =UP~TO<1Ä [oFC?ٳfϞYVN+/A@A `d9V;^X#yMݣ]B*LD_XfaRYt3g=uTM!jM @L>=nwƏOE&//rsm*BA@A$C}k*殽jhIٿ<Ѩx3G%+qhhk&6# ghnLԚN:YUjL =L⶿kouBA@+&Y2#_ [7(0D>uom Ϭˮ2f^p$2;-#l#_Gav aiT+b+U8sK2R(ACSF?kVઔj.d! S# GpvI~BA!@=u~y7A@G@qT(!ֲ_KWM<<dmD$ @D`׮]Pqq1ߟ06}'j*ˣc9~W}vTZZJGvdGA@FmPƂr&؏yY4_hKFiJRj5k&SN˗{:wĪ*[iѢE\vv6|t)yIkhӦM{s,-2nȥ;B $ ?pB;w.А!C_Os̡PM?ݛ:*++_|{9MyA_עE >|{,;- 2nȥ;B $<t9hMN4K/DSLlv߾}.HW\A1X-[Fƍsoms+Ȏ qO7M# ~,X7FTRRB4o<3۳m66m'Lݲ?Py}ݚػ#qhR%m=u57gҢ7ĭeWU8WF A!IHA오rJVZtgϞ1yȀ;R>}_ڲeKZv`$ĉtS֭]9lۢ%r鎀t?5'/7SaAVhwA5qL L*'_l'n9Y-h)Ha sN0mS uw,7c=M>]ί[/^LO>$+TYYg\A,>vՁrpFy'{@!v)kE; SZ.@mا>V|5:V/{BTP`r$k۴yf=ҬY3= O][ڠ6fr[Guu'4QvQf{<LjDs%hQ0~ 7>fBɓN:̒ D@x{ FpW3ozԹCA@;vԵSysV>&ԶGAwޠ$Oq+!@A@4syHb#UT)<z+]@+"aESo{=ف?uGL8MzKj3.25M!y.nC%sC?͚[ p)4vXB%KxЀݻi̘1~@'O)޲e4 =7reWCn\fH?BJA@3pU1c͟?@9!\#FÄ́UV;  ` 4¤ґ#GBDٳfϞM͛{.֬YC6m]vVN9 c4uYz5֦M&[ӨQtSO2:Uב鏀?,΁IP$A@ ?@UPY/Υw+'C`\d(7773gjbߡC]D QiyںuqbODmH G 76_FƂ@Jw5kԩSi{ \ů/(g@=7aE3>ZKEPEIjVNͤ=Vgɡ @)A+pB;w~:dھ}~:gΜ4" KĄA#iF[;ެ FA@7 OgI;=i$BLՎzv*?\);XIA@A@|}j40nyhʔ)fQh=qg[(e3< }gÊ%_hT)7ooxCu~4q}vNZpAa~6egC   @wD@ y$Օ+WnժUt/?_ЛV  O={g9感;*u Ph ۠m]~e+w܅O2 y(:mXЦvSiy%X*#0A@ ጱ&AƐj?1YǂFOod8p@Oڱc}駞Do|6mۗH̺|"hNtP}RUYmUMKtx_%N&XmJ__^=p/rKX[U1)}_nB7,+.^]R}KJ߾D[ʪCtPE/Y4TJ+iG;賖Tawo mA,YʼnWVl_]6~oRׂ Mj*r~nʔ4-\ ŋvC!u-,`Z>n³|gڽ9Z&[(5+v7Qa6u*L  *_y~ Ny9v5ڷoT$y p@c@QQc!p,ܲ2fVVY˖Ο|eeeޓO>-rPBħN#6^&]ŤB<|ꍃSdG+BȾMjess`'\&xlύ]si$O6 { spa6͹0k{HZ/a999{k%,d$ɋ@AA <8}(l׬Y 4lAztw,UlAoB;_r)h|48q^jU (ic-}ꩧ=tmܸQ7[ҥMȽzb?K"!{͔=C N4 < >ܐ]F`c"Q_}UJ`o=XBma4lذ[NNXX D_C'p#ׯ_)XFRf!Ľcǎq,Oȃ{h_<Ɵ\}gyqSeoN?T:!\=h M*ж`wr/Nê]wЇ@{V-l*fzShѢy5M7ݤ}CZ/T4)?h&~ZĈ?adGl9A@A@2'cǎ%LZd|,xߒ$  d: N1)eƌ4|ڲ%: /a4^   4;N $[oUt"D={h:K*$D}*__ "wb+ɋx }:%B]R9Vn|tğa!?3VT]z5u#^Aml޺u+a9o> u[$\ٷo=ssoe}h+g -_t:[i"r7)Yz׌pP{dk} Xꫯ|;n[rn!;ܺO[9acoD8|g?N]v+iVNt۶l9Oi 2*QjuW?nwQ}ꩧVosvhA?eeejѨjEpՏR<SK/2Z5>ꏻz1rcU~olo[GE8+t`_򗺯Պ\umf5ZP_W\tE? ~ )pFU?g}+lC[9+GXhҥո{V~wW?۷o׿q㪁1޳5K?p#/|*'5r82d̒ݿyykk2uoHf5BQXXH}q`+;X6އrzJ&ب?i6mZߙtfb:ܳ&؞'[[loyIa+ 7|`c강36 Xtذa:Vmo^.٦/E1k݁ÍFaiȑ1EX5$L:&eBג%KHhx1  7`/..,+**l|qXv-Kڿ׿5S]up;Gr[64zhO7lTHV.1gϞXy2;IL Pq2=O0ka^U[rns_yI풔ˤ?0Q[9n׿ [_~qA8[r~ŽmK\=>dqF ЪU+]f_DL ,+&n޼n&MY. 6LaiOC#؊ꪃ9dیS9n穐iV.6=Xׯ[';|BERn강 ҁ<`f`F?7Iʿ\강Ӎ|CON$nJRnoPV\Y%[.L+2+b}r0BOxuTS'|:,.tI|;bb*&&+++<+6^H< B!%CGql%??_G?|3|]0C[9~cC? ͟2;1_7u-~XYyV.L71ĨgV..i߾} gy~he g&Dza+d ![nMjno9강vmmK\"<(⎘H'&ݺu#F;^#VͅHx ئ޽{PU_uRdn2a~lk~\x\~V CBk׌]7-Γ-r=kE-$^a+ .Ḧ́a|강3u87pa @bny[9S}-&)Kɱ@ٿLrm )$b6ڴQ_2{V<{F]f0T:OFY2mƟF1y&񳩓20EpʥCkk#1ZI6^36}gDMm~˸myV.HC=]D!:l\eEpzEkN[rsW_5` $/Lo}bڅ}۾%[o51ľt(`yyyrD~vQo;TM|gʣ/6T>60ɥ[}h+n n7qD*zyYWlDɼgm`wlm u1x !=y강 SN߲2[9Shho86mJ*D o?luʙ۶lx6IYz Qs3O?Td-~UK#c|џp]6vXQp̄WTql/B&eC!uJ KI~lꤋ}h+.!Th%®|ٟ̈́{߶8yVίj%R y>*E8F᭍[ [k#B2m߾ya+g1 8\s̄6c*[9SW}-&)K2qW.+0k??OOǩoK#01 *G%1u8!v7}笔bR /U&ЎxǏ?ZtJ˪`D$FHD\¤ Е6cݿd=dl3K}|.g~}h+חJ1q %5b`_'5k&dNdk\mmE=[ra`c,'\RXoVpìIjϴzjwV߆߶dCTz3%GD1 n*m'ĬΞ={t4 D v7AĈ |I&r>04&.f>,?KZ~MkG[#̺ 4,j uđƛsKȷmXWlIDATo0 ./ߏ3 ~@nx)}?׋\ved{Ʉc{6X`2ymmvöW 3강3}ܳwy9ꨣ :lXE(J+zڵxɷmSL3ﳵm/rAZ!ĝ& >wan;FAd/"HyP:=3+l1D:6t^"C2_ykMmؽdsrvpy6$?=[*kk\]a+d F?x3a+ׁ{;_~=강vl^E {LA@A@"uˑ   BSd)  @BÐ|A@A@A B'CLA@A@   ):b   0d$_A@A@H!SA@A@0!#  @ ! =N"  ! = A@A@R!)t2A@A@A !aH   BqO!  a?N%^IENDB`brms/man/figures/README-conditional_effects-1.png0000644000176200001440000011473114571050177021253 0ustar liggesusersPNG  IHDRX=ciCCPkCGColorSpaceGenericRGB8U]hU>+$΃Ԧ5lRфem,lAݝi&3i)>A['!j-P(G 3k~s ,[%,-:t} }-+*&¿ gPG݅ج8"eŲ]A b ;l õWϙ2_E,(ۈ#Zsێ<5)"E6N#ӽEkۃO0}*rUt.iei #]r >cU{t7+ԙg߃xuWB_-%=^ t0uvW9 %/VBW'_tMۓP\>@y0`D i|[` hh)Tj0B#ЪhU# ~yhu fp#1I/I"0! 'Sdd:J5ǖ"sdy#R7wAgdJ7kʕn^:}nWFVst$gj-tԝr_װ_7Z ~V54V }o[G=Nd>-UlaY5V}xg[?k&>srq߀].r_r_qsGjy4k iQܟBZ-<(d=dKO a/zv7]ǰod}sn?TF'|3Nn#I?"mzv~K=گsl<b|_|4>?pߋQrib 2* (Ѧh{28oIyes8';Z9h6g>xRx'b8ՃWOϫ[xn%|^z}%x c8eXIfMM*iXw@IDATx u33ڑZ@ BcM Llc'`x~l15$Ø5&ޒxLl] Ħ}Hf_4t=F=2]U]]]o[g9yk\݄ @@"-P9@@"   <$  ;@@b @D@@ p;  @ c"  |@@{ ]D@@  1 pC  g?+7B8@@@ @[[@]]YF6lPhC@@(F܋`@@*#@^w  @QEqq0   p;WE@@(8@@WƝ"  P{Q\  @e+U@@(J(.F@@2q  %@^#  PʸsU@@ p/@@{eܹ*  E   TF2\@@܋`@@*#@^w  @QEqq0   p;WE@@(8@@WƝ"  P{Q\ L.rEš  @AA#@^" 8]!'@^G#  q@ś@P%UfB>'@ύV  @N_&!{Ƞ@-h{)@'@~{ynl\@!@~{"s%n\@VRUh+~ct@E>"&@Bw@@ n+EF@b"Ԙ?@@\SsD ܇[|Hi ł/OKǍmk@@ #TW*Xw]z̛7/ˣm_tig}6aN@@`@_=Fq_7ikkϚ5+3fxN;6l _׳>:S@[~QXwܑװlڴiYL:700 u1w\ >l  ,ۓpnЇ>UEf, 9demvz ?s|+/~Q8㌬@@`}Q7o^xA\]`fm$F-o>{ظ}+Vŋ7t[; @+1G"[P~Jz<}@>XlM>,ݶ+Wz.y# id,@UVɗ,/}KHϮ:ill%Kپ}W&r޾B=/@@1LL˲ Īd*W^yJ=VE'[nEjkGnFO @@`c0xY6M9<^KPz'?ɸuuuɝw)VIRl6n(W\q\~徎(ϛ:YfW.2!F@*pu'7MKEy>Dݤ|ooo&Gs)\mD@vI¤7J>))"gp:6}ь  P3wmWZr+@@ ] xʑEH>: мv=& "pOS@@ GPI(VX1G@ P=>7N@'@@ nwWITJ,  0)g,\p+D@ C&X[{G@X:; p>F@&GU%pGˍ! @LL Ss pF@H2{䑻a=: Qp{zDXx)j%q!pO#@@X&@rB@6d~5 Q2bsyi@q5&DA= O>  @d4׍lXrܓS@#͊~h{@H餢L=X {G@ t1^rc.P{AL IIPo{{ ]B@0A7L  Ga<2쮄{%Թ& Bebj,SR:I'}" @q.S\F%  _oKzێ϶ p/0G@X 8Ҫo< pK  he {;%yrZ@(LݮG3@{예NN jvRefI@'$UGݚqǥ p/1W@@ oLܞvlKGEG@@\AFܛ w=rn@&pE{eŷ^<-  p/@@ )K>oŪѐSf O&  (6Qҷ ' p܈#@@ AnSoO7J^~s QnO9Re({d9/ No|i1{}E@ *YҞqrD  i /Q2 " @4 PQ=u=~ό# @ cDtrC ;.@^G" @ oo"Mѹ5< z M%okO=~ό# @ ^)ܳH؁ u۝:G~/;'@^G# @ 8wK"P{q^ U(ഷF&aqyq4 T{>֪%{ #o*m>@EQ^V@".$M(k.EVWܫyr7  P@{o;BV}@B@\4&S_{\D@NTy[u}hOݟ@@ؘ; p/5WB@ 015bL(@>!" @ h۩2>6Kiab9 pG[@\jR5x k@(@L@@]\@ භvx4-@  WwX 9Am3iqw   8]WK|ۤT&qdp# Wmo}Fd|0{0?Z# @ ܎>GcD#&@Bw@@HeG 9 Hi&sb21zU{ L v 'R Z# @o'=R2i!pO~@H{옸VC^ۋEhQr"@ (i2QU?  7Y! sY@(뢎j&ݗ pϒ3! @,hwS)_=}v_v4 O=D@Dn_b#[5? J W p}@(@5%"@`RI8@.dWM ܫQr#  O T|/{ WE-+e }(|M9# DHm RR#(@@7W#fwGFw@@Ow;ڋh {@@R 8]:}FCeGƕ" @72'H 5 T@2WW*n*#7 VбmPRx8ZT@*%U|IWq<y`؍ Nx?*={>Xn @ o'rO'OŧB@@ +nstj)6.H#  p/@@ >dF)qvyǥMV\)\rfhm۶IccYF͛6 =.gcv" @dV}k`ݷ K+z+ 7 ?/| OZ,Y~֭[Oo]ޱx =.!;@@ VFl)mL6eň.USOwYtkm&=<3r{T---kF֭[;ke˖UW]Uqe  !:jI#J/͛7ˍ7F2c ?3Og/b{z;餓dڵr=А' G H~{y i,׿2k֬qgԩbAfo*˽c>[WN{駥ƶ5 GioFabg2ɏcW*Sd444xJmٲE =.G@ `Ou;ڔG 9i KuO*<7nV]Ƃw4c[ȼۚ >kGK/75b ^ߤTX#RK|B X8[n9V]rm>! Mbi5 |\It / '>ZhQ>v  @y~L5ڔS V*϶Z>?,7t,X?",`N+s++3~gG@ j 2>+єRbn3`@fZx,{u-oŊy:  P9Kb{a5kY8 93g7=w\\M>,6ˇ/s@-z.~FѮ7m$_~(u]'8^l߾+zjoǍ; o@@ n0d"l܈@,'|RoÇG҇?}W^yXzhtUr֎nǍ  iWWUwG+FE_v4*@[y/Y{1뮻K.B/EZ?:1wyX%s=W6nM*;2oz\5kȆ &:@@DNaI{4z&j;Qltp BboEs͛?_NOZMk82t  PivgjB {0?Z# @%4mnn`Ok)@^$# @tlTաnmI~/;UF2\@BZjp{SQ\ @Z!F}%'  P Oܞ_VM Q+gϕ@@ @v S OJWBk" @`  p:D@vv>Ikk!/x=/z *ප%kMG  G |O3 i2hXa ?. E XL[[^=C̫{}E@qZ_i2|b*@G@HZo;V^π  @8muA,vG=>ϊ" x/MgZj{}G@ aAduR%p  PT!&YTܣ$ L(&c1aVKЗ/@gD@@@ܖ&ͺ4D x@&Бvad&峘AM@,Jw;#l]=O# K]IoI"{?c@x hm j+@k+ICV p#C  0Vi::mQL3{Qf]>z Rvmwk`D:ܫ9r T&s%9h{U~/zSI}7 1H&3wj21xtPB8@*ToUl&d|,Q|* @ī M |L`J U"45[cu|_\tEnݺ%{6 @Lܡ!q|4TG}Tɒ%K/ŋ̙3塇;wʲeoi֊AݻWzIA1 _mKl/C;~ž>y(?L6m7n oC]}?Cݞ={s)8x %$MbC,X/~q\>Q/jkk ?O<1ѩ3{ p}M= wyr饗u n#??||H^-O@@J#Tp뭷ʬYDMM|m388(?JX\n>۾}gyfm5 ǽ. @ dvIC?e xyᇥ]wڵktIrٰaʢEo~s|oa  P͏v:}_E[&ۯ mF-QeJ5VfpOD.2/p?(7xc]*S6j.  t5v!=_۾O}S^7,-wr=x%#:q]>I{6 @&?wSOOOg  @.q{{}UGhIuuu]ztg_0ϭ# %h,Y0^f.  d,-Yz- D@moWkwݎjN5zmgX*ͽ" Qi2 "'V 76Ґ{u(#pӡo $A *Rڬ2]vyW;pk|֭[G?zF_}. +"7g{HU&pM! IDw[K %_-ozV9?- |E[[o}/^X6n(o}[JHowL5?G𷥀OJY[v7h @R/(N[~,3[{2FNpxxXv)WSNrtu|<:n@@X Twm:kCpʔ)ry;MF@K eҶ)] qp G=@Ym:]T@\@tG܌IŸGRcƱ p V hv+RM&ϟ/J_Zz6`C @$z4k_~b .c;ĪU䓟D T"^ݚ1j]|veʕw[|A9SrR2+V%K  h팶'۩j/k׮ ?;@@:W[ϢKEqh5  +ؤ[Z3gNs  Tc+4}4Bp'E JF}Eu@@z#G^aVj @Z w_Wm6Q̭W֯_/7tSGG@Ze}ڲ!劰Zor4oq1k >6?裲n:@@\AWJ=)6A{.Z%D o-9'ڈ넰r  )4Mfl$X }߾}7Qz )?w C@>Kqz}ߘ%64D BW^y,]tZh`Ӥr T~3ȏ!JU}cby$ ?яC@@R)@vtΣH΄ 2~Yg7,g//r ~3]9ON@$wS/H /;vx,_W'䱉l  7`.ۓmN'%UkF]]WSCQ$^  ~q:}߭n?HۏXȞ={rU ;Kh{0vs:;;/W U!jltGR2mJ!\rd9 T&2NZehL-[ȝw9+bOٺFK4^G$蟹^|E~7}|rYF6li@J!0uMG}zn߭1D\LjkC# ~N}ڢyfyk^#3f̐9Ɲ>[o>R %UeӦM?]*XB@ XV3 ]G?w7MYA}p˔)S=\tEY B BrMPeJkڟ u y, @&qn"M&_?{[(fAʕ+e׮]C+pڸqLT[iݺu}  PEΑ`dZ_Cݻz3:\dkXpo[b }(#' ڭ6vѢEwSV^pB@sLܮ.ߝЖ-,/J .IRy G,6{}O>|81aʌ ];fV&;@@ C:@~4&06p5kVޓ͜9,v{;:I.K&# @_I&]GT 9uԼͭ`PRe,۬TcǼo|@b.="`RdRj̿vaNr҉A˗6}".\0󣒽vgǻe"طoߤekiNzb@@H8}0V'ju7rik HOOOkvww{-[,1aJni|ߔ9I`'xb|  W+T[7?6*)`Umһg췾}(~y{[Nrb@.b? Gٶm[;vtE& A{gN@#kآK~7]gUi@2F6lؠS6l͂vK93ʚʈ[1O=շ󙬴߲e|GyDo@@ 'ߧ_=1c|,0K,k/gzXP&W|+r}ev1+sˆ !jzflRT(Y@C&XΓիWW,h>2n/G?eРW@@*ÇZO@(ͼ?LY-M<ޟ).œZmMVcc7it޼y٘ $]@=Hah,PRel/ #^{'뮻N/׿uJͧ>)>~_lݺUN>d{:ke5d xNQq~߭M3dZ4~K@(#6+~r˴iӤC6o,塇)SG>򑢕:UYjXow6n(wwΖՍ_nb0,[Lꪢ+4@@ Apڃ6y_|^5/| rYgygϞ_r%ވ[|򢕭6k_Z5k/ħevI'y%|:>*Pqs@ ]]vwYĻ~qq/PwV5F-ǼgCoڴɫ>ykn]tXz__jɯ_ɷ~[ƶ5 &UԻ]zt48PReҌwCʌmVrC||ߜgZ:Ιg}fj,5JdnK.vYV\YqVd @r_˪3)0+B`@\Zazg:<<{;B755xgl;^CRi27+o_q6Roc3̿d~{@Iiu[1/3VG7F7:Z6_z\M^}g{׿ީҩ96 KU Lv\9iU5cui Р;J; &'ʈc;kX.MMoK,o|b'zMUԘkt\u-`B=fsM73CP>v  PNp(\}-.{1f@Z 7+O:}џ3gΔ/~^лs~^=zT>ʌLo/^wL[bzhc^  @IE [0n[nFI6b,?p g-/&Ν+6 F37mF =.G@ Sݷ %p&NJ3Kwg~gumU륱q۷oD^=2Y]7 $\9t0.0)5!-J^[[++iUent[?O^E>ɑ#GVW^yWGViMoVEi[i[ǥO@/`% 6h: 0*P6 c4ҋn:v;x|SFyU3z?EyY;S̹+7n+B.qM =n\O%\"g}L>],+R_gkMFMnjG' @U h3O۳v;ai2.7 ;pLNjY萏}c׽A=PjVϽ\-d(' =n9 *ZA؂KI ګB,n9#7+BZnZ/ٳGl"y'gϮ rQ@&:X[mG ;.FRɞ}Y馛tuu,+7C@ z#~zfh$(rJ1@@!n{Р}wk"@1hq, U&j*mHl46({y  p;~7+h_=!P{f@@*RFdov?tAo:" _"nN Xp)_zKX>6: @0'Hn^zA{@k|@  qp[=vbK!}@ Hy>8 0-@@ AΑ#}6>(J 7<wY[dĽ2\@ 8T^ p -:(-@C@G`hH܃կY%շ C= E΁ @R;<컗5]Ci܃r@"-pw{宔= @ p9  H#`Sۣc$F=1EH!߭SsmG; pSs! 1g@=zIG]FÒ< DLmnwZ5ho@"{Ƞ@HhНګ)@/@)gD@bK}}qDdž pγ' #S>3ۏJT@  ^i`BO"_=  ?M ҐVI '@gB@-ګoӶ}B S# PNW[r/ԫFn{9B(8@ v_li8GH{ T(nŖabK]Wz-w  Ҧ#nMRO)@F@H+b_ ,T#P~sE@Bp{sGC)@^Nm @];ܪy(StF4@ 8G:="h@-@C Ԟ]δIv?"1e p/+7C@ }"&zdž pϳ xބC}kX h@+%u@#MHݥ)2LHO**@^Q~. @qÇB^%&DD="n  0߯+ ?ߤ)2OhCW)r69m+@@@j&w {]osM"`s}ݻ]f$d|\{` @%&NM1no"@D Aٽ;Pn2dJq:*~h @6q4s)GRLH dӓ<ܹ2%@F A@'7oB4=@ں5{YRwιR3eJG/6! Pz/}*ۆoVа[SMsӠn31 oF @J.ඵNyA>RdBVmב箫C^ \3EPg B p  ȤvltmaFj vj=.;frҢAG~lO óL "`)2n 7 ;քN2FٷGܶ1{F^Z7s[Ӎ_n: p+G;@J `,"]4:H 8j=tyhIҬ#cuuڹ'k 1  CC2#XcZARd{(46s`yk,Tdd%Yj6@_9! >8i9 4pue1GwOO>) ;"@D $46l:f :#gwvʆ8Dy̳/5SToUPA# T@ z5gH p7u;;١d2}:.tI9!  :VM̟#^ҠLqFt>pyr_4LӮ"8@EE[t6v 7Ҟbmm8'ߛ:3k)e1uB* p/2@@`s8McgqhjZLj#) k9Wߙ'H}ƪ@r:A{&oK)@^J]΍ @WdOMvV$Ef2I?vibT{9'ʶ1z-tkgCW6@(V)Im 1`zKov2*HHO9Рa=&n"_ sX :yJvM rķu4=GЮ2gg$_ogU*@^)y (QGLvD1?oֿ|d}՞y`t8h>U{@= {zZrs$\>srNjǔ9aACn3Ј:]DNqCK U$`7kJF*Eޢ-NHe/|/s CC!ߖi)axWvsA@$ o(k6Qŕ2K>VI>HjȋK33dx[ JsM@D8b$l#Ftu=Eg.g]Z.jО^נf gazr6@<MRְҏ/dn>krNT涏4 ֠=s4=f.A86TV\@%MGxZE&5U¿'oteqg-'$Ѡ=3}|̪xSy?z PM2+b%nOj^1v_ng-{RpmzΛ/A{Og{i_LО!(G)@H&YGDLOശSofP[W+u+m'c7M@e2{T@S@Y:> /[Щ#ي0gϞ4:;<3GmNנt FI=JO VǤ ˷~bhK!qn7u:i8‚?׉gg6jQ{"@ vnOO(QxO^{Q(rАnt ϗ33:}M) pCK 1ЕQS_ΞӼ&ڋsgNq5=k5K?_Ld<7h~6A{;)`mݲo_ڸnх}Qث[q c4ެdt.Ǖ.ۋq=-s'Α ^#[ گנYnv{-@@@jvq;{(F VC}Yҡy[s J>Z4h=M ңy/֢n6kގ9ke˖UW]5+\` &ڿ_="K:5rKR۵F{J Psb]yQtY WeuLb3>o1FW 6{F)εR)Y~,_\,XS,/駟B۞ 9u0gtbeQ tZqY'a @ܾ^~9}ȼ9 s*s8Oc.څ d1f%VԠ4l?J 69yOی{HSSz\9}? *ll -Je ڵcmʨAO{מj?\m/5}A{& c(P5{zi6~+6000:uƟa]B__>{6@*t̔Q񨎲[boՅ4-?'J93NrUy[Ю#'I>){@ ,uD$sݶN;M =.&>Yiŋgg @W^7GbKmT!hѿ;;w\تFbjW%}iߕr"hԚ#P5{:p3+V}cM@OmJ=4h9S9xHdjZ;rcdQc4dg|&p;w71&fnnʕ+2{@ vyCܽU8yLS9 'dt5ٽK\]%kQU: u}:ޚ#hPs3Fڳ*c&6f,}vLի'Vq _}4|ŖOHʖ_<$ uZKGsoE=?2^ v{*L:e+Rzvr-RVq' @Ú{۳ts$aq*9.bOgϑ׽Nj̖uD4hNjJ\1{*n#5nq0J1>#cYhp ַ{.-uwU9seƍrW_>YqycS׬Y#6ls@"6[Bjc~J@܃b +j.cϯ>t.zc[{afy\ɭݛiuB6=-O@ nk o~Y;ۭAHÖ[;:4?V Eꢊ,|9(gjgjL7(>xj&f>[tiɒ%z\VCv Tooy%R=֕Pw+_>[jD:>1 9~Z5hgalBT@ȸ3@F{FC!Д7au>W':Dg?ɨ6 q35+ کў]U-@^ՏCL /(2<<١~nIRYVАXyMiv_kW-#?՜v+]i1Q))$')s 9\]oD4 u ~32NMѠ=梓JkϞ!|rLB?`\%S7 5~y@K%y@"-id=jN{pW]CVNg9[ ! 昄:CԘ": ڟ#< z P.-1{WP3 5 (@ħ=# p-hiݲ| ,s|[Zٳ;]vj]pgA~'͊y3<$-@H)iUH8e"ꨜyp}^*Vqt|h||vkvM#i%hGțd 's @bܞc:U Y7Z}C6OnUct\[SӼ1͚c9i?Q gȾ ' #I𪚼uڇWrA&׋sP4]PiYR3o&+Oܜw,F iIH6 p6a @ 8mm-dAa+J=#ٵ~f|]Zjt5A5Rc.|uO'5&%" T,-sY][7~XW@=T3QsSWZ]Tɶ1͹ϯ\Qݳ?L$@>!Vi8<2Bm9OhN[Fwk.ܣ2{ԝ1ZU/ /T?V+/{  @{$U Z"ꑄ퓎/7˗KMB@[ r,dsGs?QaeTG({}Ze?r{"܋P@h 8\vlϝᣫ6q @s>N&Ns8y~ :[j4<\+ڭ>^DFcMQ pꓡ_  rR^ 7h$0hw5&g"9鵧jZV~#LՓżEGks?~h P9TJR۴r. AúB4RC:Ps(V5ӻ45f!PUc< ,wrLErg4xݯ#IۜVqiZ@[2EjO?]j"n#*Dbd_ugC@ vg6qmIJyL'$,5K٧i1ybԥfB]RjYҋ~eeob ({^R J"##΁}ڿ?YziIPj{Pb&933f\>um:n#SeIN pSs!*jGZC;A Z|pCVIO4R-fVerluɧvφ\9p۵DGߣ,@@ %ŕle 7'hۣsefe_!53{4hguzԥd?% p/)/'G#:tP=Cn/dӞR=K9Cby$Cj )٤\ e/"=({ɉ @=lP n2ف-z= ]-w9tHIdWjQtvkQirNxnujD{ժ:]ފ/: "KOm\zsf{t˯t4pϷżQZF1GQ@QhMSAslG[K2/̷䙷hi>=/- 5=T*j<ғRM_ !gӕN zOq Ӡ|mhkZ,DV=!1Rvcwu}U6^p>M+Ŝ (->[@i<4XQc8/!"d XKqD e6, V`uH'Ty&6p:0 kYe:tboi<OiJL6O GT{SӅ^YG[!G ovG-vdC 9y) [4g|Z-n֠5Ӻuq9'*x\`Aܫrk @`MH;R"=w5`tvp>SܯOP , {v 's z:Bcɧ/(^wuU#GLu&^k+ZiV9}Y'>'=`"`#um jxnh_= ER Mi]<Ͱ6٪6iq\ 6cv[F$Y:Eބnu.<$eV:}뿧M: 4DxF`ͨ(/@d 8VEble^ \_QޘŸҤ%_!&4ȮH ysC4Rkjk}|eiPa9IrϚ)S}S.|lt/hi}i wSQ8ZZȁȣn;8M2uj*L_T km6t+ C`߬0oҀ ٢+`ꋏj>=hiOK 3- o@H x׀ 9Ҡ:ԍxw~_3%XQuU!P/ږ p/9WDJ#`i{ԟUup{0_K ܹҥNi>~Fmm$Kat}2} .TY v,P]Gu= 8 iW@ :+*as٧Xe7Zx6d5Y?V@uj$ӓO ]߫y0ܥPu Oat=ߊl}=j+8DI-`(r#Dx4E*)dˆC#Q#!tȂCZ@ZP(E <ۣ+RUG'0k>O5Lm27?)XÅK'@^:[Ό/V9NmhxۀjEu ǙGt4mm0i Wk#i>4sl`&npdM2%@f_賰>a$P+lT{?aBިzcCVG)[4:ޥA- lU\ZwE4MW Om wj^Ⱥ]I`٤F J'y/_IѴHh]u6&@'"@|4vl¥o bhPkQH&v(M.nM;5yo녞e^ -X?CSaj5hd+_) k4E`]ʬY WB {g$WU3dlYJ"H"""hT "1d X H*lHm!-}2:=3=I~[r}n3|hh" $ٹz²͂ұ6K8߁(^E9u!\}hQU5Gn05l[,xɡe}SgR[t7" $gx>V[0~xKz1cG]=$܃;w"D8í]߶"-|}2JM&?&jU -덍GSX/` S&@/X/XO]FtO(*cm|er@j$SV" "?+Lu%gQ c=mK:}{N[3=Z)iynbIC @E^"*2/[ HnjHE E)R3-ꑭ[u]akݮ!؇ں_,.5FN+"_E 7C.0+׻h]eT%I#|uH3!K~U5BE c}*u^Q4a_Q{ k0g5rUIK>" p:$ &lp ؄å,*('Szuä iUv1BuD#t.>BKi1P{@[R>|+GY Âc˭6@T/Y' uĺ@M^E H0Zϛ!!{ћx =뮪(KJm=f}0&ρ AKޮ/Q\ A^ ^Mw?ur1JM"0\$܇+"0r@}Mg;:6kR;tFn9 )wZh,¯ B}cU=8Sls8|Fz R., ^ lo{R((%.5ʬȪQ>*4  ND g tw#x=:\aay7SJp'} IcuƎ.-N;S{4GBG΁URB=yPX <Gz:]^P_ ]RQ E@r{.͆"" NudiǓb-8߉gU}n/ޠFZ3n~^1LJ/x8gl!) ^A[ :9^l11gEGX'[W&"(. VD`H SZ3H0zM>h^un.qP`AevkF,& oxuٓ:dsD: bY !!iAσ;+C wT\]ҏ*D`pi3Ȍ.. \`s/#::n5CR'֞vK Žn/Bq 춃',K> B}z \[(.sZыqJ\s"yǿW*@Hm"  @<ӿ u:sVD- w! Yce(1Qfm.Kl2fi \P::B=siqBeXrs'c>D`pGH,\XSť ؑߐ]z/z>,\D zƖt`An[iFf7f0 tWE>y;w0?KԒΜ./ND:cNz%H{*FD "tAxÞFx3BmPy!]t6V^lix F-"bZd34LG7COŤM[2zNюP(W(reZ+ЦהD@D gE@r]_h&u|yJ}Soe}wz}zG{TEHΗIj6lC|;"VXt;|R5‡~3yެ}Vs՜=gV1yya,ώձ@ HpaY6@r 1!w11uGv"xVhln ~mnCFwbd83 }M@N>r6<;1sa+ӝ%f5'G9磙D9uEpۦϋ `3" F.%ugIoDNc5B/ ׸3њ{A:t'a1Gq&F砏v,G,uuC4 cq"}2>9z{ =VszspyDtDz$B|'l=!qc>5b'5"v#x7򈕛Pβ,C率rW@q/;Q|Sńp G;Hg=>D@BC@=4S @DE6 vB6g؇;~'л:ۚ…M%EJ Sb%q=e t:ˉwrVP:{9KTGNWh%h[J{Dys͟z$ܓsQ9]L\h k:ddZ y :f= !)(`NAR }PfposL7Ἃ}Q?te8 szN8A1:'{ Y= ! /e8/te(WoTE@D@F@}ottMF"Xa D:@l3JqwYv)r,\"C%8XDQJay h, ꖲrUQII\ zO,>Iϸ))y]W!]\% ឫ3q D:a1-d{T08%a)61&1&1o/t %Uv,ۭc+8ކHNȣbV]^/j^ 1 UG4P[ :m lC ;K߼Dž:ۧhDwG7Ew9Pp)<H@=EPj&@IQqQރ͉ 1{')m=*f_~ߌ҆;)iA!FsZy%֎9-ߞHg>bh*Yi=vL,XXX݁ᬣut(I8&)8&‹|O=O؞mX_@dU/" "0$܇hvGYEԱŗ.9w 2]QR(nBp=8]t5g28E75eOsC qEܮ!1E@D@N ½ ~m Zeeeց} 34WNwej]8X̓"!:-DqI~* 7h^<Ák BlSRo(َ<ڰO(+ NjvU^ x5))y]UPID@D@D` VS_}viٳ+ʕ+VG0vܽǘwATqaa7,]ȻP h?/CR\`q;XR ֵACvhd:iś,WxSzX+ U@ Ro߾.2;SOw3;?e;餓rnVo \ sr`@.{>8Q̺'£׼6hQNw!@ R]pږ,Ybk֬N8`̥­$.dTnO\rW^+{9)Sts%1bJgK@ N{ɳ>kӦM3Ĵ`{^;.Ұ#Xg^9a %Miy^bۻNrK`]9mp\*IDAT8|P' qƹ@}'اOJtҤIbŊ~׼~T!" " " " >ʼ':tzu3fwM" " " " "0B'+**PHo|gΜE@D@D@D@D`X Ngi6lQZ֭[DΙ3gX'E7B)ܗ/_ny0s=g7,QWD@D@D@D@D Eri@C5f[z!u޼y+ҥKݮ鎡,\^zt?" " " " " wN{{544.T." " " "- $7]bG%erD@D@D@D@D F@]_ L(" " " " @H`4Dpw@D@D@D@D@@@=!" " " " "$ QD@D@D@D@$p$i" " " " "P(D"VWWgwyg杩Hɓm)TB 32Rf{x㍾>??ߪɺ}S$'gl]]]7555sNOu---ёj}#mmm[(9 ,YbyxY=~֭O|z!;Cslt#k8v}cv]wC0t{QZl-ܷ8.O?= =X;t ߏUV>85ӯ  ̔)" " " "j~=@PHL;NAAcͨJ'eǏt;m! pGԩSN$!&ũ~=@P8E@D@D@D@BM@=ӯ  ̔)" " " "j~<<߾}vyzzz߶Z[pUVV|uח}N/555٬Y&hhhoV__>s#|²hnn͘D $stֹ?s=Wy`NٳgەW^iϷ+Wxuw#瞳իWŻRzZiiWo]z6}t[~ۢEox޺7ߔp$]$spz^w;$zO9v /F?e;餓l8p}fV6mds]wue"W^yNַ54 ]w\'OD;/?PG|W_*9@@$6?xOJXvQLR{ږ,Ybk֬.Z]b ]w'ts|qjkkS C=Խ%~M9ꨣU.Gu#% ܹ$egm,ezjE  F ̝<@dkm۹>?b]wB#_x׾b ztM@<䬳>^ŷWN%0n8!M`gx7%:.kC)eԩS VXaVr{/RnVWQd2gF awyǾ1Bԉ&NkmmׯW7cƌ~T!A"@Kw*ࢀ=ƍ<#}dޅ/ Dz= %?K.u]'"0 H sأ>7z5I***\7Z"&Ϸ>J"T|e 19s纝T%> =o޼~~%nEC@}&L;gyr-V[[k&MYn 9gΜx "$27t^UUklٲ^u:cp v޸5\ӏw%>ٵ~U!#{Osfh˗/w]7nr&5?]yfR,u8?ݎ~{{lذ: JyacO." {' w>rqQ#ϯv^O?r[xn졝j3.'n=_*'!3pS7ڡ5'D@#+?Z@` d\Jq$" `|L+*1ՇďYE@D@D@D@D~PT" " " " "eYE@D@D@D@D~PT" " " " "eYE@D@D@D@D~PT" " " " "eYE@D@D@D@D~PT" " " " "eYE@D@D@D@D~t>D@D l|I_ m6a;lI۩RD@D@!AJj+" "%P__oW8OvۼyO7|>`lB'" " & >ht=sxb;/evۭjcҥKUt=Zj+" }TVVk{I-(([n&Mdvw۪ " " t?" "ryyyqx% {;}WUhqjZXD`$U^#rYڦ۷*~6YjmmZQQ~O~ҕ c!beeen1l߶uuuömflhѢMt." " h4Tc9n{GO:үZ;ꨣꫯ5.N}g:~}m[o\`݂|3֫C=d+Vp/c1c {zz+s=h`Gq{˖-MUY4Y@v tuu7MԻSww+."k.[n]2ƍu/]X`p_T `͗F+"EӧO7^,o<:O<U*`4D'p7;ўFGNy&;ＳWss3q%KjOr5\H/(-t;cO6-!U." " hE@]U.rwT\d5ǛPT{3t4uuu'<<7~-0P,sS}2#rQe]ftbUtr3V9c;wtQj<@hÐ^~ʕƅgt; 1f" " O@=H#Z[[]vLLܜœ/|!;vYfů'~+e_w)Xu" " " hE@D@D@D@BJ@>!x=@Hk4ZpE@D@D@D@E@=Xъ{H'^-" " " ",/VD@D@D@D $C:zl`p|i" " " " !% ҉c{K) N[D@D@D@D X$܃5_@H Ht" " " " " hE@D@D@D@BJ@=KFDiIENDB`brms/man/figures/brms.png0000644000176200001440000012477314371144564015134 0ustar liggesusersPNG  IHDR?+``iTXtXML:com.adobe.xmp logos_brms_vector ƤiCCPsRGB IEC61966-2.1(u+DQ?f(/aƨFiI3Y3 *3sJ3eVS-cxr2LqGco\BYjY1jpx[YMOL)P.8ta3O,x)SӮWzi)mZ"8AtGNO,k,$E.QW$&6!&3͚}}~7{]*l* C.2x=Wa. Z|7+˓H B5̻=UW߰ )g4< pHYs1^1^d. IDATxwT7 .;4i&bic($$M)&T{z;*vDǙq3ggg'lKy Qsc7O88ZvYVVOϟ<33E(N2%X,TAu0n8̞="oeuBC I$sMs~loo|M60rH$''#<<8qСC/_|E 7u1oe;v5kpM3Hӧ#)) ...\?T*Enn񂂂֭;58!(2-ZtOXXgaaac=z8y߾~i 066:Yvvg233۹'\%tBۮtjkkrJOd7HHH̙3 ʺo=8!dJ脨D"1tss8::q+++'޺'`Æ 踥XHIIAHH)9r6??+W=8!%tBT*%%%qo _b TWWs)1c ,Z۴(**zڴ%tBT !!!*44p7ޱ Ç})ϟgy]pAQަkpBt%tB8s5w"ljjիsNHs /ӹ...طou܃(D"wvv^}^lڴ ׯG[[Ѓp}ǏSVBn%tBnҥKO8qػvBFFxib?0`mͷ2mWW̬A !7jԨo&M;vqq1Ұw^ޡo^~e</;;*#K͡NMH$_GGGO71{x.6oތ^yFRR"##>sLb-[{pB%tBI""""x5Jo{ŋcԦ룄N ۚn:ujﶣ]n\All,fϞ m`{rrr2A\:! okytt,U5]~=>mM۴^8t ˗/=8!:!Wxވ|͍keL;w^D۱dr-ozajJC vۧcƌ[@~~>RSSq)ޡ՞͛_|* ^QQi%:y[#""ƪ/h>P988 !!fky A ,DbILLcVVV\alذT9rwhejj{>,6/^ڵkSuuԦJD',\{kTTdމWƷ~;lmM+-Z{⎽{5B h5y[櫢ƍTۄ#99#GǏlժU{'D PB'Zkҥ/N4i/_mMX,C=xi9w#ԦhJDۚn4i7EEEHKKþ}x&WPeֆuuu ,Љ֐5&::U5]n6oތ>ɍyyyaɒ%*iZXXغe˖}=8!Ì:x"##㜜5믑qmMԩStRx{s_x޽{N8i%:hIIIsǏ~PP{Ezz:x&Csb[ަ̤WoDPB')...800pԩSy5-++CFFt\Fll,yUihhhx׉&N4D"1"::zmmmX~= mkms} yyy/-_| %t$Sf3L&Î;f466 MH$´iӰdq-ozٳ^kpB8Nŋ;v'ۚ9r8}4d'K/ĽMkkk,++kGyy~)5r!!!HIIAhh(uOQVN(4eʔ75駟rJMԔH$Œ3GGG{{{sٳ׭[W58!C@ /ƍǽS|LLL0|<3022ŋҬ/6DHЉmMEGGO20zxښ`*iZRRұwWSSSWsN PB'5͌zw[Ӟlܸ~!5%4n8$''#00{V?~UVrN PB'nҥ/O4)CmMO,_C-#">>666\cwww#+++ܹsM+.ɰĉx>wҰ~ޡ377ܦU_ko444eggP[[58!WNTN"lwf[[lxzzbɒ%-[{pB(5͈ZȽW_}L477 Mtܔ)StRpwޢSN=z#܃G DRRǏOUmMP\\;4!X9sW^QEVdggVRR2ڴ(BL:u*ښ#''ʵaammW^y>(6555999+RM+:B˘LMM5}_ghBɘ0aاNRFFfNNnD";"""EmMoߎkR[S"8E֤$1klTݻw:s5kp Nt%t2d/5v vc>|((mDb޼yxajj5KdvY^^$i%7:i#G1w[j,_foox<cwٳͷz܃E '111s,--ִghBTjԨQHII1cϯzŊ?sN%t2()Sӓ{[~VBmm-Є H{prr[ަٳg6F(JLL6f̘o6ޱO<4jkJ {9<۴677KOmZɵPB'״pBmQQQۚ644`ժU舘)J...XhnmZ_OMM]=8hDgmmm)!nCJJJڴU;vUVesN4%trYrrdҤI|‵5@EEЄ5Xx񰵵[ަuwii5k!G >>~bHH'NٳHKKÁx&D㥗^“O>6.6H$>>>c^x"֭[[R[SB%K=ٳg/߿?!==cڣ$qyddBGGGaR)KdffghBɓ6+>yիW-J:&))iބ ZgS[SBI__>(^yXZ@VV%%%s333'j :eʔU5MKKCnn.k%d`̙3G%mZsssW'SVF ]I$KOO/bbbf{ｇښ1qDmZ%_sN%t-%HvvvHvuut۶mXv-h%D"bbbwwwR)sajӪ}(kE=0nܸFͽCFmM Q1CCC9!qqqxKeeewNN[o&$#>~ښFdq}Ç?r'Æ{WLOOOښ\uuuCB@$ŋUҦ577Haau֕p N%t xGXXئc:}IѣCB8066s={NmZevYjӪY(k n+W?@mM ...HLL==vIII}^wVpNT5] ﶦGghB0;v,RRR=v^^^ǟXre+J 99I&˗S[SB4X,ߏisM&|=aޱ M^z%̛7{Fivv555ԦUPBWCwKTTT*ښY۶m}rB=ٳgߟ!d(y[UQQQ V×_~ښCTܦɓRV@ ]MݻZJ.Ü9sT٦9ԦUXe:"==999\B45$ Ν˽MkmmmoNNΚ%ԦU"H,w[K.!33ښBK.ɓ>}t_6Ï05}3""b*ښnݺk׮Ņ x&hHh$%%ÃELݻw^f)uQBF/~pܸq$ //iii8s Є-fhh'x/̸nkkڵ뻲'MQB[#""F޷BFFjkJ2Ui}?:UH"5w[ӎ|GϨ)!`MkC~~˗/{pB ]U^}צN=VZEmM !*!p]wapvб999SV(sxgXXƱcmV ĉxwpqޡ !*xg1|iNu%tNmMEFFNPE[+VraD{c?sϞ=LMM\PBEe}ttS666ۚ~㏩)!DpaaaHIIApp0؇:vioAJJJI}||Lx߱|rTVVM!Ch;;;{zzkVs (ABB¤ѣG=~x5MMME^^Є^x=7,Ȳ ֌9҂w윜,[ ϟByʊk쎎dggY\\(i6Jױp°QFm2eϟGzz:rssy&YYYa*iZWWכ>D _EGGߣ+9BvArr*۴.{p E ]NI...\lJRlݺ֭"KM뙂M+%tŋ7n܇!!!6cS[SB O_VI֬KKK6:FDDeR[SB… CMkݻnll.dBH$#F󐅅|6mDmMoٛL@*AAAHIIرc>vX#G[|w܃1K诽SNۚ~wXjy^$nV{.ʁ'ZJhH;/ 6G g[kp53 }ѢEw}ƽcǐ'N,|v_( Oˆk쌄̘1{={;Ｓ{p5 ]􃘘yۚ~'ذa5IN@+s ҿ2@ ~&jknBtOXX1j(>\}'W\ʄ7yTU5_b TUUqis$g['z.UG4 TBX,̙3{{{{zzXڴjUBOHH"ok:w3g --ښU'[bTH ]g h: 'PG~h5M놚6iՊ.HDEEE>PqY۷o}ޏ8^e@CPPt_`K"KFvYl:8T4l3B0rwwŋqs-oӚ>HD";::~ImM?stIg !jvDvH0LXb\'ګlJ:50qD$''Ϗ{,߿ĉsW^{a }ɒ%M8qu@@9։ Xou~/:ٌZ%0ѯnw^>@ohmٳg#66\cwvv"++9 \%'O;vII ӱ{nޡup3';끂w/KR`>N+ -OG ND"?6}999kkJYILMMnmmŻﾋoښr`Dno:85ـ[f& pUBzҥK1e Z8{p>K$[I...7{kR)lقuŋ`fVVV-[cƌu$H~~~S[jz3g:99q-SYY7xWFc#ϓ@0U 8 81;ɮ bh IDATp&6,QwBT*ѣG}vXXX (([VOOOQFeOJ[ȳWnGG}]s%D d)`L}][Z-MzۀssۏWA+Ӫ!D}ttt ++ v킏\]]Ŷ 266^yf߾}gj_{N>LJq߹s'{n Mi*p>.8bXfǽ"Y^Fx蠊蔆|(**ѣaaa-ѣ y緃hrpO-g{O>ʊx=ŋo&**"c / uO Q X`E;td !ڣ7oFww7BCC猵X,op@@yyy,z>̚5k7Dzz:x&W /۫Vy6c$c{۱|?_l*ePCáCwbF9qgwnn4kk'\§~?ÝIt0q5=%|ZtxF m8`Tb~`ppc#1c %%E%mZ9R?oʕp~:COII6m&MgllįTfg7WV#Mն?YBQQQP,ZbtPPн?8p[zBBBDhhۚ -- ܀mLvYg=p+j1>K ݭ ^駟ަIiuuKlӪz\\Ӝ9s~pww… HKK?TUdhjݩKN{?l+gS6-}ف=U_#h߿?#sCdbb" kkkӳiy܂D"wrrZ"ﶦϱ~zjk*>v7o+.$𙫬-/Yg&aGQ?ǏGJJ >p@ى'ZjϸgK.+""b)CoYYYHHH?n 8lƫ( (]1DzQ *++FzV^BUUU[066*((腑#GN>//˺&?vg̘񬝝rxױ~z477 MnHpr2t}r9Y#nm؍^M[B&p)l۶ 5j6LVrBH$֏>3gLVX׿PZZ34SW *H8P-ܸC[d"1{3ګٖ5p!\KWWك_\'ZXX,ػwﱡijddd37oƻKmMՄHu{Gse x_op paF]Kӓk\L{=u#k֬HC'%%=:eʔܘ͹8pعs'5U#VAWw=Jj2/gM\JCm6K' E֖mZ%nMMN2%>BEE222_A&Sntl|\*Y_pt5T;Yg8ேylmmٳgskӪPUUՓ񟙙;gH$777:v|شi\WG"ykpy&{>,lo@SN^#GDrr2ù>~xÇ_|.7}GrM;v@bb"5Uc6Ckj'W{5SDGfh>p{%hF|w8w*ڴ۴׼s݄8W^}w̴z_=??ښj:x0ed}@_@@W2)Q~"ۑ!(..͛ե6 B~БD9o޼f͚Ļimm-|M,[ښjc{ 0p͙F`nX=z;Yo<aoUҦ5 iWO6%я 'P[S !wSƎL T~NQU .7dzNUHIIAHHGjʕ%KN46mM$$$௿OP>mhҢvuX@,_3v:t'KEرc1fUi}*((h<ùV/((ҥKgQ d?oeUweK bbBnL&Caa!l izzzv{@SSÇy'@lCnz;#d%Tͅ|t-6,:!ގ5k56ۋO>3g!j4NǸL@|4lH*wz~EsõߟBnEee%ϣKL. }׮]x衇b Igfu5V 3}8Y0ծ'0w\% (++`u ρv[5PEWhaC R[l̙3q!ZRBoii;＃Gy{'&3R[W^d6}_V"1:BT˖-ٳs f—_~IZ˝m(.ǖIʟ Gְj:T4vaC=%%%Xp!֯_Sw zk!'`=h+*zZpJ,cx> _!J} l;\T4[8E!%tss6`d|}Zvn,pZ 7.BJgUg QFUNZOBN y'ӁN$&\p"롄lЯPhlHAT S>ss/FE!E ]DYM8 銞V؛_zc{ (Q1BPBa׺_]#|﯋?{ <l!\%t%6x(ߩ[N_pcEB %te8F s/x!Z( =cu:`|T t\tUw#PqCp"( so6ü܄E4x0~7+р(AF!QB1ba \okV*ܸ][u+Ke !1<d*We;iv~#n.{BPB9n2Rh-fРָE/ܸ!SDh#l YPT|f`X7.B(ɀKg%_- G#E>s8Of<@ ]G ؾB{%PCAod z&+2(ۮEʀ IcE_6 iN%tgx vQ*Ɩ!d8QBAs$L ek;z's "JZNp0sW>n:TU*Z^}ǟB %t-gʼ^V%.r-O,]lm ::BDlvYo MG-P;դ|f%o*ذ!:3F (uT P\8ecI!QBbW_xRhJ{m1p% 'JZJ$|zpy6I()gx=Y 7&B<U \<&xYG5pWv!DPBB"=VԨyO+pzpcv6b= "} p!S'@ ] Ov͊FWճtiN>еHz0|Ee^Us_F;(kcGc֍#TU:WG8jеH Xx)u Kg\*g c!%t-b`+5vƥ3`krpj؀I%!: &*,MItT5,i|! %t-o8Eg]M@N@-ܸtQ@YMYž!7JZĉ쯹KK%NRNSP6BPB.μh\EVχ%(k2Z Y"KE@L݄!DQBAHs!ɤU`%pc"h7JN 583?Mǁ}UMݴ["1`= p,!څM(./5\C_[9i+S>3qo !DPB@F]AG P{DMȀ<8(6`-!D{PB@K T,Ԉnfz۔,Xw=#E55a1w(D=՚ Q3fU hٝ%t c*ov^#p`C"Y|1XB8a|5mN횢tpf߳;! 1AL\g1`v^4jDfuTEWҝ"paC5Ȉ}@kWhTxH%#DC>p h@&Ȑ]**n:XB%t ،R hNGvHNxh`\B55z`h|vxh4)3El5u00UX5SŽ ]{ k" ,(:NѡLYVAq[#jw- FS4;/A!73q\MϚ XٚO]ljq~(!\:Jbv{&ګᤷ yW0#}EP՘z0P>kʶ 7&W^A0vnLD ]Y.>; V*x@ʶ`3$A ]M􀀗CK峎z}DT[VlFAl>Vh!d()so_OEOWpl@:DG W>λ/%_ 7&Z%_ SWg"=bzY>7Ok// .(=d@].Ld4+&lI]l@eBؿ#@,fg(~՗?W$.)w+7V:kYَZY%vZ(p0( jn\Āؘ%n=#y6LGp~Nր#g00pϩs^ @%~ErzIV(#;VHƠr@A@#ܸȍ3oS  _j$`~xQ蛲;^W{s,ݣ`}I}B𣄮NDD&9I(Q"Kমa+d桬?,dP8`*$$P5z;3y2(sv]in388L,q Uqx7>gLkp"}@8.{(-g&n`؍eoXo.`w {|VQ=Jjp26-tHyhĚ8MaCvy/ $z^-|I8Ukz:دn=b^8@g~olVL]SX{3yW$|ycP^Ϙ] br|!6.WГf%t5!c3=Qg @)ܸt%1;t;>plp]u5-gK@G%K}wNcl9͊{[olh `XGVr뛱&( @G|[ia/h!PBWz&SQ VEXh#^`I-Zϳi1@W2R):n>o.on6Ć'`v؄6!Tbm7|do@OmlAڅ_7BQBWȐ##bgF?8N o2n<d#C)+u>lp%vg[VC1[e+.1l6gA-ϛ~[{-P8h<(?LGJj"Ձnb32"}n*#&(xop!ͦk%sA[#.6K[(rkq@Q=6cwciB:/+e?eCBp8NC&lI[l0=aT T=پli'pjs$_Dq^^l`_Oso99Dv׉8/}W@QS[u&=JB)uPsYclRl P#P|RY U .JL؟Ez@H2j?gܚO瀢zlUbq`e;ρ!DQBm0eؒ&:+0bvo*/rٸBj=+.]fOaĽHVU>x+P;~-V>^vXZDd/  mjb!QBx Vg˺C=PDzlahf7J>8P=[No9'].lAi/z?^n< P(5GՍ>P8}S1h-b_oؕ?BC ]@TVD1c`|lF{&a"j`Ke;ufVMmزumph+ttC#zvȑ0q{AwewԮ1kg/~} 0Q-y( D$fKVtzZlf#bWuLy+^)&NkQ'K D=PB#26ٌg=`.PdERŏ@@k! Ӭ+!a?;g7=3f%h˿c @&e/h{Zء3@&1mK9Nի-"2cen,fş JBJ⤵ռn)vhL "XR#VvRM IDATm@(4xI `3UnQWu@k P3{~?KڊSKZD^+bHmPQ1J3gYB_'p+{~=֣'EKuկ? d+Xu\Rv<bK`_4dL t7Kْ⍀S otX֖lq2{Aw~ ; N%t;=wϫwMP0D2+1uyG=P#P3V=כͧ ]ψm71`NpG۱Wlȗ⭭vxVy7@[!d( s6A  ݸ.鱻֞Y=s "Zd}@k1;^rV}+=-lB&TBլ[]֥EWD3d_' v| :,6}Z:("v~6-ozuiK߱Aʓ.4mB_W>sd 7.A}l `? gdǾfC8P=;g,Q> /r '{؞+e}@@n隢3@ p ^q,_|8T"ذJO3;vTҩ[=n,KN1ҵ5 `4dKκN&ʶxDƎ aǦnۦqƚX< F>}3-B-fz{%\wv긽b؇Q:YT~zP*2v nz'n`D0 ʾ~amQWUL؍Q>~ڵu]Eu}rEb0n.=j>|Yd_[`7 "c]J^vnn}b1[U d?;콗9!E ]YB{;Mus` 8EC[Wz: Em;|p@}mMgÊ4s/*#fNvV~ΉCߧ!N@r8kDb!Dei_*C6+w׾#AK\y+_)%!a7 ]qڶY8  v}DbvXz`κUYJ*$~O Y ܘxpηs zQtVfоaQ;SqxV렽&ѭ05p^2o^ylx+Ik=˪ =|6b&p< h+lXZAκ4>Om b6naim/,Ũ6h>)xQ|aµ;ْo:]R3Rb~ 8*츴EG5pz5;< o= %:~f봭D%t鱥TzZYQ b` mx?_>"vǬ8Q#@`=g~g?ԍEAÚ5峽uYE9#;\> gW}OX: O%t0qf_7h:–4m_SlW8A 6Qm^@a+pf›ݭ.$츴MopcO`5_eOf :Q9J蜉(F+ziC+:m}uC; (NB\8ɮS)x?"(p<{;VF,`?\dOʶ:Q%JZ2[ϳ=5M"+~N֝Bl`[)شU_6 87qx}(X 4a]Q߿ 4L.e}D!AG68">OW\eRVn7?8H\zm ٰ.lbum o)>iŀu=#ֶuʇϓr(sg8FglCq ؀}pձO͒wA&Y֬'Y3E2!0+,@svGG܁ ++JS!PBQ~UM|\Ȋ|3}3f,A3?W`I2a^`˯Yft?{wU{f}MPq MQ6+[ls̲qC_ₚTZ[ieʢ o3e<0s}g)`9y켹DX@\ygY\^|Z!:]<}J[p*#Pzh-g%5@=cXn]-v(Pk+IcD5$@щ\պW Y#K6 ЯO@E+K8h[|6f[<ވ2NLnXjmR џFԫ"8=8]ojw:J]m=.2|^ch~SӞp潀ۀQ;YS^tUpuǛ\ 4(LN ܑp'㧟iJޛktj1 ~JDM pn;+jX c]]43+* ˀďZKf-0b0;!ʠӀǪr\55M^F˕m!:C=###]iw6'-VSp}{؏mm+,=GgKs}5+:==ضuQ@ |PzSؑ7n$efCZ`ɩ\_Bcn[=!PB Fl=V_݋̜ \'9Z]w\W9'>/ilJDiP \8ya []3wOrN zv'5\UD \%tsֻkJjo1t\R2PxcBcާm"X]@\QS0z-;JeWRݽ@eܗ#zn75J3ɧnmvSOfQ%=u@{it|F8pgVlZ?.pk.Wfӽr}Vr;l0BOc9Xn_x G\F\'^>B 6)noQO}C u-[{k SqTq M P}wmW#VzM]9Bo'AKhf Qx.̜[K3~Jn CPn,wv8p -% >ʒ>&;ݍl[hIJ^C|;ݨٮʳB۳}{DZƷ[ܓn{N{UlL`;wƦEn77@UG"Sa,͜h>%v8o^Ptyi>}VݞpC W9%7>!i;ѶK5oRYhĕ0q KF~/Sg>}!kp@qm~!Szȉx#cXj=+xո'2Kj;Wme/( ;Docʀg+13gne e;.0; p~"KH*$,=gˍ._h x5po^W?;3Ql=P_Fs M25阺Ro@MʣͻU4VZV#'f=}-6qunw.{2H>@Вy\\p[/$#lsoG4=;Q*m PSViZˬoo"u*:k(9vW`tpݾXKVn.Wf>#Q}9 N,vfNs=H'@UW#EGÆր .;vKI]wPBoL*Q}WI@gݞ7UWm\J 6&%W󆊃BcaK/@-Mώ<,@:XSjsNʟn3>cyg# ex x׬թkA*p=C}øN_twrISШ\-rpD5zŏv5tV#[U$ %tִ u!pχXCZگ@B~+XCloؾy;/ýTY9X\i 7M<&J2q7/Km(Z\ F5s.`7ySi-P|Е(!(doX/Y.N\;VfIXlݞh?EM;V|Y"3WpW-W_77pєm͏9s҉nNٺVN[p|cQHۉ._ y! /\p%Tq,BMZR*kR[d8-ݖw 8 9٢J > 庶ъބWC ^c؏|6}\jK@ wN)MbaD\`kO΋ _nfn}kѲ70r6C@ שUG_Kkf]S1v͇Y)w*s'u {U(:ݢ KM erkb} ԕru?AKӹyc{n(]/Z6n#oI]hzb-kQ0@KGA,ks1CROw9J.ysyyD@/m=,\Ogcn` t=z,;!pX J+*[_\8v5pzJ3s!ڡ28=HQF֞U(Nf@S僛@`x8W>uV13kR7srpbK56 X"H\nQ${~=^ &tFtl `lЪŋX?O4ԾdNtP]Y v#ᚙ/lm>H>[>b( z@9*޳nO6԰nre^W \[ *Ҩ+mfUΣ ́knND;RY+uCk`JjnzfpKDMv{pVWWe D\Fki᮹i-r n}ՀoZ2ϥ@ -ZeB7\bD+>R2':ȍVYs b g @G7._ X=4꧗{(~H Ľ i݁]JcJw=fhwoZ m'WX*}Fow p{K񆍪կo[@GI!.ز=Ұq8jȆJD8`]3SzлMh"w]DIj?/9s҅&>u@Y ,d<>JFv@eCY. @ɜgk/;"wȏGP+e0 ?*L)Z{\_\X3lz5B+Rw4z`ﭙ&/SMZsLUAzMp-V< ps#Lkvh?G_3BDI8zcV@M!hTD:WgzEg{ ` rShzVDIeOA+Nj.rUYJӫppg& sBӳ"Dp >Ik~3VHLm IDAT(BWK+Km?) ܈*2[w"D.kG}m5턯t&tBHt@%,*QB'r*n^r'Bt%tB!DPB'Bt%tB!DPB'Bt%tB!Dб5BQsF;SJN3":!A8P)pgDt -B!::!(B!::!(BZhɖ5= fu)h%J脐v{v XMOCFne8Q: !J3"w t#ĺ.#4=-F|g]7&Lmۆ 5̈EhK}W٠ !8OG^ V3$L`.ŀf90`QΟv>amyЉ^#OHdHp\Rk 50;6)VCeV?YiZr'($'bh#9g*"X" C!jNQ[7eC4KY j'?_3`׻iYiJBƻ6Wԍg)a⻢CrigiJOF,-*jGV⛂XIZh=AdiJ脐VE%*L؎"IgF,fEt4vS~e !0B$ D8 oo5όγ HT+/VNiFl냮,H-5ΈX &FA`#nalJ脐;bM)r2A=LBZM%wRhx ZzN1"<BFBOlD+QseCLagY !vf,s⁤Jͳ"DzV~d`}`+4S4:!]&1)0N3"D9ET4:!w}6BSc5l=I3"Dy;$"F]A_=(8C ] UUHt#co+::NW=+Ũ;!UY>i~J3lllc񰰰 P[[*TVV~5Za>eYuuur/ D"B!jkkQ]]Rlذ?U񯠔׭Ec q2M3jm4 dI/|_Eɣ 7@@@`jjZXt)***~?' PSStZ I7Ǐ/ D`RuuuF~~>q)9r%%%j{N}+20U]#,.UgyfC ] -(&M5 &&o4qy,[ gΜQT;8;ހuuu044l1ob ?w}իWcXd y{{3sl9.*i<3^(w<2sʂuaɒ%WWW8p^^^ꊡCbҤI/nݺVٶmMUz\x3f늻z"333`䓇tXcv"3|`#HgG ] 8qc%pA2-Ə{* akk:?Gܫs:gӜ /___v&M7.\qƵu/N8=*B3mFq6E ,ȑ#?s5ѣ&aטN/˭ W/vMg􈥥%-[֡׾ 矎o[bE_wcǎYm-Wiq7"QBo0*ݻ$.XjJ.^,Fxp V%^~iX[[w赯*,,:ݺu뵕@ @\\^]rA`n.w b}&Nh"0a\zU%;WC4e%8A3P(|3 >} ;;iw}t²,N8?())P(!lmmxyyC3o|\+3@x15J(?x=z<@n0eS׿ ŋU7ITYYm۶!)) ׯ>)ٳg#""Bų^#Lo4{ B+&H$,]7oƘ1ck>|CU$Jٱc ܼyS`3<'|]%&tgh;Jt5 BpppvN8$ ~7,]{yf9rÆ k3'ܐj6#] +ϴ,P_p1޽[3ϟ!8q"ݻ𴊮_srrR1sv/**B\\~zFb"4Rj 8#գ{ooVɼQXX'!ʐZhk V[[ŋcԩ͒y"kJ4h4,FxLjMےZmd|Y~̖{fE۬8QӚmi8W[yr!jzPBo7n`ܸq L-[_){;vlÀA7 ^⁡(q;Ne1c lܸQRSSqYbkBeh+w鵎2;7Ų,BBBZ=\CJ _gii$;EU[B +p:W$K.\!CP__?scw(5Vu {W}bw{h>{Utrrz)uZΆ]׫<"8rHǕ̕2e!* ²T[jO1mw z*1`0 xb@^ CMcKd=^[h(X{?q|^nҷRuv)(VF-v(s jq7g;Zkkz.Q}`)H\!G}F]e `ժUG}5g%P|ERgD ]UQ*TKٕ*8T*~ptY{uw3`0ʴ'{~5&Uxj&z<_r-ћ s`YӧONJ+<ϑo'+:g!0Y8TJVS7!V;;؏ޞbo9k;&rvԲ:])CtT*Ehh(F[%cȐ!ƨQT_Y"֞Xa"H餮h iJ%k9OqEi(^uŊ샰PLL1n߃$) ;:x Uu"… xOO?Ř1cڼؽ{7 ⶇ}?Mհ׷ (®N.+*QxJ7B %kf3$ïd$7/KƷ:yUp覄"wzfʔ)Xb++ǎ₭[bɏ#o`Q=ΆU쩧R HYnU};+pNUu +0vuӭP("Gt {{{;vhWFY:r/HanM:Uݽ{Wxf] }(sLv]$DbiO:vJnGy,ޏB:ie/ꨂsaYuuuHOO̙3! `ܹ>fnnѣG#>>^E3R`$wC/ խ tBJw.U8.rT7ited@L+J?qwᝌQcI"fPQQ+W@, AAAjRp5ai/c,ˢRN =ZW!s^|]&p2eܯ Hi'H_^d6)77WƁp *:MՁ;v:Jr ])+[[[(Y%U^T\B^}9%sZ[(w̘1h3W5@ZZz-ƀ}+YQBWXkQL3"^[+ n)v7TȂh5H(3<Ӯ_ gCHsݐ;>άww tgϪx&7*P"R5F=诖gSNŁʷ/;oՅJM8wEZSk֬r"4qKEK+jPBW„ `oo9^^^?k.)_mk*L"IUYr !XVl'`ذa%+:۷q riWg.w%aҥHIIAZZ QTTzt pOBT%EJȩ ۫[ZVns1~x|(((@RRҐT`VVVիF^zIv{uy:u$@xx?gϞ{ｧttBTJ6>s(s^dކ^uSY57D>H%nܱ,ܫLmyU%w {.|}})P:W |8~v)⃹ov+a$5F(YJJ ]iHQ'|;_؉阄L6MwX eղDTԈmڴ  X+ABbbJyfCtɯ |9-M? m2'_32kwSH-ۜȫGmb?#jk_'}Ž^' |}}1a3]GaY'ODdd$~w_(n 6bU7-<+§*HR{KWNN֭[M6i*\OQt28^__sܹsH$!C0vX9ppp@׮]akk+ƕ+WpI9rj76R4:!4e޿Ȩ_w{aY"ibbZX #J脐H1!HX;w /j!9g,*|5H(BYʽ2ThkVC_t]} !|+w561B^d.3娔R{#k$sg (Xh_\d]'D,FH 4_w ]A!]F "S-+oP,CYqYvHsee78+B "Wjm!^OA&9 ޶FtFGH~o b(^vD ѲxN0X e'q|Ν;1l0B!p|8ﱯ\R8g͚5+z^Ewϙgff"""'NB:,\SLz캸}O}UV!==ЄBH3B*,Xkkk^cWWW#::djjkQQQ=X,988D͵`-z/o>}0ރAc QCCu;˗W]pBQu[ӓ'ON˶hʕ|{փ"22|&T4..ҭ[^ݸqc Ik:iѣO-,,x[UU{رڴBׯBBB0l0c_|ŋW^}U Q@@@cǎ^VV"""pqN!: .ɓU>nV>ieBo8e{#,, o;4! 100iִ3==(+U ڴ~iT}aÆ ԦB:1a˗Ņ,ԩSn޼9#mMEz6&MM{njJ!1zhc߸qEDD=8:MBop¡{ƌӛiiiǩSM!gVVVx7Uִ>&&fC~~~6'W%F˖-O>|ǎŪUp]CByLBSNł `eek솶ښ\:mB]v7n6aֲ2>CB ooowoiqٻW^}ﶦҩz#XomZKJJ~z߿ڴB8;;#00P%mMܹSq̙oyF:-^x̠Av1™طnBXXM!DU5-,,3OmMEzF WE#G`;4!/T4::LZZڔ 6LmLצ;??]tucmm6|&7tPibbb˗]6 … {&??k֬Ç:!<&GGG,Y?<ӫO:Qhhh'FK,yfС?yyyu;+W+WBtö|ol~;++kښ$F+W`ڵԦB0 }YёIoߞq4^k)Kצy߫hӺyfOԦB0`{˗/\x]mik.z-X_~Ǝ;ﲁوcǨM+!4ŢE0i$ۚfee}YTTYg)'Nڴ~?p@c'$$ ,, n;4!t6mΝ'O<1]ۚ % mZLmZߏ 6Єql2U5yWׯ_%beϞ=w=ojjrDEEa׮]34!hwww,_\ۚ %t9-Z4x{njww"<<qqq|&¼yo477>66v]~~~>'Wz-[6sȑ{ָ8Z iizqB!^{5̟?UUU>zgkk.Е ƍ7ޞ6;wDTTi%tZFBpp0y}̙k׮y:z;4iϏڴB₠ y(wŋG 8pȑ#ݲ  6fff3g΄H$5vC[999 tPB !!! M}Q^YYY|&x[[[^c"&&ݻw_>zcjh7KmZGlٲڴB4nС x}lk.yp}}}Gݦk׮şI !j%K=vZZZ3g>\PBYCmի ˗M!c٘={Jښ"""pQjJ0;;;,Z*ښ~W_Jj8iذa[ DmZ !ZӧO{[r6::`FF }nk.լMgcǎ ֭Yž}M+!M AAApvv5vC[ mMoE ]Cb//PVB:˗/ǨQx}qDDnރ(kXC=G}t#66׸믿{[Ӝص!T3(k#Gد_?Kc:u VBjj*ߡ !H$zҒ߷GޠE ]bZ??hӺk.DEEЄ-6zh͍gΜIv둑'F ] b;77=~~~Ƽ.)) o>*#KSe[䊳g. {paеX@@w{{{ M 333̝;3fPI[sssR[SC ?jԨpUi=vV^LCBH W^A@@ll-uQ[[SR[SE "''oǍ mZ'lٲ|&BBBпc'$$d]|yںubxNxE Ypaw77ƍ6֭A tRL0iii+CCC%Njɒ%O 2dǰaxoz5ҥK|&g;Ｃғ'O='**D(wr+V3fg*iӺn:-3B0xtRtڕ}:mM $111.:yh5*wf|>~8"""M+;&M¢ET4.==}*5%I3bX5nܸٶnO?͛7SV ׏ϟϼr[֭=8(.\ԫW~~~*iCQVg}iiiU+BCC#yN:5JD%Kwuuw;< k׮6b/,Y^c75MsΔ 658)Љbqݷaee{~۷oGuu5 Q)OOO`Ȑ!NJJKJJf͚yNt%tn ,pӧ>___jJ+޽{N΢N:,00%//M 7!.FFF>}Jښѿݻwo5%E <X,geyozlذ|&ۚGƖJ<%226ޠNx!]]]{̌6~-~jJ49r$ﱯ]V0w{yN %t«E ׯ>~hӺj*uX`N{[E|HmM ( zkĈowxQV2oނ0HU,SpjB E tZw#C} CHu^]-#VWzvvLB9:HZR54e/vz! q7~'MիWӎ;Ϗ#kzʕ+)ȚK8GUȴ2Q<|9B۷o .!!j5D"ȚpЁwMDU bɋ/tTRRBGEKhh(jd̷/^x1M`>N7o޼E޶l騡4x8___ھ};]l.߉Ɂo8tjzۢE |dZϞ=Kݍ7doRv,K˗W3 80.r|32lh(22s[[[S[|gørdZ) LFOi"" Kִ^}}F1x8T*"**X,fimoo'VL}tӦM4e۷nzh2*zzz!k \ʻﾛ!H> ci=y$Roo/ipQ|M^###TSSsf@\: ֙VNtAdZ=IPtt4mgZ7 3:TQDD1T'%@Okd=)==/_|^[[<'tpy,Xp0:::j%VKɼiݺum6b;wL\vm=p-p'6mRtWHHo5Quu57|rˋ^uʢێiۥKV k  qJebbr>2eeeta[|YDDDPNN1nkkܼ8qࠃ[rdZ?IHH%Lkww7z2|EPjj*XHMMMVp'8ֲVҹsޮ={fc= hҤIB;v ___cf#k:t p92:LLJKִ VCpc82G ůXyhhJJJ V' lwzq'AȴfmhϞ=T__zC^`}ƍ555}}}i<:x,Z5>>0<uuu%''R$_d6-6mip92rV֙Q2dZŔWִu paBP*aaarbֵA2T]]L3 IIII̷;;;544Z>.&tyttaXbD_VLJ6oL7nd5yCqOO;ȚDFQI$\H>>Lϴ=zFGGn&(;;R)NSSS^8AxFiii Ν{T"vgg't:̴qf^fƍ*|NtpZ7<ИlڵkJKK3PyIDATA'wcBB{3DDd4i򢤤$̤3f0+5p.tqqϬY*Wv;}5h4GQkk`ssfP|/tT*DFFKHH`i~:X,db믿tudffe gL&?^YSbj[[j6pܐ#\.z{{3F=tiTT;:88b^ZZ:yp<@NNR"hgϞԙ֑X, +5p_8‘iBn|/tsYqT*_lpdf} or \code{_lpmf}.} \item{lb}{Vector of lower bounds of the distributional parameters. Defaults to \code{NA} that is no lower bound.} \item{ub}{Vector of upper bounds of the distributional parameters. Defaults to \code{NA} that is no upper bound.} \item{vars}{Names of variables that are part of the likelihood function without being distributional parameters. That is, \code{vars} can be used to pass data to the likelihood. Such arguments will be added to the list of function arguments at the end, after the distributional parameters. See \code{\link{stanvar}} for details about adding self-defined data to the generated \pkg{Stan} model. Addition arguments \code{vreal} and \code{vint} may be used for this purpose as well (see Examples below). See also \code{\link{brmsformula}} and \code{\link{addition-terms}} for more details.} \item{loop}{Logical; Should the likelihood be evaluated via a loop (\code{TRUE}; the default) over observations in Stan? If \code{FALSE}, the Stan code will be written in a vectorized manner over observations if possible.} \item{specials}{A character vector of special options to enable for this custom family. Currently for internal use only.} \item{threshold}{Optional threshold type for custom ordinal families. Ignored for non-ordinal families.} \item{log_lik}{Optional function to compute log-likelihood values of the model in \R. This is only relevant if one wants to ensure compatibility with method \code{\link[brms:log_lik.brmsfit]{log_lik}}.} \item{posterior_predict}{Optional function to compute posterior prediction of the model in \R. This is only relevant if one wants to ensure compatibility with method \code{\link[brms:posterior_predict.brmsfit]{posterior_predict}}.} \item{posterior_epred}{Optional function to compute expected values of the posterior predictive distribution of the model in \R. This is only relevant if one wants to ensure compatibility with method \code{\link[brms:posterior_epred.brmsfit]{posterior_epred}}.} \item{predict}{Deprecated alias of `posterior_predict`.} \item{fitted}{Deprecated alias of `posterior_epred`.} \item{env}{An \code{\link{environment}} in which certain post-processing functions related to the custom family can be found, if there were not directly passed to \code{custom_family}. This is only relevant if one wants to ensure compatibility with the methods \code{\link[brms:log_lik.brmsfit]{log_lik}}, \code{\link[brms:posterior_predict.brmsfit]{posterior_predict}}, or \code{\link[brms:posterior_epred.brmsfit]{posterior_epred}}. By default, \code{env} is the environment from which \code{custom_family} is called.} } \value{ An object of class \code{customfamily} inheriting from class \code{\link{brmsfamily}}. } \description{ Define custom families (i.e. response distribution) for use in \pkg{brms} models. It allows users to benefit from the modeling flexibility of \pkg{brms}, while applying their self-defined likelihood functions. All of the post-processing methods for \code{brmsfit} objects can be made compatible with custom families. See \code{vignette("brms_customfamilies")} for more details. For a list of built-in families see \code{\link{brmsfamily}}. } \details{ The corresponding probability density or mass \code{Stan} functions need to have the same name as the custom family. That is if a family is called \code{myfamily}, then the \pkg{Stan} functions should be called \code{myfamily_lpdf} or \code{myfamily_lpmf} depending on whether it defines a continuous or discrete distribution. } \examples{ \dontrun{ ## demonstrate how to fit a beta-binomial model ## generate some fake data phi <- 0.7 n <- 300 z <- rnorm(n, sd = 0.2) ntrials <- sample(1:10, n, replace = TRUE) eta <- 1 + z mu <- exp(eta) / (1 + exp(eta)) a <- mu * phi b <- (1 - mu) * phi p <- rbeta(n, a, b) y <- rbinom(n, ntrials, p) dat <- data.frame(y, z, ntrials) # define a custom family beta_binomial2 <- custom_family( "beta_binomial2", dpars = c("mu", "phi"), links = c("logit", "log"), lb = c(NA, 0), type = "int", vars = "vint1[n]" ) # define the corresponding Stan density function stan_density <- " real beta_binomial2_lpmf(int y, real mu, real phi, int N) { return beta_binomial_lpmf(y | N, mu * phi, (1 - mu) * phi); } " stanvars <- stanvar(scode = stan_density, block = "functions") # fit the model fit <- brm(y | vint(ntrials) ~ z, data = dat, family = beta_binomial2, stanvars = stanvars) summary(fit) # define a *vectorized* custom family (no loop over observations) # notice also that 'vint' no longer has an observation index beta_binomial2_vec <- custom_family( "beta_binomial2", dpars = c("mu", "phi"), links = c("logit", "log"), lb = c(NA, 0), type = "int", vars = "vint1", loop = FALSE ) # define the corresponding Stan density function stan_density_vec <- " real beta_binomial2_lpmf(array[] int y, vector mu, real phi, array[] int N) { return beta_binomial_lpmf(y | N, mu * phi, (1 - mu) * phi); } " stanvars_vec <- stanvar(scode = stan_density_vec, block = "functions") # fit the model fit_vec <- brm(y | vint(ntrials) ~ z, data = dat, family = beta_binomial2_vec, stanvars = stanvars_vec) summary(fit_vec) } } \seealso{ \code{\link{brmsfamily}}, \code{\link{brmsformula}}, \code{\link{stanvar}} } brms/man/cor_car.Rd0000644000176200001440000000454014213413565013676 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/autocor.R \name{cor_car} \alias{cor_car} \alias{cor_icar} \title{(Deprecated) Spatial conditional autoregressive (CAR) structures} \usage{ cor_car(W, formula = ~1, type = "escar") cor_icar(W, formula = ~1) } \arguments{ \item{W}{Adjacency matrix of locations. All non-zero entries are treated as if the two locations are adjacent. If \code{formula} contains a grouping factor, the row names of \code{W} have to match the levels of the grouping factor.} \item{formula}{An optional one-sided formula of the form \code{~ 1 | g}, where \code{g} is a grouping factor mapping observations to spatial locations. If not specified, each observation is treated as a separate location. It is recommended to always specify a grouping factor to allow for handling of new data in post-processing methods.} \item{type}{Type of the CAR structure. Currently implemented are \code{"escar"} (exact sparse CAR), \code{"esicar"} (exact sparse intrinsic CAR), \code{"icar"} (intrinsic CAR), and \code{"bym2"}. More information is provided in the 'Details' section.} } \description{ These function are deprecated. Please see \code{\link{car}} for the new syntax. These functions are constructors for the \code{cor_car} class implementing spatial conditional autoregressive structures. } \details{ The \code{escar} and \code{esicar} types are implemented based on the case study of Max Joseph (\url{https://github.com/mbjoseph/CARstan}). The \code{icar} and \code{bym2} type is implemented based on the case study of Mitzi Morris (\url{https://mc-stan.org/users/documentation/case-studies/icar_stan.html}). } \examples{ \dontrun{ # generate some spatial data east <- north <- 1:10 Grid <- expand.grid(east, north) K <- nrow(Grid) # set up distance and neighbourhood matrices distance <- as.matrix(dist(Grid)) W <- array(0, c(K, K)) W[distance == 1] <- 1 # generate the covariates and response data x1 <- rnorm(K) x2 <- rnorm(K) theta <- rnorm(K, sd = 0.05) phi <- rmulti_normal( 1, mu = rep(0, K), Sigma = 0.4 * exp(-0.1 * distance) ) eta <- x1 + x2 + phi prob <- exp(eta) / (1 + exp(eta)) size <- rep(50, K) y <- rbinom(n = K, size = size, prob = prob) dat <- data.frame(y, size, x1, x2) # fit a CAR model fit <- brm(y | trials(size) ~ x1 + x2, data = dat, family = binomial(), autocor = cor_car(W)) summary(fit) } } brms/man/opencl.Rd0000644000176200001440000000241514213413565013545 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/backends.R \name{opencl} \alias{opencl} \title{GPU support in Stan via OpenCL} \usage{ opencl(ids = NULL) } \arguments{ \item{ids}{(integer vector of length 2) The platform and device IDs of the OpenCL device to use for fitting. If you don't know the IDs of your OpenCL device, \code{c(0,0)} is most likely what you need.} } \value{ A \code{brmsopencl} object which can be passed to the \code{opencl} argument of \code{brm} and related functions. } \description{ Use OpenCL for GPU support in \pkg{Stan} via the \pkg{brms} interface. Only some \pkg{Stan} functions can be run on a GPU at this point and so a lot of \pkg{brms} models won't benefit from OpenCL for now. } \details{ For more details on OpenCL in \pkg{Stan}, check out \url{https://mc-stan.org/docs/2_26/cmdstan-guide/parallelization.html#opencl} as well as \url{https://mc-stan.org/docs/2_26/stan-users-guide/opencl.html}. } \examples{ \dontrun{ # this model just serves as an illustration # OpenCL may not actually speed things up here fit <- brm(count ~ zAge + zBase * Trt + (1|patient), data = epilepsy, family = poisson(), chains = 2, cores = 2, opencl = opencl(c(0, 0)), backend = "cmdstanr") summary(fit) } } brms/man/mvbrmsformula.Rd0000644000176200001440000000274014213413565015162 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/brmsformula.R \name{mvbrmsformula} \alias{mvbrmsformula} \alias{mvbf} \title{Set up a multivariate model formula for use in \pkg{brms}} \usage{ mvbrmsformula(..., flist = NULL, rescor = NULL) } \arguments{ \item{...}{Objects of class \code{formula} or \code{brmsformula}, each specifying a univariate model. See \code{\link{brmsformula}} for details on how to specify univariate models.} \item{flist}{Optional list of formulas, which are treated in the same way as formulas passed via the \code{...} argument.} \item{rescor}{Logical; Indicates if residual correlation between the response variables should be modeled. Currently, this is only possible in multivariate \code{gaussian} and \code{student} models. If \code{NULL} (the default), \code{rescor} is internally set to \code{TRUE} when possible.} } \value{ An object of class \code{mvbrmsformula}, which is essentially a \code{list} containing all model formulas as well as some additional information for multivariate models. } \description{ Set up a multivariate model formula for use in the \pkg{brms} package allowing to define (potentially non-linear) additive multilevel models for all parameters of the assumed response distributions. } \details{ See \code{vignette("brms_multivariate")} for a case study. } \examples{ bf1 <- bf(y1 ~ x + (1|g)) bf2 <- bf(y2 ~ s(z)) mvbf(bf1, bf2) } \seealso{ \code{\link{brmsformula}}, \code{\link{brmsformula-helpers}} } brms/man/get_refmodel.brmsfit.Rd0000644000176200001440000000662615053072461016375 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/projpred.R \name{get_refmodel.brmsfit} \alias{get_refmodel.brmsfit} \title{Projection Predictive Variable Selection: Get Reference Model} \usage{ get_refmodel.brmsfit( object, newdata = NULL, resp = NULL, cvfun = NULL, dis = NULL, latent = FALSE, brms_seed = NULL, ... ) } \arguments{ \item{object}{An object of class \code{brmsfit}.} \item{newdata}{An optional data.frame for which to evaluate predictions. If \code{NULL} (default), the original data of the model is used. \code{NA} values within factors (excluding grouping variables) are interpreted as if all dummy variables of this factor are zero. This allows, for instance, to make predictions of the grand mean when using sum coding. \code{NA} values within grouping variables are treated as a new level.} \item{resp}{Optional names of response variables. If specified, predictions are performed only for the specified response variables.} \item{cvfun}{Optional cross-validation function (see \code{\link[projpred:get_refmodel]{get_refmodel}} for details). If \code{NULL} (the default), \code{cvfun} is defined internally based on \code{\link{kfold.brmsfit}}.} \item{dis}{Passed to argument \code{dis} of \code{\link[projpred:init_refmodel]{init_refmodel}}, but leave this at \code{NULL} unless \pkg{projpred} complains about it.} \item{latent}{See argument \code{latent} of \code{\link[projpred:extend_family]{extend_family}}. Setting this to \code{TRUE} requires a \pkg{projpred} version >= 2.4.0.} \item{brms_seed}{A seed used to infer seeds for \code{\link{kfold.brmsfit}} and for sampling group-level effects for new levels (in multilevel models). If \code{NULL}, then \code{\link{set.seed}} is not called at all. If not \code{NULL}, then the pseudorandom number generator (PRNG) state is reset (to the state before calling this function) upon exiting this function.} \item{...}{Further arguments passed to \code{\link[projpred:init_refmodel]{init_refmodel}}.} } \value{ A \code{refmodel} object to be used in conjunction with the \pkg{projpred} package. } \description{ The \code{get_refmodel.brmsfit} method can be used to create the reference model structure which is needed by the \pkg{projpred} package for performing a projection predictive variable selection. This method is called automatically when performing variable selection via \code{\link[projpred:varsel]{varsel}} or \code{\link[projpred:cv_varsel]{cv_varsel}}, so you will rarely need to call it manually yourself. } \details{ The \code{extract_model_data} function used internally by \code{get_refmodel.brmsfit} ignores arguments \code{wrhs} and \code{orhs} (a warning is thrown if these are non-\code{NULL}). For example, arguments \code{weightsnew} and \code{offsetnew} of \code{\link[projpred:proj_linpred]{proj_linpred}}, \code{\link[projpred:proj_predict]{proj_predict}}, and \code{\link[projpred:predict.refmodel]{predict.refmodel}} are passed to \code{wrhs} and \code{orhs}, respectively. } \examples{ \dontrun{ # fit a simple model fit <- brm(count ~ zAge + zBase * Trt, data = epilepsy, family = poisson()) summary(fit) # The following code requires the 'projpred' package to be installed: library(projpred) # perform variable selection without cross-validation vs <- varsel(fit) summary(vs) plot(vs) # perform variable selection with cross-validation cv_vs <- cv_varsel(fit) summary(cv_vs) plot(cv_vs) } } brms/man/loo_predict.brmsfit.Rd0000644000176200001440000000643415053072461016241 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/loo_predict.R \name{loo_predict.brmsfit} \alias{loo_predict.brmsfit} \alias{loo_predict} \alias{loo_epred} \alias{loo_linpred} \alias{loo_predictive_interval} \alias{loo_epred.brmsfit} \alias{loo_linpred.brmsfit} \alias{loo_predictive_interval.brmsfit} \title{Compute Weighted Expectations Using LOO} \usage{ \method{loo_predict}{brmsfit}( object, type = c("mean", "var", "quantile"), probs = 0.5, psis_object = NULL, resp = NULL, ... ) \method{loo_epred}{brmsfit}( object, type = c("mean", "var", "quantile"), probs = 0.5, psis_object = NULL, resp = NULL, ... ) loo_epred(object, ...) \method{loo_linpred}{brmsfit}( object, type = c("mean", "var", "quantile"), probs = 0.5, psis_object = NULL, resp = NULL, ... ) \method{loo_predictive_interval}{brmsfit}(object, prob = 0.9, psis_object = NULL, ...) } \arguments{ \item{object}{An object of class \code{brmsfit}.} \item{type}{The statistic to be computed on the results. Can by either \code{"mean"} (default), \code{"var"}, or \code{"quantile"}.} \item{probs}{A vector of quantiles to compute. Only used if \code{type = quantile}.} \item{psis_object}{An optional object returned by \code{\link[loo]{psis}}. If \code{psis_object} is missing then \code{\link[loo]{psis}} is executed internally, which may be time consuming for models fit to very large datasets.} \item{resp}{Optional names of response variables. If specified, predictions are performed only for the specified response variables.} \item{...}{Optional arguments passed to the underlying methods that is \code{\link[brms:log_lik.brmsfit]{log_lik}}, as well as \code{\link[brms:posterior_predict.brmsfit]{posterior_predict}}, \code{\link[brms:posterior_epred.brmsfit]{posterior_epred}} or \code{\link[brms:posterior_linpred.brmsfit]{posterior_linpred}}.} \item{prob}{For \code{loo_predictive_interval}, a scalar in \eqn{(0,1)} indicating the desired probability mass to include in the intervals. The default is \code{prob = 0.9} (\eqn{90}\% intervals).} } \value{ \code{loo_predict}, \code{loo_epred}, \code{loo_linpred}, and \code{loo_predictive_interval} all return a matrix with one row per observation and one column per summary statistic as specified by arguments \code{type} and \code{probs}. In multivariate or categorical models a third dimension is added to represent the response variables or categories, respectively. \code{loo_predictive_interval(..., prob = p)} is equivalent to \code{loo_predict(..., type = "quantile", probs = c(a, 1-a))} with \code{a = (1 - p)/2}. } \description{ These functions are wrappers around the \code{\link[loo]{E_loo}} function of the \pkg{loo} package. } \examples{ \dontrun{ ## data from help("lm") ctl <- c(4.17,5.58,5.18,6.11,4.50,4.61,5.17,4.53,5.33,5.14) trt <- c(4.81,4.17,4.41,3.59,5.87,3.83,6.03,4.89,4.32,4.69) d <- data.frame( weight = c(ctl, trt), group = gl(2, 10, 20, labels = c("Ctl", "Trt")) ) fit <- brm(weight ~ group, data = d) loo_predictive_interval(fit, prob = 0.8) ## optionally log-weights can be pre-computed and reused psis <- loo::psis(-log_lik(fit), cores = 2) loo_predictive_interval(fit, prob = 0.8, psis_object = psis) loo_predict(fit, type = "var", psis_object = psis) loo_epred(fit, type = "var", psis_object = psis) } } brms/man/diagnostic-quantities.Rd0000644000176200001440000000274614361545260016606 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/diagnostics.R \name{diagnostic-quantities} \alias{diagnostic-quantities} \alias{log_posterior} \alias{nuts_params} \alias{rhat} \alias{neff_ratio} \alias{log_posterior.brmsfit} \alias{nuts_params.brmsfit} \alias{rhat.brmsfit} \alias{neff_ratio.brmsfit} \title{Extract Diagnostic Quantities of \pkg{brms} Models} \usage{ \method{log_posterior}{brmsfit}(object, ...) \method{nuts_params}{brmsfit}(object, pars = NULL, ...) \method{rhat}{brmsfit}(x, pars = NULL, ...) \method{neff_ratio}{brmsfit}(object, pars = NULL, ...) } \arguments{ \item{object, x}{A \code{brmsfit} object.} \item{...}{Arguments passed to individual methods.} \item{pars}{An optional character vector of parameter names. For \code{nuts_params} these will be NUTS sampler parameter names rather than model parameters. If pars is omitted all parameters are included.} } \value{ The exact form of the output depends on the method. } \description{ Extract quantities that can be used to diagnose sampling behavior of the algorithms applied by \pkg{Stan} at the back-end of \pkg{brms}. } \details{ For more details see \code{\link[bayesplot:bayesplot-extractors]{bayesplot-extractors}}. } \examples{ \dontrun{ fit <- brm(time ~ age * sex, data = kidney) lp <- log_posterior(fit) head(lp) np <- nuts_params(fit) str(np) # extract the number of divergence transitions sum(subset(np, Parameter == "divergent__")$Value) head(rhat(fit)) head(neff_ratio(fit)) } } brms/man/expose_functions.brmsfit.Rd0000644000176200001440000000165214213413565017327 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/brmsfit-methods.R \name{expose_functions.brmsfit} \alias{expose_functions.brmsfit} \alias{expose_functions} \title{Expose user-defined \pkg{Stan} functions} \usage{ \method{expose_functions}{brmsfit}(x, vectorize = FALSE, env = globalenv(), ...) expose_functions(x, ...) } \arguments{ \item{x}{An object of class \code{brmsfit}.} \item{vectorize}{Logical; Indicates if the exposed functions should be vectorized via \code{\link{Vectorize}}. Defaults to \code{FALSE}.} \item{env}{Environment where the functions should be made available. Defaults to the global environment.} \item{...}{Further arguments passed to \code{\link[rstan:expose_stan_functions]{expose_stan_functions}}.} } \description{ Export user-defined \pkg{Stan} function and optionally vectorize them. For more details see \code{\link[rstan:expose_stan_functions]{expose_stan_functions}}. } brms/man/StudentT.Rd0000644000176200001440000000251114403575116014036 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/distributions.R \name{StudentT} \alias{StudentT} \alias{dstudent_t} \alias{pstudent_t} \alias{qstudent_t} \alias{rstudent_t} \title{The Student-t Distribution} \usage{ dstudent_t(x, df, mu = 0, sigma = 1, log = FALSE) pstudent_t(q, df, mu = 0, sigma = 1, lower.tail = TRUE, log.p = FALSE) qstudent_t(p, df, mu = 0, sigma = 1, lower.tail = TRUE, log.p = FALSE) rstudent_t(n, df, mu = 0, sigma = 1) } \arguments{ \item{x}{Vector of quantiles.} \item{df}{Vector of degrees of freedom.} \item{mu}{Vector of location values.} \item{sigma}{Vector of scale values.} \item{log}{Logical; If \code{TRUE}, values are returned on the log scale.} \item{q}{Vector of quantiles.} \item{lower.tail}{Logical; If \code{TRUE} (default), return P(X <= x). Else, return P(X > x) .} \item{log.p}{Logical; If \code{TRUE}, values are returned on the log scale.} \item{p}{Vector of probabilities.} \item{n}{Number of draws to sample from the distribution.} } \description{ Density, distribution function, quantile function and random generation for the Student-t distribution with location \code{mu}, scale \code{sigma}, and degrees of freedom \code{df}. } \details{ See \code{vignette("brms_families")} for details on the parameterization. } \seealso{ \code{\link[stats:TDist]{TDist}} } brms/man/arma.Rd0000644000176200001440000000352614361545260013213 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/formula-ac.R \name{arma} \alias{arma} \title{Set up ARMA(p,q) correlation structures} \usage{ arma(time = NA, gr = NA, p = 1, q = 1, cov = FALSE) } \arguments{ \item{time}{An optional time variable specifying the time ordering of the observations. By default, the existing order of the observations in the data is used.} \item{gr}{An optional grouping variable. If specified, the correlation structure is assumed to apply only to observations within the same grouping level.} \item{p}{A non-negative integer specifying the autoregressive (AR) order of the ARMA structure. Default is \code{1}.} \item{q}{A non-negative integer specifying the moving average (MA) order of the ARMA structure. Default is \code{1}.} \item{cov}{A flag indicating whether ARMA effects should be estimated by means of residual covariance matrices. This is currently only possible for stationary ARMA effects of order 1. If the model family does not have natural residuals, latent residuals are added automatically. If \code{FALSE} (the default), a regression formulation is used that is considerably faster and allows for ARMA effects of order higher than 1 but is only available for \code{gaussian} models and some of its generalizations.} } \value{ An object of class \code{'arma_term'}, which is a list of arguments to be interpreted by the formula parsing functions of \pkg{brms}. } \description{ Set up an autoregressive moving average (ARMA) term of order (p, q) in \pkg{brms}. The function does not evaluate its arguments -- it exists purely to help set up a model with ARMA terms. } \examples{ \dontrun{ data("LakeHuron") LakeHuron <- as.data.frame(LakeHuron) fit <- brm(x ~ arma(p = 2, q = 1), data = LakeHuron) summary(fit) } } \seealso{ \code{\link{autocor-terms}}, \code{\link{ar}}, \code{\link{ma}}, } brms/man/family.brmsfit.Rd0000644000176200001440000000113214160105076015202 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/brmsfit-methods.R \name{family.brmsfit} \alias{family.brmsfit} \title{Extract Model Family Objects} \usage{ \method{family}{brmsfit}(object, resp = NULL, ...) } \arguments{ \item{object}{An object of class \code{brmsfit}.} \item{resp}{Optional names of response variables. If specified, predictions are performed only for the specified response variables.} \item{...}{Currently unused.} } \value{ A \code{brmsfamily} object or a list of such objects for multivariate models. } \description{ Extract Model Family Objects } brms/man/brmshypothesis.Rd0000644000176200001440000000474515053072461015357 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/hypothesis.R \name{brmshypothesis} \alias{brmshypothesis} \alias{print.brmshypothesis} \alias{plot.brmshypothesis} \title{Descriptions of \code{brmshypothesis} Objects} \usage{ \method{print}{brmshypothesis}( x, digits = 2, chars = 20, short = getOption("brms.short_summary", FALSE), ... ) \method{plot}{brmshypothesis}( x, nvariables = 5, N = NULL, ignore_prior = FALSE, chars = 40, colors = NULL, theme = NULL, ask = TRUE, plot = TRUE, ... ) } \arguments{ \item{x}{An object of class \code{brmsfit}.} \item{digits}{Minimal number of significant digits, see \code{\link[base:print.default]{print.default}}.} \item{chars}{Maximum number of characters of each hypothesis to print or plot. If \code{NULL}, print the full hypotheses. Defaults to \code{20}.} \item{short}{A flag indicating whether to provide a shorter summary with less informational text. Defaults to \code{FALSE}. Can be set globally for the current session via the \code{brms.short_summary} option.} \item{...}{Currently ignored.} \item{nvariables}{The number of variables (parameters) plotted per page.} \item{N}{Deprecated alias of \code{nvariables}.} \item{ignore_prior}{A flag indicating if prior distributions should also be plotted. Only used if priors were specified on the relevant parameters.} \item{colors}{Two values specifying the colors of the posterior and prior density respectively. If \code{NULL} (the default) colors are taken from the current color scheme of the \pkg{bayesplot} package.} \item{theme}{A \code{\link[ggplot2:theme]{theme}} object modifying the appearance of the plots. For some basic themes see \code{\link[ggplot2:ggtheme]{ggtheme}} and \code{\link[bayesplot:theme_default]{theme_default}}.} \item{ask}{Logical; indicates if the user is prompted before a new page is plotted. Only used if \code{plot} is \code{TRUE}.} \item{plot}{Logical; indicates if plots should be plotted directly in the active graphic device. Defaults to \code{TRUE}.} } \description{ A \code{brmshypothesis} object contains posterior draws as well as summary statistics of non-linear hypotheses as returned by \code{\link{hypothesis}}. } \details{ The two most important elements of a \code{brmshypothesis} object are \code{hypothesis}, which is a data.frame containing the summary estimates of the hypotheses, and \code{samples}, which is a data.frame containing the corresponding posterior draws. } \seealso{ \code{\link{hypothesis}} } brms/man/pp_mixture.brmsfit.Rd0000644000176200001440000000767015053072461016135 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/pp_mixture.R \name{pp_mixture.brmsfit} \alias{pp_mixture.brmsfit} \alias{pp_mixture} \title{Posterior Probabilities of Mixture Component Memberships} \usage{ \method{pp_mixture}{brmsfit}( x, newdata = NULL, re_formula = NULL, resp = NULL, ndraws = NULL, draw_ids = NULL, log = FALSE, summary = TRUE, robust = FALSE, probs = c(0.025, 0.975), ... ) pp_mixture(x, ...) } \arguments{ \item{x}{An \R object usually of class \code{brmsfit}.} \item{newdata}{An optional data.frame for which to evaluate predictions. If \code{NULL} (default), the original data of the model is used. \code{NA} values within factors (excluding grouping variables) are interpreted as if all dummy variables of this factor are zero. This allows, for instance, to make predictions of the grand mean when using sum coding. \code{NA} values within grouping variables are treated as a new level.} \item{re_formula}{formula containing group-level effects to be considered in the prediction. If \code{NULL} (default), include all group-level effects; if \code{NA} or \code{~0}, include no group-level effects.} \item{resp}{Optional names of response variables. If specified, predictions are performed only for the specified response variables.} \item{ndraws}{Positive integer indicating how many posterior draws should be used. If \code{NULL} (the default) all draws are used. Ignored if \code{draw_ids} is not \code{NULL}.} \item{draw_ids}{An integer vector specifying the posterior draws to be used. If \code{NULL} (the default), all draws are used.} \item{log}{Logical; Indicates whether to return probabilities on the log-scale.} \item{summary}{Should summary statistics be returned instead of the raw values? Default is \code{TRUE}.} \item{robust}{If \code{FALSE} (the default) the mean is used as the measure of central tendency and the standard deviation as the measure of variability. If \code{TRUE}, the median and the median absolute deviation (MAD) are applied instead. Only used if \code{summary} is \code{TRUE}.} \item{probs}{The percentiles to be computed by the \code{quantile} function. Only used if \code{summary} is \code{TRUE}.} \item{...}{Further arguments passed to \code{\link{prepare_predictions}} that control several aspects of data validation and prediction.} } \value{ If \code{summary = TRUE}, an N x E x K array, where N is the number of observations, K is the number of mixture components, and E is equal to \code{length(probs) + 2}. If \code{summary = FALSE}, an S x N x K array, where S is the number of posterior draws. } \description{ Compute the posterior probabilities of mixture component memberships for each observation including uncertainty estimates. } \details{ The returned probabilities can be written as \eqn{P(K_n = k | Y_n)}, that is the posterior probability that observation n originates from component k. They are computed using Bayes' Theorem \deqn{P(K_n = k | Y_n) = P(Y_n | K_n = k) P(K_n = k) / P(Y_n),} where \eqn{P(Y_n | K_n = k)} is the (posterior) likelihood of observation n for component k, \eqn{P(K_n = k)} is the (posterior) mixing probability of component k (i.e. parameter \code{theta}), and \deqn{P(Y_n) = \sum_{k=1,...,K} P(Y_n | K_n = k) P(K_n = k)} is a normalizing constant. } \examples{ \dontrun{ ## simulate some data set.seed(1234) dat <- data.frame( y = c(rnorm(100), rnorm(50, 2)), x = rnorm(150) ) ## fit a simple normal mixture model mix <- mixture(gaussian, nmix = 2) prior <- c( prior(normal(0, 5), Intercept, nlpar = mu1), prior(normal(0, 5), Intercept, nlpar = mu2), prior(dirichlet(2, 2), theta) ) fit1 <- brm(bf(y ~ x), dat, family = mix, prior = prior, chains = 2, init = 0) summary(fit1) ## compute the membership probabilities ppm <- pp_mixture(fit1) str(ppm) ## extract point estimates for each observation head(ppm[, 1, ]) ## classify every observation according to ## the most likely component apply(ppm[, 1, ], 1, which.max) } } brms/man/plot.brmsfit.Rd0000644000176200001440000000525414540344416014715 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/plot.R \name{plot.brmsfit} \alias{plot.brmsfit} \title{Trace and Density Plots for MCMC Draws} \usage{ \method{plot}{brmsfit}( x, pars = NA, combo = c("hist", "trace"), nvariables = 5, N = NULL, variable = NULL, regex = FALSE, fixed = FALSE, bins = 30, theme = NULL, plot = TRUE, ask = TRUE, newpage = TRUE, ... ) } \arguments{ \item{x}{An object of class \code{brmsfit}.} \item{pars}{Deprecated alias of \code{variable}. Names of the parameters to plot, as given by a character vector or a regular expression.} \item{combo}{A character vector with at least two elements. Each element of \code{combo} corresponds to a column in the resulting graphic and should be the name of one of the available \code{\link[bayesplot:MCMC-overview]{MCMC}} functions (omitting the \code{mcmc_} prefix).} \item{nvariables}{The number of variables (parameters) plotted per page.} \item{N}{Deprecated alias of \code{nvariables}.} \item{variable}{Names of the variables (parameters) to plot, as given by a character vector or a regular expression (if \code{regex = TRUE}). By default, a hopefully not too large selection of variables is plotted.} \item{regex}{Logical; Indicates whether \code{variable} should be treated as regular expressions. Defaults to \code{FALSE}.} \item{fixed}{(Deprecated) Indicates whether parameter names should be matched exactly (\code{TRUE}) or treated as regular expressions (\code{FALSE}). Default is \code{FALSE} and only works with argument \code{pars}.} \item{bins}{Number of bins used for posterior histograms (defaults to 30).} \item{theme}{A \code{\link[ggplot2:theme]{theme}} object modifying the appearance of the plots. For some basic themes see \code{\link[ggplot2:ggtheme]{ggtheme}} and \code{\link[bayesplot:theme_default]{theme_default}}.} \item{plot}{Logical; indicates if plots should be plotted directly in the active graphic device. Defaults to \code{TRUE}.} \item{ask}{Logical; indicates if the user is prompted before a new page is plotted. Only used if \code{plot} is \code{TRUE}.} \item{newpage}{Logical; indicates if the first set of plots should be plotted to a new page. Only used if \code{plot} is \code{TRUE}.} \item{...}{Further arguments passed to \code{\link[bayesplot:MCMC-combos]{mcmc_combo}}.} } \value{ An invisible list of \code{\link[gtable:gtable]{gtable}} objects. } \description{ Trace and Density Plots for MCMC Draws } \examples{ \dontrun{ fit <- brm(count ~ zAge + zBase * Trt + (1|patient) + (1|visit), data = epilepsy, family = "poisson") plot(fit) ## plot population-level effects only plot(fit, variable = "^b_", regex = TRUE) } } brms/man/posterior_predict.brmsfit.Rd0000644000176200001440000001261415053072461017473 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/posterior_predict.R \name{posterior_predict.brmsfit} \alias{posterior_predict.brmsfit} \alias{posterior_predict} \title{Draws from the Posterior Predictive Distribution} \usage{ \method{posterior_predict}{brmsfit}( object, newdata = NULL, re_formula = NULL, re.form = NULL, transform = NULL, resp = NULL, negative_rt = FALSE, ndraws = NULL, draw_ids = NULL, sort = FALSE, ntrys = 5, cores = NULL, ... ) } \arguments{ \item{object}{An object of class \code{brmsfit}.} \item{newdata}{An optional data.frame for which to evaluate predictions. If \code{NULL} (default), the original data of the model is used. \code{NA} values within factors (excluding grouping variables) are interpreted as if all dummy variables of this factor are zero. This allows, for instance, to make predictions of the grand mean when using sum coding. \code{NA} values within grouping variables are treated as a new level.} \item{re_formula}{formula containing group-level effects to be considered in the prediction. If \code{NULL} (default), include all group-level effects; if \code{NA} or \code{~0}, include no group-level effects.} \item{re.form}{Alias of \code{re_formula}.} \item{transform}{(Deprecated) A function or a character string naming a function to be applied on the predicted responses before summary statistics are computed.} \item{resp}{Optional names of response variables. If specified, predictions are performed only for the specified response variables.} \item{negative_rt}{Only relevant for Wiener diffusion models. A flag indicating whether response times of responses on the lower boundary should be returned as negative values. This allows to distinguish responses on the upper and lower boundary. Defaults to \code{FALSE}.} \item{ndraws}{Positive integer indicating how many posterior draws should be used. If \code{NULL} (the default) all draws are used. Ignored if \code{draw_ids} is not \code{NULL}.} \item{draw_ids}{An integer vector specifying the posterior draws to be used. If \code{NULL} (the default), all draws are used.} \item{sort}{Logical. Only relevant for time series models. Indicating whether to return predicted values in the original order (\code{FALSE}; default) or in the order of the time series (\code{TRUE}).} \item{ntrys}{Parameter used in rejection sampling for truncated discrete models only (defaults to \code{5}). See Details for more information.} \item{cores}{Number of cores (defaults to \code{1}). On non-Windows systems, this argument can be set globally via the \code{mc.cores} option.} \item{...}{Further arguments passed to \code{\link{prepare_predictions}} that control several aspects of data validation and prediction.} } \value{ An \code{array} of draws. In univariate models, the output is as an S x N matrix, where S is the number of posterior draws and N is the number of observations. In multivariate models, an additional dimension is added to the output which indexes along the different response variables. } \description{ Compute posterior draws of the posterior predictive distribution. Can be performed for the data used to fit the model (posterior predictive checks) or for new data. By definition, these draws have higher variance than draws of the expected value of the posterior predictive distribution computed by \code{\link{posterior_epred.brmsfit}}. This is because the residual error is incorporated in \code{posterior_predict}. However, the estimated means of both methods averaged across draws should be very similar. } \details{ \code{NA} values within factors in \code{newdata}, are interpreted as if all dummy variables of this factor are zero. This allows, for instance, to make predictions of the grand mean when using sum coding. In multilevel models, it is possible to allow new levels of grouping factors to be used in the predictions. This can be controlled via argument \code{allow_new_levels}. New levels can be sampled in multiple ways, which can be controlled via argument \code{sample_new_levels}. Both of these arguments are documented in \code{\link{prepare_predictions}} along with several other useful arguments to control specific aspects of the predictions. For truncated discrete models only: In the absence of any general algorithm to sample from truncated discrete distributions, rejection sampling is applied in this special case. This means that values are sampled until a value lies within the defined truncation boundaries. In practice, this procedure may be rather slow (especially in \R). Thus, we try to do approximate rejection sampling by sampling each value \code{ntrys} times and then select a valid value. If all values are invalid, the closest boundary is used, instead. If there are more than a few of these pathological cases, a warning will occur suggesting to increase argument \code{ntrys}. } \examples{ \dontrun{ ## fit a model fit <- brm(time | cens(censored) ~ age + sex + (1 + age || patient), data = kidney, family = "exponential", init = "0") ## predicted responses pp <- posterior_predict(fit) str(pp) ## predicted responses excluding the group-level effect of age pp <- posterior_predict(fit, re_formula = ~ (1 | patient)) str(pp) ## predicted responses of patient 1 for new data newdata <- data.frame( sex = factor(c("male", "female")), age = c(20, 50), patient = c(1, 1) ) pp <- posterior_predict(fit, newdata = newdata) str(pp) } } brms/man/prepare_predictions.Rd0000644000176200001440000001250715053072461016330 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/prepare_predictions.R \name{prepare_predictions.brmsfit} \alias{prepare_predictions.brmsfit} \alias{prepare_predictions} \alias{extract_draws} \title{Prepare Predictions} \usage{ \method{prepare_predictions}{brmsfit}( x, newdata = NULL, re_formula = NULL, allow_new_levels = FALSE, sample_new_levels = "uncertainty", incl_autocor = TRUE, oos = NULL, resp = NULL, ndraws = NULL, draw_ids = NULL, nsamples = NULL, subset = NULL, nug = NULL, smooths_only = FALSE, offset = TRUE, newdata2 = NULL, new_objects = NULL, point_estimate = NULL, ndraws_point_estimate = 1, ... ) prepare_predictions(x, ...) } \arguments{ \item{x}{An \R object typically of class \code{'brmsfit'}.} \item{newdata}{An optional data.frame for which to evaluate predictions. If \code{NULL} (default), the original data of the model is used. \code{NA} values within factors (excluding grouping variables) are interpreted as if all dummy variables of this factor are zero. This allows, for instance, to make predictions of the grand mean when using sum coding. \code{NA} values within grouping variables are treated as a new level.} \item{re_formula}{formula containing group-level effects to be considered in the prediction. If \code{NULL} (default), include all group-level effects; if \code{NA} or \code{~0}, include no group-level effects.} \item{allow_new_levels}{A flag indicating if new levels of group-level effects are allowed (defaults to \code{FALSE}). Only relevant if \code{newdata} is provided.} \item{sample_new_levels}{Indicates how to sample new levels for grouping factors specified in \code{re_formula}. This argument is only relevant if \code{newdata} is provided and \code{allow_new_levels} is set to \code{TRUE}. If \code{"uncertainty"} (default), each posterior sample for a new level is drawn from the posterior draws of a randomly chosen existing level. Each posterior sample for a new level may be drawn from a different existing level such that the resulting set of new posterior draws represents the variation across existing levels. If \code{"gaussian"}, sample new levels from the (multivariate) normal distribution implied by the group-level standard deviations and correlations. This options may be useful for conducting Bayesian power analysis or predicting new levels in situations where relatively few levels where observed in the old_data. If \code{"old_levels"}, directly sample new levels from the existing levels, where a new level is assigned all of the posterior draws of the same (randomly chosen) existing level.} \item{incl_autocor}{A flag indicating if correlation structures originally specified via \code{autocor} should be included in the predictions. Defaults to \code{TRUE}.} \item{oos}{Optional indices of observations for which to compute out-of-sample rather than in-sample predictions. Only required in models that make use of response values to make predictions, that is, currently only ARMA models.} \item{resp}{Optional names of response variables. If specified, predictions are performed only for the specified response variables.} \item{ndraws}{Positive integer indicating how many posterior draws should be used. If \code{NULL} (the default) all draws are used. Ignored if \code{draw_ids} is not \code{NULL}.} \item{draw_ids}{An integer vector specifying the posterior draws to be used. If \code{NULL} (the default), all draws are used.} \item{nsamples}{Deprecated alias of \code{ndraws}.} \item{subset}{Deprecated alias of \code{draw_ids}.} \item{nug}{Small positive number for Gaussian process terms only. For numerical reasons, the covariance matrix of a Gaussian process might not be positive definite. Adding a very small number to the matrix's diagonal often solves this problem. If \code{NULL} (the default), \code{nug} is chosen internally.} \item{smooths_only}{Logical; If \code{TRUE} only predictions related to smoothing splines (i.e., \code{s} or \code{t2}) will be computed. Defaults to \code{FALSE}.} \item{offset}{Logical; Indicates if offsets should be included in the predictions. Defaults to \code{TRUE}.} \item{newdata2}{A named \code{list} of objects containing new data, which cannot be passed via argument \code{newdata}. Required for some objects used in autocorrelation structures, or \code{\link{stanvars}}.} \item{new_objects}{Deprecated alias of \code{newdata2}.} \item{point_estimate}{Shall the returned object contain only point estimates of the parameters instead of their posterior draws? Defaults to \code{NULL} in which case no point estimate is computed. Alternatively, may be set to \code{"mean"} or \code{"median"}. This argument is primarily implemented to ensure compatibility with the \code{\link{loo_subsample}} method.} \item{ndraws_point_estimate}{Only used if \code{point_estimate} is not \code{NULL}. How often shall the point estimate's value be repeated? Defaults to \code{1}.} \item{...}{Further arguments passed to \code{\link{validate_newdata}}.} } \value{ An object of class \code{'brmsprep'} or \code{'mvbrmsprep'}, depending on whether a univariate or multivariate model is passed. } \description{ This method helps in preparing \pkg{brms} models for certain post-processing tasks most notably various forms of predictions. Unless you are a package developer, you will rarely need to call \code{prepare_predictions} directly. } brms/man/inits.brmsfit.Rd0000644000176200001440000000135615053254244015063 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/brmsfit-methods.R \name{inits.brmsfit} \alias{inits.brmsfit} \alias{inits} \title{Extract Initial Values Used for Each Chain} \usage{ \method{inits}{brmsfit}(x, ...) inits(x, ...) } \arguments{ \item{x}{A \code{brmsfit} object.} \item{...}{Currently ignored.} } \value{ The initial values (either user-specified or generated randomly) for all chains. This is a list with one component per chain. Each component is a named list containing the initial values for each parameter for the corresponding chain. } \description{ Extract the initial values used by Stan for each chain. This is currently only available if the model was fitted with the \code{rstan} backend. } brms/man/ngrps.brmsfit.Rd0000644000176200001440000000075414160105076015063 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/brmsfit-methods.R \name{ngrps.brmsfit} \alias{ngrps.brmsfit} \alias{ngrps} \title{Number of Grouping Factor Levels} \usage{ \method{ngrps}{brmsfit}(object, ...) ngrps(object, ...) } \arguments{ \item{object}{An \R object.} \item{...}{Currently ignored.} } \value{ A named list containing the number of levels per grouping factor. } \description{ Extract the number of levels of one or more grouping factors. } brms/man/ranef.brmsfit.Rd0000644000176200001440000000351314213413565015025 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/brmsfit-methods.R \name{ranef.brmsfit} \alias{ranef.brmsfit} \alias{ranef} \title{Extract Group-Level Estimates} \usage{ \method{ranef}{brmsfit}( object, summary = TRUE, robust = FALSE, probs = c(0.025, 0.975), pars = NULL, groups = NULL, ... ) } \arguments{ \item{object}{An object of class \code{brmsfit}.} \item{summary}{Should summary statistics be returned instead of the raw values? Default is \code{TRUE}.} \item{robust}{If \code{FALSE} (the default) the mean is used as the measure of central tendency and the standard deviation as the measure of variability. If \code{TRUE}, the median and the median absolute deviation (MAD) are applied instead. Only used if \code{summary} is \code{TRUE}.} \item{probs}{The percentiles to be computed by the \code{quantile} function. Only used if \code{summary} is \code{TRUE}.} \item{pars}{Optional names of coefficients to extract. By default, all coefficients are extracted.} \item{groups}{Optional names of grouping variables for which to extract effects.} \item{...}{Currently ignored.} } \value{ A list of 3D arrays (one per grouping factor). If \code{summary} is \code{TRUE}, the 1st dimension contains the factor levels, the 2nd dimension contains the summary statistics (see \code{\link{posterior_summary}}), and the 3rd dimension contains the group-level effects. If \code{summary} is \code{FALSE}, the 1st dimension contains the posterior draws, the 2nd dimension contains the factor levels, and the 3rd dimension contains the group-level effects. } \description{ Extract the group-level ('random') effects of each level from a \code{brmsfit} object. } \examples{ \dontrun{ fit <- brm(count ~ zAge + zBase * Trt + (1+Trt|visit), data = epilepsy, family = gaussian(), chains = 2) ranef(fit) } } brms/man/stancode.brmsfit.Rd0000644000176200001440000000221514571051304015524 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/stancode.R \name{stancode.brmsfit} \alias{stancode.brmsfit} \title{Extract Stan code from \code{brmsfit} objects} \usage{ \method{stancode}{brmsfit}( object, version = TRUE, regenerate = NULL, threads = NULL, backend = NULL, ... ) } \arguments{ \item{object}{An object of class \code{brmsfit}.} \item{version}{Logical; indicates if the first line containing the \pkg{brms} version number should be included. Defaults to \code{TRUE}.} \item{regenerate}{Logical; indicates if the Stan code should be regenerated with the current \pkg{brms} version. By default, \code{regenerate} will be \code{FALSE} unless required to be \code{TRUE} by other arguments.} \item{threads}{Controls whether the Stan code should be threaded. See \code{\link{threading}} for details.} \item{backend}{Controls the Stan backend. See \code{\link{brm}} for details.} \item{...}{Further arguments passed to \code{\link[brms:stancode.default]{stancode}} if the Stan code is regenerated.} } \value{ Stan code for further processing. } \description{ Extract Stan code from a fitted \pkg{brms} model. } brms/man/loo_compare.brmsfit.Rd0000644000176200001440000000250514213413565016231 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/loo.R \name{loo_compare.brmsfit} \alias{loo_compare.brmsfit} \alias{loo_compare} \title{Model comparison with the \pkg{loo} package} \usage{ \method{loo_compare}{brmsfit}(x, ..., criterion = c("loo", "waic", "kfold"), model_names = NULL) } \arguments{ \item{x}{A \code{brmsfit} object.} \item{...}{More \code{brmsfit} objects.} \item{criterion}{The name of the criterion to be extracted from \code{brmsfit} objects.} \item{model_names}{If \code{NULL} (the default) will use model names derived from deparsing the call. Otherwise will use the passed values as model names.} } \value{ An object of class "\code{compare.loo}". } \description{ For more details see \code{\link[loo:loo_compare]{loo_compare}}. } \details{ All \code{brmsfit} objects should contain precomputed criterion objects. See \code{\link{add_criterion}} for more help. } \examples{ \dontrun{ # model with population-level effects only fit1 <- brm(rating ~ treat + period + carry, data = inhaler) fit1 <- add_criterion(fit1, "waic") # model with an additional varying intercept for subjects fit2 <- brm(rating ~ treat + period + carry + (1|subject), data = inhaler) fit2 <- add_criterion(fit2, "waic") # compare both models loo_compare(fit1, fit2, criterion = "waic") } } brms/man/is.mvbrmsformula.Rd0000644000176200001440000000052014160105076015562 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/brmsformula.R \name{is.mvbrmsformula} \alias{is.mvbrmsformula} \title{Checks if argument is a \code{mvbrmsformula} object} \usage{ is.mvbrmsformula(x) } \arguments{ \item{x}{An \R object} } \description{ Checks if argument is a \code{mvbrmsformula} object } brms/man/VonMises.Rd0000644000176200001440000000215314575036401014030 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/distributions.R \name{VonMises} \alias{VonMises} \alias{dvon_mises} \alias{pvon_mises} \alias{rvon_mises} \title{The von Mises Distribution} \usage{ dvon_mises(x, mu, kappa, log = FALSE) pvon_mises(q, mu, kappa, lower.tail = TRUE, log.p = FALSE, acc = 1e-20) rvon_mises(n, mu, kappa) } \arguments{ \item{x, q}{Vector of quantiles between \code{-pi} and \code{pi}.} \item{mu}{Vector of location values.} \item{kappa}{Vector of precision values.} \item{log}{Logical; If \code{TRUE}, values are returned on the log scale.} \item{lower.tail}{Logical; If \code{TRUE} (default), return P(X <= x). Else, return P(X > x) .} \item{log.p}{Logical; If \code{TRUE}, values are returned on the log scale.} \item{acc}{Accuracy of numerical approximations.} \item{n}{Number of draws to sample from the distribution.} } \description{ Density, distribution function, and random generation for the von Mises distribution with location \code{mu}, and precision \code{kappa}. } \details{ See \code{vignette("brms_families")} for details on the parameterization. } brms/man/epilepsy.Rd0000644000176200001440000000365614213413565014127 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/datasets.R \docType{data} \name{epilepsy} \alias{epilepsy} \title{Epileptic seizure counts} \format{ A data frame of 236 observations containing information on the following 9 variables. \describe{ \item{Age}{The age of the patients in years} \item{Base}{The seizure count at 8-weeks baseline} \item{Trt}{Either \code{0} or \code{1} indicating if the patient received anti-convulsant therapy} \item{patient}{The patient number} \item{visit}{The session number from \code{1} (first visit) to \code{4} (last visit)} \item{count}{The seizure count between two visits} \item{obs}{The observation number, that is a unique identifier for each observation} \item{zAge}{Standardized \code{Age}} \item{zBase}{Standardized \code{Base}} } } \source{ Thall, P. F., & Vail, S. C. (1990). Some covariance models for longitudinal count data with overdispersion. \emph{Biometrics, 46(2)}, 657-671. \cr Breslow, N. E., & Clayton, D. G. (1993). Approximate inference in generalized linear mixed models. \emph{Journal of the American Statistical Association}, 88(421), 9-25. } \usage{ epilepsy } \description{ Breslow and Clayton (1993) analyze data initially provided by Thall and Vail (1990) concerning seizure counts in a randomized trial of anti-convulsant therapy in epilepsy. Covariates are treatment, 8-week baseline seizure counts, and age of the patients in years. } \examples{ \dontrun{ ## poisson regression without random effects. fit1 <- brm(count ~ zAge + zBase * Trt, data = epilepsy, family = poisson()) summary(fit1) plot(fit1) ## poisson regression with varying intercepts of patients ## as well as normal priors for overall effects parameters. fit2 <- brm(count ~ zAge + zBase * Trt + (1|patient), data = epilepsy, family = poisson(), prior = set_prior("normal(0,5)")) summary(fit2) plot(fit2) } } \keyword{datasets} brms/man/autocor.brmsfit.Rd0000644000176200001440000000132714213413565015407 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/autocor.R \name{autocor.brmsfit} \alias{autocor.brmsfit} \alias{autocor} \title{(Deprecated) Extract Autocorrelation Objects} \usage{ \method{autocor}{brmsfit}(object, resp = NULL, ...) autocor(object, ...) } \arguments{ \item{object}{An object of class \code{brmsfit}.} \item{resp}{Optional names of response variables. If specified, predictions are performed only for the specified response variables.} \item{...}{Currently unused.} } \value{ A \code{cor_brms} object or a list of such objects for multivariate models. Not supported for models fitted with brms 2.11.1 or higher. } \description{ (Deprecated) Extract Autocorrelation Objects } brms/man/print.brmsfit.Rd0000644000176200001440000000174115053072461015066 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/summary.R \name{print.brmsfit} \alias{print.brmsfit} \alias{print.brmssummary} \title{Print a summary for a fitted model represented by a \code{brmsfit} object} \usage{ \method{print}{brmsfit}(x, digits = 2, short = getOption("brms.short_summary", FALSE), ...) } \arguments{ \item{x}{An object of class \code{brmsfit}} \item{digits}{The number of significant digits for printing out the summary; defaults to 2. The effective sample size is always rounded to integers.} \item{short}{A flag indicating whether to provide a shorter summary with less informational text. Defaults to \code{FALSE}. Can be set globally for the current session via the \code{brms.short_summary} option.} \item{...}{Additional arguments that would be passed to method \code{summary} of \code{brmsfit}.} } \description{ Print a summary for a fitted model represented by a \code{brmsfit} object } \seealso{ \code{\link{summary.brmsfit}} } brms/man/cor_sar.Rd0000644000176200001440000000335114213413565013715 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/autocor.R \name{cor_sar} \alias{cor_sar} \alias{cor_lagsar} \alias{cor_errorsar} \title{(Deprecated) Spatial simultaneous autoregressive (SAR) structures} \usage{ cor_sar(W, type = c("lag", "error")) cor_lagsar(W) cor_errorsar(W) } \arguments{ \item{W}{An object specifying the spatial weighting matrix. Can be either the spatial weight matrix itself or an object of class \code{listw} or \code{nb}, from which the spatial weighting matrix can be computed.} \item{type}{Type of the SAR structure. Either \code{"lag"} (for SAR of the response values) or \code{"error"} (for SAR of the residuals).} } \value{ An object of class \code{cor_sar} to be used in calls to \code{\link{brm}}. } \description{ Thse functions are deprecated. Please see \code{\link{sar}} for the new syntax. These functions are constructors for the \code{cor_sar} class implementing spatial simultaneous autoregressive structures. The \code{lagsar} structure implements SAR of the response values: \deqn{y = \rho W y + \eta + e} The \code{errorsar} structure implements SAR of the residuals: \deqn{y = \eta + u, u = \rho W u + e} In the above equations, \eqn{\eta} is the predictor term and \eqn{e} are independent normally or t-distributed residuals. } \details{ Currently, only families \code{gaussian} and \code{student} support SAR structures. } \examples{ \dontrun{ data(oldcol, package = "spdep") fit1 <- brm(CRIME ~ INC + HOVAL, data = COL.OLD, autocor = cor_lagsar(COL.nb), chains = 2, cores = 2) summary(fit1) plot(fit1) fit2 <- brm(CRIME ~ INC + HOVAL, data = COL.OLD, autocor = cor_errorsar(COL.nb), chains = 2, cores = 2) summary(fit2) plot(fit2) } } brms/man/brm_multiple.Rd0000644000176200001440000003127215057500075014763 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/brm_multiple.R \name{brm_multiple} \alias{brm_multiple} \title{Run the same \pkg{brms} model on multiple datasets} \usage{ brm_multiple( formula, data, family = gaussian(), prior = NULL, data2 = NULL, autocor = NULL, cov_ranef = NULL, sample_prior = c("no", "yes", "only"), sparse = NULL, knots = NULL, stanvars = NULL, stan_funs = NULL, silent = 1, recompile = FALSE, combine = TRUE, fit = NA, algorithm = getOption("brms.algorithm", "sampling"), seed = NA, file = NULL, file_compress = TRUE, file_refit = getOption("brms.file_refit", "never"), ... ) } \arguments{ \item{formula}{An object of class \code{\link[stats:formula]{formula}}, \code{\link{brmsformula}}, or \code{\link{mvbrmsformula}} (or one that can be coerced to that classes): A symbolic description of the model to be fitted. The details of model specification are explained in \code{\link{brmsformula}}.} \item{data}{A \emph{list} of data.frames each of which will be used to fit a separate model. Alternatively, a \code{mids} object from the \pkg{mice} package.} \item{family}{A description of the response distribution and link function to be used in the model. This can be a family function, a call to a family function or a character string naming the family. Every family function has a \code{link} argument allowing to specify the link function to be applied on the response variable. If not specified, default links are used. For details of supported families see \code{\link{brmsfamily}}. By default, a linear \code{gaussian} model is applied. In multivariate models, \code{family} might also be a list of families.} \item{prior}{One or more \code{brmsprior} objects created by \code{\link{set_prior}} or related functions and combined using the \code{c} method or the \code{+} operator. See also \code{\link[brms:default_prior.default]{default_prior}} for more help.} \item{data2}{A \emph{list} of named lists each of which will be used to fit a separate model. Each of the named lists contains objects representing data which cannot be passed via argument \code{data} (see \code{\link{brm}} for examples). The length of the outer list should match the length of the list passed to the \code{data} argument.} \item{autocor}{(Deprecated) An optional \code{\link{cor_brms}} object describing the correlation structure within the response variable (i.e., the 'autocorrelation'). See the documentation of \code{\link{cor_brms}} for a description of the available correlation structures. Defaults to \code{NULL}, corresponding to no correlations. In multivariate models, \code{autocor} might also be a list of autocorrelation structures. It is now recommend to specify autocorrelation terms directly within \code{formula}. See \code{\link{brmsformula}} for more details.} \item{cov_ranef}{(Deprecated) A list of matrices that are proportional to the (within) covariance structure of the group-level effects. The names of the matrices should correspond to columns in \code{data} that are used as grouping factors. All levels of the grouping factor should appear as rownames of the corresponding matrix. This argument can be used, among others to model pedigrees and phylogenetic effects. It is now recommended to specify those matrices in the formula interface using the \code{\link{gr}} and related functions. See \code{vignette("brms_phylogenetics")} for more details.} \item{sample_prior}{Indicate if draws from priors should be drawn additionally to the posterior draws. Options are \code{"no"} (the default), \code{"yes"}, and \code{"only"}. Among others, these draws can be used to calculate Bayes factors for point hypotheses via \code{\link{hypothesis}}. Please note that improper priors are not sampled, including the default improper priors used by \code{brm}. See \code{\link{set_prior}} on how to set (proper) priors. Please also note that prior draws for the overall intercept are not obtained by default for technical reasons. See \code{\link{brmsformula}} how to obtain prior draws for the intercept. If \code{sample_prior} is set to \code{"only"}, draws are drawn solely from the priors ignoring the likelihood, which allows among others to generate draws from the prior predictive distribution. In this case, all parameters must have proper priors.} \item{sparse}{(Deprecated) Logical; indicates whether the population-level design matrices should be treated as sparse (defaults to \code{FALSE}). For design matrices with many zeros, this can considerably reduce required memory. Sampling speed is currently not improved or even slightly decreased. It is now recommended to use the \code{sparse} argument of \code{\link{brmsformula}} and related functions.} \item{knots}{Optional list containing user specified knot values to be used for basis construction of smoothing terms. See \code{\link[mgcv:gamm]{gamm}} for more details.} \item{stanvars}{An optional \code{stanvars} object generated by function \code{\link{stanvar}} to define additional variables for use in \pkg{Stan}'s program blocks.} \item{stan_funs}{(Deprecated) An optional character string containing self-defined \pkg{Stan} functions, which will be included in the functions block of the generated \pkg{Stan} code. It is now recommended to use the \code{stanvars} argument for this purpose instead.} \item{silent}{Verbosity level between \code{0} and \code{2}. If \code{1} (the default), most of the informational messages of compiler and sampler are suppressed. If \code{2}, even more messages are suppressed. The actual sampling progress is still printed. Set \code{refresh = 0} to turn this off as well. If using \code{backend = "rstan"} you can also set \code{open_progress = FALSE} to prevent opening additional progress bars.} \item{recompile}{Logical, indicating whether the Stan model should be recompiled for every imputed data set. Defaults to \code{FALSE}. If \code{NULL}, \code{brm_multiple} tries to figure out internally, if recompilation is necessary, for example because data-dependent priors have changed. Using the default of no recompilation should be fine in most cases.} \item{combine}{Logical; Indicates if the fitted models should be combined into a single fitted model object via \code{\link{combine_models}}. Defaults to \code{TRUE}.} \item{fit}{An instance of S3 class \code{brmsfit_multiple} derived from a previous fit; defaults to \code{NA}. If \code{fit} is of class \code{brmsfit_multiple}, the compiled model associated with the fitted result is re-used and all arguments modifying the model code or data are ignored. It is not recommended to use this argument directly, but to call the \code{\link[brms:update.brmsfit_multiple]{update}} method, instead.} \item{algorithm}{Character string naming the estimation approach to use. Options are \code{"sampling"} for MCMC (the default), \code{"meanfield"} for variational inference with independent normal distributions, \code{"fullrank"} for variational inference with a multivariate normal distribution, \code{"pathfinder"} for the pathfinder algorithm, \code{"laplace"} for the laplace approximation, or \code{"fixed_param"} for sampling from fixed parameter values. Can be set globally for the current \R session via the \code{"brms.algorithm"} option (see \code{\link{options}}).} \item{seed}{The seed for random number generation to make results reproducible. If \code{NA} (the default), \pkg{Stan} will set the seed randomly.} \item{file}{Either \code{NULL} or a character string. In the latter case, the fitted model object is saved via \code{\link{saveRDS}} in a file named after the string supplied in \code{file}. The \code{.rds} extension is added automatically. If the file already exists, \code{brm} will load and return the saved model object instead of refitting the model. Unless you specify the \code{file_refit} argument as well, the existing files won't be overwritten, you have to manually remove the file in order to refit and save the model under an existing file name. The file name is stored in the \code{brmsfit} object for later usage.} \item{file_compress}{Logical or a character string, specifying one of the compression algorithms supported by \code{\link{saveRDS}}. If the \code{file} argument is provided, this compression will be used when saving the fitted model object.} \item{file_refit}{Modifies when the fit stored via the \code{file} argument is re-used. Can be set globally for the current \R session via the \code{"brms.file_refit"} option (see \code{\link{options}}). For \code{"never"} (default) the fit is always loaded if it exists and fitting is skipped. For \code{"always"} the model is always refitted. If set to \code{"on_change"}, brms will refit the model if model, data or algorithm as passed to Stan differ from what is stored in the file. This also covers changes in priors, \code{sample_prior}, \code{stanvars}, covariance structure, etc. If you believe there was a false positive, you can use \code{\link{brmsfit_needs_refit}} to see why refit is deemed necessary. Refit will not be triggered for changes in additional parameters of the fit (e.g., initial values, number of iterations, control arguments, ...). A known limitation is that a refit will be triggered if within-chain parallelization is switched on/off.} \item{...}{Further arguments passed to \code{\link{brm}}.} } \value{ If \code{combine = TRUE} a \code{brmsfit_multiple} object, which inherits from class \code{brmsfit} and behaves essentially the same. If \code{combine = FALSE} a list of \code{brmsfit} objects. } \description{ Run the same \pkg{brms} model on multiple datasets and then combine the results into one fitted model object. This is useful in particular for multiple missing value imputation, where the same model is fitted on multiple imputed data sets. Models can be run in parallel using the \pkg{future} package. } \details{ The combined model may issue false positive convergence warnings, as the MCMC chains corresponding to different datasets may not necessarily overlap, even if each of the original models did converge. To find out whether each of the original models converged, subset the draws belonging to the individual models and then run convergence diagnostics. See Examples below for details. } \section{Parallelization with multiple CPU cores}{ \pkg{brms} can make use of multiple CPU cores in parallel to speed up computations in various ways. For efficient use of the available resources it is recommended to only use parallelism to an extend such that the available physical CPUs are not oversubscribed. For example, when you have 8 CPU cores locally available, then you may consider to run 4 chains with 2 threads per chain for best performance if you happen to just run a single model. In case you run a simulation study which requires to run many times a given model, then neither chain nor within-chain parallelization is advisable as the computational resources are already exhausted by the simulation study and any further parallelization beyond the simulation study itself will in fact slow down the overall runtime. Please be aware that for historical reasons the nomenclature of the arguments is possibly confusing. The \code{cores} argument refers to running different chains in parallel and the within-chain parallelization will allocate for each chain as many threads as requested. The requested threads therefore increase the use of overall CPUs in a multiplicative way. For more advanced parallelization (including beyond single model fits), \pkg{brms} also integrates with the \pkg{future} package. Importantly, this enables seamless integration with the \pkg{mirai} parallelization framework through the use of the \pkg{future.mirai} adapter. With \pkg{mirai} local and remote machines can be used in a fully transparent manner to the user. This includes the possibility to use large number of remote machines running in the context of a computer cluster, which are managed with queuing systems. Please refer to the section on distributed computing of \code{\link[mirai:daemons]{mirai::daemons}}. } \examples{ \dontrun{ library(mice) m <- 5 imp <- mice(nhanes2, m = m) # fit the model using mice and lm fit_imp1 <- with(lm(bmi ~ age + hyp + chl), data = imp) summary(pool(fit_imp1)) # fit the model using brms fit_imp2 <- brm_multiple(bmi ~ age + hyp + chl, data = imp, chains = 1) summary(fit_imp2) plot(fit_imp2, variable = "^b_", regex = TRUE) # investigate convergence of the original models library(posterior) draws <- as_draws_array(fit_imp2) # every dataset has just one chain here draws_per_dat <- lapply(1:m, \(i) subset_draws(draws, chain = i)) lapply(draws_per_dat, summarise_draws, default_convergence_measures()) # use the future package for parallelization library(future) plan(multisession, workers = 4) fit_imp3 <- brm_multiple(bmi ~ age + hyp + chl, data = imp, chains = 1) summary(fit_imp3) } } brms/man/density_ratio.Rd0000644000176200001440000000275114160105076015141 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/hypothesis.R \name{density_ratio} \alias{density_ratio} \title{Compute Density Ratios} \usage{ density_ratio(x, y = NULL, point = 0, n = 4096, ...) } \arguments{ \item{x}{Vector of draws from the first distribution, usually the posterior distribution of the quantity of interest.} \item{y}{Optional vector of draws from the second distribution, usually the prior distribution of the quantity of interest. If \code{NULL} (the default), only the density of \code{x} will be evaluated.} \item{point}{Numeric values at which to evaluate and compare the densities. Defaults to \code{0}.} \item{n}{Single numeric value. Influences the accuracy of the density estimation. See \code{\link[stats:density]{density}} for details.} \item{...}{Further arguments passed to \code{\link[stats:density]{density}}.} } \value{ A vector of length equal to \code{length(point)}. If \code{y} is provided, the density ratio of \code{x} against \code{y} is returned. Else, only the density of \code{x} is returned. } \description{ Compute the ratio of two densities at given points based on draws of the corresponding distributions. } \details{ In order to achieve sufficient accuracy in the density estimation, more draws than usual are required. That is you may need an effective sample size of 10,000 or more to reliably estimate the densities. } \examples{ x <- rnorm(10000) y <- rnorm(10000, mean = 1) density_ratio(x, y, point = c(0, 1)) } brms/man/brmsfamily.Rd0000644000176200001440000003375515053072461014444 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/families.R \name{brmsfamily} \alias{brmsfamily} \alias{student} \alias{bernoulli} \alias{beta_binomial} \alias{negbinomial} \alias{geometric} \alias{lognormal} \alias{shifted_lognormal} \alias{skew_normal} \alias{exponential} \alias{weibull} \alias{frechet} \alias{gen_extreme_value} \alias{exgaussian} \alias{wiener} \alias{Beta} \alias{xbeta} \alias{dirichlet} \alias{logistic_normal} \alias{von_mises} \alias{asym_laplace} \alias{cox} \alias{hurdle_poisson} \alias{hurdle_negbinomial} \alias{hurdle_gamma} \alias{hurdle_lognormal} \alias{hurdle_cumulative} \alias{zero_inflated_beta} \alias{zero_one_inflated_beta} \alias{zero_inflated_poisson} \alias{zero_inflated_negbinomial} \alias{zero_inflated_binomial} \alias{zero_inflated_beta_binomial} \alias{categorical} \alias{multinomial} \alias{dirichlet_multinomial} \alias{cumulative} \alias{sratio} \alias{cratio} \alias{acat} \title{Special Family Functions for \pkg{brms} Models} \usage{ brmsfamily( family, link = NULL, link_sigma = "log", link_shape = "log", link_nu = "logm1", link_phi = "log", link_kappa = "log", link_beta = "log", link_zi = "logit", link_hu = "logit", link_zoi = "logit", link_coi = "logit", link_disc = "log", link_bs = "log", link_ndt = "log", link_bias = "logit", link_xi = "log1p", link_alpha = "identity", link_quantile = "logit", threshold = "flexible", refcat = NULL ) student(link = "identity", link_sigma = "log", link_nu = "logm1") bernoulli(link = "logit") beta_binomial(link = "logit", link_phi = "log") negbinomial(link = "log", link_shape = "log") geometric(link = "log") lognormal(link = "identity", link_sigma = "log") shifted_lognormal(link = "identity", link_sigma = "log", link_ndt = "log") skew_normal(link = "identity", link_sigma = "log", link_alpha = "identity") exponential(link = "log") weibull(link = "log", link_shape = "log") frechet(link = "log", link_nu = "logm1") gen_extreme_value(link = "identity", link_sigma = "log", link_xi = "log1p") exgaussian(link = "identity", link_sigma = "log", link_beta = "log") wiener( link = "identity", link_bs = "log", link_ndt = "log", link_bias = "logit" ) Beta(link = "logit", link_phi = "log") xbeta(link = "logit", link_phi = "log", link_kappa = "log") dirichlet(link = "logit", link_phi = "log", refcat = NULL) logistic_normal(link = "identity", link_sigma = "log", refcat = NULL) von_mises(link = "tan_half", link_kappa = "log") asym_laplace(link = "identity", link_sigma = "log", link_quantile = "logit") cox(link = "log") hurdle_poisson(link = "log", link_hu = "logit") hurdle_negbinomial(link = "log", link_shape = "log", link_hu = "logit") hurdle_gamma(link = "log", link_shape = "log", link_hu = "logit") hurdle_lognormal(link = "identity", link_sigma = "log", link_hu = "logit") hurdle_cumulative( link = "logit", link_hu = "logit", link_disc = "log", threshold = "flexible" ) zero_inflated_beta(link = "logit", link_phi = "log", link_zi = "logit") zero_one_inflated_beta( link = "logit", link_phi = "log", link_zoi = "logit", link_coi = "logit" ) zero_inflated_poisson(link = "log", link_zi = "logit") zero_inflated_negbinomial(link = "log", link_shape = "log", link_zi = "logit") zero_inflated_binomial(link = "logit", link_zi = "logit") zero_inflated_beta_binomial( link = "logit", link_phi = "log", link_zi = "logit" ) categorical(link = "logit", refcat = NULL) multinomial(link = "logit", refcat = NULL) dirichlet_multinomial(link = "logit", link_phi = "log", refcat = NULL) cumulative(link = "logit", link_disc = "log", threshold = "flexible") sratio(link = "logit", link_disc = "log", threshold = "flexible") cratio(link = "logit", link_disc = "log", threshold = "flexible") acat(link = "logit", link_disc = "log", threshold = "flexible") } \arguments{ \item{family}{A character string naming the distribution family of the response variable to be used in the model. Currently, the following families are supported: \code{gaussian}, \code{student}, \code{binomial}, \code{bernoulli}, \code{beta-binomial}, \code{poisson}, \code{negbinomial}, \code{geometric}, \code{Gamma}, \code{skew_normal}, \code{lognormal}, \code{shifted_lognormal}, \code{exgaussian}, \code{wiener}, \code{inverse.gaussian}, \code{exponential}, \code{weibull}, \code{frechet}, \code{Beta}, \code{dirichlet}, \code{von_mises}, \code{asym_laplace}, \code{gen_extreme_value}, \code{categorical}, \code{multinomial}, \code{dirichlet_multinomial}, \code{cumulative}, \code{cratio}, \code{sratio}, \code{acat}, \code{hurdle_poisson}, \code{hurdle_negbinomial}, \code{hurdle_gamma}, \code{hurdle_lognormal}, \code{hurdle_cumulative}, \code{zero_inflated_binomial}, \code{zero_inflated_beta_binomial}, \code{zero_inflated_beta}, \code{zero_inflated_negbinomial}, \code{zero_inflated_poisson}, \code{zero_one_inflated_beta}, and \code{xbeta}.} \item{link}{A specification for the model link function. This can be a name/expression or character string. See the 'Details' section for more information on link functions supported by each family.} \item{link_sigma}{Link of auxiliary parameter \code{sigma} if being predicted.} \item{link_shape}{Link of auxiliary parameter \code{shape} if being predicted.} \item{link_nu}{Link of auxiliary parameter \code{nu} if being predicted.} \item{link_phi}{Link of auxiliary parameter \code{phi} if being predicted.} \item{link_kappa}{Link of auxiliary parameter \code{kappa} if being predicted.} \item{link_beta}{Link of auxiliary parameter \code{beta} if being predicted.} \item{link_zi}{Link of auxiliary parameter \code{zi} if being predicted.} \item{link_hu}{Link of auxiliary parameter \code{hu} if being predicted.} \item{link_zoi}{Link of auxiliary parameter \code{zoi} if being predicted.} \item{link_coi}{Link of auxiliary parameter \code{coi} if being predicted.} \item{link_disc}{Link of auxiliary parameter \code{disc} if being predicted.} \item{link_bs}{Link of auxiliary parameter \code{bs} if being predicted.} \item{link_ndt}{Link of auxiliary parameter \code{ndt} if being predicted.} \item{link_bias}{Link of auxiliary parameter \code{bias} if being predicted.} \item{link_xi}{Link of auxiliary parameter \code{xi} if being predicted.} \item{link_alpha}{Link of auxiliary parameter \code{alpha} if being predicted.} \item{link_quantile}{Link of auxiliary parameter \code{quantile} if being predicted.} \item{threshold}{A character string indicating the type of thresholds (i.e. intercepts) used in an ordinal model. \code{"flexible"} provides the standard unstructured thresholds, \code{"equidistant"} restricts the distance between consecutive thresholds to the same value, and \code{"sum_to_zero"} ensures the thresholds sum to zero.} \item{refcat}{Optional name of the reference response category used in \code{categorical}, \code{multinomial}, \code{dirichlet}, \code{dirichlet_multinomial} and \code{logistic_normal} models. If \code{NULL} (the default), the first category is used as the reference. If \code{NA}, all categories will be predicted, which requires strong priors or carefully specified predictor terms in order to lead to an identified model.} } \description{ Family objects provide a convenient way to specify the details of the models used by many model fitting functions. The family functions presented here are for use with \pkg{brms} only and will **not** work with other model fitting functions such as \code{glm} or \code{glmer}. However, the standard family functions as described in \code{\link[stats:family]{family}} will work with \pkg{brms}. You can also specify custom families for use in \pkg{brms} with the \code{\link{custom_family}} function. } \details{ Below, we list common use cases for the different families. This list is not ment to be exhaustive. \itemize{ \item{Family \code{gaussian} can be used for linear regression.} \item{Family \code{student} can be used for robust linear regression that is less influenced by outliers.} \item{Family \code{skew_normal} can handle skewed responses in linear regression.} \item{Families \code{poisson}, \code{negbinomial}, and \code{geometric} can be used for regression of unbounded count data.} \item{Families \code{bernoulli}, \code{binomial}, and \code{beta_binomial} can be used for binary regression (i.e., most commonly logistic regression).} \item{Families \code{categorical}, \code{multinomial} and \code{dirichlet_multinomial} can be used for multi-logistic regression when there are more than two possible outcomes.} \item{Families \code{cumulative}, \code{cratio} ('continuation ratio'), \code{sratio} ('stopping ratio'), and \code{acat} ('adjacent category') leads to ordinal regression.} \item{Families \code{Gamma}, \code{weibull}, \code{exponential}, \code{lognormal}, \code{frechet}, \code{inverse.gaussian}, and \code{cox} (Cox proportional hazards model) can be used (among others) for time-to-event regression also known as survival regression.} \item{Families \code{weibull}, \code{frechet}, and \code{gen_extreme_value} ('generalized extreme value') allow for modeling extremes.} \item{Families \code{beta}, \code{dirichlet}, and \code{logistic_normal} can be used to model responses representing rates or probabilities.} \item{Family \code{xbeta} extends the \code{beta} family to support \code{[0, 1]} responses with exact \code{0}s and / or \code{1}s, when each response takes values \code{0}, \code{1}, and \code{(0, 1)} according to a single process. If there is merit in assuming that 0 and 1 values arise from different processes than \code{(0, 1)} values, then the \code{zero_inflated_beta}, \code{zero_one_inflated_beta} families provide more flexibility. For details see Kosmidis & Zeileis (2024).} \item{Family \code{asym_laplace} allows for quantile regression when fixing the auxiliary \code{quantile} parameter to the quantile of interest.} \item{Family \code{exgaussian} ('exponentially modified Gaussian') and \code{shifted_lognormal} are especially suited to model reaction times.} \item{Family \code{wiener} provides an implementation of the Wiener diffusion model. For this family, the main formula predicts the drift parameter 'delta' and all other parameters are modeled as auxiliary parameters (see \code{\link{brmsformula}} for details).} \item{Families \code{hurdle_poisson}, \code{hurdle_negbinomial}, \code{hurdle_gamma}, \code{hurdle_lognormal}, \code{zero_inflated_poisson}, \code{zero_inflated_negbinomial}, \code{zero_inflated_binomial}, \code{zero_inflated_beta_binomial}, \code{zero_inflated_beta}, \code{zero_one_inflated_beta}, and \code{hurdle_cumulative} allow to estimate zero-inflated and hurdle models. These models can be very helpful when there are many zeros in the data (or ones in case of one-inflated models) that cannot be explained by the primary distribution of the response.} } Below, we list all possible links for each family. The first link mentioned for each family is the default. \itemize{ \item{Families \code{gaussian}, \code{student}, \code{skew_normal}, \code{exgaussian}, \code{asym_laplace}, and \code{gen_extreme_value} support the links (as names) \code{identity}, \code{log}, \code{inverse}, and \code{softplus}.} \item{Families \code{poisson}, \code{negbinomial}, \code{geometric}, \code{zero_inflated_poisson}, \code{zero_inflated_negbinomial}, \code{hurdle_poisson}, and \code{hurdle_negbinomial} support \code{log}, \code{identity}, \code{sqrt}, and \code{softplus}.} \item{Families \code{binomial}, \code{bernoulli}, \code{beta_binomial}, \code{zero_inflated_binomial}, \code{zero_inflated_beta_binomial}, \code{Beta}, \code{zero_inflated_beta}, \code{zero_one_inflated_beta}, and \code{xbeta} support \code{logit}, \code{probit}, \code{probit_approx}, \code{cloglog}, \code{cauchit}, \code{identity}, and \code{log}.} \item{Families \code{cumulative}, \code{cratio}, \code{sratio}, \code{acat}, and \code{hurdle_cumulative} support \code{logit}, \code{probit}, \code{probit_approx}, \code{cloglog}, and \code{cauchit}.} \item{Families \code{categorical}, \code{multinomial}, \code{dirichlet_multinomial} and \code{dirichlet} support \code{logit}.} \item{Families \code{Gamma}, \code{weibull}, \code{exponential}, \code{frechet}, and \code{hurdle_gamma} support \code{log}, \code{identity}, \code{inverse}, and \code{softplus}.} \item{Families \code{lognormal} and \code{hurdle_lognormal} support \code{identity} and \code{inverse}.} \item{Family \code{logistic_normal} supports \code{identity}.} \item{Family \code{inverse.gaussian} supports \code{1/mu^2}, \code{inverse}, \code{identity}, \code{log}, and \code{softplus}.} \item{Family \code{von_mises} supports \code{tan_half} and \code{identity}.} \item{Family \code{cox} supports \code{log}, \code{identity}, and \code{softplus} for the proportional hazards parameter.} \item{Family \code{wiener} supports \code{identity}, \code{log}, and \code{softplus} for the main parameter which represents the drift rate.} } Please note that when calling the \code{\link[stats:family]{Gamma}} family function of the \pkg{stats} package, the default link will be \code{inverse} instead of \code{log} although the latter is the default in \pkg{brms}. Also, when using the family functions \code{gaussian}, \code{binomial}, \code{poisson}, and \code{Gamma} of the \pkg{stats} package (see \code{\link[stats:family]{family}}), special link functions such as \code{softplus} or \code{cauchit} won't work. In this case, you have to use \code{brmsfamily} to specify the family with corresponding link function. } \examples{ # create a family object (fam1 <- student("log")) # alternatively use the brmsfamily function (fam2 <- brmsfamily("student", "log")) # both leads to the same object identical(fam1, fam2) } \references{ Kosmidis I, Zeileis A (2024). Extended-Support Beta Regression for [0, 1] Responses. \emph{arXiv Preprint}. \doi{10.48550/arXiv.2409.07233} } \seealso{ \code{\link[brms:brm]{brm}}, \code{\link[stats:family]{family}}, \code{\link{customfamily}} } brms/man/as.mcmc.brmsfit.Rd0000644000176200001440000000270314536546474015271 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/posterior_samples.R \name{as.mcmc.brmsfit} \alias{as.mcmc.brmsfit} \alias{as.mcmc} \title{(Deprecated) Extract posterior samples for use with the \pkg{coda} package} \usage{ \method{as.mcmc}{brmsfit}( x, pars = NA, fixed = FALSE, combine_chains = FALSE, inc_warmup = FALSE, ... ) } \arguments{ \item{x}{An \code{R} object typically of class \code{brmsfit}} \item{pars}{Names of parameters for which posterior samples should be returned, as given by a character vector or regular expressions. By default, all posterior samples of all parameters are extracted.} \item{fixed}{Indicates whether parameter names should be matched exactly (\code{TRUE}) or treated as regular expressions (\code{FALSE}). Default is \code{FALSE}.} \item{combine_chains}{Indicates whether chains should be combined.} \item{inc_warmup}{Indicates if the warmup samples should be included. Default is \code{FALSE}. Warmup samples are used to tune the parameters of the sampling algorithm and should not be analyzed.} \item{...}{currently unused} } \value{ If \code{combine_chains = TRUE} an \code{mcmc} object is returned. If \code{combine_chains = FALSE} an \code{mcmc.list} object is returned. } \description{ The \code{as.mcmc} method is deprecated. We recommend using the more modern and consistent \code{\link[brms:draws-brms]{as_draws_*}} extractor functions of the \pkg{posterior} package instead. } brms/man/cosy.Rd0000644000176200001440000000174514213413565013247 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/formula-ac.R \name{cosy} \alias{cosy} \title{Set up COSY correlation structures} \usage{ cosy(time = NA, gr = NA) } \arguments{ \item{time}{An optional time variable specifying the time ordering of the observations. By default, the existing order of the observations in the data is used.} \item{gr}{An optional grouping variable. If specified, the correlation structure is assumed to apply only to observations within the same grouping level.} } \value{ An object of class \code{'cosy_term'}, which is a list of arguments to be interpreted by the formula parsing functions of \pkg{brms}. } \description{ Set up a compounds symmetry (COSY) term in \pkg{brms}. The function does not evaluate its arguments -- it exists purely to help set up a model with COSY terms. } \examples{ \dontrun{ data("lh") lh <- as.data.frame(lh) fit <- brm(x ~ cosy(), data = lh) summary(fit) } } \seealso{ \code{\link{autocor-terms}} } brms/man/set_prior.Rd0000644000176200001440000004762015053072461014301 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/priors.R \name{set_prior} \alias{set_prior} \alias{brmsprior} \alias{brmsprior-class} \alias{prior} \alias{prior_} \alias{prior_string} \alias{empty_prior} \title{Prior Definitions for \pkg{brms} Models} \usage{ set_prior( prior, class = "b", coef = "", group = "", resp = "", dpar = "", nlpar = "", lb = NA, ub = NA, tag = "", check = TRUE ) prior(prior, ...) prior_(prior, ...) prior_string(prior, ...) empty_prior() } \arguments{ \item{prior}{A character string defining a distribution in \pkg{Stan} language} \item{class}{The parameter class. Defaults to \code{"b"} (i.e. population-level effects). See 'Details' for other valid parameter classes.} \item{coef}{Name of the coefficient within the parameter class.} \item{group}{Grouping factor for group-level parameters.} \item{resp}{Name of the response variable. Only used in multivariate models.} \item{dpar}{Name of a distributional parameter. Only used in distributional models.} \item{nlpar}{Name of a non-linear parameter. Only used in non-linear models.} \item{lb}{Lower bound for parameter restriction. Currently only allowed for classes \code{"b"}. Defaults to \code{NULL}, that is no restriction.} \item{ub}{Upper bound for parameter restriction. Currently only allowed for classes \code{"b"}. Defaults to \code{NULL}, that is no restriction.} \item{tag}{Character to append to the \code{lprior} variable in the Stan code. Used for selectively checking sensitivity of priors in \code{priorsense}.} \item{check}{Logical; Indicates whether priors should be checked for validity (as far as possible). Defaults to \code{TRUE}. If \code{FALSE}, \code{prior} is passed to the Stan code as is, and all other arguments are ignored.} \item{...}{Arguments passed to \code{set_prior}.} } \value{ An object of class \code{brmsprior} to be used in the \code{prior} argument of \code{\link{brm}}. } \description{ Define priors for specific parameters or classes of parameters. } \details{ \code{set_prior} is used to define prior distributions for parameters in \pkg{brms} models. The functions \code{prior}, \code{prior_}, and \code{prior_string} are aliases of \code{set_prior} each allowing for a different kind of argument specification. \code{prior} allows specifying arguments as expression without quotation marks using non-standard evaluation. \code{prior_} allows specifying arguments as one-sided formulas or wrapped in \code{quote}. \code{prior_string} allows specifying arguments as strings just as \code{set_prior} itself. Below, we explain its usage and list some common prior distributions for parameters. A complete overview on possible prior distributions is given in the Stan Reference Manual available at \url{https://mc-stan.org/}. To combine multiple priors, use \code{c(...)} or the \code{+} operator (see 'Examples'). \pkg{brms} does not check if the priors are written in correct \pkg{Stan} language. Instead, \pkg{Stan} will check their syntactical correctness when the model is parsed to \code{C++} and returns an error if they are not. This, however, does not imply that priors are always meaningful if they are accepted by \pkg{Stan}. Although \pkg{brms} trys to find common problems (e.g., setting bounded priors on unbounded parameters), there is no guarantee that the defined priors are reasonable for the model. Below, we list the types of parameters in \pkg{brms} models, for which the user can specify prior distributions. Below, we provide details for the individual parameter classes that you can set priors on. Often, it may not be immediately clear, which parameters are present in the model. To get a full list of parameters and parameter classes for which priors can be specified (depending on the model) use function \code{\link[brms:default_prior.default]{default_prior}}. 1. Population-level ('fixed') effects Every Population-level effect has its own regression parameter represents the name of the corresponding population-level effect. Suppose, for instance, that \code{y} is predicted by \code{x1} and \code{x2} (i.e., \code{y ~ x1 + x2} in formula syntax). Then, \code{x1} and \code{x2} have regression parameters \code{b_x1} and \code{b_x2} respectively. The default prior for population-level effects (including monotonic and category specific effects) is an improper flat prior over the reals. Other common options are normal priors or student-t priors. If we want to have a normal prior with mean 0 and standard deviation 5 for \code{x1}, and a unit student-t prior with 10 degrees of freedom for \code{x2}, we can specify this via \code{set_prior("normal(0,5)", class = "b", coef = "x1")} and \cr \code{set_prior("student_t(10, 0, 1)", class = "b", coef = "x2")}. To put the same prior on all population-level effects at once, we may write as a shortcut \code{set_prior("", class = "b")}. This also leads to faster sampling, because priors can be vectorized in this case. Both ways of defining priors can be combined using for instance \code{set_prior("normal(0, 2)", class = "b")} and \cr \code{set_prior("normal(0, 10)", class = "b", coef = "x1")} at the same time. This will set a \code{normal(0, 10)} prior on the effect of \code{x1} and a \code{normal(0, 2)} prior on all other population-level effects. However, this will break vectorization and may slow down the sampling procedure a bit. In case of the default intercept parameterization (discussed in the 'Details' section of \code{\link{brmsformula}}), general priors on class \code{"b"} will \emph{not} affect the intercept. Instead, the intercept has its own parameter class named \code{"Intercept"} and priors can thus be specified via \code{set_prior("", class = "Intercept")}. Setting a prior on the intercept will not break vectorization of the other population-level effects. Note that technically, this prior is set on an intercept that results when internally centering all population-level predictors around zero to improve sampling efficiency. On this centered intercept, specifying a prior is actually much easier and intuitive than on the original intercept, since the former represents the expected response value when all predictors are at their means. To treat the intercept as an ordinary population-level effect and avoid the centering parameterization, use \code{0 + Intercept} on the right-hand side of the model formula. In non-linear models, population-level effects are defined separately for each non-linear parameter. Accordingly, it is necessary to specify the non-linear parameter in \code{set_prior} so that priors we can be assigned correctly. If, for instance, \code{alpha} is the parameter and \code{x} the predictor for which we want to define the prior, we can write \code{set_prior("", coef = "x", nlpar = "alpha")}. As a shortcut we can use \code{set_prior("", nlpar = "alpha")} to set the same prior on all population-level effects of \code{alpha} at once. The same goes for specifying priors for specific distributional parameters in the context of distributional regression, for example, \code{set_prior("", coef = "x", dpar = "sigma")}. For most other parameter classes (see below), you need to indicate non-linear and distributional parameters in the same way as shown here. If desired, population-level effects can be restricted to fall only within a certain interval using the \code{lb} and \code{ub} arguments of \code{set_prior}. This is often required when defining priors that are not defined everywhere on the real line, such as uniform or gamma priors. When defining a \code{uniform(2,4)} prior, you should write \code{set_prior("uniform(2,4)", lb = 2, ub = 4)}. When using a prior that is defined on the positive reals only (such as a gamma prior) set \code{lb = 0}. In most situations, it is not useful to restrict population-level parameters through bounded priors (non-linear models are an important exception), but if you really want to this is the way to go. 2. Group-level ('random') effects Each group-level effect of each grouping factor has a standard deviation named \code{sd__}. Consider, for instance, the formula \code{y ~ x1 + x2 + (1 + x1 | g)}. We see that the intercept as well as \code{x1} are group-level effects nested in the grouping factor \code{g}. The corresponding standard deviation parameters are named as \code{sd_g_Intercept} and \code{sd_g_x1} respectively. These parameters are restricted to be non-negative and, by default, have a half student-t prior with 3 degrees of freedom and a scale parameter that depends on the standard deviation of the response after applying the link function. Minimally, the scale parameter is 2.5. This prior is used (a) to be only weakly informative in order to influence results as few as possible, while (b) providing at least some regularization to considerably improve convergence and sampling efficiency. To define a prior distribution only for standard deviations of a specific grouping factor, use \cr \code{set_prior("", class = "sd", group = "")}. To define a prior distribution only for a specific standard deviation of a specific grouping factor, you may write \cr \code{set_prior("", class = "sd", group = "", coef = "")}. If there is more than one group-level effect per grouping factor, the correlations between those effects have to be estimated. The prior \code{lkj_corr_cholesky(eta)} or in short \code{lkj(eta)} with \code{eta > 0} is essentially the only prior for (Cholesky factors) of correlation matrices. If \code{eta = 1} (the default) all correlations matrices are equally likely a priori. If \code{eta > 1}, extreme correlations become less likely, whereas \code{0 < eta < 1} results in higher probabilities for extreme correlations. Correlation matrix parameters in \code{brms} models are named as \code{cor_}, (e.g., \code{cor_g} if \code{g} is the grouping factor). To set the same prior on every correlation matrix, use for instance \code{set_prior("lkj(2)", class = "cor")}. Internally, the priors are transformed to be put on the Cholesky factors of the correlation matrices to improve efficiency and numerical stability. The corresponding parameter class of the Cholesky factors is \code{L}, but it is not recommended to specify priors for this parameter class directly. 4. Smoothing Splines Smoothing splines are implemented in \pkg{brms} using the 'random effects' formulation as explained in \code{\link[mgcv:gamm]{gamm}}). Thus, each spline has its corresponding standard deviations modeling the variability within this term. In \pkg{brms}, this parameter class is called \code{sds} and priors can be specified via \code{set_prior("", class = "sds", coef = "")}. The default prior is the same as for standard deviations of group-level effects. 5. Gaussian processes Gaussian processes as currently implemented in \pkg{brms} have two parameters, the standard deviation parameter \code{sdgp}, and characteristic length-scale parameter \code{lscale} (see \code{\link{gp}} for more details). The default prior of \code{sdgp} is the same as for standard deviations of group-level effects. The default prior of \code{lscale} is an informative inverse-gamma prior specifically tuned to the covariates of the Gaussian process (for more details see \url{https://betanalpha.github.io/assets/case_studies/gp_part3/part3.html}). This tuned prior may be overly informative in some cases, so please consider other priors as well to make sure inference is robust to the prior specification. If tuning fails, a half-normal prior is used instead. 6. Autocorrelation parameters The autocorrelation parameters currently implemented are named \code{ar} (autoregression), \code{ma} (moving average), \code{sderr} (standard deviation of latent residuals in latent ARMA models), \code{cosy} (compound symmetry correlation), \code{car} (spatial conditional autoregression), as well as \code{lagsar} and \code{errorsar} (spatial simultaneous autoregression). Priors can be defined by \code{set_prior("", class = "ar")} for \code{ar} and similar for other autocorrelation parameters. By default, \code{ar} and \code{ma} are bounded between \code{-1} and \code{1}; \code{cosy}, \code{car}, \code{lagsar}, and \code{errorsar} are bounded between \code{0} and \code{1}. The default priors are flat over the respective definition areas. 7. Parameters of measurement error terms Latent variables induced via measurement error \code{\link{me}} terms require both mean and standard deviation parameters, whose prior classes are named \code{"meanme"} and \code{"sdme"}, respectively. If multiple latent variables are induced this way, their correlation matrix will be modeled as well and corresponding priors can be specified via the \code{"corme"} class. All of the above parameters have flat priors over their respective definition spaces by default. 8. Distance parameters of monotonic effects As explained in the details section of \code{\link{brm}}, monotonic effects make use of a special parameter vector to estimate the 'normalized distances' between consecutive predictor categories. This is realized in \pkg{Stan} using the \code{simplex} parameter type. This class is named \code{"simo"} (short for simplex monotonic) in \pkg{brms}. The only valid prior for simplex parameters is the dirichlet prior, which accepts a vector of length \code{K - 1} (K = number of predictor categories) as input defining the 'concentration' of the distribution. Explaining the dirichlet prior is beyond the scope of this documentation, but we want to describe how to define this prior syntactically correct. If a predictor \code{x} with \code{K} categories is modeled as monotonic, we can define a prior on its corresponding simplex via \cr \code{prior(dirichlet(), class = simo, coef = mox1)}. The \code{1} in the end of \code{coef} indicates that this is the first simplex in this term. If interactions between multiple monotonic variables are modeled, multiple simplexes per term are required. For \code{}, we can put in any \code{R} expression defining a vector of length \code{K - 1}. The default is a uniform prior (i.e. \code{ = rep(1, K-1)}) over all simplexes of the respective dimension. 9. Parameters for specific families Some families need additional parameters to be estimated. Families \code{gaussian}, \code{student}, \code{skew_normal}, \code{lognormal}, and \code{gen_extreme_value} need the parameter \code{sigma} to account for the residual standard deviation. By default, \code{sigma} has a half student-t prior that scales in the same way as the group-level standard deviations. Further, family \code{student} needs the parameter \code{nu} representing the degrees of freedom of Student-t distribution. By default, \code{nu} has prior \code{gamma(2, 0.1)}, which is close to a penalized complexity prior (see Stan prior choice Wiki), and a fixed lower bound of \code{1}. Family \code{negbinomial} needs a \code{shape} parameter that has by default \code{inv_gamma(0.4, 0.3)} prior which is close to a penalized complexity prior (see Stan prior choice Wiki). Families \code{gamma}, \code{weibull}, and \code{inverse.gaussian}, need a \code{shape} parameter that has a \code{gamma(0.01, 0.01)} prior by default. For families \code{cumulative}, \code{cratio}, \code{sratio}, and \code{acat}, and only if \code{threshold = "equidistant"}, the parameter \code{delta} is used to model the distance between two adjacent thresholds. By default, \code{delta} has an improper flat prior over the reals. The \code{von_mises} family needs the parameter \code{kappa}, representing the concentration parameter. By default, \code{kappa} has prior \code{gamma(2, 0.01)}. Every family specific parameter has its own prior class, so that \code{set_prior("", class = "")} is the right way to go. All of these priors are chosen to be weakly informative, having only minimal influence on the estimations, while improving convergence and sampling efficiency. 10. Shrinkage priors To reduce the danger of overfitting in models with many predictor terms fit on comparably sparse data, brms supports special shrinkage priors, namely the (regularized) \code{\link{horseshoe}} and the \code{\link{R2D2}} prior. These priors can be applied on many parameter classes, either directly on the coefficient classes (e.g., class \code{b}), if directly setting priors on them is supported, or on the corresponding standard deviation hyperparameters (e.g., class \code{sd}) otherwise. Currently, the following classes support shrinkage priors: \code{b} (overall regression coefficients), \code{sds} (SDs of smoothing splines), \code{sdgp} (SDs of Gaussian processes), \code{ar} (autoregressive coefficients), \code{ma} (moving average coefficients), \code{sderr} (SD of latent residuals), \code{sdcar} (SD of spatial CAR structures), \code{sd} (SD of varying coefficients). 11. Fixing parameters to constants Fixing parameters to constants is possible by using the \code{constant} function, for example, \code{constant(1)} to fix a parameter to 1. Broadcasting to vectors and matrices is done automatically. } \section{Functions}{ \itemize{ \item \code{prior()}: Alias of \code{set_prior} allowing to specify arguments as expressions without quotation marks. \item \code{prior_()}: Alias of \code{set_prior} allowing to specify arguments as as one-sided formulas or wrapped in \code{quote}. \item \code{prior_string()}: Alias of \code{set_prior} allowing to specify arguments as strings. \item \code{empty_prior()}: Create an empty \code{brmsprior} object. }} \examples{ ## use alias functions (prior1 <- prior(cauchy(0, 1), class = sd)) (prior2 <- prior_(~cauchy(0, 1), class = ~sd)) (prior3 <- prior_string("cauchy(0, 1)", class = "sd")) identical(prior1, prior2) identical(prior1, prior3) # check which parameters can have priors default_prior(rating ~ treat + period + carry + (1|subject), data = inhaler, family = cumulative()) # define some priors bprior <- c(prior_string("normal(0,10)", class = "b"), prior(normal(1,2), class = b, coef = treat), prior_(~cauchy(0,2), class = ~sd, group = ~subject, coef = ~Intercept)) # verify that the priors indeed found their way into Stan's model code stancode(rating ~ treat + period + carry + (1|subject), data = inhaler, family = cumulative(), prior = bprior) # use the horseshoe prior to model sparsity in regression coefficients stancode(count ~ zAge + zBase * Trt, data = epilepsy, family = poisson(), prior = set_prior("horseshoe(3)")) # fix certain priors to constants bprior <- prior(constant(1), class = "b") + prior(constant(2), class = "b", coef = "zBase") + prior(constant(0.5), class = "sd") stancode(count ~ zAge + zBase + (1 | patient), data = epilepsy, prior = bprior) # pass priors to Stan without checking prior <- prior_string("target += normal_lpdf(b[1] | 0, 1)", check = FALSE) stancode(count ~ Trt, data = epilepsy, prior = prior) # define priors in a vectorized manner # useful in particular for categorical or multivariate models set_prior("normal(0, 2)", dpar = c("muX", "muY", "muZ")) # specify tags for different priors for sensitivity analysis using priorsense # It is then possible to check the sensitivity when changing the priors with # the same tag while leaving others the same prior_cov <- prior(normal(0, 10), class = "b", tag = "covariates") prior_trt <- prior(normal(0, 1), class = "b", coef = "Trt1", tag = "treatment") stancode(count ~ Trt + zAge + zBase + (1 | patient), data = epilepsy, prior = c(prior_cov, prior_trt)) } \seealso{ \code{\link[brms:default_prior.default]{default_prior}} } brms/man/cor_brms.Rd0000644000176200001440000000211514213413565014070 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/autocor.R \name{cor_brms} \alias{cor_brms} \alias{cor_brms-class} \title{(Deprecated) Correlation structure classes for the \pkg{brms} package} \description{ Classes of correlation structures available in the \pkg{brms} package. \code{cor_brms} is not a correlation structure itself, but the class common to all correlation structures implemented in \pkg{brms}. } \section{Available correlation structures}{ \describe{ \item{cor_arma}{autoregressive-moving average (ARMA) structure, with arbitrary orders for the autoregressive and moving average components} \item{cor_ar}{autoregressive (AR) structure of arbitrary order} \item{cor_ma}{moving average (MA) structure of arbitrary order} \item{cor_car}{Spatial conditional autoregressive (CAR) structure} \item{cor_sar}{Spatial simultaneous autoregressive (SAR) structure} \item{cor_fixed}{fixed user-defined covariance structure} } } \seealso{ \code{\link{cor_arma}, \link{cor_ar}, \link{cor_ma}, \link{cor_car}, \link{cor_sar}, \link{cor_fixed}} } brms/man/brm.Rd0000644000176200001440000006327415057500075013057 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/brm.R \name{brm} \alias{brm} \title{Fit Bayesian Generalized (Non-)Linear Multivariate Multilevel Models} \usage{ brm( formula, data, family = gaussian(), prior = NULL, autocor = NULL, data2 = NULL, cov_ranef = NULL, sample_prior = "no", sparse = NULL, knots = NULL, drop_unused_levels = TRUE, stanvars = NULL, stan_funs = NULL, fit = NA, save_pars = getOption("brms.save_pars", NULL), save_ranef = NULL, save_mevars = NULL, save_all_pars = NULL, init = NULL, inits = NULL, chains = 4, iter = getOption("brms.iter", 2000), warmup = floor(iter/2), thin = 1, cores = getOption("mc.cores", 1), threads = getOption("brms.threads", NULL), opencl = getOption("brms.opencl", NULL), normalize = getOption("brms.normalize", TRUE), control = NULL, algorithm = getOption("brms.algorithm", "sampling"), backend = getOption("brms.backend", "rstan"), future = getOption("future", FALSE), silent = 1, seed = NA, save_model = NULL, stan_model_args = list(), file = NULL, file_compress = TRUE, file_refit = getOption("brms.file_refit", "never"), empty = FALSE, rename = TRUE, ... ) } \arguments{ \item{formula}{An object of class \code{\link[stats:formula]{formula}}, \code{\link{brmsformula}}, or \code{\link{mvbrmsformula}} (or one that can be coerced to that classes): A symbolic description of the model to be fitted. The details of model specification are explained in \code{\link{brmsformula}}.} \item{data}{An object of class \code{data.frame} (or one that can be coerced to that class) containing data of all variables used in the model.} \item{family}{A description of the response distribution and link function to be used in the model. This can be a family function, a call to a family function or a character string naming the family. Every family function has a \code{link} argument allowing to specify the link function to be applied on the response variable. If not specified, default links are used. For details of supported families see \code{\link{brmsfamily}}. By default, a linear \code{gaussian} model is applied. In multivariate models, \code{family} might also be a list of families.} \item{prior}{One or more \code{brmsprior} objects created by \code{\link{set_prior}} or related functions and combined using the \code{c} method or the \code{+} operator. See also \code{\link[brms:default_prior.default]{default_prior}} for more help.} \item{autocor}{(Deprecated) An optional \code{\link{cor_brms}} object describing the correlation structure within the response variable (i.e., the 'autocorrelation'). See the documentation of \code{\link{cor_brms}} for a description of the available correlation structures. Defaults to \code{NULL}, corresponding to no correlations. In multivariate models, \code{autocor} might also be a list of autocorrelation structures. It is now recommend to specify autocorrelation terms directly within \code{formula}. See \code{\link{brmsformula}} for more details.} \item{data2}{A named \code{list} of objects containing data, which cannot be passed via argument \code{data}. Required for some objects used in autocorrelation structures to specify dependency structures as well as for within-group covariance matrices.} \item{cov_ranef}{(Deprecated) A list of matrices that are proportional to the (within) covariance structure of the group-level effects. The names of the matrices should correspond to columns in \code{data} that are used as grouping factors. All levels of the grouping factor should appear as rownames of the corresponding matrix. This argument can be used, among others to model pedigrees and phylogenetic effects. It is now recommended to specify those matrices in the formula interface using the \code{\link{gr}} and related functions. See \code{vignette("brms_phylogenetics")} for more details.} \item{sample_prior}{Indicate if draws from priors should be drawn additionally to the posterior draws. Options are \code{"no"} (the default), \code{"yes"}, and \code{"only"}. Among others, these draws can be used to calculate Bayes factors for point hypotheses via \code{\link{hypothesis}}. Please note that improper priors are not sampled, including the default improper priors used by \code{brm}. See \code{\link{set_prior}} on how to set (proper) priors. Please also note that prior draws for the overall intercept are not obtained by default for technical reasons. See \code{\link{brmsformula}} how to obtain prior draws for the intercept. If \code{sample_prior} is set to \code{"only"}, draws are drawn solely from the priors ignoring the likelihood, which allows among others to generate draws from the prior predictive distribution. In this case, all parameters must have proper priors.} \item{sparse}{(Deprecated) Logical; indicates whether the population-level design matrices should be treated as sparse (defaults to \code{FALSE}). For design matrices with many zeros, this can considerably reduce required memory. Sampling speed is currently not improved or even slightly decreased. It is now recommended to use the \code{sparse} argument of \code{\link{brmsformula}} and related functions.} \item{knots}{Optional list containing user specified knot values to be used for basis construction of smoothing terms. See \code{\link[mgcv:gamm]{gamm}} for more details.} \item{drop_unused_levels}{Should unused factors levels in the data be dropped? Defaults to \code{TRUE}.} \item{stanvars}{An optional \code{stanvars} object generated by function \code{\link{stanvar}} to define additional variables for use in \pkg{Stan}'s program blocks.} \item{stan_funs}{(Deprecated) An optional character string containing self-defined \pkg{Stan} functions, which will be included in the functions block of the generated \pkg{Stan} code. It is now recommended to use the \code{stanvars} argument for this purpose instead.} \item{fit}{An instance of S3 class \code{brmsfit} derived from a previous fit; defaults to \code{NA}. If \code{fit} is of class \code{brmsfit}, the compiled model associated with the fitted result is re-used and all arguments modifying the model code or data are ignored. It is not recommended to use this argument directly, but to call the \code{\link[brms:update.brmsfit]{update}} method, instead.} \item{save_pars}{An object generated by \code{\link{save_pars}} controlling which parameters should be saved in the model. The argument has no impact on the model fitting itself.} \item{save_ranef}{(Deprecated) A flag to indicate if group-level effects for each level of the grouping factor(s) should be saved (default is \code{TRUE}). Set to \code{FALSE} to save memory. The argument has no impact on the model fitting itself.} \item{save_mevars}{(Deprecated) A flag to indicate if draws of latent noise-free variables obtained by using \code{me} and \code{mi} terms should be saved (default is \code{FALSE}). Saving these draws allows to better use methods such as \code{predict} with the latent variables but leads to very large \R objects even for models of moderate size and complexity.} \item{save_all_pars}{(Deprecated) A flag to indicate if draws from all variables defined in Stan's \code{parameters} block should be saved (default is \code{FALSE}). Saving these draws is required in order to apply the methods \code{bridge_sampler}, \code{bayes_factor}, and \code{post_prob}. Can be set globally for the current \R session via the \code{"brms.save_pars"} option (see \code{\link{options}}).} \item{init}{Initial values for the sampler. If \code{NULL} (the default) or \code{"random"}, Stan will randomly generate initial values for parameters in a reasonable range. If \code{0}, all parameters are initialized to zero on the unconstrained space. This option is sometimes useful for certain families, as it happens that default random initial values cause draws to be essentially constant. Generally, setting \code{init = 0} is worth a try, if chains do not initialize or behave well. Alternatively, \code{init} can be a list of lists containing the initial values, or a function (or function name) generating initial values. The latter options are mainly implemented for internal testing but are available to users if necessary. If specifying initial values using a list or a function then currently the parameter names must correspond to the names used in the generated Stan code (not the names used in \R). For more details on specifying initial values you can consult the documentation of the selected \code{backend}.} \item{inits}{(Deprecated) Alias of \code{init}.} \item{chains}{Number of Markov chains (defaults to 4).} \item{iter}{Number of total iterations per chain (including warmup; defaults to 2000). Can be set globally for the current \R session via the \code{"brms.iter"} option (see \code{\link{options}}).} \item{warmup}{A positive integer specifying number of warmup (aka burnin) iterations. This also specifies the number of iterations used for stepsize adaptation, so warmup draws should not be used for inference. The number of warmup should not be larger than \code{iter} and the default is \code{iter/2}.} \item{thin}{Thinning rate. Must be a positive integer. Set \code{thin > 1} to save memory and computation time if \code{iter} is large.} \item{cores}{Number of cores to use when executing the chains in parallel, which defaults to 1 but we recommend setting the \code{mc.cores} option to be as many processors as the hardware and RAM allow (up to the number of chains). For non-Windows OS in non-interactive \R sessions, forking is used instead of PSOCK clusters.} \item{threads}{Number of threads to use in within-chain parallelization. For more control over the threading process, \code{threads} may also be a \code{brmsthreads} object created by \code{\link{threading}}. Within-chain parallelization is experimental! We recommend its use only if you are experienced with Stan's \code{reduce_sum} function and have a slow running model that cannot be sped up by any other means. Can be set globally for the current \R session via the \code{"brms.threads"} option (see \code{\link{options}}).} \item{opencl}{The platform and device IDs of the OpenCL device to use for fitting using GPU support. If you don't know the IDs of your OpenCL device, \code{c(0,0)} is most likely what you need. For more details, see \code{\link{opencl}}. Can be set globally for the current \R session via the \code{"brms.opencl"} option} \item{normalize}{Logical. Indicates whether normalization constants should be included in the Stan code (defaults to \code{TRUE}). Setting it to \code{FALSE} requires Stan version >= 2.25 to work. If \code{FALSE}, sampling efficiency may be increased but some post processing functions such as \code{\link{bridge_sampler}} will not be available. Can be controlled globally for the current \R session via the `brms.normalize` option.} \item{control}{A named \code{list} of parameters to control the sampler's behavior. It defaults to \code{NULL} so all the default values are used. The most important control parameters are discussed in the 'Details' section below. For a comprehensive overview see \code{\link[rstan:stan]{stan}}.} \item{algorithm}{Character string naming the estimation approach to use. Options are \code{"sampling"} for MCMC (the default), \code{"meanfield"} for variational inference with independent normal distributions, \code{"fullrank"} for variational inference with a multivariate normal distribution, \code{"pathfinder"} for the pathfinder algorithm, \code{"laplace"} for the laplace approximation, or \code{"fixed_param"} for sampling from fixed parameter values. Can be set globally for the current \R session via the \code{"brms.algorithm"} option (see \code{\link{options}}).} \item{backend}{Character string naming the package to use as the backend for fitting the Stan model. Options are \code{"rstan"} (the default) or \code{"cmdstanr"}. Can be set globally for the current \R session via the \code{"brms.backend"} option (see \code{\link{options}}). Details on the \pkg{rstan} and \pkg{cmdstanr} packages are available at \url{https://mc-stan.org/rstan/} and \url{https://mc-stan.org/cmdstanr/}, respectively. Additionally a \code{"mock"} backend is available to make testing \pkg{brms} and packages that depend on it easier. The \code{"mock"} backend does not actually do any fitting, it only checks the generated Stan code for correctness and then returns whatever is passed in an additional \code{mock_fit} argument as the result of the fit.} \item{future}{Logical; If \code{TRUE}, the \pkg{\link[future:future]{future}} package is used for parallel execution of the chains and argument \code{cores} will be ignored. Can be set globally for the current \R session via the \code{"future"} option. The execution type is controlled via \code{\link[future:plan]{plan}} (see the examples section below).} \item{silent}{Verbosity level between \code{0} and \code{2}. If \code{1} (the default), most of the informational messages of compiler and sampler are suppressed. If \code{2}, even more messages are suppressed. The actual sampling progress is still printed. Set \code{refresh = 0} to turn this off as well. If using \code{backend = "rstan"} you can also set \code{open_progress = FALSE} to prevent opening additional progress bars.} \item{seed}{The seed for random number generation to make results reproducible. If \code{NA} (the default), \pkg{Stan} will set the seed randomly.} \item{save_model}{Either \code{NULL} or a character string. In the latter case, the model's Stan code is saved via \code{\link{cat}} in a text file named after the string supplied in \code{save_model}.} \item{stan_model_args}{A \code{list} of further arguments passed to \code{\link[rstan:stan_model]{rstan::stan_model}} for \code{backend = "rstan"} or to \code{cmdstanr::cmdstan_model} for \code{backend = "cmdstanr"}, which allows to change how models are compiled.} \item{file}{Either \code{NULL} or a character string. In the latter case, the fitted model object is saved via \code{\link{saveRDS}} in a file named after the string supplied in \code{file}. The \code{.rds} extension is added automatically. If the file already exists, \code{brm} will load and return the saved model object instead of refitting the model. Unless you specify the \code{file_refit} argument as well, the existing files won't be overwritten, you have to manually remove the file in order to refit and save the model under an existing file name. The file name is stored in the \code{brmsfit} object for later usage.} \item{file_compress}{Logical or a character string, specifying one of the compression algorithms supported by \code{\link{saveRDS}}. If the \code{file} argument is provided, this compression will be used when saving the fitted model object.} \item{file_refit}{Modifies when the fit stored via the \code{file} argument is re-used. Can be set globally for the current \R session via the \code{"brms.file_refit"} option (see \code{\link{options}}). For \code{"never"} (default) the fit is always loaded if it exists and fitting is skipped. For \code{"always"} the model is always refitted. If set to \code{"on_change"}, brms will refit the model if model, data or algorithm as passed to Stan differ from what is stored in the file. This also covers changes in priors, \code{sample_prior}, \code{stanvars}, covariance structure, etc. If you believe there was a false positive, you can use \code{\link{brmsfit_needs_refit}} to see why refit is deemed necessary. Refit will not be triggered for changes in additional parameters of the fit (e.g., initial values, number of iterations, control arguments, ...). A known limitation is that a refit will be triggered if within-chain parallelization is switched on/off.} \item{empty}{Logical. If \code{TRUE}, the Stan model is not created and compiled and the corresponding \code{'fit'} slot of the \code{brmsfit} object will be empty. This is useful if you have estimated a brms-created Stan model outside of \pkg{brms} and want to feed it back into the package.} \item{rename}{For internal use only.} \item{...}{Further arguments passed to Stan. For \code{backend = "rstan"} the arguments are passed to \code{\link[rstan]{sampling}} or \code{\link[rstan]{vb}}. For \code{backend = "cmdstanr"} the arguments are passed to the \code{cmdstanr::sample} or \code{cmdstanr::variational} method.} } \value{ An object of class \code{brmsfit}, which contains the posterior draws along with many other useful information about the model. Use \code{methods(class = "brmsfit")} for an overview on available methods. } \description{ Fit Bayesian generalized (non-)linear multivariate multilevel models using Stan for full Bayesian inference. A wide range of distributions and link functions are supported, allowing users to fit -- among others -- linear, robust linear, count data, survival, response times, ordinal, zero-inflated, hurdle, extended-support beta regression, and even self-defined mixture models all in a multilevel context. Further modeling options include non-linear and smooth terms, auto-correlation structures, censored data, meta-analytic standard errors, and quite a few more. In addition, all parameters of the response distributions can be predicted in order to perform distributional regression. Prior specifications are flexible and explicitly encourage users to apply prior distributions that actually reflect their beliefs. In addition, model fit can easily be assessed and compared with posterior predictive checks and leave-one-out cross-validation. } \details{ Fit a generalized (non-)linear multivariate multilevel model via full Bayesian inference using Stan. A general overview is provided in the vignettes \code{vignette("brms_overview")} and \code{vignette("brms_multilevel")}. For a full list of available vignettes see \code{vignette(package = "brms")}. \bold{Formula syntax of brms models} Details of the formula syntax applied in \pkg{brms} can be found in \code{\link{brmsformula}}. \bold{Families and link functions} Details of families supported by \pkg{brms} can be found in \code{\link{brmsfamily}}. \bold{Prior distributions} Priors should be specified using the \code{\link[brms:set_prior]{set_prior}} function. Its documentation contains detailed information on how to correctly specify priors. To find out on which parameters or parameter classes priors can be defined, use \code{\link[brms:default_prior.default]{default_prior}}. Default priors are chosen to be non or very weakly informative so that their influence on the results will be negligible and you usually don't have to worry about them. However, after getting more familiar with Bayesian statistics, I recommend you to start thinking about reasonable informative priors for your model parameters: Nearly always, there is at least some prior information available that can be used to improve your inference. \bold{Adjusting the sampling behavior of \pkg{Stan}} In addition to choosing the number of iterations, warmup draws, and chains, users can control the behavior of the NUTS sampler, by using the \code{control} argument. The most important reason to use \code{control} is to decrease (or eliminate at best) the number of divergent transitions that cause a bias in the obtained posterior draws. Whenever you see the warning "There were x divergent transitions after warmup." you should really think about increasing \code{adapt_delta}. To do this, write \code{control = list(adapt_delta = )}, where \code{} should usually be value between \code{0.8} (current default) and \code{1}. Increasing \code{adapt_delta} will slow down the sampler but will decrease the number of divergent transitions threatening the validity of your posterior draws. Another problem arises when the depth of the tree being evaluated in each iteration is exceeded. This is less common than having divergent transitions, but may also bias the posterior draws. When it happens, \pkg{Stan} will throw out a warning suggesting to increase \code{max_treedepth}, which can be accomplished by writing \code{control = list(max_treedepth = )} with a positive integer \code{} that should usually be larger than the current default of \code{10}. For more details on the \code{control} argument see \code{\link[rstan:stan]{stan}}. } \section{Parallelization with multiple CPU cores}{ \pkg{brms} can make use of multiple CPU cores in parallel to speed up computations in various ways. For efficient use of the available resources it is recommended to only use parallelism to an extend such that the available physical CPUs are not oversubscribed. For example, when you have 8 CPU cores locally available, then you may consider to run 4 chains with 2 threads per chain for best performance if you happen to just run a single model. In case you run a simulation study which requires to run many times a given model, then neither chain nor within-chain parallelization is advisable as the computational resources are already exhausted by the simulation study and any further parallelization beyond the simulation study itself will in fact slow down the overall runtime. Please be aware that for historical reasons the nomenclature of the arguments is possibly confusing. The \code{cores} argument refers to running different chains in parallel and the within-chain parallelization will allocate for each chain as many threads as requested. The requested threads therefore increase the use of overall CPUs in a multiplicative way. For more advanced parallelization (including beyond single model fits), \pkg{brms} also integrates with the \pkg{future} package. Importantly, this enables seamless integration with the \pkg{mirai} parallelization framework through the use of the \pkg{future.mirai} adapter. With \pkg{mirai} local and remote machines can be used in a fully transparent manner to the user. This includes the possibility to use large number of remote machines running in the context of a computer cluster, which are managed with queuing systems. Please refer to the section on distributed computing of \code{\link[mirai:daemons]{mirai::daemons}}. } \examples{ \dontrun{ # Poisson regression for the number of seizures in epileptic patients fit1 <- brm( count ~ zBase * Trt + (1|patient), data = epilepsy, family = poisson(), prior = prior(normal(0, 10), class = b) + prior(cauchy(0, 2), class = sd) ) # generate a summary of the results summary(fit1) # plot the MCMC chains as well as the posterior distributions plot(fit1) # predict responses based on the fitted model head(predict(fit1)) # plot conditional effects for each predictor plot(conditional_effects(fit1), ask = FALSE) # investigate model fit loo(fit1) pp_check(fit1) # Ordinal regression modeling patient's rating of inhaler instructions # category specific effects are estimated for variable 'treat' fit2 <- brm(rating ~ period + carry + cs(treat), data = inhaler, family = sratio("logit"), prior = set_prior("normal(0,5)"), chains = 2) summary(fit2) plot(fit2, ask = FALSE) WAIC(fit2) # Survival regression modeling the time between the first # and second recurrence of an infection in kidney patients. fit3 <- brm(time | cens(censored) ~ age * sex + disease + (1|patient), data = kidney, family = lognormal()) summary(fit3) plot(fit3, ask = FALSE) plot(conditional_effects(fit3), ask = FALSE) # Probit regression using the binomial family ntrials <- sample(1:10, 100, TRUE) success <- rbinom(100, size = ntrials, prob = 0.4) x <- rnorm(100) data4 <- data.frame(ntrials, success, x) fit4 <- brm(success | trials(ntrials) ~ x, data = data4, family = binomial("probit")) summary(fit4) # Non-linear Gaussian model fit5 <- brm( bf(cum ~ ult * (1 - exp(-(dev/theta)^omega)), ult ~ 1 + (1|AY), omega ~ 1, theta ~ 1, nl = TRUE), data = loss, family = gaussian(), prior = c( prior(normal(5000, 1000), nlpar = "ult"), prior(normal(1, 2), nlpar = "omega"), prior(normal(45, 10), nlpar = "theta") ), control = list(adapt_delta = 0.9) ) summary(fit5) conditional_effects(fit5) # Normal model with heterogeneous variances data_het <- data.frame( y = c(rnorm(50), rnorm(50, 1, 2)), x = factor(rep(c("a", "b"), each = 50)) ) fit6 <- brm(bf(y ~ x, sigma ~ 0 + x), data = data_het) summary(fit6) plot(fit6) conditional_effects(fit6) # extract estimated residual SDs of both groups sigmas <- exp(as.data.frame(fit6, variable = "^b_sigma_", regex = TRUE)) ggplot(stack(sigmas), aes(values)) + geom_density(aes(fill = ind)) # Quantile regression predicting the 25\%-quantile fit7 <- brm(bf(y ~ x, quantile = 0.25), data = data_het, family = asym_laplace()) summary(fit7) conditional_effects(fit7) # use the future package for more flexible parallelization library(future) plan(multisession, workers = 4) fit7a <- update(fit7, future = TRUE) # we may also use mirai allowing the use of remote machines as # well, including the use of computer clusters managed by queuing # systems mirai::daemons(4) # distributed computing with url and remote argument plan(future.mirai::mirai_cluster) fit7b <- update(fit7, future = TRUE) mirai::daemons(0) # shuts down the 4 workers # fit a model manually via rstan scode <- stancode(count ~ Trt, data = epilepsy) sdata <- standata(count ~ Trt, data = epilepsy) stanfit <- rstan::stan(model_code = scode, data = sdata) # feed the Stan model back into brms fit8 <- brm(count ~ Trt, data = epilepsy, empty = TRUE) fit8$fit <- stanfit fit8 <- rename_pars(fit8) summary(fit8) } } \references{ Paul-Christian Buerkner (2017). brms: An R Package for Bayesian Multilevel Models Using Stan. \emph{Journal of Statistical Software}, 80(1), 1-28. \code{doi:10.18637/jss.v080.i01} Paul-Christian Buerkner (2018). Advanced Bayesian Multilevel Modeling with the R Package brms. \emph{The R Journal}. 10(1), 395–411. \code{doi:10.32614/RJ-2018-017} } \seealso{ \code{\link{brms}}, \code{\link{brmsformula}}, \code{\link{brmsfamily}}, \code{\link{brmsfit}} } \author{ Paul-Christian Buerkner \email{paul.buerkner@gmail.com} } brms/man/get_y.Rd0000644000176200001440000000163214213413565013374 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/data-response.R \name{get_y} \alias{get_y} \title{Extract response values} \usage{ get_y(x, resp = NULL, sort = FALSE, warn = FALSE, ...) } \arguments{ \item{x}{A \code{\link{brmsfit}} object.} \item{resp}{Optional names of response variables for which to extract values.} \item{sort}{Logical. Only relevant for time series models. Indicating whether to return predicted values in the original order (\code{FALSE}; default) or in the order of the time series (\code{TRUE}).} \item{warn}{For internal use only.} \item{...}{Further arguments passed to \code{\link{standata}}.} } \value{ Returns a vector of response values for univariate models and a matrix of response values with one column per response variable for multivariate models. } \description{ Extract response values from a \code{\link{brmsfit}} object. } \keyword{internal} brms/man/stanvar.Rd0000644000176200001440000000715714571050211013743 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/stanvars.R \name{stanvar} \alias{stanvar} \alias{stanvars} \title{User-defined variables passed to Stan} \usage{ stanvar( x = NULL, name = NULL, scode = NULL, block = "data", position = "start", pll_args = NULL ) } \arguments{ \item{x}{An \R object containing data to be passed to Stan. Only required if \code{block = 'data'} and ignored otherwise.} \item{name}{Optional character string providing the desired variable name of the object in \code{x}. If \code{NULL} (the default) the variable name is directly inferred from \code{x}.} \item{scode}{Line of Stan code to define the variable in Stan language. If \code{block = 'data'}, the Stan code is inferred based on the class of \code{x} by default.} \item{block}{Name of one of Stan's program blocks in which the variable should be defined. Can be \code{'data'}, \code{'tdata'} (transformed data), \code{'parameters'}, \code{'tparameters'} (transformed parameters), \code{'model'}, \code{'likelihood'} (part of the model block where the likelihood is given), \code{'genquant'} (generated quantities) or \code{'functions'}.} \item{position}{Name of the position within the block where the Stan code should be placed. Currently allowed are \code{'start'} (the default) and \code{'end'} of the block.} \item{pll_args}{Optional Stan code to be put into the header of \code{partial_log_lik} functions. This ensures that the variables specified in \code{scode} can be used in the likelihood even when within-chain parallelization is activated via \code{\link{threading}}.} } \value{ An object of class \code{stanvars}. } \description{ Prepare user-defined variables to be passed to one of Stan's program blocks. This is primarily useful for defining more complex priors, for refitting models without recompilation despite changing priors, or for defining custom Stan functions. } \details{ The \code{stanvar} function is not vectorized. Instead, multiple \code{stanvars} objects can be added together via \code{+} (see Examples). Special attention is necessary when using \code{stanvars} to inject code into the \code{'likelihood'} block while having \code{\link{threading}} activated. In this case, your custom Stan code may need adjustments to ensure correct observation indexing. Please investigate the generated Stan code via \code{\link[brms:stancode.default]{stancode}} to see which adjustments are necessary in your case. } \examples{ bprior <- prior(normal(mean_intercept, 10), class = "Intercept") stanvars <- stanvar(5, name = "mean_intercept") stancode(count ~ Trt, epilepsy, prior = bprior, stanvars = stanvars) # define a multi-normal prior with known covariance matrix bprior <- prior(multi_normal(M, V), class = "b") stanvars <- stanvar(rep(0, 2), "M", scode = " vector[K] M;") + stanvar(diag(2), "V", scode = " matrix[K, K] V;") stancode(count ~ Trt + zBase, epilepsy, prior = bprior, stanvars = stanvars) # define a hierachical prior on the regression coefficients bprior <- set_prior("normal(0, tau)", class = "b") + set_prior("target += normal_lpdf(tau | 0, 10)", check = FALSE) stanvars <- stanvar(scode = "real tau;", block = "parameters") stancode(count ~ Trt + zBase, epilepsy, prior = bprior, stanvars = stanvars) # ensure that 'tau' is passed to the likelihood of a threaded model # not necessary for this example but may be necessary in other cases stanvars <- stanvar(scode = "real tau;", block = "parameters", pll_args = "real tau") stancode(count ~ Trt + zBase, epilepsy, stanvars = stanvars, threads = threading(2)) } brms/man/default_prior.Rd0000644000176200001440000000254314572632206015131 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/priors.R \name{default_prior} \alias{default_prior} \alias{get_prior} \title{Default priors for Bayesian models} \usage{ default_prior(object, ...) get_prior(formula, ...) } \arguments{ \item{object}{An object whose class will determine which method will be used. A symbolic description of the model to be fitted.} \item{...}{Further arguments passed to the specific method.} \item{formula}{Synonym of \code{object} for use in \code{get_prior}.} } \value{ Usually, a \code{brmsprior} object. See \code{\link{default_prior.default}} for more details. } \description{ \code{default_prior} is a generic function that can be used to get default priors for Bayesian models. Its original use is within the \pkg{brms} package, but new methods for use with objects from other packages can be registered to the same generic. } \details{ See \code{\link{default_prior.default}} for the default method applied for \pkg{brms} models. You can view the available methods by typing \code{methods(default_prior)}. } \examples{ ## get all parameters and parameters classes to define priors on (prior <- default_prior(count ~ zAge + zBase * Trt + (1|patient) + (1|obs), data = epilepsy, family = poisson())) } \seealso{ \code{\link{set_prior}}, \code{\link{default_prior.default}} } brms/man/reloo.brmsfit.Rd0000644000176200001440000001306015057533707015060 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/reloo.R \name{reloo.brmsfit} \alias{reloo.brmsfit} \alias{reloo.loo} \alias{reloo} \title{Compute exact cross-validation for problematic observations} \usage{ \method{reloo}{brmsfit}( x, loo = NULL, k_threshold = 0.7, newdata = NULL, resp = NULL, check = TRUE, recompile = NULL, future_args = list(), ... ) \method{reloo}{loo}(x, fit, ...) reloo(x, ...) } \arguments{ \item{x}{An \R object of class \code{brmsfit} or \code{loo} depending on the method.} \item{loo}{An \R object of class \code{loo}. If \code{NULL}, brms will try to extract a precomputed \code{loo} object from the fitted model, added there via \code{\link{add_criterion}}.} \item{k_threshold}{The threshold at which Pareto \eqn{k} estimates are treated as problematic. Defaults to \code{0.7}. See \code{\link[loo:pareto-k-diagnostic]{pareto_k_ids}} for more details.} \item{newdata}{An optional data.frame for which to evaluate predictions. If \code{NULL} (default), the original data of the model is used. \code{NA} values within factors (excluding grouping variables) are interpreted as if all dummy variables of this factor are zero. This allows, for instance, to make predictions of the grand mean when using sum coding. \code{NA} values within grouping variables are treated as a new level.} \item{resp}{Optional names of response variables. If specified, predictions are performed only for the specified response variables.} \item{check}{Logical; If \code{TRUE} (the default), some checks check are performed if the \code{loo} object was generated from the \code{brmsfit} object passed to argument \code{fit}.} \item{recompile}{Logical, indicating whether the Stan model should be recompiled. This may be necessary if you are running \code{reloo} on another machine than the one used to fit the model.} \item{future_args}{A list of further arguments passed to \code{\link[future:future]{future}} for additional control over parallel execution if activated.} \item{...}{Further arguments passed to \code{\link{update.brmsfit}} and \code{\link{log_lik.brmsfit}}.} \item{fit}{An \R object of class \code{brmsfit}.} } \value{ An object of the class \code{loo}. } \description{ Compute exact cross-validation for problematic observations for which approximate leave-one-out cross-validation may return incorrect results. Models for problematic observations can be run in parallel using the \pkg{future} package. } \details{ Warnings about Pareto \eqn{k} estimates indicate observations for which the approximation to LOO is problematic (this is described in detail in Vehtari, Gelman, and Gabry (2017) and the \pkg{\link[loo:loo-package]{loo}} package documentation). If there are \eqn{J} observations with \eqn{k} estimates above \code{k_threshold}, then \code{reloo} will refit the original model \eqn{J} times, each time leaving out one of the \eqn{J} problematic observations. The pointwise contributions of these observations to the total ELPD are then computed directly and substituted for the previous estimates from these \eqn{J} observations that are stored in the original \code{loo} object. By default, this method uses \code{sample_new_levels = "gaussian"} to sample parameter values for new grouping-factor levels (see also \code{\link{prepare_predictions}}). This default will fail for models with non-Gaussian group-level effects. In this case, we recommend setting \code{sample_new_levels = "uncertainty"}. } \section{Parallelization with multiple CPU cores}{ \pkg{brms} can make use of multiple CPU cores in parallel to speed up computations in various ways. For efficient use of the available resources it is recommended to only use parallelism to an extend such that the available physical CPUs are not oversubscribed. For example, when you have 8 CPU cores locally available, then you may consider to run 4 chains with 2 threads per chain for best performance if you happen to just run a single model. In case you run a simulation study which requires to run many times a given model, then neither chain nor within-chain parallelization is advisable as the computational resources are already exhausted by the simulation study and any further parallelization beyond the simulation study itself will in fact slow down the overall runtime. Please be aware that for historical reasons the nomenclature of the arguments is possibly confusing. The \code{cores} argument refers to running different chains in parallel and the within-chain parallelization will allocate for each chain as many threads as requested. The requested threads therefore increase the use of overall CPUs in a multiplicative way. For more advanced parallelization (including beyond single model fits), \pkg{brms} also integrates with the \pkg{future} package. Importantly, this enables seamless integration with the \pkg{mirai} parallelization framework through the use of the \pkg{future.mirai} adapter. With \pkg{mirai} local and remote machines can be used in a fully transparent manner to the user. This includes the possibility to use large number of remote machines running in the context of a computer cluster, which are managed with queuing systems. Please refer to the section on distributed computing of \code{\link[mirai:daemons]{mirai::daemons}}. } \examples{ \dontrun{ fit1 <- brm(count ~ zAge + zBase * Trt + (1|patient), data = epilepsy, family = poisson()) # throws warning about some pareto k estimates being too high (loo1 <- loo(fit1)) # no more warnings after reloo (reloo1 <- reloo(fit1, loo = loo1, chains = 1)) } } \seealso{ \code{\link{loo}}, \code{\link{kfold}} } brms/man/loo_moment_match.brmsfit.Rd0000644000176200001440000000644315053072461017262 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/loo_moment_match.R \name{loo_moment_match.brmsfit} \alias{loo_moment_match.brmsfit} \alias{loo_moment_match} \alias{loo_moment_match.loo} \title{Moment matching for efficient approximate leave-one-out cross-validation} \usage{ \method{loo_moment_match}{brmsfit}( x, loo = NULL, k_threshold = 0.7, newdata = NULL, resp = NULL, check = TRUE, recompile = FALSE, ... ) \method{loo_moment_match}{loo}(x, fit, ...) } \arguments{ \item{x}{An \R object of class \code{brmsfit} or \code{loo} depending on the method.} \item{loo}{An \R object of class \code{loo}. If \code{NULL}, brms will try to extract a precomputed \code{loo} object from the fitted model, added there via \code{\link{add_criterion}}.} \item{k_threshold}{The Pareto \eqn{k} threshold for which observations moment matching is applied. Defaults to \code{0.7}. See \code{\link[loo:pareto-k-diagnostic]{pareto_k_ids}} for more details.} \item{newdata}{An optional data.frame for which to evaluate predictions. If \code{NULL} (default), the original data of the model is used. \code{NA} values within factors (excluding grouping variables) are interpreted as if all dummy variables of this factor are zero. This allows, for instance, to make predictions of the grand mean when using sum coding. \code{NA} values within grouping variables are treated as a new level.} \item{resp}{Optional names of response variables. If specified, predictions are performed only for the specified response variables.} \item{check}{Logical; If \code{TRUE} (the default), some checks check are performed if the \code{loo} object was generated from the \code{brmsfit} object passed to argument \code{fit}.} \item{recompile}{Logical, indicating whether the Stan model should be recompiled. This may be necessary if you are running moment matching on another machine than the one used to fit the model. No recompilation is done by default.} \item{...}{Further arguments passed to the underlying methods. Additional arguments initially passed to \code{\link{loo}}, for example, \code{newdata} or \code{resp} need to be passed again to \code{loo_moment_match} in order for the latter to work correctly.} \item{fit}{An \R object of class \code{brmsfit}.} } \value{ An updated object of class \code{loo}. } \description{ Moment matching for efficient approximate leave-one-out cross-validation (LOO-CV). See \code{\link[loo:loo_moment_match]{loo_moment_match}} for more details. } \details{ The moment matching algorithm requires draws of all variables defined in Stan's \code{parameters} block to be saved. Otherwise \code{loo_moment_match} cannot be computed. Thus, please set \code{save_pars = save_pars(all = TRUE)} in the call to \code{\link{brm}}, if you are planning to apply \code{loo_moment_match} to your models. } \examples{ \dontrun{ fit1 <- brm(count ~ zAge + zBase * Trt + (1|patient), data = epilepsy, family = poisson(), save_pars = save_pars(all = TRUE)) # throws warning about some pareto k estimates being too high (loo1 <- loo(fit1)) # no more warnings after moment matching (mmloo1 <- loo_moment_match(fit1, loo = loo1)) } } \references{ Paananen, T., Piironen, J., Buerkner, P.-C., Vehtari, A. (2021). Implicitly Adaptive Importance Sampling. Statistics and Computing. } brms/man/as.data.frame.brmsfit.Rd0000644000176200001440000000333414160105076016333 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/posterior.R \name{as.data.frame.brmsfit} \alias{as.data.frame.brmsfit} \alias{as.matrix.brmsfit} \alias{as.array.brmsfit} \title{Extract Posterior Draws} \usage{ \method{as.data.frame}{brmsfit}( x, row.names = NULL, optional = TRUE, pars = NA, variable = NULL, draw = NULL, subset = NULL, ... ) \method{as.matrix}{brmsfit}(x, pars = NA, variable = NULL, draw = NULL, subset = NULL, ...) \method{as.array}{brmsfit}(x, pars = NA, variable = NULL, draw = NULL, subset = NULL, ...) } \arguments{ \item{x}{A \code{brmsfit} object or another \R object for which the methods are defined.} \item{row.names, optional}{Unused and only added for consistency with the \code{\link[base:as.data.frame]{as.data.frame}} generic.} \item{pars}{Deprecated alias of \code{variable}. For reasons of backwards compatibility, \code{pars} is interpreted as a vector of regular expressions by default unless \code{fixed = TRUE} is specified.} \item{variable}{A character vector providing the variables to extract. By default, all variables are extracted.} \item{draw}{The draw indices to be select. Subsetting draw indices will lead to an automatic merging of chains.} \item{subset}{Deprecated alias of \code{draw}.} \item{...}{Further arguments to be passed to the corresponding \code{\link[brms:draws-brms]{as_draws_*}} methods as well as to \code{\link[posterior:subset_draws]{subset_draws}}.} } \value{ A data.frame, matrix, or array containing the posterior draws. } \description{ Extract posterior draws in conventional formats as data.frames, matrices, or arrays. } \seealso{ \code{\link[brms:draws-brms]{as_draws}}, \code{\link[posterior:subset_draws]{subset_draws}} } brms/man/gp.Rd0000644000176200001440000001506115057501217012673 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/formula-gp.R \name{gp} \alias{gp} \title{Set up Gaussian process terms in \pkg{brms}} \usage{ gp( ..., by = NA, k = NA, cov = "exp_quad", iso = TRUE, gr = TRUE, cmc = TRUE, scale = TRUE, c = 5/4 ) } \arguments{ \item{...}{One or more predictors for the GP.} \item{by}{A numeric or factor variable of the same length as each predictor. In the numeric vector case, the elements multiply the values returned by the GP. In the factor variable case, a separate GP is fitted for each factor level.} \item{k}{Optional number of basis functions for computing Hilbert-space approximate GPs. If \code{NA} (the default), exact GPs are computed.} \item{cov}{Name of the covariance kernel. Currently supported are \code{"exp_quad"} (exponentiated-quadratic kernel; default), \code{"matern32"} (Matern 3/2 kernel), \code{"matern52"} (Matern 5/2 kernel), and \code{"exponential"} (exponential kernel; alias: \code{"matern12"}).} \item{iso}{A flag to indicate whether an isotropic (\code{TRUE}; the default) or a non-isotropic GP should be used. In the former case, the same amount of smoothing is applied to all predictors. In the latter case, predictors may have different smoothing. Ignored if only a single predictor is supplied.} \item{gr}{Logical; Indicates if auto-grouping should be used (defaults to \code{TRUE}). If enabled, observations sharing the same predictor values will be represented by the same latent variable in the GP. This will improve sampling efficiency drastically if the number of unique predictor combinations is small relative to the number of observations.} \item{cmc}{Logical; Only relevant if \code{by} is a factor. If \code{TRUE} (the default), cell-mean coding is used for the \code{by}-factor, that is one GP per level is estimated. If \code{FALSE}, contrast GPs are estimated according to the contrasts set for the \code{by}-factor.} \item{scale}{Logical; If \code{TRUE} (the default), predictors are scaled so that the maximum Euclidean distance between two points is 1. This often improves sampling speed and convergence. Scaling also affects the estimated length-scale parameters in that they resemble those of scaled predictors (not of the original predictors) if \code{scale} is \code{TRUE}.} \item{c}{Numeric value only used in approximate GPs. Defines the multiplicative constant of the predictors' range over which predictions should be computed. A good default could be \code{c = 5/4} but we are still working on providing better recommendations.} } \value{ An object of class \code{'gp_term'}, which is a list of arguments to be interpreted by the formula parsing functions of \pkg{brms}. } \description{ Set up a Gaussian process (GP) term in \pkg{brms}. The function does not evaluate its arguments -- it exists purely to help set up a model with GP terms. } \details{ A GP is a stochastic process, which describes the relation between one or more predictors \eqn{x = (x_1, ..., x_d)} and a response \eqn{f(x)}, where \eqn{d} is the number of predictors. A GP is the generalization of the multivariate normal distribution to an infinite number of dimensions. Thus, it can be interpreted as a prior over functions. The values of \eqn{f( )} at any finite set of locations are jointly multivariate normal, with a covariance matrix defined by the covariance kernel \eqn{k_p(x_i, x_j)}, where \eqn{p} is the vector of parameters of the GP: \deqn{(f(x_1), \ldots f(x_n) \sim MVN(0, (k_p(x_i, x_j))_{i,j=1}^n) .} The smoothness and general behavior of the function \eqn{f} depends only on the choice of covariance kernel. For a more detailed introduction to Gaussian processes, see \url{https://en.wikipedia.org/wiki/Gaussian_process}. For mathematical details on the supported kernels, please see the Stan manual: \url{https://mc-stan.org/docs/functions-reference/matrix_operations.html} under "Gaussian Process Covariance Functions". There are several parameters estimated for GPs, the most important of which are as follows: \tabular{llll}{ \strong{Parameter} \tab \strong{Notation} \tab \strong{Support} \tab \strong{Meaning} \cr \code{lscale} \tab \eqn{\ell} \tab \eqn{\mathbb{R}^+} \tab length-scale of the GP's covariance kernel \cr \code{sdgp} \tab \eqn{\sigma} \tab \eqn{\mathbb{R}^+} \tab marginal standard deviation of the GP's covariance kernel \cr \code{zgp} \tab \eqn{z} \tab \eqn{\mathbb{R}} \tab latent variable values of the training data \cr } Assuming an exponentiated quadratic covariance structure, the parameters can be broadly interpreted as follows (see also \url{https://mc-stan.org/docs/stan-users-guide/gaussian-processes.html#gaussian-process-regression}). Note that in the above documentation the parameter \eqn{\sigma} is denoted as \eqn{\alpha} instead, and the parameter \eqn{\ell} as \eqn{\rho}. The length-scale \eqn{\ell} controls the frequency of the functions represented by the GP prior i.e., values of \eqn{\ell \gg 0} lead to lower-frequency functions, while values of \eqn{\ell \approx 0} lead to higher-frequency functions. In slightly simpler terms, \eqn{\ell} sets the distance over which observations in the input space are strongly correlated. The marginal standard deviation \eqn{\sigma} controls the magnitude of the range of the function represented by the GP i.e., it represents how much the values of the function tend to deviate from the mean level. Lastly, the parameter \eqn{z} represents latent variable values per observation (or unique input point). } \examples{ \dontrun{ # simulate data using the mgcv package dat <- mgcv::gamSim(1, n = 30, scale = 2) # fit a simple GP model fit1 <- brm(y ~ gp(x2), dat, chains = 2) summary(fit1) me1 <- conditional_effects(fit1, ndraws = 200, spaghetti = TRUE) plot(me1, ask = FALSE, points = TRUE) # fit a more complicated GP model and use an approximate GP for x2 fit2 <- brm(y ~ gp(x0) + x1 + gp(x2, k = 10) + x3, dat, chains = 2) summary(fit2) me2 <- conditional_effects(fit2, ndraws = 200, spaghetti = TRUE) plot(me2, ask = FALSE, points = TRUE) # fit a multivariate GP model with Matern 3/2 kernel fit3 <- brm(y ~ gp(x1, x2, cov = "matern32"), dat, chains = 2) summary(fit3) me3 <- conditional_effects(fit3, ndraws = 200, spaghetti = TRUE) plot(me3, ask = FALSE, points = TRUE) # compare model fit loo(fit1, fit2, fit3) # simulate data with a factor covariate dat2 <- mgcv::gamSim(4, n = 90, scale = 2) # fit separate gaussian processes for different levels of 'fac' fit4 <- brm(y ~ gp(x2, by = fac), dat2, chains = 2) summary(fit4) plot(conditional_effects(fit4), points = TRUE) } } \seealso{ \code{\link{brmsformula}} } brms/man/is.brmsformula.Rd0000644000176200001440000000050614160105076015223 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/brmsformula.R \name{is.brmsformula} \alias{is.brmsformula} \title{Checks if argument is a \code{brmsformula} object} \usage{ is.brmsformula(x) } \arguments{ \item{x}{An \R object} } \description{ Checks if argument is a \code{brmsformula} object } brms/man/posterior_smooths.brmsfit.Rd0000644000176200001440000000400714213413565017533 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/posterior_smooths.R \name{posterior_smooths.brmsfit} \alias{posterior_smooths.brmsfit} \alias{posterior_smooths} \title{Posterior Predictions of Smooth Terms} \usage{ \method{posterior_smooths}{brmsfit}( object, smooth, newdata = NULL, resp = NULL, dpar = NULL, nlpar = NULL, ndraws = NULL, draw_ids = NULL, ... ) posterior_smooths(object, ...) } \arguments{ \item{object}{An object of class \code{brmsfit}.} \item{smooth}{Name of a single smooth term for which predictions should be computed.} \item{newdata}{An optional \code{data.frame} for which to evaluate predictions. If \code{NULL} (default), the original data of the model is used. Only those variables appearing in the chosen \code{smooth} term are required.} \item{resp}{Optional names of response variables. If specified, predictions are performed only for the specified response variables.} \item{dpar}{Optional name of a predicted distributional parameter. If specified, expected predictions of this parameters are returned.} \item{nlpar}{Optional name of a predicted non-linear parameter. If specified, expected predictions of this parameters are returned.} \item{ndraws}{Positive integer indicating how many posterior draws should be used. If \code{NULL} (the default) all draws are used. Ignored if \code{draw_ids} is not \code{NULL}.} \item{draw_ids}{An integer vector specifying the posterior draws to be used. If \code{NULL} (the default), all draws are used.} \item{...}{Currently ignored.} } \value{ An S x N matrix, where S is the number of posterior draws and N is the number of observations. } \description{ Compute posterior predictions of smooth \code{s} and \code{t2} terms of models fitted with \pkg{brms}. } \examples{ \dontrun{ set.seed(0) dat <- mgcv::gamSim(1, n = 200, scale = 2) fit <- brm(y ~ s(x0) + s(x1) + s(x2) + s(x3), data = dat) summary(fit) newdata <- data.frame(x2 = seq(0, 1, 10)) str(posterior_smooths(fit, smooth = "s(x2)", newdata = newdata)) } } brms/man/VarCorr.brmsfit.Rd0000644000176200001440000000326614213413565015315 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/brmsfit-methods.R \name{VarCorr.brmsfit} \alias{VarCorr.brmsfit} \alias{VarCorr} \title{Extract Variance and Correlation Components} \usage{ \method{VarCorr}{brmsfit}( x, sigma = 1, summary = TRUE, robust = FALSE, probs = c(0.025, 0.975), ... ) } \arguments{ \item{x}{An object of class \code{brmsfit}.} \item{sigma}{Ignored (included for compatibility with \code{\link[nlme:VarCorr]{VarCorr}}).} \item{summary}{Should summary statistics be returned instead of the raw values? Default is \code{TRUE}.} \item{robust}{If \code{FALSE} (the default) the mean is used as the measure of central tendency and the standard deviation as the measure of variability. If \code{TRUE}, the median and the median absolute deviation (MAD) are applied instead. Only used if \code{summary} is \code{TRUE}.} \item{probs}{The percentiles to be computed by the \code{quantile} function. Only used if \code{summary} is \code{TRUE}.} \item{...}{Currently ignored.} } \value{ A list of lists (one per grouping factor), each with three elements: a matrix containing the standard deviations, an array containing the correlation matrix, and an array containing the covariance matrix with variances on the diagonal. } \description{ This function calculates the estimated standard deviations, correlations and covariances of the group-level terms in a multilevel model of class \code{brmsfit}. For linear models, the residual standard deviations, correlations and covariances are also returned. } \examples{ \dontrun{ fit <- brm(count ~ zAge + zBase * Trt + (1+Trt|visit), data = epilepsy, family = gaussian(), chains = 2) VarCorr(fit) } } brms/man/posterior_summary.Rd0000644000176200001440000000362414213413565016073 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/summary.R \name{posterior_summary} \alias{posterior_summary} \alias{posterior_summary.default} \alias{posterior_summary.brmsfit} \title{Summarize Posterior draws} \usage{ posterior_summary(x, ...) \method{posterior_summary}{default}(x, probs = c(0.025, 0.975), robust = FALSE, ...) \method{posterior_summary}{brmsfit}( x, pars = NA, variable = NULL, probs = c(0.025, 0.975), robust = FALSE, ... ) } \arguments{ \item{x}{An \R object.} \item{...}{More arguments passed to or from other methods.} \item{probs}{The percentiles to be computed by the \code{\link[stats:quantile]{quantile}} function.} \item{robust}{If \code{FALSE} (the default) the mean is used as the measure of central tendency and the standard deviation as the measure of variability. If \code{TRUE}, the median and the median absolute deviation (MAD) are applied instead.} \item{pars}{Deprecated alias of \code{variable}. For reasons of backwards compatibility, \code{pars} is interpreted as a vector of regular expressions by default unless \code{fixed = TRUE} is specified.} \item{variable}{A character vector providing the variables to extract. By default, all variables are extracted.} } \value{ A matrix where rows indicate variables and columns indicate the summary estimates. } \description{ Summarizes posterior draws based on point estimates (mean or median), estimation errors (SD or MAD) and quantiles. This function mainly exists to retain backwards compatibility. It will eventually be replaced by functions of the \pkg{posterior} package (see examples below). } \examples{ \dontrun{ fit <- brm(time ~ age * sex, data = kidney) posterior_summary(fit) # recommended workflow using posterior library(posterior) draws <- as_draws_array(fit) summarise_draws(draws, default_summary_measures()) } } \seealso{ \code{\link[posterior:summarize_draws]{summarize_draws}} } brms/man/mo.Rd0000644000176200001440000000407214224021465012675 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/formula-sp.R \name{mo} \alias{mo} \title{Monotonic Predictors in \pkg{brms} Models} \usage{ mo(x, id = NA) } \arguments{ \item{x}{An integer variable or an ordered factor to be modeled as monotonic.} \item{id}{Optional character string. All monotonic terms with the same \code{id} within one formula will be modeled as having the same simplex (shape) parameter vector. If all monotonic terms of the same predictor have the same \code{id}, the resulting predictions will be conditionally monotonic for all values of interacting covariates (Bürkner & Charpentier, 2020).} } \description{ Specify a monotonic predictor term in \pkg{brms}. The function does not evaluate its arguments -- it exists purely to help set up a model. } \details{ See Bürkner and Charpentier (2020) for the underlying theory. For detailed documentation of the formula syntax used for monotonic terms, see \code{help(brmsformula)} as well as \code{vignette("brms_monotonic")}. } \examples{ \dontrun{ # generate some data income_options <- c("below_20", "20_to_40", "40_to_100", "greater_100") income <- factor(sample(income_options, 100, TRUE), levels = income_options, ordered = TRUE) mean_ls <- c(30, 60, 70, 75) ls <- mean_ls[income] + rnorm(100, sd = 7) dat <- data.frame(income, ls) # fit a simple monotonic model fit1 <- brm(ls ~ mo(income), data = dat) summary(fit1) plot(fit1, N = 6) plot(conditional_effects(fit1), points = TRUE) # model interaction with other variables dat$x <- sample(c("a", "b", "c"), 100, TRUE) fit2 <- brm(ls ~ mo(income)*x, data = dat) summary(fit2) plot(conditional_effects(fit2), points = TRUE) # ensure conditional monotonicity fit3 <- brm(ls ~ mo(income, id = "i")*x, data = dat) summary(fit3) plot(conditional_effects(fit3), points = TRUE) } } \references{ Bürkner P. C. & Charpentier E. (2020). Modeling Monotonic Effects of Ordinal Predictors in Regression Models. British Journal of Mathematical and Statistical Psychology. doi:10.1111/bmsp.12195 } \seealso{ \code{\link{brmsformula}} } brms/man/fcor.Rd0000644000176200001440000000216414213413565013217 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/formula-ac.R \name{fcor} \alias{fcor} \title{Fixed residual correlation (FCOR) structures} \usage{ fcor(M) } \arguments{ \item{M}{Known correlation/covariance matrix of the response variable. If a vector is passed, it will be used as diagonal entries (variances) and correlations/covariances will be set to zero. The actual covariance matrix used in the likelihood is obtained by multiplying \code{M} by the square of the residual standard deviation parameter \code{sigma} estimated as part of the model.} } \value{ An object of class \code{'fcor_term'}, which is a list of arguments to be interpreted by the formula parsing functions of \pkg{brms}. } \description{ Set up a fixed residual correlation (FCOR) term in \pkg{brms}. The function does not evaluate its arguments -- it exists purely to help set up a model with FCOR terms. } \examples{ \dontrun{ dat <- data.frame(y = rnorm(3)) V <- cbind(c(0.5, 0.3, 0.2), c(0.3, 1, 0.1), c(0.2, 0.1, 0.2)) fit <- brm(y ~ 1 + fcor(V), data = dat, data2 = list(V = V)) } } \seealso{ \code{\link{autocor-terms}} } brms/man/draws-index-brms.Rd0000644000176200001440000000156314160105076015452 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/posterior.R \name{draws-index-brms} \alias{draws-index-brms} \alias{variables} \alias{nvariables} \alias{niterations} \alias{nchains} \alias{ndraws} \alias{Index} \alias{variables,} \alias{iterations,} \alias{chains,} \alias{and} \alias{draws.} \alias{variables.brmsfit} \alias{nvariables.brmsfit} \alias{niterations.brmsfit} \alias{nchains.brmsfit} \alias{ndraws.brmsfit} \title{Index \code{brmsfit} objects} \usage{ \method{variables}{brmsfit}(x, ...) \method{nvariables}{brmsfit}(x, ...) \method{niterations}{brmsfit}(x) \method{nchains}{brmsfit}(x) \method{ndraws}{brmsfit}(x) } \arguments{ \item{x}{A \code{brmsfit} object or another \R object for which the methods are defined.} \item{...}{Arguments passed to individual methods (if applicable).} } \description{ Index \code{brmsfit} objects } brms/man/is.brmsprior.Rd0000644000176200001440000000046714160105076014717 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/priors.R \name{is.brmsprior} \alias{is.brmsprior} \title{Checks if argument is a \code{brmsprior} object} \usage{ is.brmsprior(x) } \arguments{ \item{x}{An \R object} } \description{ Checks if argument is a \code{brmsprior} object } brms/man/posterior_interval.brmsfit.Rd0000644000176200001440000000236214213413565017665 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/summary.R \name{posterior_interval.brmsfit} \alias{posterior_interval.brmsfit} \alias{posterior_interval} \title{Compute posterior uncertainty intervals} \usage{ \method{posterior_interval}{brmsfit}(object, pars = NA, variable = NULL, prob = 0.95, ...) } \arguments{ \item{object}{An object of class \code{brmsfit}.} \item{pars}{Deprecated alias of \code{variable}. For reasons of backwards compatibility, \code{pars} is interpreted as a vector of regular expressions by default unless \code{fixed = TRUE} is specified.} \item{variable}{A character vector providing the variables to extract. By default, all variables are extracted.} \item{prob}{A value between 0 and 1 indicating the desired probability to be covered by the uncertainty intervals. The default is 0.95.} \item{...}{More arguments passed to \code{\link{as.matrix.brmsfit}}.} } \value{ A \code{matrix} with lower and upper interval bounds as columns and as many rows as selected variables. } \description{ Compute posterior uncertainty intervals for \code{brmsfit} objects. } \examples{ \dontrun{ fit <- brm(count ~ zAge + zBase * Trt, data = epilepsy, family = negbinomial()) posterior_interval(fit) } } brms/man/restructure.Rd0000644000176200001440000000234614572632206014662 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/restructure.R \name{restructure} \alias{restructure} \title{Restructure Old R Objects} \usage{ restructure(x, ...) } \arguments{ \item{x}{An object to be restructured. The object's class will determine which method to apply} \item{...}{Additional arguments to pass to the specific methods} } \value{ An object of the same class as \code{x} compatible with the latest version of the package that generated it. } \description{ \code{restructure} is a generic function used to restructure old R objects to work with newer versions of the package that generated them. Its original use is within the \pkg{brms} package, but new methods for use with objects from other packages can be registered to the same generic. } \details{ Usually the version of the package that generated the object will be stored somewhere in the object and this information will be used by the specific method to determine what transformations to apply. See \code{\link[brms:restructure.brmsfit]{restructure.brmsfit}} for the default method applied for \pkg{brms} models. You can view the available methods by typing: \code{methods(restructure)} } \seealso{ \code{\link{restructure.brmsfit}} } brms/man/InvGaussian.Rd0000644000176200001440000000206414275436221014516 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/distributions.R \name{InvGaussian} \alias{InvGaussian} \alias{dinv_gaussian} \alias{pinv_gaussian} \alias{rinv_gaussian} \title{The Inverse Gaussian Distribution} \usage{ dinv_gaussian(x, mu = 1, shape = 1, log = FALSE) pinv_gaussian(q, mu = 1, shape = 1, lower.tail = TRUE, log.p = FALSE) rinv_gaussian(n, mu = 1, shape = 1) } \arguments{ \item{x, q}{Vector of quantiles.} \item{mu}{Vector of locations.} \item{shape}{Vector of shapes.} \item{log}{Logical; If \code{TRUE}, values are returned on the log scale.} \item{lower.tail}{Logical; If \code{TRUE} (default), return P(X <= x). Else, return P(X > x) .} \item{log.p}{Logical; If \code{TRUE}, values are returned on the log scale.} \item{n}{Number of draws to sample from the distribution.} } \description{ Density, distribution function, and random generation for the inverse Gaussian distribution with location \code{mu}, and shape \code{shape}. } \details{ See \code{vignette("brms_families")} for details on the parameterization. } brms/man/rename_pars.Rd0000644000176200001440000000176214571050211014555 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/rename_pars.R \name{rename_pars} \alias{rename_pars} \title{Rename parameters in brmsfit objects} \usage{ rename_pars(x) } \arguments{ \item{x}{A \code{brmsfit} object.} } \value{ A \code{brmsfit} object with adjusted parameter names. } \description{ Rename parameters within the \code{stanfit} object after model fitting to ensure reasonable parameter names. This function is usually called automatically by \code{\link{brm}} and users will rarely be required to call it themselves. } \details{ Function \code{rename_pars} is a deprecated alias of \code{rename_pars}. } \examples{ \dontrun{ # fit a model manually via rstan scode <- stancode(count ~ Trt, data = epilepsy) sdata <- standata(count ~ Trt, data = epilepsy) stanfit <- rstan::stan(model_code = scode, data = sdata) # feed the Stan model back into brms fit <- brm(count ~ Trt, data = epilepsy, empty = TRUE) fit$fit <- stanfit fit <- rename_pars(fit) summary(fit) } } brms/man/draws-brms.Rd0000644000176200001440000000465614213413565014357 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/posterior.R \name{draws-brms} \alias{draws-brms} \alias{as_draws} \alias{as_draws_matrix} \alias{as_draws_array} \alias{as_draws_df} \alias{as_draws_rvars} \alias{as_draws_list} \alias{as_draws.brmsfit} \alias{as_draws_matrix.brmsfit} \alias{as_draws_array.brmsfit} \alias{as_draws_df.brmsfit} \alias{as_draws_list.brmsfit} \alias{as_draws_rvars.brmsfit} \title{Transform \code{brmsfit} to \code{draws} objects} \usage{ \method{as_draws}{brmsfit}(x, variable = NULL, regex = FALSE, inc_warmup = FALSE, ...) \method{as_draws_matrix}{brmsfit}(x, variable = NULL, regex = FALSE, inc_warmup = FALSE, ...) \method{as_draws_array}{brmsfit}(x, variable = NULL, regex = FALSE, inc_warmup = FALSE, ...) \method{as_draws_df}{brmsfit}(x, variable = NULL, regex = FALSE, inc_warmup = FALSE, ...) \method{as_draws_list}{brmsfit}(x, variable = NULL, regex = FALSE, inc_warmup = FALSE, ...) \method{as_draws_rvars}{brmsfit}(x, variable = NULL, regex = FALSE, inc_warmup = FALSE, ...) } \arguments{ \item{x}{A \code{brmsfit} object or another \R object for which the methods are defined.} \item{variable}{A character vector providing the variables to extract. By default, all variables are extracted.} \item{regex}{Logical; Should variable should be treated as a (vector of) regular expressions? Any variable in \code{x} matching at least one of the regular expressions will be selected. Defaults to \code{FALSE}.} \item{inc_warmup}{Should warmup draws be included? Defaults to \code{FALSE}.} \item{...}{Arguments passed to individual methods (if applicable).} } \description{ Transform a \code{brmsfit} object to a format supported by the \pkg{posterior} package. } \details{ To subset iterations, chains, or draws, use the \code{\link[posterior:subset_draws]{subset_draws}} method after transforming the \code{brmsfit} to a \code{draws} object. } \examples{ \dontrun{ fit <- brm(count ~ zAge + zBase * Trt + (1|patient), data = epilepsy, family = poisson()) # extract posterior draws in an array format (draws_fit <- as_draws_array(fit)) posterior::summarize_draws(draws_fit) # extract only certain variables as_draws_array(fit, variable = "r_patient") as_draws_array(fit, variable = "^b_", regex = TRUE) # extract posterior draws in a random variables format as_draws_rvars(fit) } } \seealso{ \code{\link[posterior:draws]{draws}} \code{\link[posterior:subset_draws]{subset_draws}} } brms/man/loo_subsample.brmsfit.Rd0000644000176200001440000000312214213413565016572 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/loo_subsample.R \name{loo_subsample.brmsfit} \alias{loo_subsample.brmsfit} \alias{loo_subsample} \title{Efficient approximate leave-one-out cross-validation (LOO) using subsampling} \usage{ \method{loo_subsample}{brmsfit}(x, ..., compare = TRUE, resp = NULL, model_names = NULL) } \arguments{ \item{x}{A \code{brmsfit} object.} \item{...}{More \code{brmsfit} objects or further arguments passed to the underlying post-processing functions. In particular, see \code{\link{prepare_predictions}} for further supported arguments.} \item{compare}{A flag indicating if the information criteria of the models should be compared to each other via \code{\link{loo_compare}}.} \item{resp}{Optional names of response variables. If specified, predictions are performed only for the specified response variables.} \item{model_names}{If \code{NULL} (the default) will use model names derived from deparsing the call. Otherwise will use the passed values as model names.} } \description{ Efficient approximate leave-one-out cross-validation (LOO) using subsampling } \details{ More details can be found on \code{\link[loo:loo_subsample]{loo_subsample}}. } \examples{ \dontrun{ # model with population-level effects only fit1 <- brm(rating ~ treat + period + carry, data = inhaler) (loo1 <- loo_subsample(fit1)) # model with an additional varying intercept for subjects fit2 <- brm(rating ~ treat + period + carry + (1|subject), data = inhaler) (loo2 <- loo_subsample(fit2)) # compare both models loo_compare(loo1, loo2) } } brms/man/add_ic.Rd0000644000176200001440000000237414555314073013477 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/loo.R \name{add_loo} \alias{add_loo} \alias{add_waic} \alias{add_ic} \alias{add_ic.brmsfit} \alias{add_ic<-} \title{Add model fit criteria to model objects} \usage{ add_loo(x, model_name = NULL, ...) add_waic(x, model_name = NULL, ...) add_ic(x, ...) \method{add_ic}{brmsfit}(x, ic = "loo", model_name = NULL, ...) add_ic(x, ...) <- value } \arguments{ \item{x}{An \R object typically of class \code{brmsfit}.} \item{model_name}{Optional name of the model. If \code{NULL} (the default) the name is taken from the call to \code{x}.} \item{...}{Further arguments passed to the underlying functions computing the model fit criteria. If you are recomputing an already stored criterion with other \code{...} arguments, make sure to set \code{overwrite = TRUE}.} \item{ic, value}{Names of model fit criteria to compute. Currently supported are \code{"loo"}, \code{"waic"}, \code{"kfold"}, \code{"R2"} (R-squared), and \code{"marglik"} (log marginal likelihood).} } \value{ An object of the same class as \code{x}, but with model fit criteria added for later usage. Previously computed criterion objects will be overwritten. } \description{ Deprecated aliases of \code{\link{add_criterion}}. } brms/man/autocor-terms.Rd0000644000176200001440000000260114361545260015070 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/formula-ac.R \name{autocor-terms} \alias{autocor-terms} \title{Autocorrelation structures} \description{ Specify autocorrelation terms in \pkg{brms} models. Currently supported terms are \code{\link{arma}}, \code{\link{ar}}, \code{\link{ma}}, \code{\link{cosy}}, \code{\link{unstr}}, \code{\link{sar}}, \code{\link{car}}, and \code{\link{fcor}}. Terms can be directly specified within the formula, or passed to the \code{autocor} argument of \code{\link{brmsformula}} in the form of a one-sided formula. For deprecated ways of specifying autocorrelation terms, see \code{\link{cor_brms}}. } \details{ The autocor term functions are almost solely useful when called in formulas passed to the \pkg{brms} package. They do not evaluate its arguments -- but exist purely to help set up a model with autocorrelation terms. } \examples{ # specify autocor terms within the formula y ~ x + arma(p = 1, q = 1) + car(M) # specify autocor terms in the 'autocor' argument bf(y ~ x, autocor = ~ arma(p = 1, q = 1) + car(M)) # specify autocor terms via 'acformula' bf(y ~ x) + acformula(~ arma(p = 1, q = 1) + car(M)) } \seealso{ \code{\link{brmsformula}}, \code{\link{acformula}}, \code{\link{arma}}, \code{\link{ar}}, \code{\link{ma}}, \code{\link{cosy}}, \code{\link{unstr}}, \code{\link{sar}}, \code{\link{car}}, \code{\link{fcor}} } brms/man/unstr.Rd0000644000176200001440000000206114361545260013437 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/formula-ac.R \name{unstr} \alias{unstr} \title{Set up UNSTR correlation structures} \usage{ unstr(time, gr) } \arguments{ \item{time}{An optional time variable specifying the time ordering of the observations. By default, the existing order of the observations in the data is used.} \item{gr}{An optional grouping variable. If specified, the correlation structure is assumed to apply only to observations within the same grouping level.} } \value{ An object of class \code{'unstr_term'}, which is a list of arguments to be interpreted by the formula parsing functions of \pkg{brms}. } \description{ Set up an unstructured (UNSTR) correlation term in \pkg{brms}. The function does not evaluate its arguments -- it exists purely to help set up a model with UNSTR terms. } \examples{ \dontrun{ # add an unstructured correlation matrix for visits within the same patient fit <- brm(count ~ Trt + unstr(visit, patient), data = epilepsy) summary(fit) } } \seealso{ \code{\link{autocor-terms}} } brms/man/car.Rd0000644000176200001440000000464715053072461013042 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/formula-ac.R \name{car} \alias{car} \title{Spatial conditional autoregressive (CAR) structures} \usage{ car(M, gr = NA, type = "escar") } \arguments{ \item{M}{Adjacency matrix of locations. All non-zero entries are treated as if the two locations are adjacent. If \code{gr} is specified, the row names of \code{M} have to match the levels of the grouping factor.} \item{gr}{An optional grouping factor mapping observations to spatial locations. If not specified, each observation is treated as a separate location. It is recommended to always specify a grouping factor to allow for handling of new data in post-processing methods.} \item{type}{Type of the CAR structure. Currently implemented are \code{"escar"} (exact sparse CAR), \code{"esicar"} (exact sparse intrinsic CAR), \code{"icar"} (intrinsic CAR), and \code{"bym2"}. More information is provided in the 'Details' section.} } \value{ An object of class \code{'car_term'}, which is a list of arguments to be interpreted by the formula parsing functions of \pkg{brms}. } \description{ Set up an spatial conditional autoregressive (CAR) term in \pkg{brms}. The function does not evaluate its arguments -- it exists purely to help set up a model with CAR terms. } \details{ The \code{escar} and \code{esicar} types are implemented based on the case study of Max Joseph (\url{https://github.com/mbjoseph/CARstan}). The \code{icar} and \code{bym2} type is implemented based on the case study of Mitzi Morris (\url{https://mc-stan.org/users/documentation/case-studies/icar_stan.html}). } \examples{ \dontrun{ # generate some spatial data east <- north <- 1:10 Grid <- expand.grid(east, north) K <- nrow(Grid) # set up distance and neighbourhood matrices distance <- as.matrix(dist(Grid)) W <- array(0, c(K, K)) W[distance == 1] <- 1 rownames(W) <- 1:nrow(W) # generate the covariates and response data x1 <- rnorm(K) x2 <- rnorm(K) theta <- rnorm(K, sd = 0.05) phi <- rmulti_normal( 1, mu = rep(0, K), Sigma = 0.4 * exp(-0.1 * distance) ) eta <- x1 + x2 + phi prob <- exp(eta) / (1 + exp(eta)) size <- rep(50, K) y <- rbinom(n = K, size = size, prob = prob) g <- 1:length(y) dat <- data.frame(y, size, x1, x2, g) # fit a CAR model fit <- brm(y | trials(size) ~ x1 + x2 + car(W, gr = g), data = dat, data2 = list(W = W), family = binomial()) summary(fit) } } \seealso{ \code{\link{autocor-terms}} } brms/DESCRIPTION0000644000176200001440000001022315060003132012707 0ustar liggesusersPackage: brms Encoding: UTF-8 Type: Package Title: Bayesian Regression Models using 'Stan' Version: 2.23.0 Date: 2025-09-08 Authors@R: c(person("Paul-Christian", "Bürkner", email = "paul.buerkner@gmail.com", role = c("aut", "cre")), person("Jonah", "Gabry", role = c("ctb")), person("Sebastian", "Weber", role = c("ctb")), person("Andrew", "Johnson", role = c("ctb")), person("Martin", "Modrak", role = c("ctb")), person("Hamada S.", "Badr", role = c("ctb")), person("Frank", "Weber", role = c("ctb")), person("Aki", "Vehtari", role = c("ctb")), person("Mattan S.", "Ben-Shachar", role = c("ctb")), person("Hayden", "Rabel", role = c("ctb")), person("Simon C.", "Mills", role = c("ctb")), person("Stephen", "Wild", role = c("ctb")), person("Ven", "Popov", role = c("ctb")), person("Ioannis", "Kosmidis", role = c("ctb")), person("Ben", "Schneider", role = c("ctb")), person("Noa", "Kallioinen", role = c("ctb")), person("Wellington J.", "Silva", role = c("ctb")), person("Luiz", "Carvalho", role = c("ctb")), person("Sermet", "Pekin", role = c("ctb"))) Depends: R (>= 3.6.0), Rcpp (>= 0.12.0), methods Imports: rstan (>= 2.29.0), ggplot2 (>= 2.0.0), loo (>= 2.8.0), posterior (>= 1.6.0), Matrix (>= 1.1.1), mgcv (>= 1.8-13), rstantools (>= 2.1.1), bayesplot (>= 1.5.0), bridgesampling (>= 0.3-0), glue (>= 1.3.0), rlang (>= 1.0.0), future (>= 1.19.0), future.apply (>= 1.0.0), matrixStats, nleqslv, nlme, coda, abind, stats, utils, parallel, grDevices, backports Suggests: testthat (>= 3.1.9), emmeans (>= 1.4.2), cmdstanr (>= 0.5.0), projpred (>= 2.0.0), priorsense (>= 1.0.0), shinystan (>= 2.4.0), splines2 (>= 0.5.0), RWiener, rtdists, extraDistr, processx, mice, spdep, mnormt, lme4, MCMCglmm, ape, arm, statmod, digest, diffobj, betareg, R.rsp, gtable, shiny, knitr, rmarkdown, ragg, colorspace, mirai, future.mirai Description: Fit Bayesian generalized (non-)linear multivariate multilevel models using 'Stan' for full Bayesian inference. A wide range of distributions and link functions are supported, allowing users to fit -- among others -- linear, robust linear, count data, survival, response times, ordinal, zero-inflated, hurdle, and even self-defined mixture models all in a multilevel context. Further modeling options include both theory-driven and data-driven non-linear terms, auto-correlation structures, censoring and truncation, meta-analytic standard errors, and quite a few more. In addition, all parameters of the response distribution can be predicted in order to perform distributional regression. Prior specifications are flexible and explicitly encourage users to apply prior distributions that actually reflect their prior knowledge. Models can easily be evaluated and compared using several methods assessing posterior or prior predictions. References: Bürkner (2017) ; Bürkner (2018) ; Bürkner (2021) ; Carpenter et al. (2017) . LazyData: true NeedsCompilation: no License: GPL-2 URL: https://github.com/paul-buerkner/brms, https://discourse.mc-stan.org/, https://paulbuerkner.com/brms/ BugReports: https://github.com/paul-buerkner/brms/issues Additional_repositories: https://stan-dev.r-universe.dev/ SystemRequirements: pngquant VignetteBuilder: knitr, R.rsp RoxygenNote: 7.3.2 Packaged: 2025-09-09 07:25:22 UTC; paulbuerkner Author: Paul-Christian Bürkner [aut, cre], Jonah Gabry [ctb], Sebastian Weber [ctb], Andrew Johnson [ctb], Martin Modrak [ctb], Hamada S. Badr [ctb], Frank Weber [ctb], Aki Vehtari [ctb], Mattan S. Ben-Shachar [ctb], Hayden Rabel [ctb], Simon C. Mills [ctb], Stephen Wild [ctb], Ven Popov [ctb], Ioannis Kosmidis [ctb], Ben Schneider [ctb], Noa Kallioinen [ctb], Wellington J. Silva [ctb], Luiz Carvalho [ctb], Sermet Pekin [ctb] Maintainer: Paul-Christian Bürkner Repository: CRAN Date/Publication: 2025-09-09 10:50:02 UTC