├── .Rbuildignore ├── .gitignore ├── .travis.yml ├── DESCRIPTION ├── NAMESPACE ├── R ├── bfrm.R ├── bfrm_tools.R ├── brms_like_functions.R ├── contr.bayes.R └── random_effects_code.R ├── README.Rmd ├── README.md ├── bfrms.Rproj ├── development.R ├── development_files ├── ANOVApriors.R ├── alpha_star_and_alpha_dist.R ├── anova_priors_marginal_effects.R ├── compare-1RE-group.Rmd ├── compare-1RE-group.html ├── example_data.R ├── model_warpbreaks.stan ├── prior_pred.pdf ├── priors_and_levels.R └── working_stanmodel_bfrms.stan ├── examples └── examples.contr.bayes.R ├── man ├── bfrm.Rd ├── brms_like.Rd └── contr.bayes.Rd ├── model_warpbreaks.stan └── tests ├── testthat.R └── testthat ├── fhchr.rda ├── test-Machines.R ├── test-contr.R └── test-make_stancode-basics.R /.Rbuildignore: -------------------------------------------------------------------------------- 1 | ^bfrms\.Rproj$ 2 | ^\.Rproj\.user$ 3 | development.R 4 | development_files 5 | ^README\.Rmd$ 6 | ^\.travis\.yml$ 7 | examples 8 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .Rproj.user 2 | .Rhistory 3 | .RData 4 | .Ruserdata 5 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | # R for travis: see documentation at https://docs.travis-ci.com/user/languages/r 2 | 3 | language: R 4 | cache: packages 5 | 6 | before_install: 7 | - mkdir -p ~/.R 8 | - echo "CXX14FLAGS=-O3 -mtune=native -march=native -Wno-unused-variable -Wno-unused-function -Wno-macro-redefined" >> ~/.R/Makevars 9 | - echo "CXX14=g++ -std=c++1y -fPIC" >> ~/.R/Makevars 10 | -------------------------------------------------------------------------------- /DESCRIPTION: -------------------------------------------------------------------------------- 1 | Package: bfrms 2 | Title: Bayes Factors for Bayesian Regression Models using 'Stan' 3 | Version: 0.1-0 4 | Authors@R: c(person(given="Henrik", family="Singmann", role=c("aut", "cre"), 5 | email="singmann@gmail.com", 6 | comment=c(ORCID="0000-0002-4842-3657")), 7 | person(given="Quentin F.", family="Gronau", role="aut", 8 | comment=c(ORCID="0000-0001-5510-6943")), 9 | person(given="Eric-Jan", family="Wagenmakers", role="ctb")) 10 | Description: Allows estimation of (Gaussian) brms 11 | models using the JZS 12 | (Jeffreys-Zellner-Siow) prior following Rouder, Morey, Speckman, and 13 | Province (2012, ). With these models it is 14 | easy to obtain Bayes factors using the bridgesampling 15 | package. 16 | License: GPL (>=2) 17 | Encoding: UTF-8 18 | LazyData: true 19 | Roxygen: list(markdown = TRUE) 20 | RoxygenNote: 6.1.1 21 | Suggests: 22 | testthat (>= 2.1.0), 23 | MEMSS, 24 | BayesFactor, 25 | bridgesampling 26 | Depends: 27 | brms (>= 2.12.11) 28 | Imports: 29 | lme4, 30 | stats 31 | -------------------------------------------------------------------------------- /NAMESPACE: -------------------------------------------------------------------------------- 1 | # Generated by roxygen2: do not edit by hand 2 | 3 | export(bfrm) 4 | export(contr.bayes) 5 | export(make_stancode_bfrms) 6 | export(make_standata_bfrms) 7 | importFrom(brms,brmsformula) 8 | importFrom(brms,is.brmsformula) 9 | importFrom(brms,make_standata) 10 | importFrom(brms,prior_string) 11 | importFrom(brms,stanvar) 12 | importFrom(stats,"contrasts<-") 13 | importFrom(stats,as.formula) 14 | importFrom(stats,gaussian) 15 | importFrom(stats,model.matrix) 16 | importFrom(stats,terms) 17 | importFrom(stats,update.formula) 18 | -------------------------------------------------------------------------------- /R/bfrm.R: -------------------------------------------------------------------------------- 1 | #' Fit Bayesian Linear Mixed Model with JZS Prior 2 | #' 3 | #' @param formula An object of class [`formula`]. 4 | #' @param data An object of class `data.frame` containing all observations and 5 | #' variables used in the model. 6 | #' @param family Currently only [gaussian()] is supported. 7 | #' @param prior_structure character string. Currently only `'jzs'` (for 8 | #' Jeffreys-Zellner-Siow) is supported. 9 | #' @param prior_arg `list` of additional arguments specific to 10 | #' `prior_structure`. For `'jzs'`, these can be `r_fixed` and `r_random`. 11 | #' @param ... Further arguments passed to [brms::brm()] such as `iter`, 12 | #' `warmup`, or `cores`. 13 | #' 14 | #' @export 15 | bfrm <- function(formula, data, 16 | family = gaussian(), 17 | prior_structure = "jzs", prior_arg = list(r_fixed = 0.5, 18 | r_random = 1), 19 | ...) { 20 | dots <- list(...) 21 | if ("save_all_pars" %in% names(dots)) { 22 | dots[["save_all_pars"]] <- NULL 23 | } 24 | brm_args <- prep_brm(formula = formula, 25 | data = data, 26 | family = family, 27 | prior_structure = prior_structure, 28 | prior_arg = prior_arg) 29 | do.call(what = "brm", 30 | args = c( 31 | brm_args, 32 | dots, 33 | save_all_pars = TRUE 34 | )) 35 | 36 | } 37 | 38 | -------------------------------------------------------------------------------- /R/bfrm_tools.R: -------------------------------------------------------------------------------- 1 | check_coding <- function(formula, data) { 2 | if (options("contrasts")[[1]][1] != "contr.bayes") { 3 | model_vars <- all.vars(formula) 4 | factor_vars <- vapply(model_vars, 5 | function(x) 6 | is.factor(data[[x]]) | is.character(data[[x]]), 7 | NA) 8 | vars_change <- model_vars[factor_vars] 9 | for (i in seq_along(vars_change)) { 10 | contrasts(data[[vars_change[i]]]) <- "contr.bayes" 11 | } 12 | if (length(vars_change) > 0) { 13 | message(paste0("Contrasts set to contr.bayes for following variables: ", 14 | paste0(vars_change, collapse=", "))) 15 | } 16 | } 17 | data 18 | } 19 | 20 | check_prior_arg <- function(prior_structure, 21 | prior_arg) { 22 | prior_structure <- match.arg(tolower(prior_structure), "jzs") 23 | if (prior_structure == "jzs") { 24 | ## replace default values with passed values 25 | default_prior_arg <- eval(formals(bfrm)$prior_arg) 26 | out_prior_arg <- default_prior_arg 27 | out_prior_arg[names(prior_arg)] <- prior_arg 28 | } 29 | out_prior_arg 30 | } 31 | 32 | #' @importFrom stats model.matrix as.formula contrasts<- gaussian terms 33 | #' @importFrom stats update.formula 34 | #' @importFrom brms is.brmsformula brmsformula prior_string stanvar 35 | prep_brm <- function(formula, data, 36 | family, 37 | prior_structure, prior_arg) { 38 | 39 | prior_arg <- check_prior_arg(prior_structure = prior_structure, 40 | prior_arg = prior_arg) 41 | 42 | if (is.brmsformula(formula)) { 43 | stop("bfrm currently only supports non-brms formulas.", call. = FALSE) 44 | } else if (inherits(formula, "formula")) { 45 | formula <- update.formula(formula, ~.) 46 | formula_fixed <- lme4::nobars(formula) 47 | if (attr(terms(formula_fixed, data = data), "intercept") == 0) { 48 | stop("formula needs to have an intercept (i.e., no 0/-1)", call. = FALSE) 49 | } 50 | mm <- model.matrix(formula_fixed, data = data) 51 | var_data <- 52 | stanvar(x = prior_arg$r_fixed, name = "r_fixed") + 53 | stanvar(x = prior_arg$r_random, name = "r_random") 54 | if (ncol(mm) > 1) { 55 | intercept_only <- FALSE 56 | brm_family <- jzs_normal 57 | var_llk <- var_likelihood 58 | bf_formula <- brmsformula(update.formula(formula, ~ 0 + .), cmc = FALSE) 59 | var_prior <- prior_string("", class = "sigmaSQ") + 60 | prior_string("", class = "sd") + 61 | prior_string("target += -log(sigmaSQ)", class = "sigmaSQ", check = FALSE) 62 | var_data <- var_data + 63 | stanvar(x = max(attr(mm, "assign")), name = "TRMS") + 64 | stanvar(x = attr(mm, "assign")[-1], name = "b_MAP") 65 | code_model_extra <- if (length(attr(mm, "assign")[-1]) > 1) 66 | var_model_m else var_model_1 67 | } else { 68 | intercept_only <- TRUE 69 | brm_family <- jzs0_normal 70 | var_llk <- var_likelihood0 71 | code_model_extra <- NULL 72 | bf_formula <- brmsformula(formula, cmc = FALSE) 73 | var_prior <- prior_string("", class = "sigmaSQ") + 74 | prior_string("", class = "sd") + 75 | prior_string("target += -log(sigmaSQ)", class = "sigmaSQ", check = FALSE) + 76 | prior_string("", class = "Intercept") 77 | } 78 | } else stop("formula needs to be a formula.", call. = FALSE) 79 | 80 | data <- check_coding(formula, data) 81 | 82 | 83 | 84 | 85 | re_code <- random_effects_code(bf_formula, data) 86 | 87 | stanvars <- var_llk + 88 | stanvar(scode = paste(code_model_extra, re_code$prior, collapse = "\n"), 89 | block = "model") + 90 | stanvar(scode = re_code$scale, 91 | block = "tparameters", 92 | position = "end") + 93 | var_data 94 | 95 | c( 96 | formula = list(bf_formula), 97 | data = list(data), 98 | family = list(brm_family), 99 | stanvars = list(stanvars), 100 | prior = list(var_prior) 101 | ) 102 | } 103 | -------------------------------------------------------------------------------- /R/brms_like_functions.R: -------------------------------------------------------------------------------- 1 | #' brms-like Functions 2 | #' @rdname brms_like 3 | #' @aliases brms_like 4 | #' 5 | #' @description Generate code or data for `brms` models using JSZ-priors to be 6 | #' passed to `Stan`. `make_stancode_bfrms` is the `bfrms` alias of 7 | #' [brms::make_stancode()] and `make_standata_bfrms` is the `bfrms` alias of 8 | #' [brms::make_standata()]. 9 | #' 10 | #' @param ... further arguments passed to the corresponding `brms` function. See 11 | #' their help pages for details. 12 | #' @inheritParams bfrm 13 | #' 14 | #' @return `make_stancode_bfrms` returns the same as [brms::make_stancode()] and 15 | #' `make_standata_bfrms` returns the same as [brms::make_standata()]. 16 | #' 17 | #' @export 18 | make_stancode_bfrms <- function(formula, data, 19 | family = gaussian(), 20 | prior_structure = "jzs", 21 | prior_arg = list(r_fixed = 0.5, r_random = 1), 22 | ...) { 23 | dots <- list(...) 24 | brm_args <- prep_brm(formula = formula, 25 | data = data, 26 | family = family, 27 | prior_structure = prior_structure, 28 | prior_arg = prior_arg) 29 | do.call(what = "make_stancode", 30 | args = c( 31 | brm_args, 32 | dots 33 | )) 34 | } 35 | 36 | #' @rdname brms_like 37 | #' @export 38 | make_standata_bfrms <- function(formula, data, 39 | family = gaussian(), 40 | prior_structure = "jzs", 41 | prior_arg = list(r_fixed = 0.5, r_random = 1), 42 | ...) { 43 | dots <- list(...) 44 | brm_args <- prep_brm(formula = formula, 45 | data = data, 46 | family = family, 47 | prior_structure = prior_structure, 48 | prior_arg = prior_arg) 49 | do.call(what = "make_standata", 50 | args = c( 51 | brm_args, 52 | dots 53 | )) 54 | } 55 | -------------------------------------------------------------------------------- /R/contr.bayes.R: -------------------------------------------------------------------------------- 1 | #' Orthonormal Contrast Matrices for Bayesian Estimation 2 | #' 3 | #' Returns a design or model matrix of orthonormal contrasts such that the 4 | #' marginal prior on all effects is identical. Implementation follows the 5 | #' description in Rouder, Morey, Speckman, & Province (2012, p. 363). 6 | #' 7 | #' @param n a vector of levels for a factor, or the number of levels. 8 | #' @param contrasts logical indicating whether contrasts should be computed. 9 | #' 10 | #' @references Rouder, J. N., Morey, R. D., Speckman, P. L., & Province, J. M. 11 | #' (2012). Default Bayes factors for ANOVA designs. *Journal of Mathematical 12 | #' Psychology*, 56(5), 356-374. https://doi.org/10.1016/j.jmp.2012.08.001 13 | #' 14 | #' @return A `matrix` with n rows and k columns, with k=n-1 if contrasts is 15 | #' `TRUE`` and k=n if contrasts is `FALSE`. 16 | #' 17 | #' @example examples/examples.contr.bayes.R 18 | #' 19 | #' @export 20 | contr.bayes <- function(n, contrasts = TRUE) { 21 | if (length(n) <= 1L) { 22 | if (is.numeric(n) && length(n) == 1L && n > 1L) 23 | TRUE 24 | else stop("not enough degrees of freedom to define contrasts") 25 | } else n <- length(n) 26 | cont <- diag(n) 27 | if (contrasts) { 28 | a <- n 29 | I_a <- diag(a) 30 | J_a <- matrix(1, nrow = a, ncol = a) 31 | Sigma_a <- I_a - J_a/a 32 | cont <- eigen(Sigma_a)$vectors[,seq_len(a-1), drop = FALSE] 33 | } 34 | cont 35 | } 36 | -------------------------------------------------------------------------------- /R/random_effects_code.R: -------------------------------------------------------------------------------- 1 | var_likelihood <- stanvar(scode = " 2 | real jzs_normal_lpdf(real Y, real mu, real sigmaSQ, real interc, real g) { 3 | return normal_lpdf(Y | interc + mu, sqrt(sigmaSQ)); 4 | } 5 | ", block = 'functions') 6 | var_likelihood0 <- stanvar(scode = " 7 | real jzs0_normal_lpdf(real Y, real mu, real sigmaSQ) { 8 | return normal_lpdf(Y | mu, sqrt(sigmaSQ)); 9 | } 10 | ", block = 'functions') 11 | 12 | var_model_1 <- " 13 | target += normal_lpdf(b | 0, sqrt(sigmaSQ * g[1])); 14 | target += inv_gamma_lpdf(g | 0.5, 0.5 * r_fixed^2); 15 | " 16 | 17 | var_model_m <- " 18 | for (k in 1:K) { 19 | target += normal_lpdf(b[k] | 0, sqrt(sigmaSQ * g[b_MAP[k]])); 20 | } 21 | target += inv_gamma_lpdf(g | 0.5, 0.5 * r_fixed^2); 22 | " 23 | 24 | jzs_normal <- custom_family("jzs_normal", 25 | dpars = c("mu", "sigmaSQ", "interc", "g[TRMS]"), 26 | type = "real", 27 | lb = c(NA, 0, NA, 0)) 28 | jzs0_normal <- custom_family("jzs0_normal", 29 | dpars = c("mu", "sigmaSQ"), 30 | type = "real", 31 | lb = c(NA, 0)) 32 | 33 | 34 | #' @importFrom brms make_standata 35 | random_effects_code <- function(formula, data) { 36 | tmpdat <- make_standata(formula, data, 37 | family = jzs_normal) 38 | re_terms <- grep("^M_" , names(tmpdat), value = TRUE) 39 | re_length <- unlist(tmpdat[re_terms]) 40 | 41 | out_prior <- vector("list", length(re_terms)) 42 | out_scale <- vector("list", length(re_terms)) 43 | 44 | prior_template <- " target += log(2) + log(SDi) + inv_gamma_lpdf(SDi^2.0 | 0.5, 0.5 * r_random^2);" 45 | # scale_template <- "r_1_1 = r_1_1 * sqrt(sigmaSQ);" 46 | 47 | for (i in seq_along(re_terms)) { 48 | tmp_prior <- vector("character", re_length[i]) 49 | tmp_scale <- vector("character", re_length[i]) 50 | for (j in seq_len(re_length[i])) { 51 | tmp_prior[j] <- gsub("SDi", paste0("sd_", i, "[", j, "]"), prior_template) 52 | tmp_scale[j] <- paste0(" r_", i, "_", j, " = ", "r_", i, "_", j, " * sqrt(sigmaSQ);") 53 | } 54 | out_prior[[i]] <- tmp_prior 55 | out_scale[[i]] <- tmp_scale 56 | } 57 | return(list( 58 | prior = paste(unlist(out_prior), collapse = "\n"), 59 | scale = paste(unlist(out_scale), collapse = "\n") 60 | )) 61 | } 62 | 63 | 64 | -------------------------------------------------------------------------------- /README.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | output: github_document 3 | --- 4 | 5 | 6 | 7 | ```{r, include = FALSE} 8 | knitr::opts_chunk$set( 9 | collapse = TRUE, 10 | comment = "#>", 11 | fig.path = "man/figures/README-", 12 | out.width = "100%" 13 | ) 14 | ``` 15 | # bfrms 16 | 17 | 18 | [![Travis build status](https://travis-ci.org/bayesstuff/bfrms.svg?branch=master)](https://travis-ci.org/bayesstuff/bfrms) 19 | [![DOI](https://zenodo.org/badge/190761217.svg)](https://zenodo.org/badge/latestdoi/190761217) 20 | 21 | 22 | The goal of bfrms is to ... 23 | 24 | ## Installation 25 | 26 | You can install the released version of bfrms from [CRAN](https://CRAN.R-project.org) with: 27 | 28 | ``` r 29 | ##NOT YET ON CRAN 30 | ``` 31 | 32 | And the development version from [GitHub](https://github.com/) with: 33 | 34 | ``` r 35 | # install.packages("devtools") 36 | devtools::install_github("bayesstuff/bfrms") 37 | ``` 38 | ## Example 39 | 40 | `bfrms::bfrm()` makes it easy to obtain Bayes factors with JZS priors using [`brms`](https://cran.r-project.org/package=brms). To do so, simply call function `bfrm` as you would call `brms::brm()`. The following shows a simple example with the `Machines` data from [`MEMSS`](https://cran.r-project.org/package=MEMSS) and compares it against the results from the [`BayesFactor`](https://cran.r-project.org/package=BayesFactor) package, which it matches within numerical accuracy (rerun both several times to see this equivalence). Note that the `bfrm` model should probably also contain the correlation between the by-worker random-effects parameter. However, this is currently not possible using the `BayesFactor` package which we use as a comparison. Furthermore, the equivalence only holds at the moment if a fixed-effect factor has not more than two levels (that is why we remove `Machine == "B"` from the data). 41 | 42 | Calculating Bayes factors requires appropriate contrast/factor coding that have the same marginal effect on all factor levels. `bfrms` comes with such a factor coding (following Rouder et al., 2012, JMP), `contr.bayes`, and applies it automatically to all factors in the data. Also, note that Bayes factors usually require a lot more samples than necessary for estimation, usually at least an order of magnitude more. Consequently, we retain 24000 post-warmup samples. 43 | 44 | ```{r example, results='hide', warning=FALSE, message=FALSE} 45 | library(bfrms) 46 | data(Machines, package = "MEMSS") 47 | Machines <- droplevels(Machines[Machines$Machine %in% c("A", "C"),]) 48 | 49 | fit1 <- bfrm(score ~ Machine + (Machine||Worker), 50 | Machines, 51 | iter = 25000, warmup = 1000, 52 | cores = 4) 53 | fit0 <- bfrm(score ~ 1 + (Machine||Worker), 54 | Machines, 55 | iter = 25000, warmup = 1000, 56 | cores = 4) 57 | library("bridgesampling") 58 | ``` 59 | 60 | ```{r, message=FALSE} 61 | bayes_factor(fit1, fit0, silent = TRUE) 62 | ``` 63 | 64 | These results replicate the results from the `BayesFactor` package as shown below. Note that we also increase the number of iterations to obtain more reliable estimates of the Bayes factor. 65 | 66 | ```{r, message=FALSE, results='hide'} 67 | library("BayesFactor") 68 | mod1 <- lmBF(score ~ Machine + Worker + Machine:Worker, Machines, 69 | whichRandom = "Worker", iterations = 1e5) 70 | 71 | mod0 <- lmBF(score ~ 1 + Worker + Machine:Worker, Machines, 72 | whichRandom = "Worker", iterations = 1e5) 73 | ``` 74 | 75 | 76 | ```{r} 77 | mod1 / mod0 78 | ``` 79 | 80 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | # bfrms 5 | 6 | 7 | 8 | [![Travis build 9 | status](https://travis-ci.org/bayesstuff/bfrms.svg?branch=master)](https://travis-ci.org/bayesstuff/bfrms) 10 | [![DOI](https://zenodo.org/badge/190761217.svg)](https://zenodo.org/badge/latestdoi/190761217) 11 | 12 | 13 | The goal of bfrms is to … 14 | 15 | ## Installation 16 | 17 | You can install the released version of bfrms from 18 | [CRAN](https://CRAN.R-project.org) with: 19 | 20 | ``` r 21 | ##NOT YET ON CRAN 22 | ``` 23 | 24 | And the development version from [GitHub](https://github.com/) with: 25 | 26 | ``` r 27 | # install.packages("devtools") 28 | devtools::install_github("bayesstuff/bfrms") 29 | ``` 30 | 31 | ## Example 32 | 33 | `bfrms::bfrm()` makes it easy to obtain Bayes factors with JZS priors 34 | using [`brms`](https://cran.r-project.org/package=brms). To do so, 35 | simply call function `bfrm` as you would call `brms::brm()`. The 36 | following shows a simple example with the `Machines` data from 37 | [`MEMSS`](https://cran.r-project.org/package=MEMSS) and compares it 38 | against the results from the 39 | [`BayesFactor`](https://cran.r-project.org/package=BayesFactor) package, 40 | which it matches within numerical accuracy (rerun both several times to 41 | see this equivalence). Note that the `bfrm` model should probably also 42 | contain the correlation between the by-worker random-effects parameter. 43 | However, this is currently not possible using the `BayesFactor` package 44 | which we use as a comparison. Furthermore, the equivalence only holds at 45 | the moment if a fixed-effect factor has not more than two levels (that 46 | is why we remove `Machine == "B"` from the data). 47 | 48 | Calculating Bayes factors requires appropriate contrast/factor coding 49 | that have the same marginal effect on all factor levels. `bfrms` comes 50 | with such a factor coding (following Rouder et al., 2012, JMP), 51 | `contr.bayes`, and applies it automatically to all factors in the data. 52 | Also, note that Bayes factors usually require a lot more samples than 53 | necessary for estimation, usually at least an order of magnitude more. 54 | Consequently, we retain 24000 post-warmup samples. 55 | 56 | ``` r 57 | library(bfrms) 58 | data(Machines, package = "MEMSS") 59 | Machines <- droplevels(Machines[Machines$Machine %in% c("A", "C"),]) 60 | 61 | fit1 <- bfrm(score ~ Machine + (Machine||Worker), 62 | Machines, 63 | iter = 25000, warmup = 1000, 64 | cores = 4) 65 | fit0 <- bfrm(score ~ 1 + (Machine||Worker), 66 | Machines, 67 | iter = 25000, warmup = 1000, 68 | cores = 4) 69 | library("bridgesampling") 70 | ``` 71 | 72 | ``` r 73 | bayes_factor(fit1, fit0, silent = TRUE) 74 | #> Estimated Bayes factor in favor of fit1 over fit0: 99.39783 75 | ``` 76 | 77 | These results replicate the results from the `BayesFactor` package as 78 | shown below. Note that we also increase the number of iterations to 79 | obtain more reliable estimates of the Bayes factor. 80 | 81 | ``` r 82 | library("BayesFactor") 83 | mod1 <- lmBF(score ~ Machine + Worker + Machine:Worker, Machines, 84 | whichRandom = "Worker", iterations = 1e5) 85 | 86 | mod0 <- lmBF(score ~ 1 + Worker + Machine:Worker, Machines, 87 | whichRandom = "Worker", iterations = 1e5) 88 | ``` 89 | 90 | ``` r 91 | mod1 / mod0 92 | #> Bayes factor analysis 93 | #> -------------- 94 | #> [1] Machine + Worker + Machine:Worker : 99.31168 ±1.86% 95 | #> 96 | #> Against denominator: 97 | #> score ~ 1 + Worker + Machine:Worker 98 | #> --- 99 | #> Bayes factor type: BFlinearModel, JZS 100 | ``` 101 | -------------------------------------------------------------------------------- /bfrms.Rproj: -------------------------------------------------------------------------------- 1 | Version: 1.0 2 | 3 | RestoreWorkspace: No 4 | SaveWorkspace: No 5 | AlwaysSaveHistory: Default 6 | 7 | EnableCodeIndexing: Yes 8 | UseSpacesForTab: Yes 9 | NumSpacesForTab: 2 10 | Encoding: UTF-8 11 | 12 | RnwWeave: Sweave 13 | LaTeX: pdfLaTeX 14 | 15 | AutoAppendNewline: Yes 16 | StripTrailingWhitespace: Yes 17 | 18 | BuildType: Package 19 | PackageUseDevtools: Yes 20 | PackageInstallArgs: --no-multiarch --with-keep.source 21 | PackageRoxygenize: rd,collate,namespace 22 | -------------------------------------------------------------------------------- /development.R: -------------------------------------------------------------------------------- 1 | 2 | devtools::load_all() 3 | devtools::document() 4 | devtools::test() 5 | 6 | usethis::use_test("Machines") 7 | library("testthat") 8 | 9 | usethis::use_test("make_stancode-basics") 10 | 11 | usethis::use_readme_rmd() 12 | usethis::use_travis() 13 | 14 | usethis::use_package("lme4") 15 | usethis::use_package("stats") 16 | usethis::use_package("brms", type = "Depends") 17 | 18 | usethis::use_package("MEMSS", type = "Suggests") ## for example data 19 | usethis::use_package("BayesFactor", type = "Suggests") ## for comparisons 20 | usethis::use_package("bridgesampling", type = "Suggests") ## for comparisons 21 | 22 | #usethis::use_testthat() 23 | #usethis::use_roxygen_md() 24 | #usethis::create_package("../bfrms") 25 | -------------------------------------------------------------------------------- /development_files/ANOVApriors.R: -------------------------------------------------------------------------------- 1 | rm(list = ls()) 2 | 3 | library(mvtnorm) 4 | library(MASS) 5 | library(fractional) 6 | 7 | 8 | #------------------------------------------------------------------------------- 9 | # naive sum-to-zero constraint implementation 10 | #------------------------------------------------------------------------------- 11 | 12 | n <- 1e5 13 | amin1 <- 2 14 | hfixed <- 1 15 | g <- 1/rgamma(n, 1/2, hfixed^2/2) 16 | alphamin1 <- sapply(seq_along(g), function(x) rmvnorm(1, sigma = g[x]*diag(amin1))) 17 | 18 | i <- 2 19 | hist(alphamin1[i,][abs(alphamin1[i,]) < 8], probability = TRUE, breaks = 50) 20 | plot(function(x) dcauchy(x, scale = hfixed), add = TRUE, xlim = c(-8, 8)) 21 | 22 | alpha3 <- apply(alphamin1, 2, function(x) -sum(x)) 23 | 24 | round(apply(rbind(alphamin1, alpha3), 2, sum), 3) 25 | 26 | hist(alpha3[abs(alpha3) < 8], probability = TRUE, breaks = 50) 27 | plot(function(x) dcauchy(x, scale = hfixed), add = TRUE, xlim = c(-8, 8)) 28 | # shows that naive sum-to-zero constraint implementation yields more diffuse 29 | # prior on eliminated effect 30 | 31 | #------------------------------------------------------------------------------- 32 | # better projection approach 33 | #------------------------------------------------------------------------------- 34 | 35 | a <- 3 36 | I_a <- diag(a) 37 | J_a <- matrix(1, nrow = a, ncol = a) 38 | Sigma_a <- I_a - J_a/a 39 | Q_a <- eigen(Sigma_a)$vectors[,seq_len(a-1)] 40 | t(Q_a) 41 | fractional(t(Q_a)) 42 | 43 | a <- 2 44 | I_a <- diag(a) 45 | J_a <- matrix(1, nrow = a, ncol = a) 46 | Sigma_a <- I_a - J_a/a 47 | Q_a <- eigen(Sigma_a)$vectors[,seq_len(a-1)] 48 | t(Q_a) 49 | 50 | a <- 5 51 | I_a <- diag(a) 52 | J_a <- matrix(1, nrow = a, ncol = a) 53 | Sigma_a <- I_a - J_a/a 54 | Q_a <- eigen(Sigma_a)$vectors[,seq_len(a-1)] 55 | t(Q_a) 56 | 57 | n <- 1e5 58 | amin1 <- a - 1 59 | hfixed <- 1 60 | g <- 1/rgamma(n, 1/2, hfixed^2/2) 61 | alphamin1 <- sapply(seq_along(g), function(x) rmvnorm(1, sigma = g[x]*diag(amin1))) 62 | 63 | i <- 3 64 | hist(alphamin1[i,][abs(alphamin1[i,]) < 8], probability = TRUE, breaks = 50) 65 | plot(function(x) dcauchy(x, scale = hfixed), add = TRUE, xlim = c(-8, 8)) 66 | 67 | 68 | # convert back to alpha (solve alphamin1 = t(Q_a) %*% alpha for alpha using SVD) 69 | svdtQ <- svd(t(Q_a)) 70 | Qdiag <- diag(1/svdtQ$d) 71 | alpha <- svdtQ$v %*% Qdiag %*% t(svdtQ$u) %*% alphamin1 72 | 73 | for (i in seq_len(a)) { 74 | Sys.sleep(1) 75 | hist(alpha[i,][abs(alpha[i,]) < 10], probability = TRUE, breaks = 20) 76 | plot(function(x) dcauchy(x, scale = hfixed), add = TRUE, xlim = c(-8, 8)) 77 | } 78 | # all marginal priors identical 79 | -------------------------------------------------------------------------------- /development_files/alpha_star_and_alpha_dist.R: -------------------------------------------------------------------------------- 1 | 2 | library("mvtnorm") 3 | library("tidyverse") 4 | theme_set(theme_bw(base_size = 15) + 5 | theme(legend.position="bottom", 6 | panel.grid.major.x = element_blank())) 7 | 8 | NSAMPLES <- 1e5 9 | FAC_LEVELS <- c(2, 3, 4, 5, 6) 10 | xlim <- c(-10, 10) 11 | 12 | 13 | ################################################################# 14 | ## Step 1: Sample alpha* ## 15 | ################################################################# 16 | 17 | ## two different generation functions: 18 | gen_alphas_g <- function(levels, n, hfixed = 1) { ## hfixed is rfixed in BayesFactor 19 | amin1 <- levels - 1 20 | g <- 1/rgamma(n, 1/2, hfixed^2/2) 21 | alphamin1 <- lapply( 22 | X = seq_along(g), 23 | FUN = function(x) rmvnorm(1, sigma = g[x]*diag(amin1)) 24 | ) 25 | do.call("rbind", alphamin1) 26 | } 27 | 28 | gen_alphas_mvc <- function(levels, n, hfixed = 1) { ## hfixed is rfixed in BayesFactor 29 | amin <- levels - 1 30 | sigma <- diag(amin) 31 | diag(sigma) <- hfixed^2 32 | mvtnorm::rmvt(n, sigma = sigma, df = 1) 33 | } 34 | 35 | alpha_star_g <- vector("list", length(FAC_LEVELS)) 36 | alpha_star_mvc <- vector("list", length(FAC_LEVELS)) 37 | 38 | for (i in seq_along(FAC_LEVELS)) { 39 | alpha_star_g[[i]] <- gen_alphas_g(FAC_LEVELS[i], n = NSAMPLES) 40 | # cat("\nalpha star (g) cor (with ", FAC_LEVELS[i], " levels):\n", sep = "") 41 | # print(cor(alpha_star_g[[i]])) 42 | alpha_star_mvc[[i]] <- gen_alphas_mvc(FAC_LEVELS[i], n = NSAMPLES) 43 | # cat("\nalpha star (mvc) cor (with ", FAC_LEVELS[i], " levels):\n", sep = "") 44 | # print(cor(alpha_star_mvc[[i]])) 45 | } 46 | 47 | ### plot marginal priors 48 | 49 | ## create reference line 50 | ref <- tibble( 51 | value = seq(xlim[1], xlim[2], length.out = 201) 52 | ) %>% 53 | mutate(cauchy_0_7 = dcauchy(value, 0, scale = sqrt(2)/2), 54 | cauchy_1_0 = dcauchy(value, 0, scale = 1)) %>% 55 | pivot_longer(cols = -value, names_to = "cauchy", values_to = "density") 56 | 57 | ## function for transforming parameters to longn format for printing 58 | transform_par_long <- function(mat, alphas = TRUE, 59 | prefix = if (alphas) "P" else "L", 60 | nlev) { 61 | if (!is.matrix(mat)) mat <- matrix(mat, ncol = 1) 62 | if (missing(nlev) & alphas) { 63 | nlev <- ncol(mat) + 1 64 | } 65 | else if (missing(nlev) & !alphas) { 66 | nlev <- ncol(mat) 67 | } 68 | colnames(mat) <- paste0(prefix, "_", seq_len(ncol(mat))) 69 | out <- as_tibble(mat) 70 | out <- mutate(out, levels = paste(nlev, "Levels")) 71 | pivot_longer(out, -levels) 72 | } 73 | 74 | ## combine both variants 75 | alpha_star <- bind_rows( 76 | mutate(map_dfr(alpha_star_g, transform_par_long), generated = "g"), 77 | mutate(map_dfr(alpha_star_mvc, transform_par_long), generated = "mvc") 78 | ) 79 | 80 | 81 | ### all priors of alpha star are marginally cauchy: 82 | alpha_star %>% 83 | ggplot(aes(value)) + 84 | geom_density(aes(color = generated), size = 1) + 85 | geom_line(data = ref, aes(x = value, y = density, linetype = cauchy), 86 | color = "black") + 87 | facet_grid(rows = vars(name), cols = vars(levels)) + 88 | xlim(xlim) 89 | 90 | 91 | ### repeat with different prior scale: 92 | alpha_star_g2 <- vector("list", length(FAC_LEVELS)) 93 | alpha_star_mvc2 <- vector("list", length(FAC_LEVELS)) 94 | 95 | for (i in seq_along(FAC_LEVELS)) { 96 | alpha_star_g2[[i]] <- gen_alphas_g(FAC_LEVELS[i], n = NSAMPLES, hfixed = sqrt(2)/2) 97 | alpha_star_mvc2[[i]] <- gen_alphas_mvc(FAC_LEVELS[i], n = NSAMPLES, hfixed = sqrt(2)/2) 98 | } 99 | 100 | ## combine both variants 101 | alpha_star2 <- bind_rows( 102 | mutate(map_dfr(alpha_star_g2, transform_par_long), generated = "g"), 103 | mutate(map_dfr(alpha_star_mvc2, transform_par_long), generated = "mvc") 104 | ) 105 | 106 | ### all priors of alpha star are marginally cauchy: 107 | alpha_star2 %>% 108 | ggplot(aes(value)) + 109 | geom_density(aes(color = generated), size = 1) + 110 | geom_line(data = ref, aes(x = value, y = density, linetype = cauchy), 111 | color = "black") + 112 | facet_grid(rows = vars(name), cols = vars(levels)) + 113 | xlim(xlim) 114 | 115 | ## function for transforming parameters to pairs and long 116 | transform_pairs_long <- function(mat, alphas = TRUE) { 117 | if (!is.matrix(mat) | ncol(mat) == 1) { 118 | return(transform_par_long(mat, prefix = "D", nlev = 1)) 119 | } else { 120 | k <- ncol(mat) 121 | outmat <- matrix(NA_real_, nrow = nrow(mat), ncol = (k*(k-1))/2) 122 | c <- 1 123 | for (i in seq_len(k)) { 124 | for (j in seq_len(k)) { 125 | if (i == j) next 126 | if (i > j) next 127 | #print(c) 128 | outmat[,c] <- mat[,i] - mat[,j] 129 | c <- c+1 130 | } 131 | } 132 | return(transform_par_long(outmat, prefix = "D", nlev = ncol(mat) + alphas)) 133 | } 134 | } 135 | 136 | diff_star <- bind_rows( 137 | mutate(map_dfr(alpha_star_g, transform_pairs_long), generated = "g"), 138 | mutate(map_dfr(alpha_star_mvc, transform_pairs_long), generated = "mvc") 139 | ) 140 | 141 | ### prior of difference of alpha star 142 | diff_star %>% 143 | ggplot(aes(value)) + 144 | geom_density(aes(color = generated), size = 1) + 145 | geom_line(data = ref, aes(x = value, y = density, linetype = cauchy), 146 | color = "black") + 147 | facet_grid(rows = vars(name), cols = vars(levels)) + 148 | xlim(xlim) 149 | 150 | 151 | 152 | ################################################################## 153 | ## Step 2: Transform alpha* to alpha with Q ## 154 | ################################################################## 155 | 156 | 157 | ## creates Q matrix 158 | contr.bayes <- function(n, contrasts = TRUE) { 159 | if (length(n) <= 1L) { 160 | if (is.numeric(n) && length(n) == 1L && n > 1L) 161 | TRUE 162 | else stop("not enough degrees of freedom to define contrasts") 163 | } else n <- length(n) 164 | cont <- diag(n) 165 | if (contrasts) { 166 | a <- n 167 | I_a <- diag(a) 168 | J_a <- matrix(1, nrow = a, ncol = a) 169 | Sigma_a <- I_a - J_a/a 170 | cont <- eigen(Sigma_a)$vectors[,seq_len(a-1), drop = FALSE] 171 | } 172 | cont 173 | } 174 | 175 | transform_alphas_and_make_long <- function(mat, fin_fun = transform_par_long) { 176 | if (!is.matrix(mat)) mat <- matrix(mat, ncol = 1) 177 | nlevels <- ncol(mat) + 1 178 | mmat <- contr.bayes(nlevels) 179 | mat_out <- t(mmat %*% t(mat)) 180 | fin_fun(mat_out, alphas = FALSE) 181 | } 182 | 183 | ## alpha = Q * alpha* 184 | alpha <- bind_rows( 185 | mutate(map_dfr(alpha_star_g, transform_alphas_and_make_long), generated = "g"), 186 | mutate(map_dfr(alpha_star_mvc, transform_alphas_and_make_long), generated = "mvc") 187 | ) 188 | 189 | alpha %>% 190 | ggplot(aes(value)) + 191 | geom_density(aes(color = generated), size = 1) + 192 | geom_line(data = ref, aes(x = value, y = density, linetype = cauchy), 193 | color = "black") + 194 | facet_grid(rows = vars(name), cols = vars(levels)) + 195 | xlim(xlim) 196 | 197 | ## alpha = Q * alpha* 198 | alpha2 <- bind_rows( 199 | mutate(map_dfr(alpha_star_g2, transform_alphas_and_make_long), generated = "g"), 200 | mutate(map_dfr(alpha_star_mvc2, transform_alphas_and_make_long), generated = "mvc") 201 | ) 202 | 203 | alpha2 %>% 204 | ggplot(aes(value)) + 205 | geom_density(aes(color = generated), size = 1) + 206 | geom_line(data = ref, aes(x = value, y = density, linetype = cauchy), 207 | color = "black") + 208 | facet_grid(rows = vars(name), cols = vars(levels)) + 209 | xlim(xlim) 210 | 211 | ## prior of differences 212 | 213 | alpha_dff <- bind_rows( 214 | mutate(map_dfr(alpha_star_g, 215 | ~transform_alphas_and_make_long(., fin_fun = transform_pairs_long)), 216 | generated = "g"), 217 | mutate(map_dfr(alpha_star_mvc, 218 | ~transform_alphas_and_make_long(., fin_fun = transform_pairs_long)), 219 | generated = "mvc") 220 | ) 221 | 222 | ### prior of difference of alpha star 223 | alpha_dff %>% 224 | filter(as.numeric(substr(name, 3, 4)) < 6) %>% 225 | ggplot(aes(value)) + 226 | geom_density(aes(color = generated), size = 1) + 227 | geom_line(data = ref, aes(x = value, y = density, linetype = cauchy), 228 | color = "black") + 229 | facet_grid(rows = vars(name), cols = vars(levels)) + 230 | xlim(xlim) 231 | 232 | 233 | ################################################################## 234 | ## 5 Levels and Prior Scaling ## 235 | ################################################################## 236 | 237 | #### check case of 5 levels: 238 | alpha_star_mvc_5l <- gen_alphas_mvc(5, n = NSAMPLES) 239 | alpha_star_mvc_5l_l <- transform_par_long(alpha_star_mvc_5l) %>% 240 | mutate(scale = "alpha* (n - 1)") %>% 241 | mutate(name = str_replace(name, "P", "L")) 242 | alpha_mvc_5l_l <- transform_alphas_and_make_long(alpha_star_mvc_5l) %>% 243 | mutate(scale = "alpha (n)") 244 | 245 | ref <- tibble( 246 | value = seq(xlim[1], xlim[2], length.out = 201) 247 | ) %>% 248 | mutate(cauchy_0_9 = dcauchy(value, 0, scale = max(contr.bayes(5))), 249 | cauchy_1_0 = dcauchy(value, 0, scale = 1)) %>% 250 | pivot_longer(cols = -value, names_to = "cauchy", values_to = "density") 251 | 252 | bind_rows(alpha_star_mvc_5l_l, alpha_mvc_5l_l) %>% 253 | ggplot(aes(value)) + 254 | geom_density(size = 1, color = "red") + 255 | geom_line(data = ref, aes(x = value, y = density, linetype = cauchy), 256 | color = "black") + 257 | facet_grid(rows = vars(name), cols = vars(scale)) + 258 | xlim(xlim) 259 | -------------------------------------------------------------------------------- /development_files/anova_priors_marginal_effects.R: -------------------------------------------------------------------------------- 1 | 2 | library("mvtnorm") 3 | library("tidyverse") 4 | theme_set(theme_bw(base_size = 15) + 5 | theme(legend.position="bottom", 6 | panel.grid.major.x = element_blank())) 7 | 8 | NSAMPLES <- 1e5 9 | 10 | ### functions ### 11 | 12 | contr.bayes <- function(n, contrasts = TRUE) { 13 | if (length(n) <= 1L) { 14 | if (is.numeric(n) && length(n) == 1L && n > 1L) 15 | TRUE 16 | else stop("not enough degrees of freedom to define contrasts") 17 | } else n <- length(n) 18 | cont <- diag(n) 19 | if (contrasts) { 20 | a <- n 21 | I_a <- diag(a) 22 | J_a <- matrix(1, nrow = a, ncol = a) 23 | Sigma_a <- I_a - J_a/a 24 | cont <- eigen(Sigma_a)$vectors[,seq_len(a-1), drop = FALSE] 25 | } 26 | cont 27 | } 28 | 29 | rand_b_anova <- function(levels, n, hfixed = 1) { 30 | amin1 <- levels - 1 31 | g <- 1/rgamma(n, 1/2, hfixed^2/2) 32 | alphamin1 <- lapply( 33 | X = seq_along(g), 34 | FUN = function(x) rmvnorm(1, sigma = g[x]*diag(amin1)) 35 | ) 36 | do.call("rbind", alphamin1) 37 | } 38 | 39 | transform_b_to_levels <- function(bmat) { 40 | nlevels <- ncol(bmat) + 1 41 | mmat <- contr.bayes(nlevels) 42 | #mmat <- mmat / max(mmat) 43 | mat_out <- matrix(NA_real_, nrow = nrow(bmat), ncol = nlevels) 44 | for (i in seq_len(nlevels)) { 45 | mat_out[,i] <- bmat %*% t(mmat[i, , drop = FALSE]) 46 | } 47 | colnames(mat_out) <- paste0("L", seq_len(nlevels)) 48 | as_tibble(mat_out) 49 | } 50 | 51 | ### main code 52 | 53 | ef_2levels <- transform_b_to_levels(rand_b_anova(2, NSAMPLES)) %>% 54 | mutate(levels = "2 Levels") %>% 55 | pivot_longer(cols = -levels) 56 | ef_3levels <- transform_b_to_levels(rand_b_anova(3, NSAMPLES)) %>% 57 | mutate(levels = "3 Levels") %>% 58 | pivot_longer(cols = -levels) 59 | ef_6levels <- transform_b_to_levels(rand_b_anova(6, NSAMPLES)) %>% 60 | mutate(levels = "6 Levels") %>% 61 | pivot_longer(cols = -levels) 62 | 63 | xlim <- c(-10, 10) ## to focus on area where it matters 64 | ref <- tibble( 65 | value = seq(xlim[1], xlim[2], length.out = 201) 66 | ) %>% 67 | mutate(cauchy_07 = dcauchy(value, 0, scale = sqrt(2)/2), 68 | cauchy_1 = dcauchy(value, 0, scale = 1)) %>% 69 | pivot_longer(cols = -value, names_to = "cauchy", values_to = "density") 70 | 71 | bind_rows(ef_2levels, ef_3levels, ef_6levels) %>% 72 | ggplot(aes(value)) + 73 | geom_density(size = 1) + 74 | geom_line(data = ref, aes(x = value, y = density, linetype = cauchy), 75 | color = "red") + 76 | facet_grid(rows = vars(name), cols = vars(levels)) + 77 | xlim(xlim) 78 | ggsave("prior_pred.pdf", width = 10, height = 12) 79 | -------------------------------------------------------------------------------- /development_files/compare-1RE-group.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "Compare bfrms Against BayesFactor with 1-RE Grouping Factor" 3 | output: html_document 4 | --- 5 | 6 | # Prepare Data and Load Packages 7 | 8 | ```{r, message=FALSE, warning=FALSE} 9 | data("fhch2010", package = "afex") 10 | 11 | library("tidyverse") 12 | library("bfrms") 13 | library("BayesFactor") 14 | 15 | fhch <- as_tibble(fhch2010) %>% 16 | filter(correct) 17 | 18 | fhch2 <- fhch %>% 19 | group_by(id, stimulus) %>% 20 | nest() %>% 21 | mutate(samp = map(data, ~.[1:5,])) %>% 22 | select(id, stimulus, samp) %>% 23 | unnest() 24 | ``` 25 | 26 | # Example 1: Single Fixed Effect w/o Random-Slope 27 | 28 | Task (lexical-decision versus naming) is a between-subjects factor so we only estimate by-participant random intercepts. 29 | 30 | ## Compute Bayes Factor with bfrms 31 | ```{r, message=FALSE, results='hide'} 32 | fit1 <- bfrm(rt ~ task + (1|id), 33 | fhch2, 34 | iter = 25000, warmup = 1000, 35 | cores = 4, 36 | prior_arg = list(r_fixed = 0.5, r_random = 1)) 37 | fit01 <- bfrm(rt ~ 1 + (1|id), 38 | fhch2, 39 | iter = 25000, warmup = 1000, 40 | cores = 4, 41 | prior_arg = list(r_fixed = 0.5, r_random = 1)) 42 | ``` 43 | 44 | ```{r} 45 | bayes_factor(fit1, fit01, silent = TRUE) 46 | ``` 47 | 48 | ## Compare to BayesFactor 49 | ```{r, message=FALSE, warning=FALSE} 50 | mod1 <- lmBF(rt ~ task + id, fhch2, whichRandom = "id", 51 | rscaleFixed = 0.5, rscaleRandom = 1) 52 | mod01 <- lmBF(rt ~ 1 + id, fhch2, whichRandom = "id", 53 | rscaleFixed = 0.5, rscaleRandom = 1) 54 | mod1 / mod01 55 | ``` 56 | 57 | # Example 2: Single Fixed Effect with Random Slopes 58 | 59 | Stimulus (word versus nonword) is a within-subjects factor so we estimate by-participant random intercepts plus by-participants random slopes for stimulus which allow every `id` to have their own idiosyncratic effect of stimulus. 60 | 61 | ## Compute Bayes Factor with bfrms 62 | ```{r, message=FALSE, results='hide'} 63 | fit2 <- bfrm(rt ~ stimulus + (stimulus||id), 64 | fhch2, 65 | iter = 25000, warmup = 1000, 66 | cores = 4, 67 | prior_arg = list(r_fixed = 0.5, r_random = 1)) 68 | fit02 <- bfrm(rt ~ 1 + (stimulus||id), 69 | fhch2, 70 | iter = 25000, warmup = 1000, 71 | cores = 4, 72 | prior_arg = list(r_fixed = 0.5, r_random = 1)) 73 | ``` 74 | 75 | ```{r} 76 | bayes_factor(fit2, fit02, silent = TRUE) 77 | ``` 78 | 79 | ## Compare to BayesFactor 80 | ```{r, message=FALSE, warning=FALSE} 81 | mod2 <- lmBF(rt ~ stimulus + id + stimulus:id, fhch2, 82 | whichRandom = c("id", "stimulus:id"), 83 | rscaleFixed = 0.5, rscaleRandom = 1) 84 | mod02 <- lmBF(rt ~ 1 + id + stimulus:id, fhch2, 85 | whichRandom = c("id", "stimulus:id"), 86 | rscaleFixed = 0.5, rscaleRandom = 1) 87 | mod2 / mod02 88 | ``` 89 | 90 | # Example 3: Two Fixed Effects (Main Effect, but not Interaction) 91 | 92 | We again have by-participant random intercept plus random slope for stimulus. 93 | 94 | ## Compute Bayes Factor with bfrms 95 | ```{r, message=FALSE, results='hide'} 96 | fit3 <- bfrm(rt ~ task + stimulus + (stimulus||id), 97 | fhch2, 98 | iter = 25000, warmup = 1000, 99 | cores = 4, 100 | prior_arg = list(r_fixed = 0.5, r_random = 1)) 101 | fit03_1 <- bfrm(rt ~ stimulus + (stimulus||id), 102 | fhch2, 103 | iter = 25000, warmup = 1000, 104 | cores = 4, 105 | prior_arg = list(r_fixed = 0.5, r_random = 1)) 106 | fit03_2 <- bfrm(rt ~ task + (stimulus||id), 107 | fhch2, 108 | iter = 25000, warmup = 1000, 109 | cores = 4, 110 | prior_arg = list(r_fixed = 0.5, r_random = 1)) 111 | ``` 112 | 113 | ```{r} 114 | bayes_factor(fit3, fit03_1, silent = TRUE) 115 | bayes_factor(fit3, fit03_2, silent = TRUE) 116 | ``` 117 | 118 | ## Compare to BayesFactor 119 | ```{r, message=FALSE, warning=FALSE} 120 | mod3 <- lmBF(rt ~ task + 121 | stimulus + id + stimulus:id, fhch2, 122 | whichRandom = c("id", "stimulus:id"), 123 | rscaleFixed = 0.5, rscaleRandom = 1) 124 | mod03_1 <- lmBF(rt ~ stimulus + id + stimulus:id, fhch2, 125 | whichRandom = c("id", "stimulus:id"), 126 | rscaleFixed = 0.5, rscaleRandom = 1) 127 | mod03_2 <- lmBF(rt ~ task + id + stimulus:id, fhch2, 128 | whichRandom = c("id", "stimulus:id"), 129 | rscaleFixed = 0.5, rscaleRandom = 1) 130 | mod3 / mod03_1 131 | mod3 / mod03_2 132 | ``` 133 | 134 | # Example 4: Three Fixed Effects (Main Effects plus Interaction) 135 | ## Compute Bayes Factor with bfrms 136 | ```{r, message=FALSE, results='hide'} 137 | fit4 <- bfrm(rt ~ task*stimulus + (stimulus||id), 138 | fhch2, 139 | iter = 25000, warmup = 1000, 140 | cores = 4, 141 | prior_arg = list(r_fixed = 0.5, r_random = 1)) 142 | fit04 <- bfrm(rt ~ task + stimulus + (stimulus||id), 143 | fhch2, 144 | iter = 25000, warmup = 1000, 145 | cores = 4, 146 | prior_arg = list(r_fixed = 0.5, r_random = 1)) 147 | ``` 148 | 149 | ```{r} 150 | bayes_factor(fit4, fit04, silent = TRUE) 151 | ``` 152 | 153 | ## Compare to BayesFactor 154 | ```{r, message=FALSE, warning=FALSE} 155 | mod4 <- lmBF(rt ~ task + stimulus + task:stimulus + 156 | id + stimulus:id, fhch2, 157 | whichRandom = c("id", "stimulus:id"), 158 | rscaleFixed = 0.5, rscaleRandom = 1) 159 | mod04 <- lmBF(rt ~ task + stimulus + 160 | id + stimulus:id, fhch2, 161 | whichRandom = c("id", "stimulus:id"), 162 | rscaleFixed = 0.5, rscaleRandom = 1) 163 | mod4 / mod04 164 | ``` 165 | -------------------------------------------------------------------------------- /development_files/example_data.R: -------------------------------------------------------------------------------- 1 | 2 | data("fhch2010", package = "afex") 3 | 4 | library("tidyverse") 5 | 6 | fhch <- as_tibble(fhch2010) %>% 7 | filter(correct) 8 | 9 | fhch2 <- fhch %>% 10 | group_by(id, stimulus) %>% 11 | nest() %>% 12 | mutate(samp = map(data, ~.[1:5,])) %>% 13 | select(id, stimulus, samp) %>% 14 | unnest() 15 | 16 | fhchr <- as.data.frame(fhch2) 17 | save(fhchr, file = "tests/testthat/fhchr.rda") 18 | 19 | #### 20 | fit1 <- bfrm(rt ~ task + (1|id), 21 | fhch2, 22 | iter = 25000, warmup = 1000, 23 | cores = 4) 24 | 25 | summary(fit1) 26 | # Family: jzs_normal 27 | # Links: mu = identity; sigmaSQ = identity; interc = identity; g = identity 28 | # Formula: rt ~ 0 + task + (1 | id) 29 | # Data: structure(list(id = structure(c(1L, 1L, 1L, 1L, 1L (Number of observations: 450) 30 | # Samples: 4 chains, each with iter = 25000; warmup = 1000; thin = 1; 31 | # total post-warmup samples = 96000 32 | # 33 | # Group-Level Effects: 34 | # ~id (Number of levels: 45) 35 | # Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat 36 | # sd(Intercept) 0.59 0.09 0.43 0.77 31505 1.00 37 | # 38 | # Population-Level Effects: 39 | # Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat 40 | # task1 0.15 0.07 0.02 0.28 47630 1.00 41 | # 42 | # Family Specific Parameters: 43 | # Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat 44 | # sigmaSQ 0.22 0.02 0.19 0.25 114615 1.00 45 | # interc 1.07 0.05 0.98 1.17 48186 1.00 46 | # g 5.67 645.02 0.05 7.23 83792 1.00 47 | # 48 | # Samples were drawn using sampling(NUTS). For each parameter, Eff.Sample 49 | # is a crude measure of effective sample size, and Rhat is the potential 50 | # scale reduction factor on split chains (at convergence, Rhat = 1). 51 | 52 | #### 53 | 54 | library("afex") 55 | afex_options("method_mixed" = "S") 56 | 57 | m_task_1 <- mixed(rt ~ task + (1|id), fhch) 58 | m_task_1 59 | 60 | m_task_2 <- mixed(rt ~ task + (1|id) + (1|item), fhch) 61 | m_task_2 62 | 63 | m_task_3 <- mixed(rt ~ task + (1|id) + (task||item), fhch, expand_re = TRUE) 64 | m_task_3 65 | summary(m_task_3) 66 | 67 | m_task_4 <- mixed(rt ~ task + (1|id) + (task|item), fhch, expand_re = TRUE) 68 | m_task_4 69 | summary(m_task_4) 70 | -------------------------------------------------------------------------------- /development_files/model_warpbreaks.stan: -------------------------------------------------------------------------------- 1 | // generated with brms 2.12.11 2 | functions { 3 | 4 | real jzs_normal_lpdf(real Y, real mu, real sigmaSQ, real interc, real g) { 5 | return normal_lpdf(Y | interc + mu, sqrt(sigmaSQ)); 6 | } 7 | 8 | } 9 | data { 10 | int N; // number of observations 11 | vector[N] Y; // response variable 12 | int K; // number of population-level effects 13 | matrix[N, K] X; // population-level design matrix 14 | // data for group-level effects of ID 1 15 | int N_1; // number of grouping levels 16 | int M_1; // number of coefficients per level 17 | int J_1[N]; // grouping indicator per observation 18 | // group-level predictor values 19 | vector[N] Z_1_1; 20 | int prior_only; // should the likelihood be ignored? 21 | real r_fixed; 22 | real r_random; 23 | int TRMS; 24 | int b_MAP[5]; 25 | } 26 | transformed data { 27 | } 28 | parameters { 29 | vector[K] b; // population-level effects 30 | real sigmaSQ; 31 | real interc; 32 | real g[TRMS]; 33 | // vector[M_1] sd_1; // group-level standard deviations 34 | // vector[N_1] z_1[M_1]; // standardized group-level effects 35 | } 36 | transformed parameters { 37 | // vector[N_1] r_1_1; // actual group-level effects 38 | // r_1_1 = (sd_1[1] * (z_1[1])); 39 | // r_1_1 = r_1_1 * sqrt(sigmaSQ); 40 | } 41 | model { 42 | // initialize linear predictor term 43 | vector[N] mu = X * b; 44 | 45 | for (k in 1:K) { 46 | target += normal_lpdf(b[k] | 0, sqrt(sigmaSQ * g[b_MAP[k]])); 47 | } 48 | target += inv_gamma_lpdf(g | 0.5, 0.5 * r_fixed^2); 49 | // target += log(2) + log(sd_1[1]) + inv_gamma_lpdf(sd_1[1]^2.0 | 0.5, 0.5 * r_random^2); 50 | // for (n in 1:N) { 51 | // add more terms to the linear predictor 52 | // mu[n] += r_1_1[J_1[n]] * Z_1_1[n]; 53 | // } 54 | // priors including all constants 55 | // target += std_normal_lpdf(z_1[1]); 56 | target += -log(sigmaSQ); 57 | // likelihood including all constants 58 | if (!prior_only) { 59 | for (n in 1:N) { 60 | target += jzs_normal_lpdf(Y[n] | mu[n], sigmaSQ, interc, g[TRMS]); 61 | } 62 | } 63 | } 64 | generated quantities { 65 | } 66 | -------------------------------------------------------------------------------- /development_files/prior_pred.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/bayesstuff/bfrms/aa480a92179262b33284da36e90faef706428401/development_files/prior_pred.pdf -------------------------------------------------------------------------------- /development_files/priors_and_levels.R: -------------------------------------------------------------------------------- 1 | 2 | warpbreaks$id <- 1:nrow(warpbreaks) 3 | 4 | fit_warpbreaks <- bfrm( 5 | breaks ~ wool * tension + 6 | (1|id), data = warpbreaks, 7 | warmup = 1000, iter = 2000, chains = 2, cores = 1, 8 | sample_prior = "only") 9 | 10 | 11 | code_warpbreaks <- make_stancode_bfrms( 12 | breaks ~ wool * tension + 13 | (1|id), data = warpbreaks, 14 | save_model = "development_files/model_warpbreaks.stan") 15 | 16 | data_warpbreaks <- make_standata_bfrms( 17 | breaks ~ wool * tension + 18 | (1|id), data = warpbreaks) 19 | 20 | data_warpbreaks$prior_only <- 1 21 | data_warpbreaks$X 22 | 23 | prior_warpbreaks <- rstan::stan( 24 | file = "development_files/model_warpbreaks.stan", 25 | data = data_warpbreaks, warmup = 1000, iter = 11000, 26 | ) 27 | prior_warpbreaks 28 | 29 | summary(prior_warpbreaks) 30 | 31 | samps <- rstan::As.mcmc.list(prior_warpbreaks) 32 | 33 | bayesplot::mcmc_dens(prior_warpbreaks, regex_pars = "^b") + 34 | ggplot2::coord_cartesian(xlim = c(-10, 10)) 35 | 36 | bayesplot::mcmc_hist_by_chain(prior_warpbreaks, regex_pars = "^b", binwidth = 5) + 37 | ggplot2::xlim(c(-1000, 1000)) 38 | 39 | 40 | bayesplot::mcmc_trace(prior_warpbreaks, regex_pars = "^b") 41 | 42 | ### re-transform: 43 | samps2 <- rstan::extract(prior_warpbreaks, pars = "b") 44 | bmat <- cbind(0, samps2$b) 45 | head(bmat) 46 | 47 | ## use generated data 48 | NNN <- 1e6 49 | bmat <- cbind(0, replicate(5, rcauchy(NNN))) 50 | 51 | ef_2levels <- bmat[,1:2] %*% t(t(c(1, sqrt(2)/2))) 52 | ef_3levels <- vector("list", 3) 53 | for (i in 1:3) { 54 | ef_3levels[[i]] <- 55 | bmat[,1:3] %*% rbind(1, t(contr.bayes(3)[i,, drop = FALSE])) 56 | 57 | } 58 | ef_3levels <- data.frame(ef_3levels) 59 | colnames(ef_3levels) <- c("L1_3", "L2_3", "L3_3") 60 | 61 | options(contrasts=c('contr.bayes', 'contr.poly')) 62 | 63 | newdf <- expand.grid(wool = levels(warpbreaks$wool), 64 | tension = levels(warpbreaks$tension)) 65 | newmm <- model.matrix(~wool * tension, newdf) 66 | 67 | ef_inter <- vector("list", 6) 68 | for (i in 1:6) { 69 | ef_inter[[i]] <- 70 | bmat %*% t(newmm[i, , drop = FALSE]) 71 | } 72 | ef_inter <- data.frame(ef_inter) 73 | colnames(ef_inter) <- c("C1_inter", "C2_inter", "C3_inter", 74 | "C4_inter", "C5_inter", "C6_inter") 75 | head(ef_inter) 76 | library("tidyverse") 77 | xlim <- c(-20, 20) 78 | 79 | all_e <- cbind(levels2 = ef_2levels, 80 | ef_3levels, ef_inter) 81 | all_e %>% 82 | pivot_longer(cols = everything()) %>% 83 | ggplot(aes(value)) + 84 | geom_density() + 85 | facet_wrap("name") + 86 | xlim(xlim) 87 | 88 | xlim <- c(-20, 20) 89 | ## xlim <- c(-500, 500) 90 | ef_2levels <- tibble(effect = ef_2levels) 91 | ggplot(ef_2levels, aes(effect)) + 92 | geom_density() + 93 | xlim(xlim) 94 | ggplot(ef_2levels, aes(effect)) + 95 | geom_histogram(binwidth = 1) + 96 | xlim(xlim) 97 | 98 | ef_3levels %>% 99 | pivot_longer(cols = everything()) %>% 100 | ggplot(aes(value)) + 101 | geom_histogram(binwidth = 1) + 102 | xlim(c(-500, 500)) + 103 | facet_wrap("name") 104 | 105 | ef_inter %>% 106 | pivot_longer(cols = everything()) %>% 107 | ggplot(aes(value)) + 108 | geom_histogram(binwidth = 1) + 109 | xlim(c(-500, 500)) + 110 | facet_wrap("name") 111 | -------------------------------------------------------------------------------- /development_files/working_stanmodel_bfrms.stan: -------------------------------------------------------------------------------- 1 | // generated with brms 2.10.0 2 | functions { 3 | 4 | real jzs_normal_lpdf(real Y, real mu, real sigmaSQ, real interc, real g) { 5 | return normal_lpdf(Y | interc + mu, sqrt(sigmaSQ)); 6 | } 7 | 8 | } 9 | data { 10 | int N; // number of observations 11 | vector[N] Y; // response variable 12 | int K; // number of population-level effects 13 | matrix[N, K] X; // population-level design matrix 14 | // data for group-level effects of ID 1 15 | int N_1; // number of grouping levels 16 | int M_1; // number of coefficients per level 17 | int J_1[N]; // grouping indicator per observation 18 | // group-level predictor values 19 | vector[N] Z_1_1; 20 | vector[N] Z_1_2; 21 | int prior_only; // should the likelihood be ignored? 22 | real r_fixed; 23 | real r_random; 24 | int TRMS; 25 | int b_MAP; 26 | } 27 | transformed data { 28 | } 29 | parameters { 30 | vector[K] b; // population-level effects 31 | real sigmaSQ; 32 | real interc; 33 | real g[TRMS]; 34 | vector[M_1] sd_1; // group-level standard deviations 35 | // standardized group-level effects 36 | vector[N_1] z_1[M_1]; 37 | } 38 | transformed parameters { 39 | // actual group-level effects 40 | vector[N_1] r_1_1 = (sd_1[1] * (z_1[1])); 41 | vector[N_1] r_1_2 = (sd_1[2] * (z_1[2])); 42 | r_1_1 = r_1_1 * sqrt(sigmaSQ); 43 | r_1_2 = r_1_2 * sqrt(sigmaSQ); 44 | } 45 | model { 46 | // initialize linear predictor term 47 | vector[N] mu = X * b; 48 | 49 | target += normal_lpdf(b | 0, sqrt(sigmaSQ * g[1])); 50 | target += inv_gamma_lpdf(g | 0.5, 0.5 * r_fixed^2); 51 | target += log(2) + log(sd_1[1]) + inv_gamma_lpdf(sd_1[1]^2.0 | 0.5, 0.5 * r_random^2); 52 | target += log(2) + log(sd_1[2]) + inv_gamma_lpdf(sd_1[2]^2.0 | 0.5, 0.5 * r_random^2); 53 | for (n in 1:N) { 54 | // add more terms to the linear predictor 55 | mu[n] += r_1_1[J_1[n]] * Z_1_1[n] + r_1_2[J_1[n]] * Z_1_2[n]; 56 | } 57 | // priors including all constants 58 | target += normal_lpdf(z_1[1] | 0, 1); 59 | target += normal_lpdf(z_1[2] | 0, 1); 60 | target += -log(sigmaSQ); 61 | // likelihood including all constants 62 | if (!prior_only) { 63 | for (n in 1:N) { 64 | target += jzs_normal_lpdf(Y[n] | mu[n], sigmaSQ, interc, g[TRMS]); 65 | } 66 | } 67 | } 68 | generated quantities { 69 | } 70 | -------------------------------------------------------------------------------- /examples/examples.contr.bayes.R: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | contr.bayes(2) ## Q_2 in Rouder et al. (2012, p. 363) 5 | # [,1] 6 | # [1,] -0.7071068 7 | # [2,] 0.7071068 8 | 9 | contr.bayes(5) ## equivalent to Q_5 in Rouder et al. (2012, p. 363) 10 | 11 | ## check decomposition 12 | Q3 <- contr.bayes(3) 13 | Q3 %*% diag(2) %*% t(Q3) 14 | ## 2/3 on diagonal and -1/3 on off-diagonal elements 15 | -------------------------------------------------------------------------------- /man/bfrm.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/bfrm.R 3 | \name{bfrm} 4 | \alias{bfrm} 5 | \title{Fit Bayesian Linear Mixed Model with JZS Prior} 6 | \usage{ 7 | bfrm(formula, data, family = gaussian(), prior_structure = "jzs", 8 | prior_arg = list(r_fixed = 0.5, r_random = 1), ...) 9 | } 10 | \arguments{ 11 | \item{formula}{An object of class \code{\link{formula}}.} 12 | 13 | \item{data}{An object of class \code{data.frame} containing all observations and 14 | variables used in the model.} 15 | 16 | \item{family}{Currently only \code{\link[=gaussian]{gaussian()}} is supported.} 17 | 18 | \item{prior_structure}{character string. Currently only \code{'jzs'} (for 19 | Jeffreys-Zellner-Siow) is supported.} 20 | 21 | \item{prior_arg}{\code{list} of additional arguments specific to 22 | \code{prior_structure}. For \code{'jzs'}, these can be \code{r_fixed} and \code{r_random}.} 23 | 24 | \item{...}{Further arguments passed to \code{\link[brms:brm]{brms::brm()}} such as \code{iter}, 25 | \code{warmup}, or \code{cores}.} 26 | } 27 | \description{ 28 | Fit Bayesian Linear Mixed Model with JZS Prior 29 | } 30 | -------------------------------------------------------------------------------- /man/brms_like.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/brms_like_functions.R 3 | \name{make_stancode_bfrms} 4 | \alias{make_stancode_bfrms} 5 | \alias{brms_like} 6 | \alias{make_standata_bfrms} 7 | \title{brms-like Functions} 8 | \usage{ 9 | make_stancode_bfrms(formula, data, family = gaussian(), 10 | prior_structure = "jzs", prior_arg = list(r_fixed = 0.5, r_random = 11 | 1), ...) 12 | 13 | make_standata_bfrms(formula, data, family = gaussian(), 14 | prior_structure = "jzs", prior_arg = list(r_fixed = 0.5, r_random = 15 | 1), ...) 16 | } 17 | \arguments{ 18 | \item{formula}{An object of class \code{\link{formula}}.} 19 | 20 | \item{data}{An object of class \code{data.frame} containing all observations and 21 | variables used in the model.} 22 | 23 | \item{family}{Currently only \code{\link[=gaussian]{gaussian()}} is supported.} 24 | 25 | \item{prior_structure}{character string. Currently only \code{'jzs'} (for 26 | Jeffreys-Zellner-Siow) is supported.} 27 | 28 | \item{prior_arg}{\code{list} of additional arguments specific to 29 | \code{prior_structure}. For \code{'jzs'}, these can be \code{r_fixed} and \code{r_random}.} 30 | 31 | \item{...}{further arguments passed to the corresponding \code{brms} function. See 32 | their help pages for details.} 33 | } 34 | \value{ 35 | \code{make_stancode_bfrms} returns the same as \code{\link[brms:make_stancode]{brms::make_stancode()}} and 36 | \code{make_standata_bfrms} returns the same as \code{\link[brms:make_standata]{brms::make_standata()}}. 37 | } 38 | \description{ 39 | Generate code or data for \code{brms} models using JSZ-priors to be 40 | passed to \code{Stan}. \code{make_stancode_bfrms} is the \code{bfrms} alias of 41 | \code{\link[brms:make_stancode]{brms::make_stancode()}} and \code{make_standata_bfrms} is the \code{bfrms} alias of 42 | \code{\link[brms:make_standata]{brms::make_standata()}}. 43 | } 44 | -------------------------------------------------------------------------------- /man/contr.bayes.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/contr.bayes.R 3 | \name{contr.bayes} 4 | \alias{contr.bayes} 5 | \title{Orthonormal Contrast Matrices for Bayesian Estimation} 6 | \usage{ 7 | contr.bayes(n, contrasts = TRUE) 8 | } 9 | \arguments{ 10 | \item{n}{a vector of levels for a factor, or the number of levels.} 11 | 12 | \item{contrasts}{logical indicating whether contrasts should be computed.} 13 | } 14 | \value{ 15 | A \code{matrix} with n rows and k columns, with k=n-1 if contrasts is 16 | \code{TRUE`` and k=n if contrasts is }FALSE`. 17 | } 18 | \description{ 19 | Returns a design or model matrix of orthonormal contrasts such that the 20 | marginal prior on all effects is identical. Implementation follows the 21 | description in Rouder, Morey, Speckman, & Province (2012, p. 363). 22 | } 23 | \examples{ 24 | 25 | 26 | 27 | contr.bayes(2) ## Q_2 in Rouder et al. (2012, p. 363) 28 | # [,1] 29 | # [1,] -0.7071068 30 | # [2,] 0.7071068 31 | 32 | contr.bayes(5) ## equivalent to Q_5 in Rouder et al. (2012, p. 363) 33 | 34 | ## check decomposition 35 | Q3 <- contr.bayes(3) 36 | Q3 \%*\% diag(2) \%*\% t(Q3) 37 | ## 2/3 on diagonal and -1/3 on off-diagonal elements 38 | } 39 | \references{ 40 | Rouder, J. N., Morey, R. D., Speckman, P. L., & Province, J. M. 41 | (2012). Default Bayes factors for ANOVA designs. \emph{Journal of Mathematical 42 | Psychology}, 56(5), 356-374. https://doi.org/10.1016/j.jmp.2012.08.001 43 | } 44 | -------------------------------------------------------------------------------- /model_warpbreaks.stan: -------------------------------------------------------------------------------- 1 | // generated with brms 2.12.11 2 | functions { 3 | 4 | real jzs_normal_lpdf(real Y, real mu, real sigmaSQ, real interc, real g) { 5 | return normal_lpdf(Y | interc + mu, sqrt(sigmaSQ)); 6 | } 7 | 8 | } 9 | data { 10 | int N; // number of observations 11 | vector[N] Y; // response variable 12 | int K; // number of population-level effects 13 | matrix[N, K] X; // population-level design matrix 14 | // data for group-level effects of ID 1 15 | int N_1; // number of grouping levels 16 | int M_1; // number of coefficients per level 17 | int J_1[N]; // grouping indicator per observation 18 | // group-level predictor values 19 | vector[N] Z_1_1; 20 | int prior_only; // should the likelihood be ignored? 21 | real r_fixed; 22 | real r_random; 23 | int TRMS; 24 | int b_MAP[5]; 25 | } 26 | transformed data { 27 | } 28 | parameters { 29 | vector[K] b; // population-level effects 30 | real sigmaSQ; 31 | real interc; 32 | real g[TRMS]; 33 | vector[M_1] sd_1; // group-level standard deviations 34 | vector[N_1] z_1[M_1]; // standardized group-level effects 35 | } 36 | transformed parameters { 37 | vector[N_1] r_1_1; // actual group-level effects 38 | r_1_1 = (sd_1[1] * (z_1[1])); 39 | r_1_1 = r_1_1 * sqrt(sigmaSQ); 40 | } 41 | model { 42 | // initialize linear predictor term 43 | vector[N] mu = X * b; 44 | 45 | for (k in 1:K) { 46 | target += normal_lpdf(b[k] | 0, sqrt(sigmaSQ * g[b_MAP[k]])); 47 | } 48 | target += inv_gamma_lpdf(g | 0.5, 0.5 * r_fixed^2); 49 | target += log(2) + log(sd_1[1]) + inv_gamma_lpdf(sd_1[1]^2.0 | 0.5, 0.5 * r_random^2); 50 | for (n in 1:N) { 51 | // add more terms to the linear predictor 52 | mu[n] += r_1_1[J_1[n]] * Z_1_1[n]; 53 | } 54 | // priors including all constants 55 | target += std_normal_lpdf(z_1[1]); 56 | target += -log(sigmaSQ); 57 | // likelihood including all constants 58 | if (!prior_only) { 59 | for (n in 1:N) { 60 | target += jzs_normal_lpdf(Y[n] | mu[n], sigmaSQ, interc, g[TRMS]); 61 | } 62 | } 63 | } 64 | generated quantities { 65 | } 66 | -------------------------------------------------------------------------------- /tests/testthat.R: -------------------------------------------------------------------------------- 1 | library(testthat) 2 | library(bfrms) 3 | 4 | test_check("bfrms") 5 | -------------------------------------------------------------------------------- /tests/testthat/fhchr.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/bayesstuff/bfrms/aa480a92179262b33284da36e90faef706428401/tests/testthat/fhchr.rda -------------------------------------------------------------------------------- /tests/testthat/test-Machines.R: -------------------------------------------------------------------------------- 1 | test_that("Machine Data Reproduces BayesFactor results", { 2 | testthat::skip_on_cran() 3 | testthat::skip_if_not_installed("MEMSS") 4 | testthat::skip_if_not_installed("BayesFactor") 5 | testthat::skip_if_not_installed("bridgesampling") 6 | data(Machines, package = "MEMSS") 7 | Machines <- droplevels(Machines[Machines$Machine %in% c("A", "C"),]) 8 | 9 | fit1 <- bfrm(score ~ Machine + (Machine||Worker), 10 | Machines, 11 | iter = 25000, warmup = 1000, 12 | cores = 1) 13 | fit0 <- bfrm(score ~ 1 + (Machine||Worker), 14 | Machines, 15 | iter = 25000, warmup = 1000, 16 | cores = 1) 17 | bf1 <- bridgesampling::bayes_factor(fit1, fit0, silent = TRUE) 18 | library("BayesFactor") 19 | mod1 <- lmBF(score ~ Machine + Worker + Machine:Worker, Machines, 20 | whichRandom = "Worker") 21 | 22 | mod0 <- lmBF(score ~ 1 + Worker + Machine:Worker, Machines, 23 | whichRandom = "Worker") 24 | bf2 <- mod1 / mod0 25 | 26 | testthat::expect_equivalent(bf1$bf, extractBF(bf2, onlybf = TRUE), 27 | tolerance = bf1$bf * 0.1, scale = 1) 28 | }) 29 | 30 | test_that("Machine Data Reproduces BayesFactor results even with change in prior", { 31 | testthat::skip_on_cran() 32 | testthat::skip_if_not_installed("MEMSS") 33 | testthat::skip_if_not_installed("BayesFactor") 34 | testthat::skip_if_not_installed("bridgesampling") 35 | data(Machines, package = "MEMSS") 36 | Machines <- droplevels(Machines[Machines$Machine %in% c("A", "C"),]) 37 | r_random <- 2 38 | 39 | fit1 <- bfrm(score ~ Machine + (Machine||Worker), 40 | Machines, 41 | iter = 25000, warmup = 1000, 42 | cores = 1, prior_arg = list(r_random = r_random)) 43 | fit0 <- bfrm(score ~ 1 + (Machine||Worker), 44 | Machines, 45 | iter = 25000, warmup = 1000, 46 | cores = 1, prior_arg = list(r_random = r_random)) 47 | bf1 <- bridgesampling::bayes_factor(fit1, fit0, silent = TRUE) 48 | library("BayesFactor") 49 | mod1 <- lmBF(score ~ Machine + Worker + Machine:Worker, Machines, 50 | whichRandom = "Worker", rscaleRandom = r_random, 51 | iterations = 200000) 52 | 53 | mod0 <- lmBF(score ~ 1 + Worker + Machine:Worker, Machines, 54 | whichRandom = "Worker", rscaleRandom = r_random, 55 | iterations = 200000) 56 | bf2 <- mod1 / mod0 57 | # extractBF(bf2, onlybf = TRUE) 58 | 59 | testthat::expect_equivalent(bf1$bf, extractBF(bf2, onlybf = TRUE), 60 | tolerance = bf1$bf * 0.1, scale = 1) 61 | }) 62 | -------------------------------------------------------------------------------- /tests/testthat/test-contr.R: -------------------------------------------------------------------------------- 1 | test_that("contr.bayes uses correct decomposition", { 2 | Q3 <- contr.bayes(3) 3 | tt <- Q3 %*% diag(2) %*% t(Q3) 4 | 5 | expect_equivalent(diag(tt), rep(2/3, 3)) 6 | expect_equivalent(tt[upper.tri(tt)], rep(-(1/3), 3)) 7 | expect_equivalent(tt[lower.tri(tt)], rep(-(1/3), 3)) 8 | }) 9 | 10 | -------------------------------------------------------------------------------- /tests/testthat/test-make_stancode-basics.R: -------------------------------------------------------------------------------- 1 | context("Produces correct code for different inputs") 2 | 3 | test_that("formulas with explicit or missing intercept are handled correctly", { 4 | testthat::skip_if_not_installed("MEMSS") 5 | data(Machines, package = "MEMSS") 6 | Machines <- droplevels(Machines[Machines$Machine %in% c("A", "C"),]) 7 | 8 | m1 <- make_stancode_bfrms(score ~ Machine + (Machine||Worker), 9 | Machines) 10 | m2 <- make_stancode_bfrms(score ~ 1 + Machine + (Machine||Worker), 11 | Machines) 12 | testthat::expect_equal(m1, m2) 13 | 14 | testthat::expect_error( 15 | make_stancode_bfrms(score ~ 0 + Machine + (Machine||Worker), Machines), 16 | "formula needs to have an intercept" 17 | ) 18 | 19 | }) 20 | 21 | test_that("works with multiple fixed effects", { 22 | ## load("tests/testthat/fhchr.rda") 23 | load("fhchr.rda") 24 | 25 | d1 <- make_standata_bfrms(rt ~ 1 + (length||id), fhchr) 26 | expect_true("r_random" %in% names(d1)) 27 | d2 <- make_standata_bfrms(rt ~ task + (length||id), fhchr) 28 | expect_identical(d2$TRMS, 1L) 29 | expect_identical(d2$b_MAP, 1L) 30 | 31 | d3 <- make_standata_bfrms(rt ~ task + length + (length||id), fhchr) 32 | expect_identical(d3$TRMS, 2L) 33 | expect_identical(d3$b_MAP, c(1L, 2L, 2L)) 34 | 35 | d4 <- make_standata_bfrms(rt ~ length + task + (length|id), fhchr) 36 | expect_identical(d4$TRMS, 2L) 37 | expect_identical(d4$b_MAP, c(1L, 1L, 2L)) 38 | 39 | d5 <- make_standata_bfrms(rt ~ length * task + (length|id), fhchr) 40 | expect_identical(d5$TRMS, 3L) 41 | expect_identical(d5$b_MAP, c(1L, 1L, 2L, 3L, 3L)) 42 | }) 43 | 44 | 45 | --------------------------------------------------------------------------------